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,3922 +1,3874 @@ section \Approximation with Affine Forms\ 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 \\label{sec:approxaffine}\ lemma convex_on_imp_above_tangent:\ \TODO: generalizes @{thm convex_on_imp_above_tangent}\ assumes convex: "convex_on A f" and connected: "connected A" assumes c: "c \ A" and x : "x \ A" assumes deriv: "(f has_field_derivative f') (at c within A)" shows "f x - f c \ f' * (x - c)" proof (cases x c rule: linorder_cases) assume xc: "x > c" let ?A' = "{c<.. A" using xc x c by (simp add: connected connected_contains_Ioo) have "at c within ?A' \ bot" using xc by (simp add: at_within_eq_bot_iff) moreover from deriv have "((\y. (f y - f c) / (y - c)) \ 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 (\y. (f y - f c) / (y - c) \ (f x - f c) / (x - c)) (at_right c)" proof eventually_elim fix y assume y: "y \ {c<.. (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 \ (f x - f c) / (x - c) * (y - c)" by simp thus "(f y - f c) / (y - c) \ (f x - f c) / (x - c)" using y xc by (simp add: divide_simps) qed hence "eventually (\y. (f y - f c) / (y - c) \ (f x - f c) / (x - c)) (at c within ?A')" by (simp add: eventually_at_filter eventually_mono) ultimately have "f' \ (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<.. A" using xc x c by (simp add: connected connected_contains_Ioo) have "at c within ?A' \ bot" using xc by (simp add: at_within_eq_bot_iff) moreover from deriv have "((\y. (f y - f c) / (y - c)) \ 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 (\y. (f y - f c) / (y - c) \ (f x - f c) / (x - c)) (at_left c)" proof eventually_elim fix y assume y: "y \ {x<.. (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 \ (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) \ (f x - f c) / (x - c)" using y xc by (simp add: divide_simps) qed hence "eventually (\y. (f y - f c) / (y - c) \ (f x - f c) / (x - c)) (at c within ?A')" by (simp add: eventually_at_filter eventually_mono) ultimately have "f' \ (f x - f c) / (x - c)" by (simp add: tendsto_lowerbound) thus ?thesis using xc by (simp add: field_simps) qed simp_all text \Approximate operations on affine forms.\ lemma Affine_notempty[intro, simp]: "Affine X \ {}" by (auto simp: Affine_def valuate_def) lemma truncate_up_lt: "x < y \ x < truncate_up prec y" by (rule less_le_trans[OF _ truncate_up]) lemma truncate_up_pos_eq[simp]: "0 < truncate_up p x \ 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 \ Affine (aform_of_point x)" by simp lemma aform_val_aform_of_ivl_innerE: assumes "e \ UNIV \ {-1 .. 1}" assumes "a \ b" "c \ Basis" obtains f where "aform_val e (aform_of_ivl a b) \ c = aform_val f (aform_of_ivl (a \ c) (b \ c))" "f \ UNIV \ {-1 .. 1}" proof - have [simp]: "a \ c \ b \ c" using assms by (auto simp: eucl_le[where 'a='a]) have "(\x. x \ c)  Affine (aform_of_ivl a b) = Affine (aform_of_ivl (a \ c) (b \ c))" using assms by (auto simp: Affine_aform_of_ivl eucl_le[where 'a='a] image_eqI[where x="\i\Basis. (if i = c then x else a \ i) *\<^sub>R i" for x]) then obtain f where "aform_val e (aform_of_ivl a b) \ c = aform_val f (aform_of_ivl (a \ c) (b \ c))" "f \ UNIV \ {-1 .. 1}" using assms by (force simp: Affine_def valuate_def) thus ?thesis .. qed lift_definition coord_pdevs::"nat \ real pdevs" is "\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 ($$i, (l, u)). ((l + u)/2, scaleR_pdevs ((u - l)/2) (coord_pdevs i))) (zip [0..i. i < length xs \ xs ! i \ {ls ! i .. us ! i}" shows "xs \ Joints (aforms_of_ivls ls us)" proof - { fix i assume "i < length xs" then have "\e. e \ {-1 .. 1} \ 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 \ {-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 \Approximate Operations\ definition "max_pdev x = fold (\x y. if infnorm (snd x) \ infnorm (snd y) then x else y) (list_of_pdevs x) (0, 0)" subsubsection \set of generated endpoints\ 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 \Approximate total deviation\ definition sum_list'::"nat \ 'a list \ 'a::executable_euclidean_space" where "sum_list' p xs = fold (\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\'a\'a" assumes mono: "\w x y z. w \ x \ y \ z \ f w y \ f x z" shows "x \ y \ fold f xs x \ 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 \ fold (\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 "\ \ fold (\x y. eucl_truncate_up p (x + y)) xs (z + x)" using Cons by simp also have "\ \ fold (\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 \ 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 \ sum_list xs \ y \ sum_list' p xs" by (metis sum_list_le_sum_list' order.trans) lemma tdev': "tdev x \ tdev' p x" unfolding tdev'_def proof - have "tdev x = (\i = 0 ..< degree x. \pdevs_apply x i$$" by (auto intro!: sum.mono_neutral_cong_left simp: tdev_def) also have "\ = (\i \ rev [0 ..< degree x]. \pdevs_apply x i\)" by (metis atLeastLessThan_upt sum_list_rev rev_map sum_set_upt_conv_sum_list_nat) also have "\ = sum_list (map (\xa. \pdevs_apply x xa\) [xa\rev [0.. 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\rev [0.. 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 "\x. x", simplified] degree_gt) finally show "tdev x \ sum_list' p (map (abs \ 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 \ tdev y \ x \ 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 \ 'a" where "Radius X \ tdev (snd X)" abbreviation Radius'::"nat\'a::executable_euclidean_space aform \ 'a" where "Radius' p X \ tdev' p (snd X)" lemma Radius'_uminus_aform[simp]: "Radius' p (uminus_aform X) = Radius' p X" by (auto simp: uminus_aform_def) subsubsection \truncate partial deviations\ definition trunc_pdevs_raw::"nat \ (nat \ 'a) \ nat \ '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 \ 0} \ {i. x i \ 0}" by (auto simp: trunc_pdevs_raw_def[abs_def]) lift_definition trunc_pdevs::"nat \ 'a::executable_euclidean_space pdevs \ 'a pdevs" is trunc_pdevs_raw by (auto intro!: finite_subset[OF nonzeros_trunc_pdevs_raw]) definition trunc_err_pdevs_raw::"nat \ (nat \ 'a) \ nat \ '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 \ 0} \ {i. x i \ 0}" by (auto simp: trunc_pdevs_raw_def trunc_err_pdevs_raw_def[abs_def]) lift_definition trunc_err_pdevs::"nat \ 'a::executable_euclidean_space pdevs \ '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 "\ = 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 \ 'a aform \ '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 \ 'a aform \ '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 \ UNIV \ {- 1..1}" shows "abs (aform_val e X) \ eucl_truncate_up p (\fst X\ + tdev' p (snd X))" proof - have "abs (aform_val e X) \ \fst X\ + \pdevs_val e (snd X)\" by (auto simp: aform_val_def intro!: abs_triangle_ineq) also have "\pdevs_val e (snd X)\ \ 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 \truncation with error bound\ 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 "\err\ \ 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 \ snd (trunc_bound_eucl p x)" by (simp add: trunc_bound_eucl_def Let_def eucl_truncate_up) ultimately show "\err. \err\ \ snd (trunc_bound_eucl p x) \ 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 \ UNIV \ {- 1..1}" obtains err where "\err\ \ 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 \ 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 "\err. \err\ \ snd (trunc_bound_pdevs p x) \ 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 \ n" assumes "degree Y \ n" shows "degree (add_pdevs X Y) \ 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 \ k" obtains e::real where "err = e * k" "e \ {-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 \ 0 \ eucl_truncate_up p x = 0 \ x = 0" by (metis (poly_guards_query) eq_iff eucl_truncate_up eucl_truncate_up_zero) lemma aform_val_consume_error: assumes "abs err \ 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 \ abs (pdevs_apply (snd X) n)" obtains err' where "aform_val (e(n := 0)) X + err = aform_val (e(n := err')) X" "err' \ {-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 \ n" shows "degree (trunc_pdevs p X) \ n" using assms by (auto intro!: degree_le) lemma pdevs_val_sum_less_degree: "pdevs_val e X = (\iR pdevs_apply X i)" if "degree X \ d" unfolding pdevs_val_pdevs_domain apply (rule sum.mono_neutral_cong_left) using that by force+ subsubsection \general affine operation\ 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..iR Basis_list ! i)" by (auto simp: pdevs_val_pdevs_domain length_Basis_list intro!:sum.cong) lemma affine_binop: assumes "degree_aforms [X, Y] \ 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 \ \TODO: more round-off operations here?\ (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 \ (\x\set xs. x = 0)" if "\x. x \ set xs \ x \ 0" proof safe fix x assume x: "sum_list' p xs = 0" "x \ set xs" from that have "0 \ 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 "(\ix\set xs. x = 0 \ sum_list' p xs = 0" by (induction xs) (auto simp: sum_list'_def) qed lemma affine_binop'E: assumes deg: "degree_aforms [X, Y] \ k" assumes e: "e \ UNIV \ {- 1..1}" assumes d: "abs u \ 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 \ {-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 \ 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: "\eps\ \ 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)) \ 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 \pdevs_apply (fst (trunc_bound_pdevs p (add_pdevs (scaleR_pdevs a (snd X)) (scaleR_pdevs b (snd Y))))) k = 0\ by auto done done moreover have "ek \ {-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 \Inf/Sup\ 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 \ 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 \ 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 \ 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 \ Sup_aform' p X" by (metis Inf_aform' Inf_aform_le_Sup_aform Sup_aform' order.trans) definition - "ivls_of_aforms prec = map (\a. Some (float_of (Inf_aform' prec a), float_of(Sup_aform' prec a)))" + "ivls_of_aforms prec = map (\a. Interval' (float_of (Inf_aform' prec a)) (float_of(Sup_aform' prec a)))" lemma assumes "\i. e'' i \ 1" assumes "\i. -1 \ e'' i" shows Inf_aform'_le: "Inf_aform' p r \ aform_val e'' r" and Sup_aform'_le: "aform_val e'' r \ 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 \ float" "Sup_aform' p X \ 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 \ Joints XS \ bounded_by xs (ivls_of_aforms prec XS)" - by (auto simp: bounded_by_def ivls_of_aforms_def Affine_def valuate_def Pi_iff + 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: option.splits) + 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 \ 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 = (\xs \ env. length xs = l)" lemma env_len_takeI: "env_len xs d1 \ d1 \ d \ env_len (take d  xs) d" by (auto simp: env_len_def) subsection \Min Range approximation\ lemma linear_lower: fixes x::real assumes "\x. x \ {a .. b} \ (f has_field_derivative f' x) (at x within {a .. b})" assumes "\x. x \ {a .. b} \ f' x \ u" assumes "x \ {a .. b}" shows "f b + u * (x - b) \ f x" proof - from assms(2-) mvt_very_simple[of x b f "\x. (*) (f' x)", rule_format, OF _ has_derivative_subset[OF assms(1)[simplified has_field_derivative_def]]] obtain y where "y \ {x .. b}" "f b - f x = (b - x) * f' y" by (auto simp: Bex_def ac_simps) moreover hence "f' y \ u" using assms by auto ultimately have "f b - f x \ (b - x) * u" by (auto intro!: mult_left_mono) thus ?thesis by (simp add: algebra_simps) qed lemma linear_lower2: fixes x::real assumes "\x. x \ {a .. b} \ (f has_field_derivative f' x) (at x within {a .. b})" assumes "\x. x \ {a .. b} \ l \ f' x" assumes "x \ {a .. b}" shows "f x \ f a + l * (x - a)" proof - from assms(2-) mvt_very_simple[of a x f "\x. (*) (f' x)", rule_format, OF _ has_derivative_subset[OF assms(1)[simplified has_field_derivative_def]]] obtain y where "y \ {a .. x}" "f x - f a = (x - a) * f' y" by (auto simp: Bex_def ac_simps) moreover hence "l \ f' y" using assms by auto ultimately have "(x - a) * l \ 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 "\x. x \ {a .. b} \ (f has_field_derivative f' x) (at x within {a .. b})" assumes "\x. x \ {a .. b} \ f' x \ u" assumes "x \ {a .. b}" shows "f x \ f a + u * (x - a)" proof - from assms(2-) mvt_very_simple[of a x f "\x. (*) (f' x)", rule_format, OF _ has_derivative_subset[OF assms(1)[simplified has_field_derivative_def]]] obtain y where "y \ {a .. x}" "f x - f a = (x - a) * f' y" by (auto simp: Bex_def ac_simps) moreover hence "f' y \ u" using assms by auto ultimately have "(x - a) * u \ 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 "\x. x \ {a .. b} \ (f has_field_derivative f' x) (at x within {a .. b})" assumes "\x. x \ {a .. b} \ l \ f' x" assumes "x \ {a .. b}" shows "f x \ f b + l * (x - b)" proof - from assms(2-) mvt_very_simple[of x b f "\x. (*) (f' x)", rule_format, OF _ has_derivative_subset[OF assms(1)[simplified has_field_derivative_def]]] obtain y where "y \ {x .. b}" "f b - f x = (b - x) * f' y" by (auto simp: Bex_def ac_simps) moreover hence "l \ f' y" using assms by auto ultimately have "f b - f x \ (b - x) * l" by (auto intro!: mult_left_mono) thus ?thesis by (simp add: algebra_simps) qed lemma linear_enclosure: fixes x::real assumes "\x. x \ {a .. b} \ (f has_field_derivative f' x) (at x within {a .. b})" assumes "\x. x \ {a .. b} \ f' x \ u" assumes "x \ {a .. b}" shows "f x \ {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 = ((fst ivl + snd ivl::float)/2, (snd ivl - fst ivl)/2)" +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 \Addition\ definition add_aform::"'a::real_vector aform \ 'a aform \ '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 \ real" definition add_aform'::"nat \ aform_err \ aform_err \ 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 \ nat" where "degree_aform_err X \ degree_aform (fst X)" lemma degree_aform_err_add_aform': assumes "degree_aform_err x \ n" assumes "degree_aform_err y \ n" shows "degree_aform_err (add_aform' p x y) \ 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 \ aform_err e Xe" if "abs (x - aform_val e (fst Xe)) \ snd Xe" using that by (auto simp: aform_err_def abs_real_def algebra_simps split: if_splits) lemma add_aform': assumes e: "e \ UNIV \ {- 1..1}" assumes x: "x \ aform_err e X" assumes y: "y \ aform_err e Y" shows "x + y \ 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: "\e1\ \ 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: "\e2\ \ 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: "\e1 + e2 + snd X + snd Y\ \ 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 \Scaling\ definition aform_scaleR::"real aform \ 'a::real_vector \ '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 \Multiplication\ 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))) + (\iR pdevs_apply (snd x) i)*(\iR pdevs_apply (snd y) i)" if "degree (snd x) \ d" "degree (snd y) \ d" using that by (auto simp: pdevs_val_sum_less_degree[where d=d] aform_val_def algebra_simps) lemma sum_times_bound:\ \TODO: this gives better bounds for the remainder of multiplication\ "(\iii2 * (f i * g i)) + ($$i, j) | i < j \ j < d. (e i * e j) * (f j * g i + f i * g j))" for d::nat proof - have "(\ii(i, j)\{.. {.. = (\(i, j)\{.. {.. {(i, j). i = j}. e i * f i * (e j * g j)) + ((\(i, j)\{.. {.. {(i, j). i < j}. e i * f i * (e j * g j)) + (\(i, j)\{.. {.. {(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 = (\(i, j)\{.. {.. {(i, j). i < j}. e i * f j * (e j * g i))" by (rule sum.reindex_cong[of "\(x, y). (y, x)"]) (auto intro!: inj_onI) also have "?b + \ = (\(i, j)\{.. {.. {(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 "\ = (\(i, j) | i < j \ j < d. (e i * e j) * (f j * g i + f i * g j))" by (rule sum.cong) auto also have "?a = (\i2 * (f i * g i))" by (rule sum.reindex_cong[of "\i. (i, i)"]) (auto simp: power2_eq_square intro!: inj_onI) finally show ?thesis by simp qed definition mult_aform::"aform_err \ aform_err \ 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 \ UNIV \ {- 1..1}" assumes x: "x \ aform_err e X" assumes y: "y \ aform_err e Y" shows "x * y \ aform_err e (mult_aform X Y)" proof - define ex where "ex \ x - aform_val e (fst X)" define ey where "ey \ y - aform_val e (fst Y)" have [intro, simp]: "\ex\ \ \snd X\" "\ey\ \ \snd Y\" 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 \ 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 \ aform_err \ aform_err \ 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)) \ snd X" if "x \ aform_err e X" using that by (auto simp: aform_err_def) lemma mult_aform'E: fixes X Y::"aform_err" assumes e: "e \ UNIV \ {- 1..1}" assumes x: "x \ aform_err e X" assumes y: "y \ aform_err e Y" shows "x * y \ 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: "\e1\ \ 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: "\e2\ \ 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: "\e3\ \ 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: "\e4\ \ 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 (\fst (fst Y)\ + ?ty))" let ?e2 = "truncate_up p (abs (snd Y) * truncate_up p (\fst (fst X)\ + ?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 \ abs ?e0 + abs e1 + abs e2 + abs e3 + abs e4" by arith also have "\ \ 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) \ 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 \ ?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)) \ ?l" by (auto intro!: truncate_up_le) also have "?ee + ?e1 + ?e2 + ?l + snd ?z0 + snd ?u + snd ?v + snd ?w \ 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 "\ \ (snd (mult_aform' p X Y))" by (auto simp: mult_aform'_def Let_def assms split: prod.splits) finally have err_le: "abs ?err \ (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 \ n" assumes "degree_aform_err y \ n" shows "degree_aform_err (mult_aform' p x y) \ 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 \ {a ..b}" assumes "- inverse (b*b) \ alpha" shows inverse_linear_lower: "inverse b + alpha * (x - b) \ inverse x" (is ?lower) and inverse_linear_upper: "inverse x \ inverse a + alpha * (x - a)" (is ?upper) proof - have deriv_inv: "\x. x \ {a .. b} \ (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 \Inverse\ definition inverse_aform'::"nat \ real aform \ real aform \ 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 \ UNIV \ {-1 .. 1}" assumes Inf_pos: "Inf_aform' p X > 0" assumes "x = aform_val e X" shows "inverse x \ 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 \ u" by (auto simp: l_def u_def) hence a_def': "a = l" and b_def': "b = u" and "0 < a" "0 < b" using \0 < l\ 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 \ ?x" by (metis order.trans Inf_aform e Inf_aform' a_def' l_def) have "?x \ b" by (metis order.trans Sup_aform e Sup_aform' b_def' u_def) hence "?x \ {?x .. b}" by simp have "- inverse (b * b) \ 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 \0 < b$$ { note \0 < a\ moreover have "?x \ {a .. b}" using \a \ ?x\ \?x \ b\ by simp moreover note \- inverse (b * b) \ alpha\ ultimately have "inverse ?x \ inverse a + alpha * (?x - a)" by (rule inverse_linear_upper) also have "\ = alpha * ?x + (inverse a - alpha * a)" by (simp add: algebra_simps) also have "inverse a - (alpha * a) \ (real_divr p 1 a - alpha * a)" by (auto simp: inverse_eq_divide real_divr) also have "\ \ (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 "_ \ (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 \ 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 \ (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 \ 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 \ 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) \ inverse b" by (rule order_trans[OF add_left_mono[OF truncate_down]]) (auto simp: inverse_eq_divide real_divl) hence "zeta + alpha * b \ 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 \ inverse b + alpha * (?x - b)" by (simp add: algebra_simps) also { note \0 < aform_val e X\ moreover note \aform_val e X \ {aform_val e X .. b}\ moreover note \- inverse (b * b) \ alpha\ ultimately have "inverse b + alpha * (aform_val e X - b) \ inverse (aform_val e X)" by (rule inverse_linear_lower) } finally have "alpha * (aform_val e X) + zeta - delta \ 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 \ {- delta .. delta}" using lower upper by simp hence linerr_le: "abs ?linerr \ delta" by auto let ?z0 = "trunc_bound_eucl p (alpha * fst X)" from trunc_bound_euclE obtain e1 where abs_e1: "\e1\ \ 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': "\e1'\ \ 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: "\e2\ \ 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 \0 < l\ 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 \ abs ?linerr + abs e1 + abs e1' + abs e2" by simp also have "\ \ delta + snd ?z0 + snd ?z1 + snd ?zs" by (blast intro: add_mono linerr_le abs_e1 abs_e1' abs_e2) also have "\ \ (snd (inverse_aform' p X))" unfolding inverse_aform'_def Let_def vars[symmetric] using \0 < l\ 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 \ 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 \ 0 \ 0 \ u) then None else if (l \ 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 \ UNIV \ {-1 .. 1}" and disj: "Inf_aform' p X > 0 \ Sup_aform' p X < 0" obtains Y where "inverse_aform p X = Some Y" "inverse (aform_val e X) \ aform_err e Y" proof - { assume neg: "Sup_aform' p X < 0" from neg have [simp]: "Inf_aform' p X \ 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)) \ 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) \ 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) \ 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 \ nat \ 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 \ aform_err e X" assumes deg: "degree_aform_err X \ n" obtains err where "x = aform_val (e(n:=err)) (aform_err_to_aform X n)" "-1 \ err" "err \ 1" proof - from aform_errE[OF assms(1)] have "\x - aform_val e (fst X)\ \ snd X" by auto from error_absE[OF this] obtain err where err: "x - aform_val e (fst X) = err * snd X" "err \ {- 1..1}" by auto have "x = aform_val (e(n:=err)) (aform_err_to_aform X n)" "-1 \ err" "err \ 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 \ nat \ 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 \ aform_err e (aform_to_aform_err X n)" if "e \ UNIV \ {-1 .. 1}" proof - from that have abs_e[simp]: "\i. \e i\ \ 1" by (auto simp: abs_real_def) have "- e n * pdevs_apply (snd X) n \ \pdevs_apply (snd X) n\" proof - have "- e n * pdevs_apply (snd X) n \ \- e n * pdevs_apply (snd X) n\" by auto also have "\ \ 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 \ \pdevs_apply (snd X) n\" proof - have "e n * pdevs_apply (snd X) n \ \e n * pdevs_apply (snd X) n\" by auto also have "\ \ 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 \ (fst x, truncate_up p (snd x + e))" -definition "ivl_err l u \ (((u + l)/2, zero_pdevs::real pdevs), (u - l) / 2)" +definition ivl_err :: "real interval \ (real \ real pdevs) \ real" + where "ivl_err ivl \ (((upper ivl + lower ivl)/2, zero_pdevs::real pdevs), (upper ivl - lower ivl) / 2)" lemma inverse_aform: fixes X::"real aform" assumes e: "e \ UNIV \ {-1 .. 1}" assumes "inverse_aform p X = Some Y" shows "inverse (aform_val e X) \ aform_err e Y" proof - from assms have "Inf_aform' p X > 0 \ 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) \ aform_err e Y" by auto with assms show ?thesis by auto qed lemma aform_err_acc_err_leI: "fx \ aform_err e (acc_err p X err)" if "aform_val e (fst X) - (snd X + err) \ fx" "fx \ 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 \ aform_err e (acc_err p X err)" if "fx \ 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) \ \B\" if "-1 \ err" "err \ 1" for err::real proof - have [simp]: "abs err \ 1" using that by (auto simp: ) have "- (err * B) \ abs (- err * B)" by auto also have "\ \ 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 \ \B\" if "-1 \ err" "err \ 1" for err::real proof - have [simp]: "abs err \ 1" using that by (auto simp: ) have "err * B \ abs (err * B)" by auto also have "\ \ abs B" by (auto simp: abs_mult intro!: mult_left_le_one_le) finally show ?thesis by simp qed lemma aform_err_lemma1: "- 1 \ err \ err \ 1 \ X1 + (A - e d * B + err * B) - e1 \ x \ X1 + (A - e d * B) - truncate_up p (\B\ + e1) \ 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 \ err \ err \ 1 \ x \ X1 + (A - e d * B + err * B) + e1 \ x \ X1 + (A - e d * B) + truncate_up p (\B\ + 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 \ aform_err e (acc_err p (aform_to_aform_err X1 d) e1)" if "-1 \ err" "err \ 1" "x \ 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) \ I X0; Some (acc_err p (aform_to_aform_err X1 (degree_aform_err X)) e1) })" lemma map_aform_err: "i x \ aform_err e Y" if I: "\e X Y. e \ UNIV \ {-1 .. 1} \ I X = Some Y \ i (aform_val e X) \ aform_err e Y" and e: "e \ UNIV \ {-1 .. 1}" and Y: "map_aform_err I p X = Some Y" and x: "x \ 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 \ err" "err \ 1" by auto then have e': "?e \ UNIV \ {-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) \ aform_err e Y" apply rule unfolding Y using \-1 \ err\ \err \ 1\ 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 \ aform_err e Y" if e: "e \ UNIV \ {-1 .. 1}" and Y: "inverse_aform_err p X = Some Y" and x: "x \ 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 \Reduction (Summarization of Coefficients)\ text \\label{sec:affinesummarize}\ 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 \ 0} = {i. f i \ 0} \ {x. s x (f x)}" by (auto simp: filter_pdevs_raw_def) definition summarize_pdevs:: "nat \ (nat \ 'a \ bool) \ nat \ 'a::executable_euclidean_space pdevs \ '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 \ infnorm y \ t * infnorm (eucl_truncate_up p (tdev' p x))" lemma error_abs_euclE: fixes err::"'a::ordered_euclidean_space" assumes "abs err \ k" obtains e::"'a \ real" where "err = (\i\Basis. (e i * (k \ i)) *\<^sub>R i)" "e \ UNIV \ {-1 .. 1}" proof atomize_elim { fix i::'a assume "i \ Basis" hence "abs (err \ i) \ (k \ i)" using assms by (auto simp add: eucl_le[where 'a='a] abs_inner) hence "\e. (err \ i = e * (k \ i)) \ e \ {-1..1}" by (rule error_absE) auto } then obtain e where e: "\i. i \ Basis \ err \ i = e i * (k \ i)" "\i. i \ Basis \ e i \ {-1 .. 1}" by metis have singleton: "\b. b \ Basis \ (\i\Basis. e i * (k \ i) * (if i = b then 1 else 0)) = (\i\{b}. e i * (k \ i) * (if i = b then 1 else 0))" by (rule sum.mono_neutral_cong_right) auto show "\e::'a\real. err = (\i\Basis. (e i * (k \ i)) *\<^sub>R i) \ (e \ UNIV \ {-1..1})" using e by (auto intro!: exI[where x="\i. if i \ 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 \ UNIV \ {-1 .. 1}" assumes d: "degree x \ d" obtains e' where "pdevs_val e x = pdevs_val e' (summarize_pdevs p I d x)" "\i. i < d \ e i = e' i" "e' \ UNIV \ {-1 .. 1}" proof atomize_elim have "pdevs_val e x = (\iR pdevs_apply x i)" by (auto simp add: pdevs_val_sum intro!: sum.cong) also have "\ = (\i \ {.. {i. I i (pdevs_apply x i)}. e i *\<^sub>R pdevs_apply x i) + (\i\ {..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 \ \ tdev' p (filter_pdevs (-I) x)" (is "abs ?r \ ?t") using e by (rule abs_pdevs_val_le_tdev') hence "?r \ {-?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 \ UNIV \ {- 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 (\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 (\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' \ UNIV \ {-1 .. 1}" using e e2 by (auto simp: e'_def Pi_iff) moreover have "\i < d. e' i = e i" by (auto simp: e'_def) ultimately show "\e'. pdevs_val e x = pdevs_val e' (summarize_pdevs p I d x) \ (\i e' \ UNIV \ {- 1..1}" by auto qed definition "summarize_pdevs_list p I d xs = map ($$d, x). summarize_pdevs p (\i _. I i (pdevs_applys xs i)) d x) (zip [d..i. i \ pdevs_domain y \ 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: "\i. i \ pdevs_domain d \ 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 (\a b. \ P a b) b) = filter_pdevs (\a b. \ 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 \ Mapping.keys M)" by (transfer) auto lemma lookup_eq_SomeD: "(Mapping.lookup M x = Some y) \ (x \ Mapping.keys M)" by transfer auto definition "domain_pdevs xs = (\(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 (\(x, y). summarize_pdevs p (\i _. I i (M i)) x y) (zip [d.. {-t .. t}" obtains e where "e \ {-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 \ 'a::real_normed_vector pdevs" is "\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 \ UNIV \ {-1 .. 1}" assumes d: "degrees X \ d" obtains e' where "pdevs_vals e X = pdevs_vals e' (summarize_pdevs_list p I d X)" "\i. i < d \ e i = e' i" "e' \ UNIV \ {-1 .. 1}" proof - let ?I = "{i. I i (pdevs_applys X i)}" let ?J = "\i x. I i (pdevs_applys X i)" have "pdevs_vals e X = map (\x. \iR 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 "\ = map (\x. (\i\{.. ?I. e i * pdevs_apply x i) + (\i\{.. = map (\x. pdevs_val e (filter_pdevs ?J x) + pdevs_val e (filter_pdevs (-?J) x)) X" (is "_ = map (\x. ?large x + ?small x) _") by (auto simp: pdevs_val_filter_pdevs Diff_eq Compl_eq) also have "\ = map snd (zip [d..)" by simp also have "\ = map (\(d, x). ?large x + ?small x) (zip [d.. = map (\(d', x). ?large x + ?small (snd (?z ! (d' - d)))) ?z" by (auto simp: in_set_zip) also let ?t = "\x. tdev' p (filter_pdevs (-?J) x)" let ?x = "\d'. snd (?z ! (d' - d))" { fix d' assume "d \ d'" "d' < d + length X" have "abs (?small (?x d')) \ ?t (?x d')" using \e \ _\ by (rule abs_pdevs_val_le_tdev') then have "?small (?x d') \ {-?t (?x d') .. ?t (?x d')}" by auto from in_centered_ivlE[OF this] have "\e\{-1 .. 1}. ?small (?x d') = e * ?t (?x d')" by blast } then obtain e'' where e'': "e'' d' \ {-1 .. 1}" "?small (?x d') = e'' d' * ?t (?x d')" if "d' \ {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' \ \i. if i < d then e i else if i < d + length X then e'' i else 0" have e': "e' d' \ {-1 .. 1}" "?small (?x d') = e' d' * ?t (?x d')" if "d' \ {d ..< d + length X}" for d' using e'' that by (auto simp: e'_def split: if_splits) then have *: "pdevs_val e (filter_pdevs (\a b. \ I a (pdevs_applys X a)) (?x d')) = e' d' * ?t (?x d')" if "d' \ {d ..< d + length X}" for d' using that by auto have "map (\(d', x). ?large x + ?small (?x d')) ?z = map (\(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 "\ = map (\(d', x). pdevs_val e' (summarize_pdevs p ?J d' x)) (zip [d..i x. I i (pdevs_applys X i)) (X ! n)) \ 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 \\n. \n < length X; degrees X \ d\ \ degree (X ! n) \ d + n\ degree_filter_pdevs_le less_le_trans) by (meson less_le_trans trans_less_add1) qed done also have "\ = 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 "(\i. i < d \ e i = e' i)" "e' \ UNIV \ {- 1..1}" using \e \ _\ 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 \ list_ex2 P xs ys)" lemma list_ex2_iff: "list_ex2 P xs ys \ (\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 (\(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 \ UNIV \ {-1 .. 1}" assumes d: "degree_aforms X \ d" obtains e' where "aform_vals e X = aform_vals e' (summarize_aforms p C d X)" "\i. i < d \ e i = e' i" "e' \ UNIV \ {-1 .. 1}" proof - define Xs where "Xs = map snd X" have "aform_vals e X = map (\(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' \ UNIV \ {-1 .. 1}" "\i. i < d \ 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 (\(x, y). x + y) (zip (map fst X)$$ = 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)" "\i. i < d \ e i = e' i" "e' \ UNIV \ {-1 .. 1}" using e' d by (auto simp: Xs_def) then show ?thesis .. qed text \Different reduction strategies:\ definition "collect_threshold p ta t (X::real aform list) = (let Xs = map snd X; as = map (\X. max ta (t * tdev' p X)) Xs in ($$i::nat) xs. list_ex2 ($$ 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 \ m then (\_ _. True) else let Ds = sorted_list_of_set D; ortho_indices = map fst (take (2 * N) (sort_key ($$i, r). r) (map (\i. let xs = M i in (i, sum_list' p xs - fold max xs 0)) Ds))); _ = () in (\i (xs::real list). i \ set ortho_indices))" subsection \Splitting with heuristics\ definition "abs_pdevs = unop_pdevs abs" definition "abssum_of_pdevs_list X = fold (\a b. (add_pdevs (abs_pdevs a) b)) X zero_pdevs" definition "split_aforms xs i = (let splits = map (\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) - (snd Rd))))" -definition "Sup_aform_err p Rd = (float_of (truncate_up p (Sup_aform' p (fst Rd) + (snd Rd))))" - -definition "approx_un p f a = do { - (rd) \ a; - (l, u) \ f (Inf_aform_err p rd) (Sup_aform_err p rd); - Some (ivl_err (real_of_float l) ((real_of_float u))) +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 \ aform_err \ float interval" + is "\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 + \ (float interval \ float interval option) + \ ((real \ real pdevs) \ real) option + \ ((real \ real pdevs) \ real) option" + where "approx_un p f a = do { + rd \ a; + ivl \ f (ivl_of_aform_err p rd); + Some (ivl_err (real_interval ivl)) }" -definition interval_extension1::"(float \ float \ (float * float) option) \ (real \ real) \ bool" - where "interval_extension1 F f \ (\l u i s. F l u = Some (i, s) \ f  {l .. u} \ {i .. s})" +definition interval_extension1::"(float interval \ (float interval) option) \ (real \ real) \ bool" + where "interval_extension1 F f \ (\ivl ivl'. F ivl = Some ivl' \ (\x. x \\<^sub>r ivl \ f x \\<^sub>r ivl'))" lemma interval_extension1D: assumes "interval_extension1 F f" - assumes "F l u = Some (i, s)" - shows "f  {l .. u} \ {i .. s}" + assumes "F ivl = Some ivl'" + assumes "x \\<^sub>r ivl" + shows "f x \\<^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) \ 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) \ 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 (l') (u')) = {l'..u'}" - by (auto simp: aform_err_def ivl_err_def aform_val_def divide_simps) +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 \ UNIV \ {-1 .. 1}" defines "X' \ fst X" shows "aform_err e X \ {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 \ UNIV \ {-1 .. 1}" + shows "x \ aform_err e X \ x \\<^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 \ UNIV \ {-1 .. 1}" assumes au: "approx_un p F X'err = Some Ye" - assumes x: "case X'err of None \ True | Some X'err \ x \ aform_err e (X'err)" + assumes x: "case X'err of None \ True | Some X'err \ x \ aform_err e X'err" shows "f x \ aform_err e Ye" proof - - from au obtain l' u' X' err - where F: " F (Inf_aform_err p (X', err)) (Sup_aform_err p (X', err)) = Some (l', u')" - (is "F ?i ?s = _") - and Y: "Ye = ivl_err (real_of_float l') (real_of_float u')" - (is "_ = (ivl_err ?l' ?u')") + 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 \ aform_err e (X', err)" by (auto simp: X'err) - also note Inf_Sup_aform_err[OF e, where p=p] - finally have "x \ {?i .. ?s}" . - then have "f x \ f  {real_of_float ?i .. real_of_float ?s}" by (rule imageI) - also note interval_extension1D[OF ie F] - also have "{real_of_float l'..real_of_float u'} = aform_err e Ye" unfolding Y aform_err_ivl_err .. + from ivl_of_aform_err[OF e this] + have "x \\<^sub>r ivl_of_aform_err p (X', err)" . + from interval_extension1D[OF ie F this] + have "f x \\<^sub>r ivl'" . + also have "\ = aform_err e Ye" + unfolding Y aform_err_ivl_err .. finally show ?thesis . qed definition "approx_bin p f rd sd = do { - (l, u) \ f (Inf_aform_err p rd) (Sup_aform_err p rd) - (Inf_aform_err p sd) (Sup_aform_err p sd); - Some (ivl_err (real_of_float l) ((real_of_float u))) + ivl \ f (ivl_of_aform_err p rd) + (ivl_of_aform_err p sd); + Some (ivl_err (real_interval ivl)) }" -definition interval_extension2::"(float \ float \ float \ float \ (float * float) option) \ (real \ real \ real) \ bool" - where "interval_extension2 F f \ (\l u l' u' i s. F l u l' u' = Some (i, s) \ - (\(x, y). f x y)  ({l .. u} \ {l' .. u'}) \ {i .. s})" +definition interval_extension2::"(float interval \ float interval \ float interval option) \ (real \ real \ real) \ bool" + where "interval_extension2 F f \ (\ivl1 ivl2 ivl. F ivl1 ivl2 = Some ivl \ + (\x y. x \\<^sub>r ivl1 \ y \\<^sub>r ivl2 \ f x y \\<^sub>r ivl))" lemma interval_extension2D: assumes "interval_extension2 F f" - assumes "F l u l' u' = Some (i, s)" - shows "(\(x, y). f x y)  ({l .. u} \ {l' .. u'}) \ {i .. s}" + assumes "F ivl1 ivl2 = Some ivl" + shows "x \\<^sub>r ivl1 \ y \\<^sub>r ivl2 \ f x y \\<^sub>r ivl" using assms by (auto simp: interval_extension2_def) lemma approx_binE: assumes ie: "interval_extension2 F f" assumes w: "w \ aform_err e (W', errw)" assumes x: "x \ aform_err e (X', errx)" assumes ab: "approx_bin p F ((W', errw)) ((X', errx)) = Some Ye" assumes e: "e \ UNIV \ {-1 .. 1}" shows "f w x \ aform_err e Ye" proof - - from ab obtain l' u' - where F: "F (Inf_aform_err p (W', errw)) (Sup_aform_err p (W', errw)) - (Inf_aform_err p (X', errx)) (Sup_aform_err p (X', errx)) = Some (l', u')" - (is "F ?i ?s ?i' ?s' = _") - and Y: "Ye = ivl_err (real_of_float l') (real_of_float u')" - (is "_ = ivl_err ?l' ?u'") + 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) - { note w - also note Inf_Sup_aform_err[OF e, where p=p] - finally have "w \ {?i .. ?s}" . - } moreover { - note x - also note Inf_Sup_aform_err[OF e, where p=p] - finally have "x \ {?i' .. ?s'}" . - } ultimately - have "f w x \ (\(a, b). f a b)  ({real_of_float ?i .. ?s} \ {real_of_float ?i' .. ?s'})" - by auto - also note interval_extension2D[OF ie F] - also have "{real_of_float l'..real_of_float u'} = aform_err e Ye" unfolding Y aform_err_ivl_err .. + 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 \\<^sub>r ivl'" . + also have "\ = aform_err e Ye" unfolding Y aform_err_ivl_err .. finally show ?thesis . qed definition "min_aform_err p a1 (a2::aform_err) = (let - i1 = Inf_aform_err p a1; - s1 = Sup_aform_err p a1; - i2 = Inf_aform_err p a2; - s2 = Sup_aform_err p a2 - in if s1 < i2 then a1 - else if s2 < i1 then a2 - else ivl_err (min i1 i2) (min s1 s2))" + 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 - i1 = Inf_aform_err p a1; - s1 = Sup_aform_err p a1; - i2 = Inf_aform_err p a2; - s2 = Sup_aform_err p a2 - in if s1 < i2 then (a2) - else if s2 < i1 then (a1) - else ivl_err (max i1 i2) (max s1 s2))" + 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 \Approximate Min Range - Kind Of Trigonometric Functions\ definition affine_unop :: "nat \ real \ real \ real \ aform_err \ 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 (\a\ * xe), axe, ye, yse, d]))" \ \TODO: also do binop\ lemma aform_err_leI: "y \ aform_err e (c, d)" if "y \ aform_err e (c, d')" "d' \ d" using that by (auto simp: aform_err_def) lemma aform_err_eqI: "y \ aform_err e (c, d)" if "y \ 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 \ aform_err e (c, sum_list' p ds)" if "y \ 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 \ aform_err e ((fst (trunc_bound_eucl p X), xs), snd (trunc_bound_eucl p X) + d)" if y: "y \ aform_err e ((X, xs), d)" using that proof - from aform_errE[OF y] have "\y - aform_val e (X, xs)\ \ 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 \ UNIV \ {-1 .. 1}" obtains err where "\err\ \ 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 \ aform_err e ((c, fst (trunc_bound_pdevs p xs)), snd (trunc_bound_pdevs p xs) + d)" if y: "y \ aform_err e ((c, xs), d)" and e: "e \ UNIV \ {-1 .. 1}" using that proof - define exs where "exs = trunc_err_pdevs p xs" from aform_errE[OF y] have "\y - aform_val e (c, xs)\ \ 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 \ aform_err e ((a + b, xs), d)" if "y - b \ aform_err e ((a, xs), d)" using that by (auto simp: aform_err_def aform_val_def) theorem affine_unop: assumes x: "x \ aform_err e X" assumes f: "\f x - (a * x + b)\ \ d" and e: "e \ UNIV \ {-1 .. 1}" shows "f x \ 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': "\x - x'\ \ snd X" using aform_errE[OF x] by (auto simp: x'_def aform_val_def) have "\f x - b - (a * fst (fst X) + a * pdevs_val e (snd (fst X)))\ = \f x - (a * x + b) + a * (x - x')\" by (simp add: algebra_simps x'_def) also have "\ \ \f x - (a * x + b)\ + \a * (x - x')\" by (rule abs_triangle_ineq) also note f also have "\a * (x - x')\ \ truncate_up p (\a\ * snd X)" by (rule truncate_up_le) (auto simp: abs_mult intro!: mult_left_mono x_x') finally show "\f x - b - (a * fst (fst X) + a * pdevs_val e (snd (fst X)))\ \ truncate_up p (\a\ * snd X) + d" by auto qed qed lemma min_range_coeffs_ge: "\f x - (a * x + b)\ \ d" if l: "l \ x" and u: "x \ u" and f': "\y. y \ {l .. u} \ (f has_real_derivative f' y) (at y)" and a: "\y. y \ {l..u} \ a \ f' y" and d: "d \ (f u - f l - a * (u - l)) / 2 + \(f l + f u - a * (l + u)) / 2 - b\" 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 \ {l .. u}" and llu: "l \ {l .. u}" by simp_all define m where "m = (f l + f u - a * (l + u)) / 2" have "\f x - (a * x + b)\ = \f x - (a * x + m) + (m - b)\" by (simp add: algebra_simps) also have "\ \ \f x - (a * x + m)\ + \m - b\" by (rule abs_triangle_ineq) also have "\f x - (a * x + m)\ \ (f u - f l - a * (u - l)) / 2" proof (rule abs_leI) have "f x \ f l + a * (x - l)" (is "?l \ ?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 \ ?r" by (simp add: algebra_simps m_def field_simps) finally (xtrans) show "- (f x - (a * x + m)) \ (f u - f l - a * (u - l)) / 2" by (simp add: algebra_simps m_def divide_simps) next have "f x \ 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 "\ \ 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) \ (f u - f l - a * (u - l)) / 2" by (simp add: algebra_simps m_def divide_simps) qed also have "\m - b\ = abs ((f l + f u - a * (l + u)) / 2 - b)" unfolding m_def .. finally show "\f x - (a * x + b)\ \ (f u - f l - a * (u - l)) / 2 + \(f l + f u - a * (l + u)) / 2 - b\" by (simp) qed lemma min_range_coeffs_le: "\f x - (a * x + b)\ \ d" if l: "l \ x" and u: "x \ u" and f': "\y. y \ {l .. u} \ (f has_real_derivative f' y) (at y)" and a: "\y. y \ {l .. u} \ f' y \ a" and d: "d \ (f l - f u + a * (u - l)) / 2 + \(f l + f u - a * (l + u)) / 2 - b\" 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 \ {l .. u}" and llu: "l \ {l .. u}" by simp_all define m where "m = (f l + f u - a * (l + u)) / 2" have "\f x - (a * x + b)\ = \f x - (a * x + m) + (m - b)\" by (simp add: algebra_simps) also have "\ \ \f x - (a * x + m)\ + \m - b\" by (rule abs_triangle_ineq) also have "\f x - (a * x + m)\ \ (f l - f u + a * (u - l)) / 2" proof (rule abs_leI) have "f x \ f u + a * (x - u)" (is "?l \ ?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 \ ?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)) \ (f l - f u + a * (u - l)) / 2" by (simp add: algebra_simps m_def divide_simps) next have "f x \ 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 "\ \ 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) \ (f l - f u + a * (u - l)) / 2" by (simp add: algebra_simps m_def divide_simps) qed also have "\m - b\ = abs ((f l + f u - a * (l + u)) / 2 - b)" unfolding m_def .. finally show "\f x - (a * x + b)\ \ (f l - f u + a * (u - l)) / 2 + \(f l + f u - a * (l + u)) / 2 - b\" by (simp) qed context includes floatarith_notation begin definition "range_reducer p l = (if l < 0 \ 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] sym, simplified] +lemmas approx_emptyD = approx[OF bounded_by_None[of Nil], simplified] lemma range_reducerE: - assumes "range_reducer p l = Some (r, r')" - obtains n::int where "r \ n * (2 * pi)" "n * (2 * pi) \ r'" + assumes "range_reducer p l = Some ivl" + obtains n::int where "n * (2 * pi) \\<^sub>r ivl" proof (cases "l \ 0 \ l \ 2 * lb_pi p") case False - with assms have - "r \ - \l / (2 * pi)\ * (2 * pi)" - "- \l / (2 * pi)\ * (2 * pi) \ r'" + with assms have "- \l / (2 * pi)\ * (2 * pi) \\<^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 "r \ real_of_int 0 * (2 * pi)" "real_of_int 0 * (2 * pi) \ r'" using assms - by (auto simp: range_reducer_def zero_prod_def) + case True then have "real_of_int 0 * (2 * pi) \\<^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 { - let l = Inf_aform_err p X; - let u = Sup_aform_err p X; - (r, r') \ range_reducer p l; - Some (add_aform' p X (ivl_err (real_of_float r) (real_of_float r'))) + r \ 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 \ UNIV \ {-1 .. 1}" assumes x: "x \ aform_err e X" assumes "range_reduce_aform_err p X = Some Y" obtains n::int where "x + n * (2 * pi) \ aform_err e Y" proof - - from assms obtain r r' + from assms obtain r where x: "x \ aform_err e X" - and r: "range_reducer p (Inf_aform_err p X) = Some (r, r')" - and Y: "Y = add_aform' p X (ivl_err (real_of_float r) (real_of_float r'))" + 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 "r \ n * (2 * pi)" "n * (2 * pi) \ r'" + obtain n::int where "n * (2 * pi) \\<^sub>r r" by auto - then have "n * (2 * pi) \ aform_err e (ivl_err (real_of_float r) (real_of_float r'))" - by (auto simp: aform_val_def ac_simps divide_simps abs_real_def intro!: aform_errI) + then have "n * (2 * pi) \ 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) \ 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; - (a, _) \ approx p (Min (DF L) (DF U)) []; + aivl \ approx p (Min (DF L) (DF U)) []; + let a = lower aivl; let A = Num a; bivl \ 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)); - (_, d) \ approx p ((Half (F U - F L - A * (U - L))) + Be) []; - Some (affine_unop p a b (real_of_float d) X) + divl \ 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 \ aform_err e X" assumes "l \ x" "x \ u" assumes "min_range_mono p F DF l u X = Some Y" assumes e: "e \ UNIV \ {-1 .. 1}" assumes F: "\x. x \ {real_of_float l .. u} \ interpret_floatarith (F (Num x)) [] = f x" assumes DF: "\x. x \ {real_of_float l .. u} \ interpret_floatarith (DF (Num x)) [] = f' x" assumes f': "\x. x \ {real_of_float l .. u} \ (f has_real_derivative f' x) (at x)" assumes f'_le: "\x. x \ {real_of_float l .. u} \ min (f' l) (f' u) \ f' x" shows "f x \ aform_err e Y" proof - - from assms obtain a bl bu du - where bl: "bl \ (f l + f u - a * (l + u)) / 2" - and bu: "(f l + f u - a * (l + u))/2 \ bu" - and Y: "Y = affine_unop p (a) ((bl + bu) / 2) (du) X" - and du: "(f u - f l - a * (u - l)) / 2 + (bu - bl) / 2 \ du" + from assms obtain a b be bivl divl + where bivl: "(f l + f u - a * (l + u))/2 \\<^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 \\<^sub>r divl" and a: "a \ f' l" "a \ f' u" - by (auto simp: min_range_mono_def Let_def bind_eq_Some_conv mid_err_def + 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) - then obtain b be where b_def: "b = (bl + bu) / 2" and be_def: "be = (bu - bl) / 2" - by blast have diff_le: "real_of_float a \ f' y" if "real_of_float l \ y" "y \ u" for y using f'_le[of y] that a by auto have le_be: "\(f (l) + f (u) - a * (real_of_float l + u)) / 2 - b\ \ be" - using bl bu + using bivl unfolding b_def be_def - by (auto simp: abs_real_def divide_simps) - have "\f x - (a * x + b)\ \ du" + by (auto simp: abs_real_def divide_simps set_of_eq) + have "\f x - (a * x + b)\ \ upper divl" apply (rule min_range_coeffs_ge) apply (rule \l \ x$$ apply (rule \x \ u\) 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 bl bu + using bivl du unfolding b_def[symmetric] be_def[symmetric] - by auto + by (auto simp: set_of_eq) from affine_unop[where f=f and p = p, OF \x \ _\ this e] - have "f x \ aform_err e (affine_unop p (real_of_float a) b du X)" + have "f x \ 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; - (_, a) \ approx p (Max (DF L) (DF U)) []; + aivl \ approx p (Max (DF L) (DF U)) []; + let a = upper aivl; let A = Num a; bivl \ 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)); - (_, d) \ approx p (Add (Half (F L - F U + A * (U - L))) Be) []; - Some (affine_unop p a b (real_of_float d) X) + divl \ 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 \ aform_err e X" assumes "l \ x" "x \ u" assumes "min_range_antimono p F DF l u X = Some Y" assumes e: "e \ UNIV \ {-1 .. 1}" assumes F: "\x. x \ {real_of_float l .. u} \ interpret_floatarith (F (Num x)) [] = f x" assumes DF: "\x. x \ {real_of_float l .. u} \ interpret_floatarith (DF (Num x)) [] = f' x" assumes f': "\x. x \ {real_of_float l .. u} \ (f has_real_derivative f' x) (at x)" assumes f'_le: "\x. x \ {real_of_float l .. u} \ f' x \ max (f' l) (f' u)" shows "f x \ aform_err e Y" proof - - from assms obtain a bl bu du - where bl: "bl \ (f l + f u - a * (l + u)) / 2" - and bu: "(f l + f u - a * (l + u))/2 \ bu" - and Y: "Y = affine_unop p (a) ((bl + bu) / 2) (du) X" - and du: "(f l - f u + a * (u - l)) / 2 + (bu - bl) / 2 \ du" - and a: "f' l \ a" "f' u \ a" - by (auto simp: min_range_antimono_def Let_def bind_eq_Some_conv mid_err_def + from assms obtain a b be aivl bivl divl + where bivl: "(f l + f u - real_of_float a * (l + u)) / 2 \\<^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 \\<^sub>r divl" + and a: "f' l \ a" "f' u \ 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) - then obtain b be where b_def: "b = (bl + bu) / 2" and be_def: "be = (bu - bl) / 2" - by blast have diff_le: "f' y \ real_of_float a" if "real_of_float l \ y" "y \ u" for y using f'_le[of y] that a by auto have le_be: "$$f (l) + f (u) - a * (real_of_float l + u)) / 2 - b\ \ be" - using bl bu + using bivl unfolding b_def be_def - by (auto simp: abs_real_def divide_simps) - have "\f x - (a * x + b)\ \ du" + by (auto simp: abs_real_def divide_simps set_of_eq) + have "\f x - (a * x + b)\ \ upper divl" apply (rule min_range_coeffs_le) apply (rule \l \ x$$ apply (rule \x \ u\) 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 bl bu + using du bivl unfolding b_def[symmetric] be_def[symmetric] - by auto + by (auto simp: set_of_eq) from affine_unop[where f=f and p = p, OF \x \ _\ this e] - have "f x \ aform_err e (affine_unop p (real_of_float a) b du X)" + have "f x \ 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 \ range_reduce_aform_err p X; - let l = Inf_aform_err p X; - let u = Sup_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 \ 0 \ u \ lb_pi p then min_range_antimono p Cos (\x. (Minus (Sin x))) l u X else if l \ ub_pi p \ u \ 2 * lb_pi p then min_range_mono p Cos (\x. (Minus (Sin x))) l u X else do { - let (a, b) = (bnds_cos p l u); - Some (ivl_err a b) + Some (ivl_err (real_interval (cos_float_interval p ivl))) } }" lemma abs_half_enclosure: fixes r::real assumes "bl \ r" "r \ bu" shows "\r - (bl + bu) / 2\ \ (bu - bl) / 2" using assms by (auto simp: abs_real_def divide_simps) lemma cos_aform_err: assumes x: "x \ aform_err e X0" assumes "cos_aform_err p X0 = Some Y" assumes e: "e \ UNIV \ {-1 .. 1}" shows "cos x \ aform_err e Y" proof - - from assms obtain X l u where + from assms obtain X ivl l u where X: "range_reduce_aform_err p X0 = Some X" - and l: "l = Inf_aform_err p X" - and u: "u = Sup_aform_err p 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) \ aform_err e X" by auto define xn where "xn = x + n * (2 * pi)" with xn have xn: "xn \ aform_err e X" by auto - with l u have lxn: "l \ xn" and uxn: "xn \ u" - using Inf_Sup_aform_err[OF e, of X p] - by auto + from ivl_of_aform_err[OF e xn, of p, folded ivl_def] + have "xn \\<^sub>r ivl" . + then have lxn: "l \ xn" and uxn: "xn \ u" + by (auto simp: l_def u_def set_of_eq) consider "l \ 0" "u \ lb_pi p" | "l < 0 \ u > lb_pi p" "l \ ub_pi p" "u \ 2 * lb_pi p" | "l < 0 \ u > lb_pi p" "l < ub_pi p \ u > 2 * lb_pi p" by arith then show ?thesis proof cases case 1 then have min_eq_Some: "min_range_antimono p Cos (\x. Minus (Sin x)) l u X = Some Y" and bounds: "0 \ l" "u \ (lb_pi p)" using assms(2) - unfolding cos_aform_err_def X l u - by (auto simp: X l[symmetric] u[symmetric] split: prod.splits) + 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 \ l" "u \ pi" using bounds pi_boundaries[of p] by auto have diff_le: "- sin y \ max (- sin (real_of_float l)) (- sin (real_of_float u))" if "real_of_float l \ y" "y \ real_of_float u" for y proof - consider "y \ pi / 2" | "y \ pi / 2" by arith then show ?thesis proof cases case 1 then have "- sin y \ - sin l" using that bounds by (auto intro!: sin_monotone_2pi_le) then show ?thesis by auto next case 2 then have "- sin y \ - 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 \ aform_err e Y" apply (rule min_range_antimono[OF xn lxn uxn min_eq_Some e, where f'="\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: ) next case 2 then have min_eq_Some: "min_range_mono p Cos (\x. Minus (Sin x)) l u X = Some Y" and bounds: "ub_pi p \ l" "u \ 2 * lb_pi p" using assms(2) - unfolding cos_aform_err_def X l u - by (auto simp: X l[symmetric] u[symmetric] split: prod.splits) + 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 \ l" "u \ 2 * pi" using bounds pi_boundaries[of p] by auto have diff_le: "min (- sin (real_of_float l)) (- sin (real_of_float u)) \ - sin y" if "real_of_float l \ y" "y \ real_of_float u" for y proof - consider "y \ 3 * pi / 2" | "y \ 3 * pi / 2" by arith then show ?thesis proof cases case 1 then have "- sin l \ - 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 \ - 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 \ aform_err e Y" apply (rule min_range_mono[OF xn lxn uxn min_eq_Some e, where f'="\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: ) next case 3 - then obtain l' u' where - "bnds_cos p l u = (l', u')" - "Y = ivl_err (real_of_float l') (real_of_float u')" + 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 u - by (auto simp: X l[symmetric] u[symmetric] split: prod.splits) - with bnds_cos[of l' u' p, rule_format, of l u xn] lxn uxn + 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 \xn \\<^sub>r ivl\, of p] show ?thesis by (auto simp: xn_def) qed qed definition "sqrt_aform_err p X = do { - let l = Inf_aform_err p X; - let u = Sup_aform_err p X; + 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 (\x. Half (Inverse (Sqrt x))) l u X - else Some (ivl_err (lb_sqrt p l) (ub_sqrt p u)) + else Some (ivl_err (real_interval (sqrt_float_interval p ivl))) }" lemma sqrt_aform_err: assumes x: "x \ aform_err e X" assumes "sqrt_aform_err p X = Some Y" assumes e: "e \ UNIV \ {-1 .. 1}" shows "sqrt x \ aform_err e Y" proof - - obtain l u where l: "l = Inf_aform_err p X" - and u: "u = Sup_aform_err p X" + 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 x l u have lx: "l \ x" and ux: "x \ u" - using Inf_Sup_aform_err[OF e, of X p] - by auto + from ivl_of_aform_err[OF e x, of p, folded ivl_def] + have ivl: "x \\<^sub>r ivl" . + then have lx: "l \ x" and ux: "x \ u" + by (auto simp flip: ivl_def simp: l_def u_def set_of_eq) consider "l > 0" | "l \ 0" by arith then show ?thesis proof cases case 1 then have min_eq_Some: "min_range_mono p Sqrt (\x. Half (Inverse (Sqrt x))) l u X = Some Y" and bounds: "0 < l" using assms(2) - unfolding sqrt_aform_err_def l u - by (auto simp: l[symmetric] u[symmetric] split: prod.splits if_splits) + unfolding sqrt_aform_err_def + by (auto simp: Let_def simp flip: l_def u_def ivl_def split: prod.splits) have "sqrt x \ aform_err e Y" apply (rule min_range_mono[OF x lx ux min_eq_Some e, where f'="\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 \l > 0\ by (auto simp: inverse_eq_divide min_def divide_simps) done then show ?thesis by (simp add: ) next case 2 - then have "Y = ivl_err (lb_sqrt p l) (ub_sqrt p u)" + then have "Y = ivl_err (real_interval (sqrt_float_interval p ivl))" using assms(2) - unfolding sqrt_aform_err_def l u - by (auto simp: l[symmetric] u[symmetric] split: prod.splits) - with bnds_sqrt[rule_format, OF conjI[OF refl], of x l u p] lx ux + 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: ) + by (auto simp: set_of_eq) qed qed definition "ln_aform_err p X = do { - let l = Inf_aform_err p X; - let u = Sup_aform_err p X; - if 0 < l then min_range_mono p Ln inverse l u X + 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 \ aform_err e X" assumes "ln_aform_err p X = Some Y" assumes e: "e \ UNIV \ {-1 .. 1}" shows "ln x \ aform_err e Y" proof - - obtain l u where l: "l = Inf_aform_err p X" - and u: "u = Sup_aform_err p X" + 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 x l u have lx: "l \ x" and ux: "x \ u" - using Inf_Sup_aform_err[OF e, of X p] - by auto + from ivl_of_aform_err[OF e x, of p, folded ivl_def] + have "x \\<^sub>r ivl" . + then have lx: "l \ x" and ux: "x \ u" + by (auto simp: set_of_eq l_def u_def) consider "l > 0" | "l \ 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 l u - by (auto simp: l[symmetric] u[symmetric] split: prod.splits if_splits) + 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 \ 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 \l > 0\ by (auto simp: inverse_eq_divide min_def divide_simps) done then show ?thesis by (simp add: ) next case 2 then show ?thesis using assms - by (auto simp: ln_aform_err_def Let_def l[symmetric]) + by (auto simp: ln_aform_err_def Let_def l_def ivl_def) qed qed definition "exp_aform_err p X = do { - let l = Inf_aform_err p X; - let u = Sup_aform_err p X; - min_range_mono p Exp Exp l u X + 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 \ aform_err e X" assumes "exp_aform_err p X = Some Y" assumes e: "e \ UNIV \ {-1 .. 1}" shows "exp x \ aform_err e Y" proof - - obtain l u where l: "l = Inf_aform_err p X" - and u: "u = Sup_aform_err p X" + 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 x l u have lx: "l \ x" and ux: "x \ u" - using Inf_Sup_aform_err[OF e, of X p] - by auto + from ivl_of_aform_err[OF e x, of p, folded ivl_def] + have "x \\<^sub>r ivl" . + then have lx: "l \ x" and ux: "x \ 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 l u - by (auto simp: l[symmetric] u[symmetric] split: prod.splits if_splits) + 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 \ 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: ) 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 (\x. 1 / (Num 1 + x * x)) l u X }" lemma pos_add_nonneg_ne_zero: "a > 0 \ b \ 0 \ a + b \ 0" for a b::real by arith lemma arctan_aform_err: assumes x: "x \ aform_err e X" assumes "arctan_aform_err p X = Some Y" assumes e: "e \ UNIV \ {-1 .. 1}" shows "arctan x \ 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 \ x" and ux: "x \ u" using Inf_Sup_aform_err[OF e, of X p] by auto have min_eq_Some: "min_range_mono p Arctan (\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 \ aform_err e Y" apply (rule min_range_mono[OF x lx ux min_eq_Some e, where f'="\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 \ 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: ) qed subsection \Power, TODO: compare with Min-range approximation?!\ 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 + err = the (approx p (Num (of_nat n) * Num xe * Abs (Num x0) ^\<^sub>e (n - 1) + (Sum\<^sub>e (\k. Num (of_nat (n choose k)) * Abs (Num x0) ^\<^sub>e (n - k) * (Num xe + Num (float_of t)) ^\<^sub>e k) - [2.. - {real_of_float (fst (the (approx p f []))) .. real_of_float (snd (the (approx p f [])))}" + shows "interpret_floatarith f [] \\<^sub>r (the (approx p f []))" proof - from plain_floatarith_approx_not_None[OF assms(1), of Nil p] - obtain l u where "Some (l, u) = approx p f []" + obtain ivl where "approx p f [] = Some ivl" by auto - from this[symmetric] approx[OF bounded_by_Nil this] + 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) \ list_all (\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 \ float" by (induction xs rule: rev_induct) (auto simp: sum_list'_def eucl_truncate_up_real_def) lemma tdev'_float[simp]: "tdev' p xs \ float" by (auto simp: tdev'_def) lemma fixes x y::real assumes "abs (x - y) \ e" obtains err where "x = y + err" "abs err \ 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 \ aform_err e X" assumes floats[simp]: "fst (fst X) \ float" "snd X \ float" assumes e: "e \ UNIV \ {-1 .. 1}" shows "x ^ n \ aform_err e (power_aform_err p X n)" proof - consider "n = 0" | "n = 1" | "n \ 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 \ float" "xe \ 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': "\xe'\ \ xe" by (auto simp: x0_def xs_def xe_def xe'_def) then have xe_nonneg: "0 \ xe" by (auto simp: ) - + define t where "t = tdev' p xs" have t: "tdev xs \ t" "t \ float" by (auto simp add: t_def tdev'_le) then have t_nonneg: "0 \ 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 "\ ^ n = x0 ^ n + n * x0 ^ (n - Suc 0) * pdevs_val e xs + (n * xe' * x0 ^ (n - Suc 0) + (\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) + + + let ?ERR = "(Num (of_nat n) * Num (float_of xe) * Abs (Num (float_of x0)) ^\<^sub>e (n - 1) + (Sum\<^sub>e (\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.. ERR" proof - have err_aerr: "abs (?err) \ n * xe * abs x0 ^ (n - Suc 0) + (\k = 2..n. real (n choose k) * (t + xe) ^ k * abs x0 ^ (n - k))" (is "_ \ ?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 ..e times_floatarith_def plus_floatarith_def intro!: list_allI) from plain_floatarith_approx[OF this, of p] have "ERR \ ?aerr" using n - by (auto simp: ERR_def sum_list_distinct_conv_sum_set rewr t x0_def algebra_simps) + 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 \ {fst C .. snd C}" - by (auto simp: C_def x0_def) - + have C: "x0 ^ n \ {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') \ 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) \ {fst NX .. snd NX}" - by (auto simp: NX_def x0_def) - + have NX: "n * x0 ^ (n - 1) \ {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 \ nxe * t" by (auto simp: Ye_def truncate_up_le) have nx: "abs (nx') \ nxe" "0 \ 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) \ 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)) \ 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 "\x ^ n - aform_val e (c, Y') \ = \ce' + - pdevs_val e (trunc_err_pdevs p Y) + nx' * pdevs_val e xs + ?err\" by (simp add: algebra_simps aform_val_def) also have "\ \ ce + Y_err + Ye + ERR" by (intro ERR abs_triangle_ineq[THEN order_trans] add_mono ce' Ye Y_err) also have "\ \ 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') + 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 \ r \ 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 \ ln_aform_err p X; exp_aform_err p (mult_aform' p A L) } - else approx_bin p (bnds_powr p) X A)" - -lemma interval_extension_powr: "interval_extension2 (bnds_powr p) (powr)" - using bnds_powr[of _ _ p] - by (force simp: interval_extension2_def) + 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 \ aform_err e X" assumes a: "a \ aform_err e A" assumes e: "e \ UNIV \ {-1 .. 1}" assumes Y: "powr_aform_err p X A = Some Y" shows "x powr a \ 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 \ aform_err e L" . from mult_aform'E[OF e a this] have "a * ln x \ aform_err e (mult_aform' p A L)" . from exp_aform_err[OF this E e] have "exp (a * ln x) \ aform_err e Y" . finally show ?thesis . next from x a have xa: "x \ aform_err e (fst X, snd X)" "a \ aform_err e (fst A, snd A)" by simp_all assume "\ Inf_aform_err p X > 0" - then have "approx_bin p (bnds_powr p) (fst X, snd X) (fst A, snd A) = Some Y" + 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 \ aform_err e Y" . qed fun approx_floatarith :: "nat \ floatarith \ aform_err list \ (aform_err) option" where "approx_floatarith p (Add a b) vs = do { a1 \ approx_floatarith p a vs; a2 \ approx_floatarith p b vs; Some (add_aform' p a1 a2) }" | "approx_floatarith p (Mult a b) vs = do { a1 \ approx_floatarith p a vs; a2 \ approx_floatarith p b vs; Some (mult_aform' p a1 a2) }" | "approx_floatarith p (Inverse a) vs = do { a \ 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 \ approx_floatarith p a vs; - let i = Inf_aform_err p r; - let s = Sup_aform_err p r; + 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 0 (max (- i) \s\)) + Some (ivl_err (real_interval (abs_interval ivl))) } }" | "approx_floatarith p (Min a b) vs = do { a1 \ approx_floatarith p a vs; a2 \ approx_floatarith p b vs; Some (min_aform_err p a1 a2) }" | "approx_floatarith p (Max a b) vs = do { a1 \ approx_floatarith p a vs; a2 \ approx_floatarith p b vs; Some (max_aform_err p a1 a2) }" | "approx_floatarith p (Floor a) vs = - approx_un p (\l u. Some (floor_fl l, floor_fl u)) (approx_floatarith p a vs)" + approx_un p (\ivl. Some (floor_float_interval ivl)) (approx_floatarith p a vs)" | "approx_floatarith p (Cos a) vs = do { a \ approx_floatarith p a vs; cos_aform_err p a }" -| "approx_floatarith p Pi vs = Some (ivl_err (lb_pi p) (ub_pi p))" +| "approx_floatarith p Pi vs = Some (ivl_err (real_interval (pi_float_interval p)))" | "approx_floatarith p (Sqrt a) vs = do { a \ approx_floatarith p a vs; sqrt_aform_err p a }" | "approx_floatarith p (Ln a) vs = do { a \ approx_floatarith p a vs; ln_aform_err p a }" | "approx_floatarith p (Arctan a) vs = do { a \ approx_floatarith p a vs; arctan_aform_err p a }" | "approx_floatarith p (Exp a) vs = do { a \ approx_floatarith p a vs; exp_aform_err p a }" | "approx_floatarith p (Power a n) vs = do { ((a, as), e) \ approx_floatarith p a vs; if is_float a \ is_float e then Some (power_aform_err p ((a, as), e) n) else None }" | "approx_floatarith p (Powr a b) vs = do { ae1 \ approx_floatarith p a vs; ae2 \ 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 interval_extension_cos: "interval_extension1 (\l u. Some (bnds_cos p l u)) cos" - using bnds_cos - by (auto simp: interval_extension1_def) metis+ - -lemma interval_extension_power: "interval_extension1 (\l u. Some (float_power_bnds p n l u)) (\x. x ^ n)" - using bnds_power - by (auto simp: interval_extension1_def bind_eq_Some_conv; metis) - -lemma interval_extension_ln: "interval_extension1 (\l u. do {l' \ lb_ln p l; u' \ ub_ln p u; Some (l', u')}) ln" - using bnds_ln[of _ _ p] - by (auto simp del: lb_ln.simps ub_ln.simps simp: interval_extension1_def bind_eq_Some_conv; metis) - -lemma interval_extension_arctan: "interval_extension1 (\l u. Some (lb_arctan p l, ub_arctan p u)) arctan" - using bnds_arctan - by (auto simp del: lb_arctan.simps ub_arctan.simps simp: interval_extension1_def; metis) - -lemma interval_extension_exp: "interval_extension1 (\l u. Some (lb_exp p l, ub_exp p u)) exp" - using bnds_exp - by (auto simp: interval_extension1_def; metis) - -lemma interval_extension_sqrt: "interval_extension1 (\l u. Some (lb_sqrt p l, ub_sqrt p u)) sqrt" - using bnds_sqrt - by (auto simp: interval_extension1_def; metis) - -lemma interval_extension_floor: "interval_extension1 (\l u. Some (floor_fl l, floor_fl u)) floor" - by (auto simp: interval_extension1_def floor_fl.rep_eq floor_mono) - lemma degree_aform_inverse_aform': "degree_aform X \ n \ degree_aform (fst (inverse_aform' p X)) \ 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 \ n" shows "degree_aform (fst Y) \ n" - using assms + 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 b)) = 0" +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) \ m" assumes "degree_aform (fst Y) \ m" shows "degree_aform (fst Z) \ 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 \ True | Some X \ degree_aform (fst X) \ d1" shows "degree_aform (fst Y) \ 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 \ d" assumes "degree_aform_err y \ d" shows "degree_aform_err (max_aform_err p x y) \ 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 \ d" assumes "degree_aform_err y \ d" shows "degree_aform_err ((min_aform_err p x y)) \ 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)) \ d" if "degree_aform (fst X) \ d" using that by (auto simp: acc_err_def) lemma degree_pdev_upd_degree: assumes "degree b \ Suc n" assumes "degree b \ Suc (degree_aform_err X)" assumes "degree_aform_err X \ n" shows "degree (pdev_upd b (degree_aform_err X) 0) \ 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 \ n" shows "degree_aform_err Y \ 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) \ n" if "degree_aform_err X \ 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 \ n" shows "degree_aform_err Y \ 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 \ n" shows "degree_aform_err Y \ 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 \ n" shows "degree_aform_err Y \ 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 \ n" shows "degree_aform_err Y \ 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 \ n" shows "degree_aform_err Y \ 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 \ n" shows "degree_aform_err Y \ 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 \ n" shows "degree_aform_err Y \ 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 \ n" shows "degree_aform_err (power_aform_err p X m) \ 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 \ n" assumes "degree_aform_err Z \ n" shows "degree_aform_err Y \ 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 "\V. V \ set VS \ degree_aform_err V \ d" shows "degree_aform_err X \ 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 \ ( \d a1 a2 X e2. fnctn_aff d a1 a2 = Some X \ e2 \ UNIV \ {- 1..1} \ d \ degree_aform a1 \ d \ degree_aform a2 \ (\e3 \ UNIV \ {- 1..1}. (fnctn (aform_val e2 a1) (aform_val e2 a2) = aform_val e3 X \ (\n. n < d \ e3 n = e2 n) \ aform_val e2 a1 = aform_val e3 a1 \ 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 \ UNIV \ {- 1..1}" "d \ degree_aform a1" "d \ degree_aform a2" obtains e' where "e' \ UNIV \ {- 1..1}" "fnctn (aform_val e a1) (aform_val e a2) = aform_val e' X" "\n. n < d \ 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 \ aform_err e (uminus_aform X, ba)" if "e \ UNIV \ {-1 .. 1}" "x \ 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 \ set_Cons A B" if "a \ A" and "b \ B" using that by (auto simp: set_Cons_def) lemma mem_aforms_err_Cons_iff[simp]: "x#xs \ aforms_err e (X#XS) \ x \ aform_err e X \ xs \ aforms_err e XS" by (auto simp: aforms_err_Cons set_Cons_def) lemma mem_aforms_err_Cons_iff_Ex_conv: "x \ aforms_err e (X#XS) \ (\y ys. x = y#ys \ y \ aform_err e X \ ys \ aforms_err e XS)" by (auto simp: aforms_err_Cons set_Cons_def) lemma listset_Cons_mem_conv: "a # vs \ listset AVS \ (\A VS. AVS = A # VS \ a \ A \ vs \ listset VS)" by (induction AVS) (auto simp: set_Cons_def) lemma listset_Nil_mem_conv[simp]: "[] \ listset AVS \ AVS = []" by (induction AVS) (auto simp: set_Cons_def) lemma listset_nthD: "vs \ listset VS \ i < length vs \ vs ! i \ VS ! i" by (induction vs arbitrary: VS i) (auto simp: nth_Cons listset_Cons_mem_conv split: nat.splits) lemma length_listsetD: "vs \ listset VS \ length vs = length VS" by (induction vs arbitrary: VS) (auto simp: listset_Cons_mem_conv) lemma length_aforms_errD: "vs \ aforms_err e VS \ length vs = length VS" by (auto simp: aforms_err_def length_listsetD) lemma nth_aforms_errI: "vs ! i \ aform_err e (VS ! i)" if "vs \ 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 \ float" by (auto simp: eucl_truncate_down_def) lemma eucl_truncate_up_float[simp]: "eucl_truncate_up p x \ float" by (auto simp: eucl_truncate_up_def) lemma trunc_bound_eucl_float[simp]: "fst (trunc_bound_eucl p x) \ float" "snd (trunc_bound_eucl p x) \ float" by (auto simp: trunc_bound_eucl_def Let_def) lemma add_aform'_float: "add_aform' p x y = ((a, b), ba) \ a \ float" "add_aform' p x y = ((a, b), ba) \ ba \ float" by (auto simp: add_aform'_def Let_def) lemma uminus_aform_float: "uminus_aform (aa, bb) = (a, b) \ aa \ float \ a \ float" by (auto simp: uminus_aform_def) lemma mult_aform'_float: "mult_aform' p x y = ((a, b), ba) \ a \ float" "mult_aform' p x y = ((a, b), ba) \ ba \ float" by (auto simp: mult_aform'_def Let_def split_beta') lemma inverse_aform'_float: "inverse_aform' p x = ((a, bb), baa) \ a \ 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) \ a \ 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) \ a \ float" "inverse_aform_err p x = Some ((a, b), ba) \ ba \ 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) \ a \ float" "affine_unop p asdf aaa bba h = ((a, b), ba) \ ba \ 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) \ a \ float" "min_range_antimono p f f' i g h = Some ((a, b), ba) \ ba \ 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) \ a \ float" "min_range_mono p f f' i g h = Some ((a, b), ba) \ ba \ float" by (auto simp: min_range_mono_def Let_def bind_eq_Some_conv mid_err_def affine_unop_float split: prod.splits) -lemma ivl_err_float: - assumes "ivl_err x y = ((a, b), ba)" "x \ float" "y \ float" - shows "a \ float" "ba \ float" -proof - - from assms(1) have "a = (x + y) / 2" "ba = (y - x) / 2" - by (auto simp: ivl_err_def) - moreover have "(x + y) / 2 \ float" "(y - x) / 2 \ float" - using assms - by (auto intro!: ) - ultimately show "a \ float" "ba \ float" by blast+ -qed - lemma in_float_timesI: "a \ float" if "b = a * 2" "b \ float" proof - from that have "a = b / 2" by simp also have "\ \ float" using that(2) by auto finally show ?thesis . qed +lemma interval_extension_floor: "interval_extension1 (\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 \ UNIV \ {-1 .. 1}" assumes "vs \ aforms_err e VS" shows "interpret_floatarith ra vs \ 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 \ aform_err e a" by auto - let ?i = "Inf_aform_err p a" - let ?s = "Sup_aform_err p a" + then have mem': "-interpret_floatarith fa vs \ 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 \ 0" "?s < 0" | "?i \ 0" "?s \ 0" by arith then show ?case proof cases case hyps: 1 then show ?thesis - using Abs.prems mem Inf_Sup_aform_err[OF e, of a p] - by (auto simp: a) + 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 Inf_Sup_aform_err[OF e, of "apfst uminus_aform a" p] - Inf_Sup_aform_err[OF e, of "a" p] - by (cases a) (auto simp: a abs_real_def intro!: aform_err_uminus_aform[OF e]) + 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 Inf_Sup_aform_err[OF e, of a p] - by (auto simp: a abs_real_def max_def Let_def) + 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 \ aform_err e a" "interpret_floatarith ra2 vs \ aform_err e b" by auto - let ?ia = "Inf_aform_err p a" - let ?sa = "Sup_aform_err p a" - let ?ib = "Inf_aform_err p b" - let ?sb = "Sup_aform_err p b" + 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 \ ?ib" "?sb < ?ia" | "?sa \ ?ib" "?sb \ ?ia" by arith then show ?case - proof cases - case hyps: 1 - then show ?thesis - using Max.prems mem Inf_Sup_aform_err[OF e, of a p] Inf_Sup_aform_err[OF e, of b p] - by (force simp: a b max_def max_aform_err_def) - next - case hyps: 2 - then show ?thesis - using Max.prems mem Inf_Sup_aform_err[OF e, of a p] Inf_Sup_aform_err[OF e, of b p] - Inf_Sup_aform_err[OF e, of "a" p] - by (force simp: a b max_def max_aform_err_def) - next - case hyps: 3 - then show ?thesis - using Max.prems mem - apply (simp add: a b max_aform_err_def) - apply auto - using Inf_Sup_aform_err[OF e, of a p] Inf_Sup_aform_err[OF e, of b p] - by (auto simp: max_def) - qed + 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 \ aform_err e a" "interpret_floatarith ra2 vs \ aform_err e b" by auto - let ?ia = "Inf_aform_err p a" - let ?sa = "Sup_aform_err p a" - let ?ib = "Inf_aform_err p b" - let ?sb = "Sup_aform_err p b" + 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 \ ?ib" "?sb < ?ia" | "?sa \ ?ib" "?sb \ ?ia" by arith then show ?case - proof cases - case hyps: 1 - then show ?thesis - using Min.prems mem Inf_Sup_aform_err[OF e, of a p] Inf_Sup_aform_err[OF e, of b p] - by (force simp: a b min_def min_aform_err_def) - next - case hyps: 2 - then show ?thesis - using Min.prems mem Inf_Sup_aform_err[OF e, of a p] Inf_Sup_aform_err[OF e, of b p] - Inf_Sup_aform_err[OF e, of "a" p] - by (force simp: a b min_def min_aform_err_def) - next - case hyps: 3 - then show ?thesis - using Min.prems mem - apply (simp add: a b min_aform_err_def) - apply auto - using Inf_Sup_aform_err[OF e, of a p] Inf_Sup_aform_err[OF e, of b p] - by (auto simp: min_def) - qed + 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_boundaries + then show ?case using pi_float_interval by (auto simp: ) 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 \ floatarith list \ aform_err list \ aform_err list option" where "approx_floatariths_aformerr _ [] _ = Some []" | "approx_floatariths_aformerr p (a#bs) vs = do { a \ approx_floatarith p a vs; r \ approx_floatariths_aformerr p bs vs; Some (a#r) }" lemma approx_floatariths_Elem: assumes "e \ UNIV \ {-1 .. 1}" assumes "approx_floatariths_aformerr p ra VS = Some X" assumes "vs \ aforms_err e VS" shows "interpret_floatariths ra vs \ 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 \ y \ fold max zs x \ 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 \ 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 \ set xs \ x \ fold max xs z" by (induct xs arbitrary: x z) (auto intro: order_trans[OF _ fold_max_le_self]) abbreviation "degree_aforms_err \ degrees o map (snd o fst)" definition "aforms_err_to_aforms d xs = (map ($$d, x). aform_err_to_aform x d) (zip [d.. 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) \ 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)) \ (if snd X = 0 then {} else {n})" if "n \ 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 \ aforms_err e X" assumes deg: "degree_aforms_err X \ n" assumes e: "e \ UNIV \ {-1 .. 1}" shows "\e'\ UNIV \ {-1 .. 1}. x = aform_vals e' (aforms_err_to_aforms n X) \ (\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="\i. e i"]) next case (Cons X XS) from Cons.prems obtain y ys where ys: "degree_aform_err X \ n" "degree_aforms_err XS \ n" "x = y # ys" "y \ aform_err e X" "ys \ aforms_err e XS" by (auto simp: mem_aforms_err_Cons_iff_Ex_conv degrees_def) then have "degree_aforms_err XS \ Suc n" by auto from Cons.IH[OF ys(5) this] obtain e' where e': "e'\UNIV \ {- 1..1}" "ys = aform_vals e' (aforms_err_to_aforms (Suc n) XS)" "(\i err" "err \ 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 (\a. if a = n then err else e' a) b = pdevs_val (e'(n:=err)) b" unfolding fun_upd_def by simp also have "\ = 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) \ n" using ys(2) i by (auto simp: degrees_def) then have "n \ 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 \ aforms_err e X" assumes deg: "degree_aforms_err X \ n" assumes e: "e \ UNIV \ {-1 .. 1}" obtains e' where "x = aform_vals e' (aforms_err_to_aforms n X)" "e' \ UNIV \ {-1 .. 1}" "\i. i < n \ 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 (\x. (x, 0)) as); rs \ 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 (\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 \ Joints as" shows "(interpret_floatariths ea vs @ vs) \ Joints (XS @ as)" proof - from assms obtain da aes rs d where da: "da = degree_aforms as" and aes: "aes = (map (\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) \ set as \ degree b \ degree_aforms as" for a b apply (rule degrees_leD[OF order_refl]) by force from da d have i_less: "(a, b) \ set as \ i < degree b \ i < min d da" for i a b by (auto dest!: abbd) have abbd: "(a, b) \ set as \ degree b \ 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' \ UNIV \ {-1 .. 1}" by (auto simp: Joints_def valuate_def) note vs also have vs_aes: "vs \ 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) \ aforms_err e' rs" by (auto simp: vs) have "degree_aforms_err rs \ 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 \ UNIV \ {- 1..1}" "\i. i < d \ 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 \ length (x#xs) = length (y#ys)" by auto subsection \Generic operations on Affine Forms in Euclidean Space\ lemma pdevs_val_domain_cong: assumes "b = d" assumes "\i. i \ pdevs_domain b \ 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 \ Joints XS" assumes "list_all (\Y. pdevs_domain (snd X) \ pdevs_domain (snd Y) = {}) XS" assumes "x \ Affine X" shows "x#xs \ Joints (X#XS)" using assms unfolding Joints_def Affine_def valuate_def proof safe fix e e'::"nat \ real" assume H: "list_all (\Y. pdevs_domain (snd X) \ pdevs_domain (snd Y) = {}) XS" "e \ UNIV \ {- 1..1}" "e' \ UNIV \ {- 1..1}" have "\a b i. \Y\set XS. pdevs_domain (snd X) \ pdevs_domain (snd Y) = {} \ pdevs_apply b i \ 0 \ pdevs_apply (snd X) i \ 0 \ (a, b) \ 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 \ (\e. map (aform_val e) (X # XS))  (UNIV \ {- 1..1})" by (intro image_eqI[where x = "\i. if i \ 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 \ slp \ aform_err list \ aform_err list option" where "approx_slp p [] xs = Some xs" | "approx_slp p (ea # eas) xs = do { r \ approx_floatarith p ea xs; approx_slp p eas (r#xs) }" lemma Nil_mem_Joints[intro, simp]: "[] \ Joints []" by (force simp: Joints_def valuate_def) lemma map_nth_Joints: "xs \ Joints XS \ (\i. i \ set is \ i < length XS) \ map (nth xs) is @ xs \ Joints (map (nth XS) is @ XS)" by (auto simp: Joints_def valuate_def) lemma map_nth_Joints': "xs \ Joints XS \ (\i. i \ set is \ i < length XS) \ map (nth xs) is \ Joints (map (nth XS) is)" by (rule Joints_appendD2[OF map_nth_Joints]) auto lemma approx_slp_Elem: assumes e: "e \ UNIV \ {-1 .. 1}" assumes "vs \ aforms_err e VS" assumes "approx_slp p ra VS = Some X" shows "interpret_slp ra vs \ 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 \ aform_err e a" by auto then have 1: "interpret_floatarith ra vs#vs \ 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 (\x. (x, 0)) XS); rs \ 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 \ listset XS \ take n xs \ 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 \ aforms_err e (take n XS)" if "xs \ 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 \ Joints XS" shows "interpret_floatariths fas xs @ xs \ Joints (RS @ XS)" proof - from assms obtain d XSe rs rs' d' where d: "d = degree_aforms XS" and XSe: "XSe = (map (\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) \ set XS \ degree b \ degree_aforms XS" for a b apply (rule degrees_leD[OF order_refl]) by force from d' d have i_less: "(a, b) \ set XS \ i < degree b \ 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' \ UNIV \ {-1 .. 1}" by (auto simp: Joints_def valuate_def) from d have d: "V \ set XS \ degree_aform V \ d" for V by (auto intro!: degrees_leD) have xs_XSe: "xs \ 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 \ 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) \ aforms_err e' rs'" unfolding rs' by (auto simp: take_map intro!: take_in_aforms_errI) finally have ier: "interpret_floatariths fas xs \ aforms_err e' rs'" . have "degree_aforms_err rs' \ 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 \ UNIV \ {- 1..1}" "\i. i < d' \ e i = e' i" unfolding RS by (auto simp: ) 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 \ Joints XS" shows "interpret_floatariths fas xs \ 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 \ 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/Print.thy b/thys/Affine_Arithmetic/Print.thy --- a/thys/Affine_Arithmetic/Print.thy +++ b/thys/Affine_Arithmetic/Print.thy @@ -1,232 +1,234 @@ section \Target Language debug messages\ theory Print imports "HOL-Decision_Procs.Approximation" Affine_Code Show.Show_Instances "HOL-Library.Monad_Syntax" Optimize_Float begin hide_const (open) floatarith.Max subsection \Printing\ text \Just for debugging purposes\ definition print::"String.literal \ unit" where "print x = ()" context includes integer.lifting begin end code_printing constant print \ (SML) "TextIO.print" subsection \Write to File\ definition file_output::"String.literal \ ((String.literal \ unit) \ 'a) \ 'a" where "file_output _ f = f (\_. ())" code_printing constant file_output \ (SML) "(fn s => fn f => File.open'_output (fn os => f (File.output os)) (Path.explode s))" subsection \Show for Floats\ definition showsp_float :: "float showsp" where "showsp_float p x = ( let m = mantissa x; e = exponent x in if e = 0 then showsp_int p m else showsp_int p m o shows_string ''*2^'' o showsp_int p e)" lemma show_law_float [show_law_intros]: "show_law showsp_float r" by (auto simp: showsp_float_def Let_def show_law_simps intro!: show_lawI) lemma showsp_float_append [show_law_simps]: "showsp_float p r (x @ y) = showsp_float p r x @ y" by (intro show_lawD show_law_intros) local_setup \Show_Generator.register_foreign_showsp @{typ float} @{term "showsp_float"} @{thm show_law_float}\ derive "show" float subsection \Convert Float to Decimal number\ text \type for decimal floating point numbers (currently just for printing, TODO? generalize theory Float for arbitrary base)\ datatype float10 = Float10 (mantissa10: int) (exponent10: int) notation Float10 (infix "\" 999) partial_function (tailrec) normalize_float10 where [code]: "normalize_float10 f = (if mantissa10 f mod 10 \ 0 \ mantissa10 f = 0 then f else normalize_float10 (Float10 (mantissa10 f div 20) (exponent10 f + 1)))" subsubsection \Version that should be easy to prove correct, but slow!\ context includes floatarith_notation begin definition "float_to_float10_approximation f = the (do { let (x, y) = (mantissa f * 1024, exponent f - 10); let p = nat (bitlen (abs x) + bitlen (abs y) + 80); \ \FIXME: are there guarantees?\ y_log \ approx p (Mult (Num (of_int y)) ((Mult (Ln (Num 2)) (Inverse (Ln (Num 10)))))) []; - let e_fl = floor_fl (fst y_log); + let e_fl = floor_fl (lower y_log); let e = int_floor_fl e_fl; - (ml, mu) \ approx p (Mult (Num (of_int x)) (Powr (Num 10) (Add(Var 0) (Minus (Num e_fl))))) [Some y_log]; + m \ approx p (Mult (Num (of_int x)) (Powr (Num 10) (Add(Var 0) (Minus (Num e_fl))))) [Some y_log]; + let ml = lower m; + let mu = upper m; Some (normalize_float10 (Float10 (int_floor_fl ml) e), normalize_float10 (Float10 (- int_floor_fl (- mu)) e)) })" end lemma compute_float_of[code]: "float_of (real_of_float f) = f" by simp subsection \Trusted, but faster version\ text \TODO: this is the HOL version of the SML-code in Approximation.thy\ lemma prod_case_call_mono[partial_function_mono]: "mono_tailrec (\f. (let (d, e) = a in (\y. f (c d e y))) b)" by (simp add: split_beta' call_mono) definition divmod_int::"int \ int \ int * int" where "divmod_int a b = (a div b, a mod b)" partial_function (tailrec) f2f10_frac where "f2f10_frac c p r digits cnt e = (if r = 0 then (digits, cnt, 0) else if p = 0 then (digits, cnt, r) else (let (d, r) = divmod_int (r * 10) (power_int 2 (-e)) in f2f10_frac (c \ d \ 0) (if d \ 0 \ c then p - 1 else p) r (digits * 10 + d) (cnt + 1)) e)" declare f2f10_frac.simps[code] definition float2_float10::"int \ bool \ int \ int \ (int * int)" where "float2_float10 prec rd m e = ( let (m, e) = (if e < 0 then (m,e) else (m * power_int 2 e, 0)); sgn = sgn m; m = abs m; round_down = (sgn = 1 \ rd) \ (sgn = -1 \ \ rd); (x, r) = divmod_int m ((power_int 2 (-e))); p = ((if x = 0 then prec else prec - (log2 x + 1)) * 3) div 10 + 1; (digits, e10, r) = if p > 0 then f2f10_frac (x \ 0) p r 0 0 e else (0,0,0); digits = if round_down \ r = 0 then digits else digits + 1 in (sgn * (digits + x * (power_int 10 e10)), -e10))" definition "lfloat10 r = (let f = float_of r in case_prod Float10 (float2_float10 20 True (mantissa f) (exponent f)))" definition "ufloat10 r = (let f = float_of r in case_prod Float10 (float2_float10 20 False (mantissa f) (exponent f)))" partial_function (tailrec) digits where [code]: "digits m ds = (if m = 0 then ds else digits (m div 10) (m mod 10 # ds))" primrec showsp_float10 :: "float10 showsp" where "showsp_float10 p (Float10 m e) = ( let ds = digits (nat (abs m)) []; d = int (length ds); e = e + d - 1; mp = take 1 ds; ms = drop 1 ds; ms = rev (dropWhile ((=) 0) (rev ms)); show_digits = shows_list_gen (showsp_nat p) ''0'' '''' '''' '''' in (if m < 0 then shows_string ''-'' else (\x. x)) o show_digits mp o (if ms = [] then (\x. x) else shows_string ''.'' o show_digits ms) o (if e = 0 then (\x. x) else shows_string ''e'' o showsp_int p e))" lemma show_law_float10_aux: fixes m e shows "show_law showsp_float10 (Float10 m e)" apply (rule show_lawI) unfolding showsp_float10.simps Let_def apply (simp add: show_law_simps ) done lemma show_law_float10 [show_law_intros]: "show_law showsp_float10 r" by (cases r) (auto simp: show_law_float10_aux) lemma showsp_float10_append [show_law_simps]: "showsp_float10 p r (x @ y) = showsp_float10 p r x @ y" by (intro show_lawD show_law_intros) local_setup \Show_Generator.register_foreign_showsp @{typ float10} @{term "showsp_float10"} @{thm show_law_float10}\ derive "show" float10 definition "showsp_real p x = showsp_float10 p (lfloat10 x)" lemma show_law_real[show_law_intros]: "show_law showsp_real x" using show_law_float10[of "lfloat10 x"] by (auto simp: showsp_real_def[abs_def] Let_def show_law_def simp del: showsp_float10.simps intro!: show_law_intros) local_setup \Show_Generator.register_foreign_showsp @{typ real} @{term "showsp_real"} @{thm show_law_real}\ derive "show" real subsection \gnuplot output\ subsubsection \vector output of 2D zonotope\ fun polychain_of_segments::"((real \ real) \ (real \ real)) list \ (real \ real) list" where "polychain_of_segments [] = []" | "polychain_of_segments (((x0, y0), z)#segs) = (x0, y0)#z#map snd segs" definition shows_segments_of_aform where "shows_segments_of_aform a b xs color = shows_list_gen id '''' '''' ''\'' ''\'' (map (\(x0, y0). shows_words (map lfloat10 [x0, y0]) o shows_space o shows_string color) (polychain_of_segments (segments_of_aform (prod_of_aforms (xs ! a) (xs ! b)))))" abbreviation "show_segments_of_aform a b x c \ shows_segments_of_aform a b x c ''''" definition shows_box_of_aforms\ \box and some further information\ where "shows_box_of_aforms (XS::real aform list) = (let RS = map (Radius' 20) XS; l = map (Inf_aform' 20) XS; u = map (Sup_aform' 20) XS in shows_words (l @ u @ RS) o shows_space o shows (card (\((\x. pdevs_domain (snd x))  (set XS)))) )" abbreviation "show_box_of_aforms x \ shows_box_of_aforms x ''''" definition "pdevs_domains ((XS::real aform list)) = (\((\x. pdevs_domain (snd x))  (set XS)))" definition "generators XS = (let is = sorted_list_of_set (pdevs_domains XS); rs = map (\i. (i, map (\x. pdevs_apply (snd x) i) XS)) is in (map fst XS, rs))" definition shows_box_of_aforms_hr\ \human readable\ where "shows_box_of_aforms_hr XS = (let RS = map (Radius' 20) XS; l = map (Inf_aform' 20) XS; u = map (Sup_aform' 20) XS in shows_paren (shows_words l) o shows_string '' .. '' o shows_paren (shows_words u) o shows_string ''; devs: '' o shows (card (pdevs_domains XS)) o shows_string ''; tdev: '' o shows_paren (shows_words RS) )" abbreviation "show_box_of_aforms_hr x \ shows_box_of_aforms_hr x ''''" definition shows_aforms_hr\ \human readable\ where "shows_aforms_hr XS = shows (generators XS)" abbreviation "show_aform_hr x \ shows_aforms_hr x ''''" end diff --git a/thys/Differential_Dynamic_Logic/Differential_Axioms.thy b/thys/Differential_Dynamic_Logic/Differential_Axioms.thy --- a/thys/Differential_Dynamic_Logic/Differential_Axioms.thy +++ b/thys/Differential_Dynamic_Logic/Differential_Axioms.thy @@ -1,2650 +1,2648 @@ theory "Differential_Axioms" imports Ordinary_Differential_Equations.ODE_Analysis "Ids" "Lib" "Syntax" "Denotational_Semantics" "Frechet_Correctness" "Axioms" "Coincidence" begin context ids begin section \Differential Axioms\ text \Differential axioms fall into two categories: Axioms for computing the derivatives of terms and axioms for proving properties of ODEs. The derivative axioms are all corollaries of the frechet correctness theorem. The ODE axioms are more involved, often requiring extensive use of the ODE libraries.\ subsection \Derivative Axioms\ definition diff_const_axiom :: "('sf, 'sc, 'sz) formula" where [axiom_defs]:"diff_const_axiom \ Equals (Differential (f fid1 empty)) (Const 0)" definition diff_var_axiom :: "('sf, 'sc, 'sz) formula" where [axiom_defs]:"diff_var_axiom \ Equals (Differential (Var vid1)) (DiffVar vid1)" definition state_fun ::"'sf \ ('sf, 'sz) trm" where [axiom_defs]:"state_fun f = (f f (\i. Var i))" definition diff_plus_axiom :: "('sf, 'sc, 'sz) formula" where [axiom_defs]:"diff_plus_axiom \ Equals (Differential (Plus (state_fun fid1) (state_fun fid2))) (Plus (Differential (state_fun fid1)) (Differential (state_fun fid2)))" definition diff_times_axiom :: "('sf, 'sc, 'sz) formula" where [axiom_defs]:"diff_times_axiom \ Equals (Differential (Times (state_fun fid1) (state_fun fid2))) (Plus (Times (Differential (state_fun fid1)) (state_fun fid2)) (Times (state_fun fid1) (Differential (state_fun fid2))))" \ \$y=g(x)][y'=1](f(g(x))' = f(y)')\\ definition diff_chain_axiom::"('sf, 'sc, 'sz) formula" where [axiom_defs]:"diff_chain_axiom \ [[Assign vid2 (f1 fid2 vid1)]]([[DiffAssign vid2 (Const 1)]] (Equals (Differential (f fid1 (singleton (f1 fid2 vid1)))) (Times (Differential (f1 fid1 vid2)) (Differential (f1 fid2 vid1)))))" subsection \ODE Axioms\ definition DWaxiom :: "('sf, 'sc, 'sz) formula" where [axiom_defs]:"DWaxiom = ([[EvolveODE (OVar vid1) (Predicational pid1)]](Predicational pid1))" definition DWaxiom' :: "('sf, 'sc, 'sz) formula" where [axiom_defs]:"DWaxiom' = ([[EvolveODE (OSing vid1 (Function fid1 (singleton (Var vid1)))) (Prop vid2 (singleton (Var vid1)))]](Prop vid2 (singleton (Var vid1))))" definition DCaxiom :: "('sf, 'sc, 'sz) formula" where [axiom_defs]:"DCaxiom = ( ([[EvolveODE (OVar vid1) (Predicational pid1)]]Predicational pid3) \ (([[EvolveODE (OVar vid1) (Predicational pid1)]](Predicational pid2)) \ ([[EvolveODE (OVar vid1) (And (Predicational pid1) (Predicational pid3))]]Predicational pid2)))" definition DEaxiom :: "('sf, 'sc, 'sz) formula" where [axiom_defs]:"DEaxiom = (([[EvolveODE (OSing vid1 (f1 fid1 vid1)) (p1 vid2 vid1)]] (P pid1)) \ ([[EvolveODE (OSing vid1 (f1 fid1 vid1)) (p1 vid2 vid1)]] [[DiffAssign vid1 (f1 fid1 vid1)]]P pid1))" definition DSaxiom :: "('sf, 'sc, 'sz) formula" where [axiom_defs]:"DSaxiom = (([[EvolveODE (OSing vid1 (f0 fid1)) (p1 vid2 vid1)]]p1 vid3 vid1) \ (Forall vid2 (Implies (Geq (Var vid2) (Const 0)) (Implies (Forall vid3 (Implies (And (Geq (Var vid3) (Const 0)) (Geq (Var vid2) (Var vid3))) (Prop vid2 (singleton (Plus (Var vid1) (Times (f0 fid1) (Var vid3))))))) ([[Assign vid1 (Plus (Var vid1) (Times (f0 fid1) (Var vid2)))]]p1 vid3 vid1)))))" \ \\(Q \ [c&Q](f(x)' \ g(x)'))\\ \ \\\\\ \ \\([c&Q](f(x) \ g(x))) --> (Q \ (f(x) \ g(x))\\ definition DIGeqaxiom :: "('sf, 'sc, 'sz) formula" where [axiom_defs]:"DIGeqaxiom = Implies (Implies (Prop vid1 empty) ([[EvolveODE (OVar vid1) (Prop vid1 empty)]](Geq (Differential (f1 fid1 vid1)) (Differential (f1 fid2 vid1))))) (Implies (Implies(Prop vid1 empty) (Geq (f1 fid1 vid1) (f1 fid2 vid1))) ([[EvolveODE (OVar vid1) (Prop vid1 empty)]](Geq (f1 fid1 vid1) (f1 fid2 vid1))))" \ \\g(x) > h(x) \ [x'=f(x), c & p(x)](g(x)' \ h(x)') \ [x'=f(x), c & p(x)]g(x) > h(x)\\ \ \\(Q \ [c&Q](f(x)' \ g(x)'))\\ \ \\\\\ \ \\([c&Q](f(x) > g(x))) <-> (Q \ (f(x) > g(x))\\ definition DIGraxiom :: "('sf, 'sc, 'sz) formula" where [axiom_defs]:"DIGraxiom = Implies (Implies (Prop vid1 empty) ([[EvolveODE (OVar vid1) (Prop vid1 empty)]](Geq (Differential (f1 fid1 vid1)) (Differential (f1 fid2 vid1))))) (Implies (Implies(Prop vid1 empty) (Greater (f1 fid1 vid1) (f1 fid2 vid1))) ([[EvolveODE (OVar vid1) (Prop vid1 empty)]](Greater (f1 fid1 vid1) (f1 fid2 vid1))))" \ \\[{1' = 1(1) & 1(1)}]2(1) <->\\ \ \\\2. [{1'=1(1), 2' = 2(1)*2 + 3(1) & 1(1)}]2(1)*)\\ definition DGaxiom :: "('sf, 'sc, 'sz) formula" where [axiom_defs]:"DGaxiom = (([[EvolveODE (OSing vid1 (f1 fid1 vid1)) (p1 vid1 vid1)]]p1 vid2 vid1) \ (Exists vid2 ([[EvolveODE (OProd (OSing vid1 (f1 fid1 vid1)) (OSing vid2 (Plus (Times (f1 fid2 vid1) (Var vid2)) (f1 fid3 vid1)))) (p1 vid1 vid1)]] p1 vid2 vid1)))" subsection \Proofs for Derivative Axioms\ lemma constant_deriv_inner: assumes interp:"\x i. (Functions I i has_derivative FunctionFrechet I i x) (at x)" shows "FunctionFrechet I id1 (vec_lambda (\i. sterm_sem I (empty i) (fst$$)) (vec_lambda(\i. frechet I (empty i) (fst \) (snd \)))= 0" proof - have empty_zero:"(vec_lambda(\i. frechet I (empty i) (fst \) (snd \))) = 0" using local.empty_def Cart_lambda_cong frechet.simps(5) zero_vec_def apply auto apply(rule vec_extensionality) using local.empty_def Cart_lambda_cong frechet.simps(5) zero_vec_def by (simp add: local.empty_def) let ?x = "(vec_lambda (\i. sterm_sem I (empty i) (fst \)))" from interp have has_deriv:"(Functions I id1 has_derivative FunctionFrechet I id1 ?x) (at ?x)" by auto then have f_linear:"linear (FunctionFrechet I id1 ?x)" using Deriv.has_derivative_linear by auto then show ?thesis using empty_zero f_linear linear_0 by (auto) qed lemma constant_deriv_zero:"is_interp I \ directional_derivative I (f id1 empty) \ = 0" apply(simp only: is_interp_def directional_derivative_def frechet.simps frechet_correctness) apply(rule constant_deriv_inner) apply(auto) done theorem diff_const_axiom_valid: "valid diff_const_axiom" apply(simp only: valid_def diff_const_axiom_def equals_sem) apply(rule allI | rule impI)+ apply(simp only: dterm_sem.simps constant_deriv_zero sterm_sem.simps) done theorem diff_var_axiom_valid: "valid diff_var_axiom" apply(auto simp add: diff_var_axiom_def valid_def directional_derivative_def) by (metis inner_prod_eq) theorem diff_plus_axiom_valid: "valid diff_plus_axiom" apply(auto simp add: diff_plus_axiom_def valid_def) subgoal for I a b using frechet_correctness[of I "(Plus (state_fun fid1) (state_fun fid2))" b] unfolding state_fun_def apply (auto intro: dfree.intros) unfolding directional_derivative_def by auto done theorem diff_times_axiom_valid: "valid diff_times_axiom" apply(auto simp add: diff_times_axiom_def valid_def) subgoal for I a b using frechet_correctness[of I "(Times (state_fun fid1) (state_fun fid2))" b] unfolding state_fun_def apply (auto intro: dfree.intros) unfolding directional_derivative_def by auto done subsection \Proofs for ODE Axioms\ lemma DW_valid:"valid DWaxiom" apply(unfold DWaxiom_def valid_def Let_def impl_sem ) apply(safe) apply(auto simp only: fml_sem.simps prog_sem.simps box_sem) subgoal for I aa ba ab bb sol t using mk_v_agree[of I "(OVar vid1)" "(ab,bb)" "sol t"] Vagree_univ[of "aa" "ba" "sol t" "ODEs I vid1 (sol t)"] solves_ode_domainD by (fastforce) done lemma DE_lemma: fixes ab bb::"'sz simple_state" and sol::"real \ 'sz simple_state" and I::"('sf, 'sc, 'sz) interp" shows "repd (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t)) vid1 (dterm_sem I (f1 fid1 vid1) (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t))) = mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t)" proof have set_eq:" {Inl vid1, Inr vid1} = {Inr vid1, Inl vid1}" by auto have agree:"Vagree (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t)) (mk_xode I (OSing vid1 (f1 fid1 vid1)) (sol t)) {Inl vid1, Inr vid1}" using mk_v_agree[of I "(OSing vid1 (f1 fid1 vid1))" "(ab, bb)" "(sol t)"] unfolding semBV.simps using set_eq by auto have fact:"dterm_sem I (f1 fid1 vid1) (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t)) = snd (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t))  vid1" using agree unfolding Vagree_def dterm_sem.simps f1_def mk_xode.simps proof - assume alls:"(\i. Inl i \ {Inl vid1, Inr vid1} \ fst (mk_v I (OSing vid1 (f fid1 (singleton (trm.Var vid1)))) (ab, bb) (sol t))  i = fst (sol t, ODE_sem I (OSing vid1 (f fid1 (singleton (trm.Var vid1)))) (sol t))  i) \ (\i. Inr i \ {Inl vid1, Inr vid1} \ snd (mk_v I (OSing vid1 (f fid1 (singleton (trm.Var vid1)))) (ab, bb) (sol t))  i = snd (sol t, ODE_sem I (OSing vid1 (f fid1 (singleton (trm.Var vid1)))) (sol t))  i)" hence atVid'':"snd (mk_v I (OSing vid1 (f fid1 (singleton (trm.Var vid1)))) (ab, bb) (sol t))  vid1 = sterm_sem I (f fid1 (singleton (trm.Var vid1))) (sol t)" by auto have argsEq:"(\ i. dterm_sem I (singleton (trm.Var vid1) i) (mk_v I (OSing vid1 (f fid1 (singleton (trm.Var vid1)))) (ab, bb) (sol t))) = (\ i. sterm_sem I (singleton (trm.Var vid1) i) (sol t))" using alls f1_def by auto thus "Functions I fid1 (\ i. dterm_sem I (singleton (trm.Var vid1) i) (mk_v I (OSing vid1 (f fid1 (singleton (trm.Var vid1)))) (ab, bb) (sol t))) = snd (mk_v I (OSing vid1 (f fid1 (singleton (trm.Var vid1)))) (ab, bb) (sol t))  vid1" by (simp only: atVid'' ODE_sem.simps sterm_sem.simps dterm_sem.simps) qed have eqSnd:"(\ y. if vid1 = y then snd (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t))  vid1 else snd (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t))  y) = snd (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t))" by (simp add: vec_extensionality) have truth:"repd (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t)) vid1 (dterm_sem I (f1 fid1 vid1) (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t))) = mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t)" using fact by (auto simp only: eqSnd repd.simps fact prod.collapse split: if_split) thus "fst (repd (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t)) vid1 (dterm_sem I (f1 fid1 vid1) (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t)))) = fst (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t))" "snd (repd (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t)) vid1 (dterm_sem I (f1 fid1 vid1) (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t)))) = snd (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t)) " by auto qed lemma DE_valid:"valid DEaxiom" proof - have dsafe:"dsafe (f fid1 (singleton (trm.Var vid1)))" unfolding singleton_def by(auto intro: dsafe.intros) have osafe:"osafe(OSing vid1 (f1 fid1 vid1))" unfolding f1_def empty_def singleton_def using dsafe osafe.intros dsafe.intros by (simp add: osafe_Sing dfree_Const) have fsafe:"fsafe (p1 vid2 vid1)" unfolding p1_def singleton_def using hpsafe_fsafe.intros(10) using dsafe dsafe_Fun_simps image_iff by (simp add: dfree_Const) show "valid DEaxiom" apply(auto simp only: DEaxiom_def valid_def Let_def iff_sem impl_sem) apply(auto simp only: fml_sem.simps prog_sem.simps mem_Collect_eq box_sem) proof - fix I::"('sf,'sc,'sz) interp" and aa ba ab bb sol and t::real and ac bc assume "is_interp I" assume allw:"\\. (\\ sol t. ((ab, bb), \) = (\, mk_v I (OSing vid1 (f1 fid1 vid1)) \ (sol t)) \ 0 \ t \ (sol solves_ode (\_. ODE_sem I (OSing vid1 (f1 fid1 vid1)))) {0..t} {x. mk_v I (OSing vid1 (f1 fid1 vid1)) \ x \ fml_sem I (p1 vid2 vid1)} \ (sol 0) = (fst \) ) \ \ \ fml_sem I (P pid1)" assume t:"0 \ t" assume aaba:"(aa, ba) = mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t)" assume solve:" (sol solves_ode (\_. ODE_sem I (OSing vid1 (f1 fid1 vid1)))) {0..t} {x. mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) x \ fml_sem I (p1 vid2 vid1)}" assume sol0:" (sol 0) = (fst (ab, bb)) " assume rep:" (ac, bc) = repd (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t)) vid1 (dterm_sem I (f1 fid1 vid1) (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t)))" have aaba_sem:"(aa,ba) \ fml_sem I (P pid1)" using allw t aaba solve sol0 rep by blast have truth:"repd (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t)) vid1 (dterm_sem I (f1 fid1 vid1) (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t))) = mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t)" using DE_lemma by auto show " repd (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t)) vid1 (dterm_sem I (f1 fid1 vid1) (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t))) \ fml_sem I (P pid1)" using aaba aaba_sem truth by (auto) next fix I::"('sf,'sc,'sz) interp" and aa ba ab bb sol and t::real assume "is_interp I" assume all:"\\. (\\ sol t. ((ab, bb), \) = (\, mk_v I (OSing vid1 (f1 fid1 vid1)) \ (sol t)) \ 0 \ t \ (sol solves_ode (\_. ODE_sem I (OSing vid1 (f1 fid1 vid1)))) {0..t} {x. mk_v I (OSing vid1 (f1 fid1 vid1)) \ x \ fml_sem I (p1 vid2 vid1)} \ (sol 0) = (fst \) ) \ (\\'. \' = repd \ vid1 (dterm_sem I (f1 fid1 vid1) \) \ \' \ fml_sem I (P pid1))" hence justW:"(\\ sol t. ((ab, bb), (aa, ba)) = (\, mk_v I (OSing vid1 (f1 fid1 vid1)) \ (sol t)) \ 0 \ t \ (sol solves_ode (\_. ODE_sem I (OSing vid1 (f1 fid1 vid1)))) {0..t} {x. mk_v I (OSing vid1 (f1 fid1 vid1)) \ x \ fml_sem I (p1 vid2 vid1)} \ (sol 0) = (fst \)) \ (\\'. \' = repd (aa, ba) vid1 (dterm_sem I (f1 fid1 vid1) (aa, ba)) \ \' \ fml_sem I (P pid1))" by (rule allE) assume t:"0 \ t" assume aaba:"(aa, ba) = mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t)" assume sol:"(sol solves_ode (\_. ODE_sem I (OSing vid1 (f1 fid1 vid1)))) {0..t} {x. mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) x \ fml_sem I (p1 vid2 vid1)}" assume sol0:" (sol 0) = (fst (ab, bb))" have "repd (aa, ba) vid1 (dterm_sem I (f1 fid1 vid1) (aa, ba)) \ fml_sem I (P pid1)" using justW t aaba sol sol0 by auto hence foo:"repd (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t)) vid1 (dterm_sem I (f1 fid1 vid1) (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t))) \ fml_sem I (P pid1)" using aaba by auto hence "repd (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t)) vid1 (dterm_sem I (f1 fid1 vid1) (mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t))) = mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t)" using DE_lemma by auto thus "mk_v I (OSing vid1 (f1 fid1 vid1)) (ab, bb) (sol t) \ fml_sem I (P pid1)" using foo by auto qed qed lemma ODE_zero:"\i. Inl i \ BVO ODE \ Inr i \ BVO ODE \ ODE_sem I ODE \  i= 0" by(induction ODE, auto) lemma DE_sys_valid: assumes disj:"{Inl vid1, Inr vid1} \ BVO ODE = {}" shows "valid (([[EvolveODE (OProd (OSing vid1 (f1 fid1 vid1)) ODE) (p1 vid2 vid1)]] (P pid1)) \ ([[EvolveODE ((OProd (OSing vid1 (f1 fid1 vid1))ODE)) (p1 vid2 vid1)]] [[DiffAssign vid1 (f1 fid1 vid1)]]P pid1))" proof - have dsafe:"dsafe (f fid1 (singleton (trm.Var vid1)))" unfolding singleton_def by(auto intro: dsafe.intros) have osafe:"osafe(OSing vid1 (f1 fid1 vid1))" unfolding f1_def empty_def singleton_def using dsafe osafe.intros dsafe.intros by (simp add: osafe_Sing dfree_Const) have fsafe:"fsafe (p1 vid2 vid1)" unfolding p1_def singleton_def using hpsafe_fsafe.intros(10) using dsafe dsafe_Fun_simps image_iff by (simp add: dfree_Const) show "valid (([[EvolveODE (OProd (OSing vid1 (f1 fid1 vid1)) ODE) (p1 vid2 vid1)]] (P pid1)) \ ([[EvolveODE ((OProd (OSing vid1 (f1 fid1 vid1)) ODE)) (p1 vid2 vid1)]] [[DiffAssign vid1 (f1 fid1 vid1)]]P pid1))" apply(auto simp only: DEaxiom_def valid_def Let_def iff_sem impl_sem) apply(auto simp only: fml_sem.simps prog_sem.simps mem_Collect_eq box_sem f1_def p1_def P_def expand_singleton) proof - fix I ::"('sf,'sc,'sz) interp" and aa ba ab bb sol and t::real and ac bc assume good:"is_interp I" assume bigAll:" \\. (\\ sol t. ((ab, bb), \) = (\, mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) ODE) \ (sol t)) \ 0 \ t \ (sol solves_ode (\_. ODE_sem I (OProd(OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) ODE ))) {0..t} {x. Predicates I vid2 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) \ x))} \ sol 0 = fst \) \ \ \ fml_sem I (Pc pid1)" let ?my\ = "mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) (ab,bb) (sol t)" assume t:"0 \ t" assume aaba:"(aa, ba) = mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) (ab, bb) (sol t)" assume sol:"(sol solves_ode (\_. ODE_sem I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE))) {0..t} {x. Predicates I vid2 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) (ab, bb) x))}" assume sol0:"sol 0 = fst (ab, bb)" assume acbc:"(ac, bc) = repd (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) (ab, bb) (sol t)) vid1 (dterm_sem I (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) (ab, bb) (sol t)))" have bigEx:"(\\ sol t. ((ab, bb), ?my\) = (\, mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) \ (sol t)) \ 0 \ t \ (sol solves_ode (\_. ODE_sem I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE))) {0..t} {x. Predicates I vid2 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) \ x))} \ sol 0 = fst \)" apply(rule exI[where x="(ab, bb)"]) apply(rule exI[where x="sol"]) apply(rule exI[where x="t"]) apply(rule conjI) apply(rule refl) apply(rule conjI) apply(rule t) apply(rule conjI) using sol apply blast by (rule sol0) have bigRes:"?my\ \ fml_sem I (Pc pid1)" using bigAll bigEx by blast have notin1:"Inl vid1 \ BVO ODE" using disj by auto have notin2:"Inr vid1 \ BVO ODE" using disj by auto have ODE_sem:"ODE_sem I ODE (sol t)  vid1 = 0" using ODE_zero notin1 notin2 by blast have vec_eq:"(\ i. sterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (sol t)) = (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) (ab, bb) (sol t)))" apply(rule vec_extensionality) apply simp using mk_v_agree[of I "(OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE)" "(ab, bb)" "(sol t)"] by(simp add: Vagree_def) have sem_eq:"(?my\ \ fml_sem I (Pc pid1)) = ((repd (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) (ab, bb) (sol t)) vid1 (dterm_sem I (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) (ab, bb) (sol t)))) \ fml_sem I (Pc pid1))" apply(rule coincidence_formula) subgoal by simp subgoal by (rule Iagree_refl) using mk_v_agree[of "I" "(OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE)" "(ab, bb)" "(sol t)"] unfolding Vagree_def apply simp apply(erule conjE)+ apply(erule allE[where x="vid1"])+ apply(simp add: ODE_sem) using vec_eq by simp show "repd (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) (ab, bb) (sol t)) vid1 (dterm_sem I (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) (ab, bb) (sol t))) \ fml_sem I (Pc pid1)" using bigRes sem_eq by blast next fix I::"('sf,'sc,'sz)interp" and aa ba ab bb sol and t::real assume good_interp:"is_interp I" assume all:"\\. (\\ sol t. ((ab, bb), \) = (\, mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) \ (sol t)) \ 0 \ t \ (sol solves_ode (\_. ODE_sem I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE))) {0..t} {x. Predicates I vid2 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) \ x))} \ sol 0 = fst \) \ (\\'. \' = repd \ vid1 (dterm_sem I (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)) \) \ \' \ fml_sem I (Pc pid1))" let ?my\ = "mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) (ab, bb) (sol t)" assume t:"0 \ t" assume aaba:"(aa, ba) = mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) (ab, bb) (sol t)" assume sol:" (sol solves_ode (\_. ODE_sem I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE))) {0..t} {x. Predicates I vid2 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) (ab, bb) x))}" assume sol0:"sol 0 = fst (ab, bb)" have bigEx:"(\\ sol t. ((ab, bb), ?my\) = (\, mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) \ (sol t)) \ 0 \ t \ (sol solves_ode (\_. ODE_sem I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE))) {0..t} {x. Predicates I vid2 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) \ x))} \ sol 0 = fst \)" apply(rule exI[where x="(ab, bb)"]) apply(rule exI[where x=sol]) apply(rule exI[where x=t]) apply(rule conjI) apply(rule refl) apply(rule conjI) apply(rule t) apply(rule conjI) using sol sol0 by(blast)+ have rep_sem_eq:"repd (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) (ab, bb) (sol t)) vid1 (dterm_sem I (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) (ab, bb) (sol t))) \ fml_sem I (Pc pid1) = (repd ?my\ vid1 (dterm_sem I (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)) ?my\) \ fml_sem I (Pc pid1))" apply(rule coincidence_formula) subgoal by simp subgoal by (rule Iagree_refl) by(simp add: Vagree_def) have notin1:"Inl vid1 \ BVO ODE" using disj by auto have notin2:"Inr vid1 \ BVO ODE" using disj by auto have ODE_sem:"ODE_sem I ODE (sol t)  vid1 = 0" using ODE_zero notin1 notin2 by blast have vec_eq:" (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) (ab, bb) (sol t))) = (\ i. sterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (sol t))" apply(rule vec_extensionality) using mk_v_agree[of I "(OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE)" "(ab, bb)" "(sol t)"] by (simp add: Vagree_def) have sem_eq: "(repd ?my\ vid1 (dterm_sem I (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)) ?my\) \ fml_sem I (Pc pid1)) = (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) (ab, bb) (sol t) \ fml_sem I (Pc pid1)) " apply(rule coincidence_formula) subgoal by simp subgoal by (rule Iagree_refl) using mk_v_agree[of I "(OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE)" "(ab, bb)" "(sol t)"] unfolding Vagree_def apply simp apply(erule conjE)+ apply(erule allE[where x=vid1])+ by (simp add: ODE_sem vec_eq) have some_sem:"repd (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) (ab, bb) (sol t)) vid1 (dterm_sem I (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) (ab, bb) (sol t))) \ fml_sem I (Pc pid1)" using rep_sem_eq using all bigEx by blast have bigImp:"(\\'. \' = repd ?my\ vid1 (dterm_sem I (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)) ?my\) \ \' \ fml_sem I (Pc pid1))" apply(rule allI) apply(rule impI) apply auto using some_sem by auto have fml_sem:"repd ?my\ vid1 (dterm_sem I (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)) ?my\) \ fml_sem I (Pc pid1)" using sem_eq bigImp by blast show "mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))ODE) (ab, bb) (sol t) \ fml_sem I (Pc pid1)" using fml_sem sem_eq by blast qed qed lemma DC_valid:"valid DCaxiom" proof (auto simp only: fml_sem.simps prog_sem.simps DCaxiom_def valid_def iff_sem impl_sem box_sem, auto) fix I::"('sf,'sc,'sz) interp" and aa ba bb sol t assume "is_interp I" and all3:"\a b. (\sola. sol 0 = sola 0 \ (\t. (a, b) = mk_v I (OVar vid1) (sola 0, bb) (sola t) \ 0 \ t \ (sola solves_ode (\a. ODEs I vid1)) {0..t} {x. mk_v I (OVar vid1) (sola 0, bb) x \ Contexts I pid1 UNIV})) \ (a, b) \ Contexts I pid3 UNIV" and all2:"\a b. (\sola. sol 0 = sola 0 \ (\t. (a, b) = mk_v I (OVar vid1) (sola 0, bb) (sola t) \ 0 \ t \ (sola solves_ode (\a. ODEs I vid1)) {0..t} {x. mk_v I (OVar vid1) (sola 0, bb) x \ Contexts I pid1 UNIV})) \ (a, b) \ Contexts I pid2 UNIV" and t:"0 \ t" and aaba:"(aa, ba) = mk_v I (OVar vid1) (sol 0, bb) (sol t)" and sol:"(sol solves_ode (\a. ODEs I vid1)) {0..t} {x. mk_v I (OVar vid1) (sol 0, bb) x \ Contexts I pid1 UNIV \ mk_v I (OVar vid1) (sol 0, bb) x \ Contexts I pid3 UNIV}" from sol have sol1:"(sol solves_ode (\a. ODEs I vid1)) {0..t} {x. mk_v I (OVar vid1) (sol 0, bb) x \ Contexts I pid1 UNIV}" by (metis (mono_tags, lifting) Collect_mono solves_ode_supset_range) from all2 have all2':"\v. (\sola. sol 0 = sola 0 \ (\t. v = mk_v I (OVar vid1) (sola 0, bb) (sola t) \ 0 \ t \ (sola solves_ode (\a. ODEs I vid1)) {0..t} {x. mk_v I (OVar vid1) (sola 0, bb) x \ Contexts I pid1 UNIV})) \ v \ Contexts I pid2 UNIV" by auto show "mk_v I (OVar vid1) (sol 0, bb) (sol t) \ Contexts I pid2 UNIV" apply(rule all2'[of "mk_v I (OVar vid1) (sol 0, bb) (sol t)"]) apply(rule exI[where x=sol]) apply(rule conjI) subgoal by (rule refl) subgoal using t sol1 by auto done next fix I::"('sf,'sc,'sz) interp" and aa ba bb sol t assume "is_interp I" and all3:"\a b. (\sola. sol 0 = sola 0 \ (\t. (a, b) = mk_v I (OVar vid1) (sola 0, bb) (sola t) \ 0 \ t \ (sola solves_ode (\a. ODEs I vid1)) {0..t} {x. mk_v I (OVar vid1) (sola 0, bb) x \ Contexts I pid1 UNIV})) \ (a, b) \ Contexts I pid3 UNIV" and all2:"\a b. (\sola. sol 0 = sola 0 \ (\t. (a, b) = mk_v I (OVar vid1) (sola 0, bb) (sola t) \ 0 \ t \ (sola solves_ode (\a. ODEs I vid1)) {0..t} {x. mk_v I (OVar vid1) (sola 0, bb) x \ Contexts I pid1 UNIV \ mk_v I (OVar vid1) (sola 0, bb) x \ Contexts I pid3 UNIV})) \ (a, b) \ Contexts I pid2 UNIV" and t:"0 \ t" and aaba:"(aa, ba) = mk_v I (OVar vid1) (sol 0, bb) (sol t)" and sol:"(sol solves_ode (\a. ODEs I vid1)) {0..t} {x. mk_v I (OVar vid1) (sol 0, bb) x \ Contexts I pid1 UNIV}" from all2 have all2':"\v. (\sola. sol 0 = sola 0 \ (\t. v = mk_v I (OVar vid1) (sola 0, bb) (sola t) \ 0 \ t \ (sola solves_ode (\a. ODEs I vid1)) {0..t} {x. mk_v I (OVar vid1) (sola 0, bb) x \ Contexts I pid1 UNIV \ mk_v I (OVar vid1) (sola 0, bb) x \ Contexts I pid3 UNIV})) \ v \ Contexts I pid2 UNIV" by auto from all3 have all3':"\v. (\sola. sol 0 = sola 0 \ (\t. v = mk_v I (OVar vid1) (sola 0, bb) (sola t) \ 0 \ t \ (sola solves_ode (\a. ODEs I vid1)) {0..t} {x. mk_v I (OVar vid1) (sola 0, bb) x \ Contexts I pid1 UNIV})) \ v \ Contexts I pid3 UNIV" by auto have inp1:"\s. 0 \ s \ s \ t \ mk_v I (OVar vid1) (sol 0, bb) (sol s) \ Contexts I pid1 UNIV" using sol solves_odeD atLeastAtMost_iff by blast have inp3:"\s. 0 \ s \ s \ t \ mk_v I (OVar vid1) (sol 0, bb) (sol s) \ Contexts I pid3 UNIV" apply(rule all3') subgoal for s apply(rule exI [where x=sol]) apply(rule conjI) subgoal by (rule refl) apply(rule exI [where x=s]) apply(rule conjI) subgoal by (rule refl) apply(rule conjI) subgoal by assumption subgoal using sol by (meson atLeastatMost_subset_iff order_refl solves_ode_subset) done done have inp13:"\s. 0 \ s \ s \ t \ mk_v I (OVar vid1) (sol 0, bb) (sol s) \ Contexts I pid1 UNIV \ mk_v I (OVar vid1) (sol 0, bb) (sol s) \ Contexts I pid3 UNIV" using inp1 inp3 by auto have sol13:"(sol solves_ode (\a. ODEs I vid1)) {0..t} {x. mk_v I (OVar vid1) (sol 0, bb) x \ Contexts I pid1 UNIV \ mk_v I (OVar vid1) (sol 0, bb) x \ Contexts I pid3 UNIV}" apply(rule solves_odeI) subgoal using sol by (rule solves_odeD) subgoal for s using inp13[of s] by auto done show "mk_v I (OVar vid1) (sol 0, bb) (sol t) \ Contexts I pid2 UNIV" using t sol13 all2'[of "mk_v I (OVar vid1) (sol 0, bb) (sol t)"] by auto qed lemma DS_valid:"valid DSaxiom" proof - have dsafe:"dsafe(f fid1 (\i. Const 0))" using dsafe_Const by auto have osafe:"osafe(OSing vid1 (f0 fid1))" unfolding f0_def empty_def using dsafe osafe.intros by (simp add: osafe_Sing dfree_Const) have fsafe:"fsafe(p1 vid2 vid1)" unfolding p1_def apply(rule fsafe_Prop) using singleton.simps dsafe_Const by (auto intro: dfree.intros) show "valid DSaxiom" apply(auto simp only: DSaxiom_def valid_def Let_def iff_sem impl_sem box_sem) apply(auto simp only: fml_sem.simps prog_sem.simps mem_Collect_eq iff_sem impl_sem box_sem forall_sem) proof - fix I::"('sf,'sc,'sz) interp" and a b r aa ba assume good_interp:"is_interp I" assume allW:"\\. (\\ sol t. ((a, b), \) = (\, mk_v I (OSing vid1 (f0 fid1)) \ (sol t)) \ 0 \ t \ (sol solves_ode (\_. ODE_sem I (OSing vid1 (f0 fid1)))) {0..t} {x. mk_v I (OSing vid1 (f0 fid1)) \ x \ fml_sem I (p1 vid2 vid1)} \ (sol 0) = (fst \)) \ \ \ fml_sem I (p1 vid3 vid1)" assume "dterm_sem I (Const 0) (repv (a, b) vid2 r) \ dterm_sem I (trm.Var vid2) (repv (a, b) vid2 r)" hence leq:"0 \ r" by (auto) assume "\ra. repv (repv (a, b) vid2 r) vid3 ra \ {v. dterm_sem I (Const 0) v \ dterm_sem I (trm.Var vid3) v} \ {v. dterm_sem I (trm.Var vid3) v \ dterm_sem I (trm.Var vid2) v} \ Predicates I vid2 (\ i. dterm_sem I (singleton (Plus (trm.Var vid1) (Times (f0 fid1) (trm.Var vid3))) i) (repv (repv (a, b) vid2 r) vid3 ra))" hence constraint:"\ra. (0 \ ra \ ra \ r) \ (repv (repv (a, b) vid2 r) vid3 ra) \ fml_sem I (Prop vid2 (singleton (Plus (Var vid1) (Times (f0 fid1) (Var vid3)))))" using leq by auto assume aaba:" (aa, ba) = repv (repv (a, b) vid2 r) vid1 (dterm_sem I (Plus (trm.Var vid1) (Times (f0 fid1) (trm.Var vid2))) (repv (a, b) vid2 r))" let ?abba = "repv (repd (a, b) vid1 (Functions I fid1 (\ i. 0))) vid1 (dterm_sem I (Plus (trm.Var vid1) (Times (f0 fid1) (trm.Var vid2))) (repv (a, b) vid2 r))" from allW have thisW:"(\\ sol t. ((a, b), ?abba) = (\, mk_v I (OSing vid1 (f0 fid1)) \ (sol t)) \ 0 \ t \ (sol solves_ode (\_. ODE_sem I (OSing vid1 (f0 fid1)))) {0..t} {x. mk_v I (OSing vid1 (f0 fid1)) \ x \ fml_sem I (p1 vid2 vid1)} \ (sol 0) = (fst \)) \ ?abba \ fml_sem I (p1 vid3 vid1)" by blast let ?c = "Functions I fid1 (\ _. 0)" let ?sol = "(\t. \ i. if i = vid1 then (a  i) + ?c * t else (a  i))" have agrees:"Vagree (mk_v I (OSing vid1 (f0 fid1)) (a, b) (?sol r)) (a, b) (- semBV I (OSing vid1 (f0 fid1))) \ Vagree (mk_v I (OSing vid1 (f0 fid1)) (a, b) (?sol r)) (mk_xode I (OSing vid1 (f0 fid1)) (?sol r)) (semBV I (OSing vid1 (f0 fid1)))" using mk_v_agree[of "I" "(OSing vid1 (f0 fid1))" "(a,b)" "(?sol r)"] by auto have prereq1a:"fst ?abba = fst (mk_v I (OSing vid1 (f0 fid1)) (a,b) (?sol r))" using agrees aaba apply (auto simp add: aaba Vagree_def) apply (rule vec_extensionality) subgoal for i apply (cases "i = vid1") using vne12 agrees Vagree_def apply (auto simp add: aaba f0_def empty_def) done apply (rule vec_extensionality) subgoal for i apply (cases "i = vid1") apply(auto simp add: f0_def empty_def) done done have prereq1b:"snd (?abba) = snd (mk_v I (OSing vid1 (f0 fid1)) (a,b) (?sol r))" using agrees aaba apply (auto simp add: aaba Vagree_def) apply (rule vec_extensionality) subgoal for i apply (cases "i = vid1") using vne12 agrees Vagree_def apply (auto simp add: aaba f0_def empty_def ) done done have "?abba = mk_v I (OSing vid1 (f0 fid1)) (a,b) (?sol r)" using prod_eq_iff prereq1a prereq1b by blast hence req1:"((a, b), ?abba) = ((a, b), mk_v I (OSing vid1 (f0 fid1)) (a,b) (?sol r))" by auto have "sterm_sem I (f fid1 (\i. Const 0)) b = Functions I fid1 (\ i. 0)" by auto hence vec_simp:"(\a b. \ i. if i = vid1 then sterm_sem I (f fid1 (\i. Const 0)) b else 0) = (\a b. \ i. if i = vid1 then Functions I fid1 (\ i. 0) else 0)" by (auto simp add: vec_eq_iff cong: if_cong) have sub: "{0..r} \ UNIV" by auto have sub2:"{x. mk_v I (OSing vid1 (f0 fid1)) (a,b) x \ fml_sem I (p1 vid2 vid1)} \ UNIV" by auto have req3:"(?sol solves_ode (\_. ODE_sem I (OSing vid1 (f0 fid1)))) {0..r} {x. mk_v I (OSing vid1 (f0 fid1)) (a,b) x \ fml_sem I (p1 vid2 vid1)}" apply(auto simp add: f0_def empty_def vec_simp) apply(rule solves_odeI) apply(auto simp only: has_vderiv_on_def has_vector_derivative_def box_sem) apply (rule has_derivative_vec[THEN has_derivative_eq_rhs]) defer apply (rule ext) apply (subst scaleR_vec_def) apply (rule refl) apply (auto intro!: derivative_eq_intros) \ \Domain constraint satisfied\ using constraint apply (auto) subgoal for t apply(erule allE[where x="t"]) apply(auto simp add: p1_def) proof - have eq:"(\ i. dterm_sem I (if i = vid1 then Plus (trm.Var vid1) (Times (f0 fid1) (trm.Var vid3)) else Const 0) (\ y. if vid3 = y then t else fst (\ y. if vid2 = y then r else fst (a, b)  y, b)  y, b)) = (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OSing vid1 (f fid1 (\i. Const 0))) (a, b) (\ i. if i = vid1 then a  i + Functions I fid1 (\ _. 0) * t else a  i)))" using vne12 vne13 mk_v_agree[of "I" "(OSing vid1 (f fid1 (\i. Const 0)))" "(a, b)" "(\ i. if i = vid1 then a  i + Functions I fid1 (\ _. 0) * t else a  i)"] by (auto simp add: vec_eq_iff f0_def empty_def Vagree_def) show "0 \ t \ t \ r \ Predicates I vid2 (\ i. dterm_sem I (if i = vid1 then Plus (trm.Var vid1) (Times (f0 fid1) (trm.Var vid3)) else Const 0) (\ y. if vid3 = y then t else fst (\ y. if vid2 = y then r else fst (a, b)  y, b)  y, b)) \ Predicates I vid2 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OSing vid1 (f fid1 (\i. Const 0))) (a, b) (\ i. if i = vid1 then a  i + Functions I fid1 (\ _. 0) * t else a  i)))" using eq by auto qed done have req4':"?sol 0 = fst (a,b)" by (auto simp: vec_eq_iff) then have req4: " (?sol 0) = (fst (a,b))" using VSagree_refl[of a] req4' unfolding VSagree_def by auto have inPred:"?abba \ fml_sem I (p1 vid3 vid1)" using req1 leq req3 req4 thisW by fastforce have sem_eq:"?abba \ fml_sem I (p1 vid3 vid1) \ (aa,ba) \ fml_sem I (p1 vid3 vid1)" apply (rule coincidence_formula) apply (auto simp add: aaba Vagree_def p1_def f0_def empty_def) subgoal using Iagree_refl by auto done from inPred sem_eq have inPred':"(aa,ba) \ fml_sem I (p1 vid3 vid1)" by auto \ \thus by lemma 6 consequence for formulas\ show "repv (repv (a, b) vid2 r) vid1 (dterm_sem I (Plus (trm.Var vid1) (Times (f0 fid1) (trm.Var vid2))) (repv (a, b) vid2 r)) \ fml_sem I (p1 vid3 vid1)" using aaba inPred' by (auto) next fix I::"('sf,'sc,'sz) interp" and aa ba ab bb sol and t:: real assume good_interp:"is_interp I" assume all:" \r. dterm_sem I (Const 0) (repv (ab, bb) vid2 r) \ dterm_sem I (trm.Var vid2) (repv (ab, bb) vid2 r) \ (\ra. repv (repv (ab, bb) vid2 r) vid3 ra \ {v. dterm_sem I (Const 0) v \ dterm_sem I (trm.Var vid3) v} \ {v. dterm_sem I (trm.Var vid3) v \ dterm_sem I (trm.Var vid2) v} \ Predicates I vid2 (\ i. dterm_sem I (singleton (Plus (trm.Var vid1) (Times (f0 fid1) (trm.Var vid3))) i) (repv (repv (ab, bb) vid2 r) vid3 ra))) \ (\\. \ = repv (repv (ab, bb) vid2 r) vid1 (dterm_sem I (Plus (trm.Var vid1) (Times (f0 fid1) (trm.Var vid2))) (repv (ab, bb) vid2 r)) \ \ \ fml_sem I (p1 vid3 vid1))" assume t:"0 \ t" assume aaba:"(aa, ba) = mk_v I (OSing vid1 (f0 fid1)) (ab, bb) (sol t)" assume sol:"(sol solves_ode (\_. ODE_sem I (OSing vid1 (f0 fid1)))) {0..t} {x. mk_v I (OSing vid1 (f0 fid1)) (ab, bb) x \ fml_sem I (p1 vid2 vid1)}" hence constraint:"\s. s \ {0 .. t} \ sol s \ {x. mk_v I (OSing vid1 (f0 fid1)) (ab, bb) x \ fml_sem I (p1 vid2 vid1)}" using solves_ode_domainD by fastforce \ \\sol 0 = fst (ab, bb)\\ assume sol0:" (sol 0) = (fst (ab, bb)) " have impl:"dterm_sem I (Const 0) (repv (ab, bb) vid2 t) \ dterm_sem I (trm.Var vid2) (repv (ab, bb) vid2 t) \ (\ra. repv (repv (ab, bb) vid2 t) vid3 ra \ {v. dterm_sem I (Const 0) v \ dterm_sem I (trm.Var vid3) v} \ {v. dterm_sem I (trm.Var vid3) v \ dterm_sem I (trm.Var vid2) v} \ Predicates I vid2 (\ i. dterm_sem I (singleton (Plus (trm.Var vid1) (Times (f0 fid1) (trm.Var vid3))) i) (repv (repv (ab, bb) vid2 t) vid3 ra))) \ (\\. \ = repv (repv (ab, bb) vid2 t) vid1 (dterm_sem I (Plus (trm.Var vid1) (Times (f0 fid1) (trm.Var vid2))) (repv (ab, bb) vid2 t)) \ \ \ fml_sem I (p1 vid3 vid1))" using all by auto interpret ll:ll_on_open_it UNIV "(\_. ODE_sem I (OSing vid1 (f0 fid1)))" "UNIV" 0 apply(standard) apply(auto) unfolding local_lipschitz_def f0_def empty_def sterm_sem.simps using gt_ex lipschitz_on_constant by blast have eq_UNIV:"ll.existence_ivl 0 (sol 0) = UNIV" apply(rule ll.existence_ivl_eq_domain) apply(auto) subgoal for tm tM t apply(unfold f0_def empty_def sterm_sem.simps) by(metis add.right_neutral mult_zero_left order_refl) done \ \Combine with \flow_usolves_ode\ and \equals_flowI\ to get uniqueness of solution\ let ?f = "(\_. ODE_sem I (OSing vid1 (f0 fid1)))" have sol_UNIV: "\t x. (ll.flow 0 x usolves_ode ?f from 0) (ll.existence_ivl 0 x) UNIV" using ll.flow_usolves_ode by auto from sol have sol': "(sol solves_ode (\_. ODE_sem I (OSing vid1 (f0 fid1)))) {0..t} UNIV" apply (rule solves_ode_supset_range) by auto from sol' have sol'':"\s. s \ 0 \ s \ t \ (sol solves_ode (\_. ODE_sem I (OSing vid1 (f0 fid1)))) {0..s} UNIV" by (simp add: solves_ode_subset) have sol0_eq:"sol 0 = ll.flow 0 (sol 0) 0" using ll.general.flow_initial_time_if by auto have isFlow:"\s. s \ 0 \ s \ t \ sol s = ll.flow 0 (sol 0) s" apply(rule ll.equals_flowI) apply(auto) subgoal using eq_UNIV by auto subgoal using sol'' closed_segment_eq_real_ivl t by (auto simp add: solves_ode_singleton) subgoal using eq_UNIV sol sol0_eq by auto done let ?c = "Functions I fid1 (\ _. 0)" let ?sol = "(\t. \ i. if i = vid1 then (ab  i) + ?c * t else (ab  i))" have vec_simp:"(\a b. \ i. if i = vid1 then sterm_sem I (f fid1 (\i. Const 0)) b else 0) = (\a b. \ i. if i = vid1 then Functions I fid1 (\ i. 0) else 0)" by (auto simp add: vec_eq_iff cong: if_cong) have exp_sol:"(?sol solves_ode (\_. ODE_sem I (OSing vid1 (f0 fid1)))) {0..t} UNIV" apply(auto simp add: f0_def empty_def vec_simp) apply(rule solves_odeI) apply(auto simp only: has_vderiv_on_def has_vector_derivative_def box_sem) apply (rule has_derivative_vec[THEN has_derivative_eq_rhs]) defer apply (rule ext) apply (subst scaleR_vec_def) apply (rule refl) apply (auto intro!: derivative_eq_intros) done from exp_sol have exp_sol':"\s. s \ 0 \ s \ t \ (?sol solves_ode (\_. ODE_sem I (OSing vid1 (f0 fid1)))) {0..s} UNIV" by (simp add: solves_ode_subset) have exp_sol0_eq:"?sol 0 = ll.flow 0 (?sol 0) 0" using ll.general.flow_initial_time_if by auto have more_eq:"(\ i. if i = vid1 then ab  i + Functions I fid1 (\ _. 0) * 0 else ab  i) = sol 0" using sol0 apply auto apply(rule vec_extensionality) by(auto) have exp_isFlow:"\s. s \ 0 \ s \ t \ ?sol s = ll.flow 0 (sol 0) s" apply(rule ll.equals_flowI) apply(auto) subgoal using eq_UNIV by auto defer subgoal for s using eq_UNIV apply auto subgoal using exp_sol exp_sol0_eq more_eq apply(auto) done done using exp_sol' closed_segment_eq_real_ivl t apply(auto) by (simp add: solves_ode_singleton) have sol_eq_exp:"\s. s \ 0 \ s \ t \ ?sol s = sol s" unfolding exp_isFlow isFlow by auto then have sol_eq_exp_t:"?sol t = sol t" using t by auto then have sol_eq_exp_t':"sol t  vid1 = ?sol t  vid1" by auto then have useful:"?sol t  vid1 = ab  vid1 + Functions I fid1 (\ i. 0) * t" by auto from sol_eq_exp_t' useful have useful':"sol t  vid1 = ab  vid1 + Functions I fid1 (\ i. 0) * t" by auto have sol_int:"((ll.flow 0 (sol 0)) usolves_ode ?f from 0) {0..t} {x. mk_v I (OSing vid1 (f0 fid1)) (ab, bb) x \ fml_sem I (p1 vid2 vid1)}" apply (rule usolves_ode_subset_range[of "(ll.flow 0 (sol 0))" "?f" "0" "{0..t}" "UNIV" "{x. mk_v I (OSing vid1 (f0 fid1)) (ab, bb) x \ fml_sem I (p1 vid2 vid1)}"]) subgoal using eq_UNIV sol_UNIV[of "(sol 0)"] apply (auto) apply (rule usolves_ode_subset) using t by(auto) apply(auto) using sol apply(auto dest!: solves_ode_domainD) subgoal for xa using isFlow[of xa] by(auto) done have thing:"\s. 0 \ s \ s \ t \ fst (mk_v I (OSing vid1 (f fid1 (\i. Const 0))) (ab, bb) (?sol s))  vid1 = ab  vid1 + Functions I fid1 (\ i. 0) * s" subgoal for s using mk_v_agree[of I "(OSing vid1 (f fid1 (\i. Const 0)))" "(ab, bb)" "(?sol s)"] apply auto unfolding Vagree_def by auto done have thing':"\s. 0 \ s \ s \ t \ fst (mk_v I (OSing vid1 (f fid1 (\i. Const 0))) (ab, bb) (sol s))  vid1 = ab  vid1 + Functions I fid1 (\ i. 0) * s" subgoal for s using thing[of s] sol_eq_exp[of s] by auto done have another_eq:"\i s. 0 \ s \ s \ t \ dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OSing vid1 (f0 fid1)) (ab, bb) (sol s)) = dterm_sem I (if i = vid1 then Plus (trm.Var vid1) (Times (f0 fid1) (trm.Var vid3)) else Const 0) (\ y. if vid3 = y then s else fst (\ y. if vid2 = y then s else fst (ab, bb)  y, bb)  y, bb)" using mk_v_agree[of "I" "(OSing vid1 (f0 fid1))" "(ab, bb)" "(sol s)"] vne12 vne23 vne13 apply(auto simp add: f0_def p1_def empty_def) unfolding Vagree_def apply(simp add: f0_def empty_def) subgoal for s using thing' by auto done have allRa':"(\ra. repv (repv (ab, bb) vid2 t) vid3 ra \ {v. dterm_sem I (Const 0) v \ dterm_sem I (trm.Var vid3) v} \ {v. dterm_sem I (trm.Var vid3) v \ dterm_sem I (trm.Var vid2) v} \ Predicates I vid2 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OSing vid1 (f0 fid1)) (ab, bb) (sol ra))))" apply(rule allI) subgoal for ra using mk_v_agree[of "I" "(OSing vid1 (f0 fid1))" "(ab, bb)" "(sol ra)"] vne23 constraint[of ra] apply(auto simp add: Vagree_def p1_def) done done have anotherFact:"\ra. 0 \ ra \ ra \ t \ (\ i. if i = vid1 then ab  i + Functions I fid1 (\ _. 0) * ra else ab  i)  vid1 = ab  vid1 + dterm_sem I (f0 fid1) (\ y. if vid3 = y then ra else fst (\ y. if vid2 = y then t else fst (ab, bb)  y, bb)  y, bb) * ra " subgoal for ra apply simp apply(rule disjI2) by (auto simp add: f0_def empty_def) done have thing':"\ra i. 0 \ ra \ ra \ t \ dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OSing vid1 (f fid1 (\i. Const 0))) (ab, bb) (sol ra)) = dterm_sem I (if i = vid1 then Plus (trm.Var vid1) (Times (f0 fid1) (trm.Var vid3)) else Const 0) (\ y. if vid3 = y then ra else fst (\ y. if vid2 = y then t else fst (ab, bb)  y, bb)  y, bb) " subgoal for ra i using vne12 vne13 mk_v_agree[of I "OSing vid1 (f fid1 (\i. Const 0))" "(ab,bb)" "(sol ra)"] apply (auto) unfolding Vagree_def apply(safe) apply(erule allE[where x="vid1"])+ using sol_eq_exp[of ra] anotherFact[of ra] by auto done have allRa:"(\ra. repv (repv (ab, bb) vid2 t) vid3 ra \ {v. dterm_sem I (Const 0) v \ dterm_sem I (trm.Var vid3) v} \ {v. dterm_sem I (trm.Var vid3) v \ dterm_sem I (trm.Var vid2) v} \ Predicates I vid2 (\ i. dterm_sem I (singleton (Plus (trm.Var vid1) (Times (f0 fid1) (trm.Var vid3))) i) (repv (repv (ab, bb) vid2 t) vid3 ra)))" apply(rule allI) subgoal for ra using mk_v_agree[of "I" "(OSing vid1 (f0 fid1))" "(ab, bb)" "(sol ra)"] vne23 constraint[of ra] apply(auto simp add: Vagree_def p1_def) using sol_eq_exp[of ra] apply (auto simp add: f0_def empty_def Vagree_def vec_eq_iff) using thing' by auto done have fml3:"\ra. 0 \ ra \ ra \ t \ (\\. \ = repv (repv (ab, bb) vid2 t) vid1 (dterm_sem I (Plus (trm.Var vid1) (Times (f0 fid1) (trm.Var vid2))) (repv (ab, bb) vid2 t)) \ \ \ fml_sem I (p1 vid3 vid1))" using impl allRa by auto have someEq:"(\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (\ y. if vid1 = y then (if vid2 = vid1 then t else fst (ab, bb)  vid1) + Functions I fid1 (\ i. 0) * t else fst (\ y. if vid2 = y then t else fst (ab, bb)  y, bb)  y, bb)) = (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OSing vid1 (f fid1 (\i. Const 0))) (ab, bb) (sol t)))" apply(rule vec_extensionality) using vne12 sol_eq_exp t thing by auto show "mk_v I (OSing vid1 (f0 fid1)) (ab, bb) (sol t) \ fml_sem I (p1 vid3 vid1)" using mk_v_agree[of I "OSing vid1 (f0 fid1)" "(ab, bb)" "sol t"] fml3[of t] unfolding f0_def p1_def empty_def Vagree_def using someEq by(auto simp add: sol_eq_exp_t' t vec_extensionality vne12) qed qed lemma MVT0_within: fixes f ::"real \ real" and f'::"real \ real \ real" and s t :: real assumes f':"\x. x \ {0..t} \ (f has_derivative (f' x)) (at x within {0..t})" assumes geq':"\x. x \ {0..t} \ f' x s \ 0" assumes int_s:"s > 0 \ s \ t" assumes t: "0 < t" shows "f s \ f 0" proof - have "f 0 + 0 \ f s" apply (rule Lib.MVT_ivl'[OF f', of 0 s 0]) subgoal for x by assumption subgoal for x using geq' by auto using t int_s t apply auto subgoal for x by (metis int_s mult.commute mult.right_neutral order.trans real_mult_le_cancel_iff2) done then show "?thesis" by auto qed lemma MVT': fixes f g ::"real \ real" fixes f' g'::"real \ real \ real" fixes s t ::real assumes f':"\s. s \ {0..t} \ (f has_derivative (f' s)) (at s within {0..t})" assumes g':"\s. s \ {0..t} \ (g has_derivative (g' s)) (at s within {0..t})" assumes geq':"\x. x \ {0..t} \ f' x s \ g' x s" assumes geq0:"f 0 \ g 0" assumes int_s:"s > 0 \ s \ t" assumes t:"t > 0" shows "f s \ g s" proof - let ?h = "(\x. f x - g x)" let ?h' = "(\s x. f' s x - g' s x)" have "?h s \ ?h 0" apply(rule MVT0_within[of t ?h "?h'" s]) subgoal for s using f'[of s] g'[of s] by auto subgoal for sa using geq'[of sa] by auto subgoal using int_s by auto subgoal using t by auto done then show "?thesis" using geq0 by auto qed lemma MVT'_gr: fixes f g ::"real \ real" fixes f' g'::"real \ real \ real" fixes s t ::real assumes f':"\s. s \ {0..t} \ (f has_derivative (f' s)) (at s within {0..t})" assumes g':"\s. s \ {0..t} \ (g has_derivative (g' s)) (at s within {0..t})" assumes geq':"\x. x \ {0..t} \ f' x s \ g' x s" assumes geq0:"f 0 > g 0" assumes int_s:"s > 0 \ s \ t" assumes t:"t > 0" shows "f s > g s" proof - let ?h = "(\x. f x - g x)" let ?h' = "(\s x. f' s x - g' s x)" have "?h s \ ?h 0" apply(rule MVT0_within[of t ?h "?h'" s]) subgoal for s using f'[of s] g'[of s] by auto subgoal for sa using geq'[of sa] by auto subgoal using int_s by auto subgoal using t by auto done then show "?thesis" using geq0 by auto qed lemma frech_linear: fixes x \ \ \' I assumes good_interp:"is_interp I" assumes free:"dfree \" shows "x * frechet I \ \ \' = frechet I \ \ (x *\<^sub>R \')" using frechet_linear[OF good_interp free] by (simp add: linear_simps) lemma rift_in_space_time: fixes sol I ODE \ \ t s b assumes good_interp:"is_interp I" assumes free:"dfree \" assumes osafe:"osafe ODE" assumes sol:"(sol solves_ode (\_ \'. ODE_sem I ODE \')) {0..t} {x. mk_v I ODE (sol 0, b) x \ fml_sem I \}" assumes FVT:"FVT \ \ semBV I ODE" assumes ivl:"s \ {0..t}" shows "((\t. sterm_sem I \ (fst (mk_v I ODE (sol 0, b) (sol t)))) \ \This is Frechet derivative, so equivalent to:\ \ \\has_real_derivative frechet I \ (fst((mk_v I ODE (sol 0, b) (sol s)))) (snd (mk_v I ODE (sol 0, b) (sol s))))) (at s within {0..t})\\ has_derivative (\t'. t' * frechet I \ (fst((mk_v I ODE (sol 0, b) (sol s)))) (snd (mk_v I ODE (sol 0, b) (sol s))))) (at s within {0..t})" proof - let ?\ = "(\t. (mk_v I ODE (sol 0, b) (sol t)))" let ?\s = "(\t. fst (?\ t))" have sol_deriv:"\s. s \ {0..t} \ (sol has_derivative (\xa. xa *\<^sub>R ODE_sem I ODE (sol s))) (at s within {0..t})" using sol apply simp apply (drule solves_odeD(1)) unfolding has_vderiv_on_def has_vector_derivative_def by auto have sol_dom:"\s. s\ {0..t} \ ?\ s \ fml_sem I \" using sol apply simp apply (drule solves_odeD(2)) by auto let ?h = "(\t. sterm_sem I \ (?\s t))" let ?g = "(\\. sterm_sem I \ \)" let ?f = "?\s" let ?f' = "(\t'. t' *\<^sub>R (\ i. if i \ ODE_vars I ODE then ODE_sem I ODE (sol s)  i else 0))" let ?g' = "(frechet I \ (?\s s))" have heq:"?h = ?g \ ?f" by (auto) have fact1:"\i. i \ ODE_vars I ODE \ (\t. ?\s(t)  i) = (\t. sol t  i)" subgoal for i apply(rule ext) subgoal for t using mk_v_agree[of I ODE "(sol 0, b)" "sol t"] unfolding Vagree_def by auto done done have fact2:"\i. i \ ODE_vars I ODE \ (\t. if i \ ODE_vars I ODE then ODE_sem I ODE (sol t)  i else 0) = (\t. ODE_sem I ODE (sol t)  i)" subgoal for i apply(rule ext) subgoal for t using mk_v_agree[of I ODE "(sol 0, b)" "sol t"] unfolding Vagree_def by auto done done have fact3:"\i. i \ (-ODE_vars I ODE) \ (\t. ?\s(t)  i) = (\t. sol 0  i)" subgoal for i apply(rule ext) subgoal for t using mk_v_agree[of I ODE "(sol 0, b)" "sol t"] unfolding Vagree_def by auto done done have fact4:"\i. i \ (-ODE_vars I ODE) \ (\t. if i \ ODE_vars I ODE then ODE_sem I ODE (sol t)  i else 0) = (\t. 0)" subgoal for i apply(rule ext) subgoal for t using mk_v_agree[of I ODE "(sol 0, b)" "sol t"] unfolding Vagree_def by auto done done have some_eq:"(\v'. \ i. v' *\<^sub>R ODE_sem I ODE (sol s)  i) = (\v'. v' *\<^sub>R ODE_sem I ODE (sol s))" apply(rule ext) apply(rule vec_extensionality) by auto have some_sol:"(sol has_derivative (\v'. v' *\<^sub>R ODE_sem I ODE (sol s))) (at s within {0..t})" using sol ivl unfolding solves_ode_def has_vderiv_on_def has_vector_derivative_def by auto have some_eta:"(\t. \ i. sol t  i) = sol" by (rule ext, rule vec_extensionality, auto) have ode_deriv:"\i. i \ ODE_vars I ODE \ ((\t. sol t  i) has_derivative (\ v'. v' *\<^sub>R ODE_sem I ODE (sol s)  i)) (at s within {0..t})" subgoal for i apply(rule has_derivative_proj) using some_eq some_sol some_eta by auto done have eta:"(\t. (\ i. ?f t  i)) = ?f" by(rule ext, rule vec_extensionality, auto) have eta_esque:"(\t'. \ i. t' * (if i \ ODE_vars I ODE then ODE_sem I ODE (sol s)  i else 0)) = (\t'. t' *\<^sub>R (\ i. if i \ ODE_vars I ODE then ODE_sem I ODE (sol s)  i else 0))" apply(rule ext | rule vec_extensionality)+ subgoal for t' i by auto done have "((\t. (\ i. ?f t  i)) has_derivative (\t'. (\ i. ?f' t'  i))) (at s within {0..t})" apply (rule has_derivative_vec) subgoal for i apply(cases "i \ ODE_vars I ODE") subgoal using fact1[of i] fact2[of i] ode_deriv[of i] by auto subgoal using fact3[of i] fact4[of i] by auto done done then have fderiv:"(?f has_derivative ?f') (at s within {0..t})" using eta eta_esque by auto have gderiv:"(?g has_derivative ?g') (at (?f s) within ?f  {0..t})" using has_derivative_at_withinI using frechet_correctness free good_interp by blast have chain:"((?g \ ?f) has_derivative (?g' \ ?f')) (at s within {0..t})" using fderiv gderiv diff_chain_within by blast let ?co\1 = "(fst (mk_v I ODE (sol 0, b) (sol s)), ODE_sem I ODE (fst (mk_v I ODE (sol 0, b) (sol s))))" let ?co\2 = "(fst (mk_v I ODE (sol 0, b) (sol s)), snd (mk_v I ODE (sol 0, b) (sol s)))" have sub_cont:"\a .a \ ODE_vars I ODE \ Inl a \ FVT \ \ False" using FVT by auto have sub_cont2:"\a .a \ ODE_vars I ODE \ Inr a \ FVT \ \ False" using FVT by auto have "Vagree (mk_v I ODE (sol 0, b) (sol s)) (sol s, b) (Inl  ODE_vars I ODE)" using mk_v_agree[of I ODE "(sol 0, b)" "sol s"] unfolding Vagree_def by auto let ?co'\1 = "(\x. (fst (mk_v I ODE (sol 0, b) (sol s)), x *\<^sub>R (\ i. if i \ ODE_vars I ODE then ODE_sem I ODE (sol s)  i else 0)))" let ?co'\2 = "(\x. (fst (mk_v I ODE (sol 0, b) (sol s)), x *\<^sub>R snd (mk_v I ODE (sol 0, b) (sol s))))" have co_agree_sem:"\s. Vagree (?co'\1 s) (?co'\2 s) (semBV I ODE)" subgoal for sa using mk_v_agree[of I ODE "(sol 0, b)" "sol s"] unfolding Vagree_def by auto done have co_agree_help:"\s. Vagree (?co'\1 s) (?co'\2 s) (FVT \)" using agree_sub[OF FVT co_agree_sem] by auto have co_agree':"\s. Vagree (?co'\1 s) (?co'\2 s) (FVDiff \)" subgoal for s using mk_v_agree[of I ODE "(sol 0, b)" "sol s"] unfolding Vagree_def apply auto subgoal for i x apply(cases x) subgoal for a apply(cases "a \ ODE_vars I ODE") by (simp | metis (no_types, lifting) FVT ODE_vars_lr Vagree_def mk_v_agree mk_xode.elims subsetD snd_conv)+ subgoal for a apply(cases "a \ ODE_vars I ODE") by (simp | metis (no_types, lifting) FVT Vagree_def mk_v_agree mk_xode.elims subsetD snd_conv)+ done subgoal for i x apply(cases x) subgoal for a apply(cases "a \ ODE_vars I ODE") using FVT ODE_vars_lr Vagree_def mk_v_agree mk_xode.elims subsetD snd_conv by auto subgoal for a apply(cases "a \ ODE_vars I ODE") apply(erule allE[where x=i])+ using FVT ODE_vars_lr Vagree_def mk_v_agree mk_xode.elims subsetD snd_conv by auto done done done have heq'':"(?g' \ ?f') = (\t'. t' *\<^sub>R frechet I \ (?\s s) (snd (?\ s)))" using mk_v_agree[of I ODE "(sol 0, b)" "sol s"] unfolding comp_def apply auto apply(rule ext | rule vec_extensionality)+ subgoal for x using frech_linear[of I \ x "(fst (mk_v I ODE (sol 0, b) (sol s)))" "(snd (mk_v I ODE (sol 0, b) (sol s)))", OF good_interp free] using coincidence_frechet[OF free, of "(?co'\1 x)" "(?co'\2 x)", OF co_agree'[of x], of I] by auto done have "((?g \ ?f) has_derivative (?g' \ ?f')) (at s within {0..t})" using chain by auto then have "((?g \ ?f) has_derivative (\t'. t' * frechet I \ (?\s s) (snd (?\ s)))) (at s within {0..t})" using heq'' by auto then have result:"((\t. sterm_sem I \ (?\s t)) has_derivative (\t. t * frechet I \ (?\s s) (snd (?\ s)))) (at s within {0..t})" using heq by auto then show "?thesis" by auto qed lemma dterm_sterm_dfree: "dfree \ \ (\\ \'. sterm_sem I \ \ = dterm_sem I \ (\, \'))" by(induction rule: dfree.induct, auto) \ \\g(x)\ h(x) \ [x'=f(x), c & p(x)](g(x)' \ h(x)') \ [x'=f(x), c]g(x) \ h(x)\\ lemma DIGeq_valid:"valid DIGeqaxiom" unfolding DIGeqaxiom_def apply(unfold DIGeqaxiom_def valid_def impl_sem iff_sem) apply(auto) (* 4 goals*) proof - fix I::"('sf,'sc,'sz) interp" and b aa ba and sol::"real \ 'sz simple_state" and t::real let ?ODE = "OVar vid1" let ?\ = "(\t. mk_v I (?ODE) (sol 0, b) (sol t))" assume t:"0 \ t" and sol:"(sol solves_ode (\a. ODEs I vid1)) {0..t} {x. Predicates I vid1 (\ i. dterm_sem I (empty i) (mk_v I ?ODE (sol 0, b) x))}" and notin:" $$Predicates I vid1 (\ i. dterm_sem I (empty i) (sol 0, b)))" have fsafe:"fsafe (Prop vid1 empty)" by (auto simp add: empty_def) from sol have "Predicates I vid1 (\ i. dterm_sem I (empty i) (?\ 0))" using t solves_ode_domainD[of sol "(\a. ODEs I vid1)" "{0..t}"] by auto then have incon:"Predicates I vid1 (\ i. dterm_sem I (empty i) ((sol 0, b)))" using coincidence_formula[OF fsafe Iagree_refl[of I], of "(sol 0, b)" "?\ 0"] unfolding Vagree_def by (auto simp add: empty_def) show "dterm_sem I (f1 fid2 vid1) (mk_v I (OVar vid1) (sol 0, b) (sol t)) \ dterm_sem I (f1 fid1 vid1) (mk_v I (OVar vid1) (sol 0, b) (sol t))" using notin incon by auto next fix I::"('sf,'sc,'sz) interp" and b aa ba and sol::"real \ 'sz simple_state" and t::real let ?ODE = "OVar vid1" let ?\ = "(\t. mk_v I (?ODE) (sol 0, b) (sol t))" assume t:"0 \ t" and sol:"(sol solves_ode (\a. ODEs I vid1)) {0..t} {x. Predicates I vid1 (\ i. dterm_sem I (empty i) (mk_v I ?ODE (sol 0, b) x))}" and notin:" \(Predicates I vid1 (\ i. dterm_sem I (empty i) (sol 0, b)))" have fsafe:"fsafe (Prop vid1 empty)" by (auto simp add: empty_def) from sol have "Predicates I vid1 (\ i. dterm_sem I (empty i) (?\ 0))" using t solves_ode_domainD[of sol "(\a. ODEs I vid1)" "{0..t}"] by auto then have incon:"Predicates I vid1 (\ i. dterm_sem I (empty i) ((sol 0, b)))" using coincidence_formula[OF fsafe Iagree_refl[of I], of "(sol 0, b)" "?\ 0"] unfolding Vagree_def by (auto simp add: empty_def) show "dterm_sem I (f1 fid2 vid1) (mk_v I (OVar vid1) (sol 0, b) (sol t)) \ dterm_sem I (f1 fid1 vid1) (mk_v I (OVar vid1) (sol 0, b) (sol t))" using notin incon by auto next fix I::"('sf,'sc,'sz) interp" and b aa ba and sol::"real \ 'sz simple_state" and t::real let ?ODE = "OVar vid1" let ?\ = "(\t. mk_v I (?ODE) (sol 0, b) (sol t))" assume t:"0 \ t" assume sol:"(sol solves_ode (\a. ODEs I vid1)) {0..t} {x. Predicates I vid1 (\ i. dterm_sem I (local.empty i) (mk_v I (OVar vid1) (sol 0, b) x))}" assume notin:"\ Predicates I vid1 (\ i. dterm_sem I (local.empty i) (sol 0, b))" have fsafe:"fsafe (Prop vid1 empty)" by (auto simp add: empty_def) from sol have "Predicates I vid1 (\ i. dterm_sem I (empty i) (?\ 0))" using t solves_ode_domainD[of sol "(\a. ODEs I vid1)" "{0..t}"] by auto then have incon:"Predicates I vid1 (\ i. dterm_sem I (empty i) ((sol 0, b)))" using coincidence_formula[OF fsafe Iagree_refl[of I], of "(sol 0, b)" "?\ 0"] unfolding Vagree_def by (auto simp add: empty_def) show "dterm_sem I (f1 fid2 vid1) (mk_v I (OVar vid1) (sol 0, b) (sol t)) \ dterm_sem I (f1 fid1 vid1) (mk_v I (OVar vid1) (sol 0, b) (sol t))" using incon notin by auto next fix I::"('sf,'sc,'sz) interp" and b aa ba and sol::"real \ 'sz simple_state" and t::real let ?ODE = "OVar vid1" let ?\ = "(\t. mk_v I (?ODE) (sol 0, b) (sol t))" assume good_interp:"is_interp I" assume aaba:"(aa, ba) = mk_v I (OVar vid1) (sol 0, b) (sol t)" assume t:"0 \ t" assume sol:"(sol solves_ode (\a. ODEs I vid1)) {0..t} {x. Predicates I vid1 (\ i. dterm_sem I (local.empty i) (mk_v I (OVar vid1) (sol 0, b) x))}" assume box:"\a ba. (\sola. sol 0 = sola 0 \ (\t. (a, ba) = mk_v I (OVar vid1) (sola 0, b) (sola t) \ 0 \ t \ (sola solves_ode (\a. ODEs I vid1)) {0..t} {x. Predicates I vid1 (\ i. dterm_sem I (local.empty i) (mk_v I (OVar vid1) (sola 0, b) x))})) \ directional_derivative I (f1 fid2 vid1) (a, ba) \ directional_derivative I (f1 fid1 vid1) (a, ba)" assume geq0:"dterm_sem I (f1 fid2 vid1) (sol 0, b) \ dterm_sem I (f1 fid1 vid1) (sol 0, b)" have free1:"dfree (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0))" by (auto intro: dfree.intros) have free2:"dfree (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))" by (auto intro: dfree.intros) from geq0 have geq0':"sterm_sem I (f1 fid2 vid1) (sol 0) \ sterm_sem I (f1 fid1 vid1) (sol 0)" unfolding f1_def using dterm_sterm_dfree[OF free1, of I "sol 0" b] dterm_sterm_dfree[OF free2, of I "sol 0" b] by auto let ?\s = "\x. fst (?\ x)" let ?\t = "\x. snd (?\ x)" let ?df1 = "(\t. dterm_sem I (f1 fid2 vid1) (?\ t))" let ?f1 = "(\t. sterm_sem I (f1 fid2 vid1) (?\s t))" let ?f1' = "(\ s t'. t' * frechet I (f1 fid2 vid1) (?\s s) (?\t s))" have dfeq:"?df1 = ?f1" apply(rule ext) subgoal for t using dterm_sterm_dfree[OF free1, of I "?\s t" "snd (?\ t)"] unfolding f1_def expand_singleton by auto done have free3:"dfree (f1 fid2 vid1)" unfolding f1_def by (auto intro: dfree.intros) let ?df2 = "(\t. dterm_sem I (f1 fid1 vid1) (?\ t))" let ?f2 = "(\t. sterm_sem I (f1 fid1 vid1) (?\s t))" let ?f2' = "(\s t' . t' * frechet I (f1 fid1 vid1) (?\s s) (?\t s))" let ?int = "{0..t}" have bluh:"\x i. (Functions I i has_derivative (THE f'. \x. (Functions I i has_derivative f' x) (at x)) x) (at x)" using good_interp unfolding is_interp_def by auto have blah:"(Functions I fid2 has_derivative (THE f'. \x. (Functions I fid2 has_derivative f' x) (at x)) (\ i. if i = vid1 then sol t vid1 else 0)) (at (\ i. if i = vid1 then sol t vid1 else 0))" using bluh by auto have bigEx:"\s. s \ {0..t} \(\sola. sol 0 = sola 0 \ (\ta. (fst (?\ s), snd (?\ s)) = mk_v I (OVar vid1) (sola 0, b) (sola ta) \ 0 \ ta \ (sola solves_ode (\a. ODEs I vid1)) {0..ta} {x. Predicates I vid1 (\ i. dterm_sem I (local.empty i) (mk_v I (OVar vid1) (sol 0, b) x))}))" subgoal for s apply(rule exI[where x=sol]) apply(rule conjI) subgoal by (rule refl) apply(rule exI[where x=s]) apply(rule conjI) subgoal by auto apply(rule conjI) subgoal by auto using sol using atLeastAtMost_iff atLeastatMost_subset_iff order_refl solves_ode_on_subset by (metis (no_types, lifting) subsetI) done have box':"\s. s \ {0..t} \ directional_derivative I (f1 fid2 vid1) (?\s s, ?\t s) \ directional_derivative I (f1 fid1 vid1) (?\s s, ?\t s)" subgoal for s using box apply simp apply (erule allE[where x="?\s s"]) apply (erule allE[where x="?\t s"]) using bigEx[of s] by auto done have dsafe1:"dsafe (f1 fid2 vid1)" unfolding f1_def by (auto intro: dsafe.intros) have dsafe2:"dsafe (f1 fid1 vid1)" unfolding f1_def by (auto intro: dsafe.intros) have agree1:"Vagree (sol 0, b) (?\ 0) (FVT (f1 fid2 vid1))" using mk_v_agree[of I "(OVar vid1)" "(sol 0, b)" "fst (?\ 0)"] unfolding f1_def Vagree_def expand_singleton apply auto by (metis (no_types, lifting) Compl_iff Vagree_def fst_conv mk_v_agree mk_xode.simps semBV.simps) have agree2:"Vagree (sol 0, b) (?\ 0) (FVT (f1 fid1 vid1))" using mk_v_agree[of I "(OVar vid1)" "(sol 0, b)" "fst (?\ 0)"] unfolding f1_def Vagree_def expand_singleton apply auto by (metis (no_types, lifting) Compl_iff Vagree_def fst_conv mk_v_agree mk_xode.simps semBV.simps) have sem_eq1:"dterm_sem I (f1 fid2 vid1) (sol 0, b) = dterm_sem I (f1 fid2 vid1) (?\ 0)" using coincidence_dterm[OF dsafe1 agree1] by auto then have sem_eq1':"sterm_sem I (f1 fid2 vid1) (sol 0) = sterm_sem I (f1 fid2 vid1) (?\s 0)" using dterm_sterm_dfree[OF free1, of I "sol 0" "b"] dterm_sterm_dfree[OF free1, of I "(?\s 0)" "snd (?\ 0)"] unfolding f1_def expand_singleton by auto have sem_eq2:"dterm_sem I (f1 fid1 vid1) (sol 0, b) = dterm_sem I (f1 fid1 vid1) (?\ 0)" using coincidence_dterm[OF dsafe2 agree2] by auto then have sem_eq2':"sterm_sem I (f1 fid1 vid1) (sol 0) = sterm_sem I (f1 fid1 vid1) (?\s 0)" using dterm_sterm_dfree[OF free2, of I "sol 0" "b"] dterm_sterm_dfree[OF free2, of I "(?\s 0)" "snd (?\ 0)"] unfolding f1_def expand_singleton by auto have good_interp':"\i x. (Functions I i has_derivative (THE f'. \x. (Functions I i has_derivative f' x) (at x)) x) (at x)" using good_interp unfolding is_interp_def by auto have chain : "\f f' g g' x s. (f has_derivative f') (at x within s) \ (g has_derivative g') (at (f x) within f  s) \ (g \ f has_derivative g' \ f') (at x within s)" by(auto intro: derivative_intros) have sol1:"(sol solves_ode (\_. ODE_sem I (OVar vid1))) {0..t} {x. mk_v I (OVar vid1) (sol 0, b) x \ fml_sem I (Prop vid1 empty)}" using sol unfolding p1_def singleton_def empty_def by auto have FVTsub1:"vid1 \ ODE_vars I (OVar vid1) \ FVT (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) \ semBV I ((OVar vid1))" apply auto subgoal for x xa apply(cases "xa = vid1") by auto done have FVTsub2:"vid1 \ ODE_vars I (OVar vid1) \ FVT (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)) \ semBV I ((OVar vid1))" apply auto subgoal for x xa apply(cases "xa = vid1") by auto done have osafe:"osafe (OVar vid1)" by auto have deriv1:"\s. vid1 \ ODE_vars I (OVar vid1) \ s \ ?int \ (?f1 has_derivative (?f1' s)) (at s within {0..t})" subgoal for s using rift_in_space_time[OF good_interp free1 osafe sol1 FVTsub1, of s] unfolding f1_def expand_singleton directional_derivative_def by blast done have deriv2:"\s. vid1 \ ODE_vars I (OVar vid1) \ s \ ?int \ (?f2 has_derivative (?f2' s)) (at s within {0..t})" subgoal for s using rift_in_space_time[OF good_interp free2 osafe sol1 FVTsub2, of s] unfolding f1_def expand_singleton directional_derivative_def by blast done have leq:"\s . s \ ?int \ ?f1' s 1 \ ?f2' s 1" subgoal for s using box'[of s] by (simp add: directional_derivative_def) done have preserve_agree1:"vid1 \ ODE_vars I (OVar vid1) \ VSagree (sol 0) (fst (mk_v I (OVar vid1) (sol 0, b) (sol t))) {vid1}" using mk_v_agree[of I "OVar vid1" "(sol 0, b)" "sol t"] unfolding Vagree_def VSagree_def by auto have preserve_coincide1: "vid1 \ ODE_vars I (OVar vid1) \ sterm_sem I (f1 fid2 vid1) (fst (mk_v I (OVar vid1) (sol 0, b) (sol t))) = sterm_sem I (f1 fid2 vid1) (sol 0)" using coincidence_sterm[of "(sol 0, b)" "(mk_v I (OVar vid1) (sol 0, b) (sol t))" "f1 fid2 vid1" I] preserve_agree1 unfolding VSagree_def Vagree_def f1_def by auto have preserve_coincide2: "vid1 \ ODE_vars I (OVar vid1) \ sterm_sem I (f1 fid1 vid1) (fst (mk_v I (OVar vid1) (sol 0, b) (sol t))) = sterm_sem I (f1 fid1 vid1) (sol 0)" using coincidence_sterm[of "(sol 0, b)" "(mk_v I (OVar vid1) (sol 0, b) (sol t))" "f1 fid1 vid1" I] preserve_agree1 unfolding VSagree_def Vagree_def f1_def by auto have "?f1 t \ ?f2 t" apply(cases "t = 0") subgoal using geq0' sem_eq1' sem_eq2' by auto subgoal apply(cases "vid1 \ ODE_vars I (OVar vid1)") subgoal apply (rule MVT'[OF deriv2 deriv1, of t]) (* 8 subgoals *) subgoal by auto subgoal by auto subgoal for s using deriv2[of s] using leq by auto using t leq geq0' sem_eq1' sem_eq2' by auto subgoal using geq0 using dterm_sterm_dfree[OF free1, of I "sol 0" "b"] using dterm_sterm_dfree[OF free2, of I "sol 0" "b"] using preserve_coincide1 preserve_coincide2 by(simp add: f1_def) done done then show " dterm_sem I (f1 fid2 vid1) (mk_v I (OVar vid1) (sol 0, b) (sol t)) \ dterm_sem I (f1 fid1 vid1) (mk_v I (OVar vid1) (sol 0, b) (sol t)) " using t dterm_sterm_dfree[OF free2, of I "?\s t" "snd (?\ t)"] dterm_sterm_dfree[OF free1, of I "?\s t" "snd (?\ t)"] by (simp add: f1_def) qed lemma DIGr_valid:"valid DIGraxiom" unfolding DIGraxiom_def apply(unfold DIGraxiom_def valid_def impl_sem iff_sem) apply(auto) (* 4 subgoals*) proof - fix I::"('sf,'sc,'sz) interp" and b aa ba and sol::"real \ 'sz simple_state" and t::real let ?ODE = "OVar vid1" let ?\ = "(\t. mk_v I (?ODE) (sol 0, b) (sol t))" assume t:"0 \ t" and sol:"(sol solves_ode (\a. ODEs I vid1)) {0..t} {x. Predicates I vid1 (\ i. dterm_sem I (empty i) (mk_v I ?ODE (sol 0, b) x))}" and notin:" \(Predicates I vid1 (\ i. dterm_sem I (empty i) (sol 0, b)))" have fsafe:"fsafe (Prop vid1 empty)" by (auto simp add: empty_def) from sol have "Predicates I vid1 (\ i. dterm_sem I (empty i) (?\ 0))" using t solves_ode_domainD[of sol "(\a. ODEs I vid1)" "{0..t}"] by auto then have incon:"Predicates I vid1 (\ i. dterm_sem I (empty i) ((sol 0, b)))" using coincidence_formula[OF fsafe Iagree_refl[of I], of "(sol 0, b)" "?\ 0"] unfolding Vagree_def by (auto simp add: empty_def) show "dterm_sem I (f1 fid2 vid1) (mk_v I (OVar vid1) (sol 0, b) (sol t)) < dterm_sem I (f1 fid1 vid1) (mk_v I (OVar vid1) (sol 0, b) (sol t))" using notin incon by auto next fix I::"('sf,'sc,'sz) interp" and b aa ba and sol::"real \ 'sz simple_state" and t::real let ?ODE = "OVar vid1" let ?\ = "(\t. mk_v I (?ODE) (sol 0, b) (sol t))" assume t:"0 \ t" and sol:"(sol solves_ode (\a. ODEs I vid1)) {0..t} {x. Predicates I vid1 (\ i. dterm_sem I (empty i) (mk_v I ?ODE (sol 0, b) x))}" and notin:" \(Predicates I vid1 (\ i. dterm_sem I (empty i) (sol 0, b)))" have fsafe:"fsafe (Prop vid1 empty)" by (auto simp add: empty_def) from sol have "Predicates I vid1 (\ i. dterm_sem I (empty i) (?\ 0))" using t solves_ode_domainD[of sol "(\a. ODEs I vid1)" "{0..t}"] by auto then have incon:"Predicates I vid1 (\ i. dterm_sem I (empty i) ((sol 0, b)))" using coincidence_formula[OF fsafe Iagree_refl[of I], of "(sol 0, b)" "?\ 0"] unfolding Vagree_def by (auto simp add: empty_def) show "dterm_sem I (f1 fid2 vid1) (mk_v I (OVar vid1) (sol 0, b) (sol t)) < dterm_sem I (f1 fid1 vid1) (mk_v I (OVar vid1) (sol 0, b) (sol t))" using notin incon by auto next fix I::"('sf,'sc,'sz) interp" and b aa ba and sol::"real \ 'sz simple_state" and t::real let ?ODE = "OVar vid1" let ?\ = "(\t. mk_v I (?ODE) (sol 0, b) (sol t))" assume t:"0 \ t" assume sol:"(sol solves_ode (\a. ODEs I vid1)) {0..t} {x. Predicates I vid1 (\ i. dterm_sem I (local.empty i) (mk_v I (OVar vid1) (sol 0, b) x))}" assume notin:"\ Predicates I vid1 (\ i. dterm_sem I (local.empty i) (sol 0, b))" have fsafe:"fsafe (Prop vid1 empty)" by (auto simp add: empty_def) from sol have "Predicates I vid1 (\ i. dterm_sem I (empty i) (?\ 0))" using t solves_ode_domainD[of sol "(\a. ODEs I vid1)" "{0..t}"] by auto then have incon:"Predicates I vid1 (\ i. dterm_sem I (empty i) ((sol 0, b)))" using coincidence_formula[OF fsafe Iagree_refl[of I], of "(sol 0, b)" "?\ 0"] unfolding Vagree_def by (auto simp add: empty_def) show "dterm_sem I (f1 fid2 vid1) (mk_v I (OVar vid1) (sol 0, b) (sol t)) < dterm_sem I (f1 fid1 vid1) (mk_v I (OVar vid1) (sol 0, b) (sol t))" using incon notin by auto next fix I::"('sf,'sc,'sz) interp" and b aa ba and sol::"real \ 'sz simple_state" and t::real let ?ODE = "OVar vid1" let ?\ = "(\t. mk_v I (?ODE) (sol 0, b) (sol t))" assume good_interp:"is_interp I" assume aaba:"(aa, ba) = mk_v I (OVar vid1) (sol 0, b) (sol t)" assume t:"0 \ t" assume sol:"(sol solves_ode (\a. ODEs I vid1)) {0..t} {x. Predicates I vid1 (\ i. dterm_sem I (local.empty i) (mk_v I (OVar vid1) (sol 0, b) x))}" assume box:"\a ba. (\sola. sol 0 = sola 0 \ (\t. (a, ba) = mk_v I (OVar vid1) (sola 0, b) (sola t) \ 0 \ t \ (sola solves_ode (\a. ODEs I vid1)) {0..t} {x. Predicates I vid1 (\ i. dterm_sem I (local.empty i) (mk_v I (OVar vid1) (sola 0, b) x))})) \ directional_derivative I (f1 fid2 vid1) (a, ba) \ directional_derivative I (f1 fid1 vid1) (a, ba)" assume geq0:"dterm_sem I (f1 fid2 vid1) (sol 0, b) < dterm_sem I (f1 fid1 vid1) (sol 0, b)" have free1:"dfree (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0))" by (auto intro: dfree.intros) have free2:"dfree (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))" by (auto intro: dfree.intros) from geq0 have geq0':"sterm_sem I (f1 fid2 vid1) (sol 0) < sterm_sem I (f1 fid1 vid1) (sol 0)" unfolding f1_def using dterm_sterm_dfree[OF free1, of I "sol 0" b] dterm_sterm_dfree[OF free2, of I "sol 0" b] by auto let ?\s = "\x. fst (?\ x)" let ?\t = "\x. snd (?\ x)" let ?df1 = "(\t. dterm_sem I (f1 fid2 vid1) (?\ t))" let ?f1 = "(\t. sterm_sem I (f1 fid2 vid1) (?\s t))" let ?f1' = "(\ s t'. t' * frechet I (f1 fid2 vid1) (?\s s) (?\t s))" have dfeq:"?df1 = ?f1" apply(rule ext) subgoal for t using dterm_sterm_dfree[OF free1, of I "?\s t" "snd (?\ t)"] unfolding f1_def expand_singleton by auto done have free3:"dfree (f1 fid2 vid1)" unfolding f1_def by (auto intro: dfree.intros) let ?df2 = "(\t. dterm_sem I (f1 fid1 vid1) (?\ t))" let ?f2 = "(\t. sterm_sem I (f1 fid1 vid1) (?\s t))" let ?f2' = "(\s t' . t' * frechet I (f1 fid1 vid1) (?\s s) (?\t s))" let ?int = "{0..t}" have bluh:"\x i. (Functions I i has_derivative (THE f'. \x. (Functions I i has_derivative f' x) (at x)) x) (at x)" using good_interp unfolding is_interp_def by auto have blah:"(Functions I fid2 has_derivative (THE f'. \x. (Functions I fid2 has_derivative f' x) (at x)) (\ i. if i = vid1 then sol t vid1 else 0)) (at (\ i. if i = vid1 then sol t vid1 else 0))" using bluh by auto have bigEx:"\s. s \ {0..t} \(\sola. sol 0 = sola 0 \ (\ta. (fst (?\ s), snd (?\ s)) = mk_v I (OVar vid1) (sola 0, b) (sola ta) \ 0 \ ta \ (sola solves_ode (\a. ODEs I vid1)) {0..ta} {x. Predicates I vid1 (\ i. dterm_sem I (local.empty i) (mk_v I (OVar vid1) (sol 0, b) x))}))" subgoal for s apply(rule exI[where x=sol]) apply(rule conjI) subgoal by (rule refl) apply(rule exI[where x=s]) apply(rule conjI) subgoal by auto apply(rule conjI) subgoal by auto using sol using atLeastAtMost_iff atLeastatMost_subset_iff order_refl solves_ode_on_subset by (metis (no_types, lifting) subsetI) done have box':"\s. s \ {0..t} \ directional_derivative I (f1 fid2 vid1) (?\s s, ?\t s) \ directional_derivative I (f1 fid1 vid1) (?\s s, ?\t s)" subgoal for s using box apply simp apply (erule allE[where x="?\s s"]) apply (erule allE[where x="?\t s"]) using bigEx[of s] by auto done have dsafe1:"dsafe (f1 fid2 vid1)" unfolding f1_def by (auto intro: dsafe.intros) have dsafe2:"dsafe (f1 fid1 vid1)" unfolding f1_def by (auto intro: dsafe.intros) have agree1:"Vagree (sol 0, b) (?\ 0) (FVT (f1 fid2 vid1))" using mk_v_agree[of I "(OVar vid1)" "(sol 0, b)" "fst (?\ 0)"] unfolding f1_def Vagree_def expand_singleton apply auto by (metis (no_types, lifting) Compl_iff Vagree_def fst_conv mk_v_agree mk_xode.simps semBV.simps) have agree2:"Vagree (sol 0, b) (?\ 0) (FVT (f1 fid1 vid1))" using mk_v_agree[of I "(OVar vid1)" "(sol 0, b)" "fst (?\ 0)"] unfolding f1_def Vagree_def expand_singleton apply auto by (metis (no_types, lifting) Compl_iff Vagree_def fst_conv mk_v_agree mk_xode.simps semBV.simps) have sem_eq1:"dterm_sem I (f1 fid2 vid1) (sol 0, b) = dterm_sem I (f1 fid2 vid1) (?\ 0)" using coincidence_dterm[OF dsafe1 agree1] by auto then have sem_eq1':"sterm_sem I (f1 fid2 vid1) (sol 0) = sterm_sem I (f1 fid2 vid1) (?\s 0)" using dterm_sterm_dfree[OF free1, of I "sol 0" "b"] dterm_sterm_dfree[OF free1, of I "(?\s 0)" "snd (?\ 0)"] unfolding f1_def expand_singleton by auto have sem_eq2:"dterm_sem I (f1 fid1 vid1) (sol 0, b) = dterm_sem I (f1 fid1 vid1) (?\ 0)" using coincidence_dterm[OF dsafe2 agree2] by auto then have sem_eq2':"sterm_sem I (f1 fid1 vid1) (sol 0) = sterm_sem I (f1 fid1 vid1) (?\s 0)" using dterm_sterm_dfree[OF free2, of I "sol 0" "b"] dterm_sterm_dfree[OF free2, of I "(?\s 0)" "snd (?\ 0)"] unfolding f1_def expand_singleton by auto have good_interp':"\i x. (Functions I i has_derivative (THE f'. \x. (Functions I i has_derivative f' x) (at x)) x) (at x)" using good_interp unfolding is_interp_def by auto have chain : "\f f' g g' x s. (f has_derivative f') (at x within s) \ (g has_derivative g') (at (f x) within f  s) \ (g \ f has_derivative g' \ f') (at x within s)" by(auto intro: derivative_intros) have sol1:"(sol solves_ode (\_. ODE_sem I (OVar vid1))) {0..t} {x. mk_v I (OVar vid1) (sol 0, b) x \ fml_sem I (Prop vid1 empty)}" using sol unfolding p1_def singleton_def empty_def by auto have FVTsub1:"vid1 \ ODE_vars I (OVar vid1) \ FVT (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) \ semBV I ((OVar vid1))" apply auto subgoal for x xa apply(cases "xa = vid1") by auto done have FVTsub2:"vid1 \ ODE_vars I (OVar vid1) \ FVT (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)) \ semBV I ((OVar vid1))" apply auto subgoal for x xa apply(cases "xa = vid1") by auto done have osafe:"osafe (OVar vid1)" by auto have deriv1:"\s. vid1 \ ODE_vars I (OVar vid1) \ s \ ?int \ (?f1 has_derivative (?f1' s)) (at s within {0..t})" subgoal for s using rift_in_space_time[OF good_interp free1 osafe sol1 FVTsub1, of s] unfolding f1_def expand_singleton directional_derivative_def by blast done have deriv2:"\s. vid1 \ ODE_vars I (OVar vid1) \ s \ ?int \ (?f2 has_derivative (?f2' s)) (at s within {0..t})" subgoal for s using rift_in_space_time[OF good_interp free2 osafe sol1 FVTsub2, of s] unfolding f1_def expand_singleton directional_derivative_def by blast done have leq:"\s . s \ ?int \ ?f1' s 1 \ ?f2' s 1" subgoal for s using box'[of s] by (simp add: directional_derivative_def) done have preserve_agree1:"vid1 \ ODE_vars I (OVar vid1) \ VSagree (sol 0) (fst (mk_v I (OVar vid1) (sol 0, b) (sol t))) {vid1}" using mk_v_agree[of I "OVar vid1" "(sol 0, b)" "sol t"] unfolding Vagree_def VSagree_def by auto have preserve_coincide1: "vid1 \ ODE_vars I (OVar vid1) \ sterm_sem I (f1 fid2 vid1) (fst (mk_v I (OVar vid1) (sol 0, b) (sol t))) = sterm_sem I (f1 fid2 vid1) (sol 0)" using coincidence_sterm[of "(sol 0, b)" "(mk_v I (OVar vid1) (sol 0, b) (sol t))" "f1 fid2 vid1" I] preserve_agree1 unfolding VSagree_def Vagree_def f1_def by auto have preserve_coincide2: "vid1 \ ODE_vars I (OVar vid1) \ sterm_sem I (f1 fid1 vid1) (fst (mk_v I (OVar vid1) (sol 0, b) (sol t))) = sterm_sem I (f1 fid1 vid1) (sol 0)" using coincidence_sterm[of "(sol 0, b)" "(mk_v I (OVar vid1) (sol 0, b) (sol t))" "f1 fid1 vid1" I] preserve_agree1 unfolding VSagree_def Vagree_def f1_def by auto have "?f1 t < ?f2 t" apply(cases "t = 0") subgoal using geq0' sem_eq1' sem_eq2' by auto subgoal apply(cases "vid1 \ ODE_vars I (OVar vid1)") subgoal apply (rule MVT'_gr[OF deriv2 deriv1, of t]) subgoal by auto subgoal by auto subgoal for s using deriv2[of s] using leq by auto using t leq geq0' sem_eq1' sem_eq2' by auto subgoal using geq0 using dterm_sterm_dfree[OF free1, of I "sol 0" "b"] using dterm_sterm_dfree[OF free2, of I "sol 0" "b"] using preserve_coincide1 preserve_coincide2 by(simp add: f1_def) done done then show "dterm_sem I (f1 fid2 vid1) (mk_v I (OVar vid1) (sol 0, b) (sol t)) < dterm_sem I (f1 fid1 vid1) (mk_v I (OVar vid1) (sol 0, b) (sol t))" using t dterm_sterm_dfree[OF free2, of I "?\s t" "snd (?\ t)"] dterm_sterm_dfree[OF free1, of I "?\s t" "snd (?\ t)"] using geq0 f1_def by (simp add: f1_def) qed lemma DG_valid:"valid DGaxiom" proof - have osafe:"osafe (OSing vid1 (f1 fid1 vid1))" by(auto simp add: osafe_Sing dfree_Fun dfree_Const f1_def expand_singleton) have fsafe:"fsafe (p1 vid1 vid1)" by(auto simp add: p1_def dfree_Const) have osafe2:"osafe (OProd (OSing vid1 (f1 fid1 vid1)) (OSing vid2 (Plus (Times (f1 fid2 vid1) (trm.Var vid2)) (f1 fid3 vid1))))" by(auto simp add: f1_def expand_singleton osafe.intros dfree.intros vne12) note sem = ode_alt_sem[OF osafe fsafe] note sem2 = ode_alt_sem[OF osafe2 fsafe] have p2safe:"fsafe (p1 vid2 vid1)" by(auto simp add: p1_def dfree_Const) show "valid DGaxiom" apply(auto simp del: prog_sem.simps(8) simp add: DGaxiom_def valid_def sem sem2) apply(rule exI[where x=0], auto simp add: f1_def p1_def expand_singleton) subgoal for I a b aa ba sol t proof - assume good_interp:"is_interp I" assume " \aa ba. (\sol t. (aa, ba) = mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) (sol t) \ 0 \ t \ (sol solves_ode (\a b. \ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) b else 0)) {0..t} {x. Predicates I vid1 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) x))} \ VSagree (sol 0) a {uu. uu = vid1 \ Inl uu \ Inl  {x. \xa. Inl x \ FVT (if xa = vid1 then trm.Var vid1 else Const 0)} \ (\x. Inl uu \ FVT (if x = vid1 then trm.Var vid1 else Const 0))}) \ Predicates I vid2 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (aa, ba))" then have bigAll:" \aa ba. (\sol t. (aa, ba) = mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) (sol t) \ 0 \ t \ (sol solves_ode (\a b. \ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) b else 0)) {0..t} {x. Predicates I vid1 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) x))} \ VSagree (sol 0) a {uu. uu = vid1 \ (\x. Inl uu \ FVT (if x = vid1 then trm.Var vid1 else Const 0))}) \ Predicates I vid2 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (aa, ba))" by (auto) assume aaba:"(aa, ba) = mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) (\ y. if vid2 = y then 0 else fst (a, b) y, b) (sol t)" assume t:"0 \ t" assume sol:" (sol solves_ode (\a b. (\ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) b else 0) + (\ i. if i = vid2 then sterm_sem I (Plus (Times (f1 fid2 vid1) (trm.Var vid2)) (f1 fid3 vid1)) b else 0))) {0..t} {x. Predicates I vid1 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) (\ y. if vid2 = y then 0 else fst (a, b) y, b) x))}" assume VSag:"VSagree (sol 0) (\ y. if vid2 = y then 0 else fst (a, b) y) {x. x = vid2 \ x = vid1 \ x = vid2 \ x = vid1 \ Inl x \ Inl  {x. x = vid2 \ x = vid1} \ x = vid1}" let ?sol = "(\t. \ i. if i = vid1 then sol t vid1 else 0)" let ?aaba' = "mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) (?sol t)" from bigAll[of "fst ?aaba'" "snd ?aaba'"] have bigEx:"(\sol t. ?aaba' = mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) (sol t) \ 0 \ t \ (sol solves_ode (\a b. \ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) b else 0)) {0..t} {x. Predicates I vid1 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) x))} \ VSagree (sol 0) a {uu. uu = vid1 \ (\x. Inl uu \ FVT (if x = vid1 then trm.Var vid1 else Const 0))}) \ Predicates I vid2 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (?aaba'))" by simp have pre1:"?aaba' = mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) (?sol t)" by (rule refl) have agreeL:"\s. fst (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) (\ y. if vid2 = y then 0 else fst (a, b) y, b) (sol s)) vid1 = sol s vid1" subgoal for s using mk_v_agree[of I "(OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0)))))" "(\ y. if vid2 = y then 0 else fst (a, b) y, b)" "(sol s)"] unfolding Vagree_def by auto done have agreeR:"\s. fst (mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) (\ i. if i = vid1 then sol s vid1 else 0)) vid1 = sol s vid1" subgoal for s using mk_v_agree[of "I" "(OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))" "(a, b)" "(\ i. if i = vid1 then sol s vid1 else 0)"] unfolding Vagree_def by auto done have FV:"(FVF (p1 vid1 vid1)) = {Inl vid1}" unfolding p1_def expand_singleton apply auto subgoal for x xa apply(cases "xa = vid1") by auto done have agree:"\s. Vagree (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) (\ y. if vid2 = y then 0 else fst (a, b) y, b) (sol s)) (mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) (\ i. if i = vid1 then sol s vid1 else 0)) (FVF (p1 vid1 vid1))" using agreeR agreeL unfolding Vagree_def FV by auto note con_sem_eq = coincidence_formula[OF fsafe Iagree_refl agree] have constraint:"\s. 0 \ s \ s \ t \ Predicates I vid1 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) (\ i. if i = vid1 then sol s vid1 else 0)))" using sol apply simp apply(drule solves_odeD(2)) apply auto[1] subgoal for s using con_sem_eq by (auto simp add: p1_def expand_singleton) done have eta:"sol = (\t. \ i. sol t i)" by (rule ext, rule vec_extensionality, simp) have yet_another_eq:"\x. (\xa. xa *\<^sub>R ((\ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) (sol x) else 0) + (\ i. if i = vid2 then sterm_sem I (Plus (Times (f1 fid2 vid1) (trm.Var vid2)) (f1 fid3 vid1)) (sol x) else 0))) = (\xa. (\ i. (xa *\<^sub>R ((\ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) (sol x) else 0) + (\ i. if i = vid2 then sterm_sem I (Plus (Times (f1 fid2 vid1) (trm.Var vid2)) (f1 fid3 vid1)) (sol x) else 0))) i))" subgoal for x by (rule ext, rule vec_extensionality, simp) done have sol_deriv:"\x. x \{0..t} \ (sol has_derivative (\xa. xa *\<^sub>R ((\ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) (sol x) else 0) + (\ i. if i = vid2 then sterm_sem I (Plus (Times (f1 fid2 vid1) (trm.Var vid2)) (f1 fid3 vid1)) (sol x) else 0)))) (at x within {0..t})" using sol apply simp apply(drule solves_odeD(1)) unfolding has_vderiv_on_def has_vector_derivative_def by auto then have sol_deriv:"\x. x \ {0..t} \ ((\t. \ i. sol t i) has_derivative (\xa. (\ i. (xa *\<^sub>R ((\ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) (sol x) else 0) + (\ i. if i = vid2 then sterm_sem I (Plus (Times (f1 fid2 vid1) (trm.Var vid2)) (f1 fid3 vid1)) (sol x) else 0))) i))) (at x within {0..t})" using yet_another_eq eta by auto have sol_deriv1: "\x. x \ {0..t} \ ((\t. sol t vid1) has_derivative (\xa. (xa *\<^sub>R ((\ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) (sol x) else 0) + (\ i. if i = vid2 then sterm_sem I (Plus (Times (f1 fid2 vid1) (trm.Var vid2)) (f1 fid3 vid1)) (sol x) else 0)) vid1))) (at x within {0..t})" subgoal for s (* I heard higher-order unification is hard.*) apply(rule has_derivative_proj[of "(\ i t. sol t i)" "(\j xa. (xa *\<^sub>R ((\ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) (sol s) else 0) + (\ i. if i = vid2 then sterm_sem I (Plus (Times (f1 fid2 vid1) (trm.Var vid2)) (f1 fid3 vid1)) (sol s) else 0)) j))" "at s within {0..t}""vid1"]) using sol_deriv[of s] by auto done have hmm:"\s. (\ i. sterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (sol s)) = (\ i. sterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (\ i. if i = vid1 then sol s vid1 else 0))" by(rule vec_extensionality, auto) have aha:"\s. (\xa. xa * sterm_sem I (f1 fid1 vid1) (sol s)) = (\xa. xa * sterm_sem I (f1 fid1 vid1) (\ i. if i = vid1 then sol s vid1 else 0))" subgoal for s apply(rule ext) subgoal for xa using hmm by (auto simp add: f1_def) done done let ?sol' = "(\s. (\xa. \ i. if i = vid1 then xa * sterm_sem I (f1 fid1 vid1) (\ i. if i = vid1 then sol s vid1 else 0) else 0))" let ?project_me_plz = "(\t. (\ i. if i = vid1 then ?sol t vid1 else 0))" have sol_deriv_eq:"\s. s \{0..t} \ ((\t. (\ i. if i = vid1 then ?sol t vid1 else 0)) has_derivative ?sol' s) (at s within {0..t})" subgoal for s apply(rule has_derivative_vec) subgoal for i apply (cases "i = vid1", cases "i = vid2", auto) using vne12 apply simp using sol_deriv1[of s] using aha by auto done done have yup:"(\t. (\ i. if i = vid1 then ?sol t vid1 else 0) vid1) = (\t. sol t vid1)" by(rule ext, auto) have maybe:"\s. (\xa. xa * sterm_sem I (f1 fid1 vid1) (\ i. if i = vid1 then sol s vid1 else 0)) = (\xa. (\ i. if i = vid1 then xa * sterm_sem I (f1 fid1 vid1) (\ i. if i = vid1 then sol s vid1 else 0) else 0) vid1) " by(rule ext, auto) have almost:"(\x. if vid1 = vid1 then (\ i. if i = vid1 then sol x vid1 else 0) vid1 else 0) = (\x. (\ i. if i = vid1 then sol x vid1 else 0) vid1)" by(rule ext, auto) have almost':"\s. (\h. if vid1 = vid1 then h * sterm_sem I (f1 fid1 vid1) (\ i. if i = vid1 then sol s vid1 else 0) else 0) = (\h. h * sterm_sem I (f1 fid1 vid1) (\ i. if i = vid1 then sol s vid1 else 0))" by(rule ext, auto) have deriv':" \x. x \ {0..t} \ ((\t. \ i. if i = vid1 then sol t vid1 else 0) has_derivative (\xa. (\ i. xa *\<^sub>R (if i = vid1 then sterm_sem I (f1 fid1 vid1) (\ i. if i = vid1 then sol x vid1 else 0) else 0)))) (at x within {0..t})" subgoal for s apply(rule has_derivative_vec) subgoal for i apply(cases "i = vid1") prefer 2 subgoal by auto apply auto using has_derivative_proj[OF sol_deriv_eq[of s], of vid1] using yup maybe[of s] almost almost'[of s] by fastforce done done have derEq:"\s. (\xa. (\ i. xa *\<^sub>R (if i = vid1 then sterm_sem I (f1 fid1 vid1) (\ i. if i = vid1 then sol s vid1 else 0) else 0))) = (\xa. xa *\<^sub>R (\ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) (\ i. if i = vid1 then sol s vid1 else 0) else 0))" subgoal for s apply (rule ext, rule vec_extensionality) by auto done have "\x. x \ {0..t} \ ((\t. \ i. if i = vid1 then sol t vid1 else 0) has_derivative (\xa. xa *\<^sub>R (\ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) (\ i. if i = vid1 then sol x vid1 else 0) else 0))) (at x within {0..t})" subgoal for s using deriv'[of s] derEq[of s] by auto done then have deriv:"((\t. \ i. if i = vid1 then sol t vid1 else 0) has_vderiv_on (\t. \ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) (\ i. if i = vid1 then sol t vid1 else 0) else 0)) {0..t}" unfolding has_vderiv_on_def has_vector_derivative_def by auto have pre2:"(?sol solves_ode (\a b. \ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) b else 0)) {0..t} {x. Predicates I vid1 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) x))}" apply(rule solves_odeI) subgoal by (rule deriv) subgoal for s using constraint by auto done have pre3:"VSagree (?sol 0) a {u. u = vid1 \ (\x. Inl u \ FVT (if x = vid1 then trm.Var vid1 else Const 0))}" using vne12 VSag unfolding VSagree_def by simp have bigPre:"(\sol t. ?aaba' = mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then Var vid1 else Const 0))) (a, b) (sol t) \ 0 \ t \ (sol solves_ode (\a b. \ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) b else 0)) {0..t} {x. Predicates I vid1 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then Var vid1 else Const 0))) (a, b) x))} \ VSagree (sol 0) a {u. u = vid1 \ (\x. Inl u \ FVT (if x = vid1 then Var vid1 else Const 0))})" apply(rule exI[where x="?sol"]) apply(rule exI[where x=t]) apply(rule conjI) apply(rule pre1) apply(rule conjI) apply(rule t) apply(rule conjI) apply(rule pre2) by(rule pre3) have pred2:"Predicates I vid2 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) ?aaba')" using bigEx bigPre by auto then have pred2':"?aaba' \ fml_sem I (p1 vid2 vid1)" unfolding p1_def expand_singleton by auto let ?res_state = "(mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) (\ y. if vid2 = y then 0 else fst (a, b) y, b) (sol t))" have aabaX:"(fst ?aaba') vid1 = sol t vid1" using aaba mk_v_agree[of "I" "(OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))" "(a, b)" "(?sol t)"] proof - assume " Vagree (mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) (\ i. if i = vid1 then sol t vid1 else 0)) (a, b) (- semBV I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))) \ Vagree (mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) (\ i. if i = vid1 then sol t vid1 else 0)) (mk_xode I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (\ i. if i = vid1 then sol t vid1 else 0)) (semBV I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))))" then have ag:" Vagree (mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) (?sol t)) (mk_xode I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (?sol t)) (semBV I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))))" by auto have sembv:"(semBV I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))) = {Inl vid1, Inr vid1}" by auto have sub:"{Inl vid1} \ {Inl vid1, Inr vid1}" by auto have ag':"Vagree (mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) (?sol t)) (mk_xode I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (?sol t)) {Inl vid1}" using ag agree_sub[OF sub] sembv by auto then have eq1:"fst (mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) (?sol t)) vid1 = fst (mk_xode I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (?sol t)) vid1" unfolding Vagree_def by auto moreover have "... = sol t vid1" by auto ultimately show ?thesis by auto qed have res_stateX:"(fst ?res_state) vid1 = sol t vid1" using mk_v_agree[of I "(OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0)))))" "(\ y. if vid2 = y then 0 else fst (a, b) y, b)" "(sol t)"] proof - assume "Vagree (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) (\ y. if vid2 = y then 0 else fst (a, b) y, b) (sol t)) (\ y. if vid2 = y then 0 else fst (a, b) y, b) (- semBV I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0)))))) \ Vagree (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) (\ y. if vid2 = y then 0 else fst (a, b) y, b) (sol t)) (mk_xode I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) (sol t)) (semBV I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))))" then have ag:" Vagree (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) (\ y. if vid2 = y then 0 else fst (a, b) y, b) (sol t)) (mk_xode I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) (sol t)) (semBV I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))))" by auto have sembv:"(semBV I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0)))))) = {Inl vid1, Inr vid1, Inl vid2, Inr vid2}" by auto have sub:"{Inl vid1} \ {Inl vid1, Inr vid1, Inl vid2, Inr vid2}" by auto have ag':"Vagree (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) (\ y. if vid2 = y then 0 else fst (a, b) y, b) (sol t)) (mk_xode I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) (sol t)) {Inl vid1}" using ag sembv agree_sub[OF sub] by auto then have "fst ?res_state vid1 = fst ((mk_xode I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) (sol t))) vid1" unfolding Vagree_def by blast moreover have "... = sol t vid1" by auto ultimately show "?thesis" by linarith qed have agree:"Vagree ?aaba' (?res_state) (FVF (p1 vid2 vid1))" unfolding p1_def Vagree_def using aabaX res_stateX by auto have fml_sem_eq:"(?res_state \ fml_sem I (p1 vid2 vid1)) = (?aaba' \ fml_sem I (p1 vid2 vid1))" using coincidence_formula[OF p2safe Iagree_refl agree, of I] by auto then show "Predicates I vid2 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) (\ y. if vid2 = y then 0 else fst (a, b) y, b) (sol t)))" using pred2 unfolding p1_def expand_singleton by auto qed subgoal for I a b r aa ba sol t proof - assume good_interp:"is_interp I" assume bigAll:" \aa ba. (\sol t. (aa, ba) = mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) (\ y. if vid2 = y then r else fst (a, b) y, b) (sol t) \ 0 \ t \ (sol solves_ode (\a b. (\ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) b else 0) + (\ i. if i = vid2 then sterm_sem I (Plus (Times (f1 fid2 vid1) (trm.Var vid2)) (f1 fid3 vid1)) b else 0))) {0..t} {x. Predicates I vid1 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) (\ y. if vid2 = y then r else fst (a, b) y, b) x))} \ VSagree (sol 0) (\ y. if vid2 = y then r else fst (a, b) y) {uu. uu = vid2 \ uu = vid1 \ uu = vid2 \ uu = vid1 \ Inl uu \ Inl  ({x. \xa. Inl x \ FVT (if xa = vid1 then trm.Var vid1 else Const 0)} \ {x. x = vid2 \ (\xa. Inl x \ FVT (if xa = vid1 then trm.Var vid1 else Const 0))}) \ (\x. Inl uu \ FVT (if x = vid1 then trm.Var vid1 else Const 0))}) \ Predicates I vid2 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (aa, ba))" assume aaba:"(aa, ba) = mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) (sol t)" assume t:"0 \ t" assume sol:"(sol solves_ode (\a b. \ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) b else 0)) {0..t} {x. Predicates I vid1 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) x))}" assume VSA:"VSagree (sol 0) a {uu. uu = vid1 \ Inl uu \ Inl  {x. \xa. Inl x \ FVT (if xa = vid1 then trm.Var vid1 else Const 0)} \ (\x. Inl uu \ FVT (if x = vid1 then trm.Var vid1 else Const 0))}" let ?xode = "(\a b. \ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) b else 0)" let ?xconstraint = UNIV let ?ivl = "ll_on_open.existence_ivl {0 .. t} ?xode ?xconstraint 0 (sol 0)" have freef1:"dfree (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))" by(auto simp add: dfree_Fun dfree_Const) have simple_term_inverse':"\\. dfree \ \ raw_term (simple_term$$ = \" using simple_term_inverse by auto have old_lipschitz:"local_lipschitz (UNIV::real set) UNIV (\a b. \ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) b else 0)" apply(rule c1_implies_local_lipschitz[where f'="(\ (t,b). blinfun_vec(\ i. if i = vid1 then blin_frechet (good_interp I) (simple_term (Function fid1 (\ i. if i = vid1 then Var vid1 else Const 0))) b else Blinfun(\ _. 0)))"]) apply auto subgoal for x apply(rule has_derivative_vec) subgoal for i apply(auto simp add: bounded_linear_Blinfun_apply good_interp_inverse good_interp) apply(auto simp add: simple_term_inverse'[OF freef1]) apply(cases "i = vid1") apply(auto simp add: f1_def expand_singleton) proof - let ?h = "(\b. Functions I fid1 (\ i. sterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) b))" let ?h' = "(\b'. FunctionFrechet I fid1 (\ i. sterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) x) (\ i. frechet I (if i = vid1 then trm.Var vid1 else Const 0) x b'))" let ?f = "(\ b. (\ i. sterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) b))" let ?f' = "(\ b'. (\ i. frechet I (if i = vid1 then trm.Var vid1 else Const 0) x b'))" let ?g = "Functions I fid1" let ?g'= "FunctionFrechet I fid1 (?f x)" have heq:"?h = ?g \ ?f" by(rule ext, auto) have heq':"?h' = ?g' \ ?f'" by(rule ext, auto) have fderiv:"(?f has_derivative ?f') (at x)" apply(rule has_derivative_vec) by (auto simp add: svar_deriv axis_def) have gderiv:"(?g has_derivative ?g') (at (?f x))" using good_interp unfolding is_interp_def by blast have gfderiv: "((?g \ ?f) has_derivative(?g' \ ?f')) (at x)" using fderiv gderiv diff_chain_at by blast have boring_eq:"(\b. Functions I fid1 (\ i. sterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) b)) = sterm_sem I (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))" by(rule ext, auto) have "(?h has_derivative ?h') (at x)" using gfderiv heq heq' by auto then show "(sterm_sem I (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)) has_derivative (\v'. (THE f'. \x. (Functions I fid1 has_derivative f' x) (at x)) (\ i. sterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) x) (\ i. frechet I (if i = vid1 then trm.Var vid1 else Const 0) x v'))) (at x)" using boring_eq by auto qed done proof - have the_thing:"continuous_on (UNIV::('sz Rvec set)) (\b. blinfun_vec (\i. if i = vid1 then blin_frechet (good_interp I) (simple_term (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) b else Blinfun (\_. 0)))" apply(rule continuous_blinfun_vec') subgoal for i apply(cases "i = vid1") apply(auto) using frechet_continuous[OF good_interp freef1] by (auto simp add: continuous_on_const) done have another_cont:"continuous_on (UNIV) (\x. blinfun_vec (\i. if i = vid1 then blin_frechet (good_interp I) (simple_term (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (snd x) else Blinfun (\_. 0)))" apply(rule continuous_on_compose2[of UNIV "(\b. blinfun_vec (\i. if i = vid1 then blin_frechet (good_interp I) (simple_term (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) b else Blinfun (\_. 0)))"]) apply(rule the_thing) by (auto intro!: continuous_intros) have ext:"(\x. case x of (t, b) \ blinfun_vec (\i. if i = vid1 then blin_frechet (good_interp I) (simple_term (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) b else Blinfun (\_. 0))) =(\x. blinfun_vec (\i. if i = vid1 then blin_frechet (good_interp I) (simple_term (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (snd x) else Blinfun (\_. 0))) " apply(rule ext, auto) by (metis snd_conv) then show "continuous_on (UNIV) (\x. case x of (t, b) \ blinfun_vec (\i. if i = vid1 then blin_frechet (good_interp I) (simple_term (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) b else Blinfun (\_. 0)))" using another_cont by (simp add: another_cont local.ext) qed have old_continuous:" \x. x \ UNIV \ continuous_on UNIV (\t. \ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) x else 0)" by(rule continuous_on_const) interpret ll_old: ll_on_open_it "UNIV" ?xode ?xconstraint 0 apply(standard) subgoal by auto prefer 3 subgoal by auto prefer 3 subgoal by auto apply(rule old_lipschitz) by (rule old_continuous) let ?ivl = "(ll_old.existence_ivl 0 (sol 0))" let ?flow = "ll_old.flow 0 (sol 0)" have tclosed:"{0..t} = {0--t}" using t real_Icc_closed_segment by auto have "(sol solves_ode (\a b. \ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) b else 0)) {0..t} UNIV" apply(rule solves_ode_supset_range) apply(rule sol) by auto then have sol':"(sol solves_ode (\a b. \ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) b else 0)) {0--t} UNIV" using tclosed by auto have sub:"{0--t} \ ll_old.existence_ivl 0 (sol 0)" apply(rule ll_old.closed_segment_subset_existence_ivl) apply(rule ll_old.existence_ivl_maximal_segment) apply(rule sol') apply(rule refl) by auto have usol_old:"(?flow usolves_ode ?xode from 0) ?ivl UNIV" by(rule ll_old.flow_usolves_ode, auto) have sol_old:"(ll_old.flow 0 (sol 0) solves_ode ?xode) ?ivl UNIV" by(rule ll_old.flow_solves_ode, auto) have another_sub:"\s. s \ {0..t} \ {s--0} \ {0..t}" unfolding closed_segment_def apply auto by (metis diff_0_right diff_left_mono mult.commute mult_left_le order.trans) have sol_eq_flow:"\s. s \ {0..t} \ sol s = ?flow s" using usol_old apply simp apply(drule usolves_odeD(4)) (* 7 subgoals*) apply auto subgoal for s x proof - assume xs0:"x \ {s--0}" assume s0:"0 \ s" and st: "s \ t" have "{s--0} \ {0..t}" using another_sub[of s] s0 st by auto then have "x \ {0..t}" using xs0 by auto then have "x \ {0--t}" using tclosed by auto then show "x \ ll_old.existence_ivl 0 (sol 0)" using sub by auto qed apply(rule solves_ode_subset) using sol' apply auto[1] subgoal for s proof - assume s0:"0 \ s" and st:"s \ t" show "{s--0} \ {0--t}" using tclosed unfolding closed_segment using s0 st using another_sub intervalE by blast qed done have sol_deriv_orig:"\s. s\?ivl \ (?flow has_derivative (\xa. xa *\<^sub>R (\ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) (?flow s) else 0))) (at s within ?ivl)" using sol_old apply simp apply(drule solves_odeD(1)) by (auto simp add: has_vderiv_on_def has_vector_derivative_def) have sol_eta:"(\t. \ i. ?flow t  i) = ?flow" by(rule ext, rule vec_extensionality, auto) have sol_deriv_eq1:"\s i. (\xa. xa *\<^sub>R (\ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) (?flow s) else 0)) = (\xa. \ i. xa * (if i = vid1 then sterm_sem I (f1 fid1 vid1) (?flow s) else 0))" by(rule ext, rule vec_extensionality, auto) have sol_deriv_proj:"\s i. s\?ivl \ ((\t. ?flow t  i) has_derivative (\xa. (xa *\<^sub>R (\ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) (?flow s) else 0))  i)) (at s within ?ivl)" subgoal for s i apply(rule has_derivative_proj[of "(\ i t. ?flow t  i)" "(\ i t'. (t' *\<^sub>R (\ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) (?flow s) else 0))  i)" "(at s within ?ivl)" "i"]) using sol_deriv_orig[of s] sol_eta sol_deriv_eq1 by auto done have sol_deriv_eq2:"\s i. (\xa. xa * (if i = vid1 then sterm_sem I (f1 fid1 vid1) (?flow s) else 0)) = (\xa. (xa *\<^sub>R (\ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) (?flow s) else 0))  i)" by(rule ext, auto) have sol_deriv_proj':"\s i. s\?ivl \ ((\t. ?flow t  i) has_derivative (\xa. xa * (if i = vid1 then sterm_sem I (f1 fid1 vid1) (?flow s) else 0))) (at s within ?ivl)" subgoal for s i using sol_deriv_proj[of s i] sol_deriv_eq2[of i s] by metis done have sol_deriv_proj_vid1:"\s. s\?ivl \ ((\t. ?flow t  vid1) has_derivative (\xa. xa * (sterm_sem I (f1 fid1 vid1) (?flow s)))) (at s within ?ivl)" subgoal for s using sol_deriv_proj'[of s vid1] by auto done have deriv1_args:"\s. s \ ?ivl \ ((\ t. (\ i. sterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (?flow t))) has_derivative ((\ t'. \ i . t' * (if i = vid1 then sterm_sem I (f1 fid1 vid1) (?flow s) else 0)))) (at s within ?ivl)" apply(rule has_derivative_vec) by (auto simp add: sol_deriv_proj_vid1) have con_fid:"\fid. continuous_on ?ivl (\x. sterm_sem I (f1 fid vid1) (?flow x))" subgoal for fid apply(rule has_derivative_continuous_on[of "?ivl" "(\x. sterm_sem I (f1 fid vid1) (?flow x))" "(\t t'. FunctionFrechet I fid (\ i. sterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (?flow t)) (\ i . t' * (if i = vid1 then sterm_sem I (f1 fid1 vid1) (?flow t) else 0)))"]) proof - fix s assume ivl:"s \ ?ivl" let ?h = "(\x. sterm_sem I (f1 fid vid1) (?flow x))" let ?g = "Functions I fid" let ?f = "(\x. (\ i. sterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (?flow x)))" let ?h' = "(\t'. FunctionFrechet I fid (\ i. sterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (?flow s)) (\ i. t' * (if i = vid1 then sterm_sem I (f1 fid1 vid1) (?flow s) else 0)))" let ?g' = "FunctionFrechet I fid (?f s)" let ?f' = "(\ t'. \ i . t' * (if i = vid1 then sterm_sem I (f1 fid1 vid1) (?flow s) else 0))" have heq:"?h = ?g \ ?f" unfolding comp_def f1_def expand_singleton by auto have heq':"?h' = ?g' \ ?f'" unfolding comp_def by auto have fderiv:"(?f has_derivative ?f') (at s within ?ivl)" using deriv1_args[OF ivl] by auto have gderiv:"(?g has_derivative ?g') (at (?f s) within (?f  ?ivl))" using good_interp unfolding is_interp_def using has_derivative_within_subset by blast have gfderiv:"((?g \ ?f) has_derivative (?g' \ ?f')) (at s within ?ivl)" using fderiv gderiv diff_chain_within by blast show "((\x. sterm_sem I (f1 fid vid1) (?flow x)) has_derivative (\t'. FunctionFrechet I fid (\ i. sterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (?flow s)) (\ i. t' * (if i = vid1 then sterm_sem I (f1 fid1 vid1) (?flow s) else 0)))) (at s within ?ivl)" using heq heq' gfderiv by auto qed done have con:"\x. continuous_on (?ivl) (\t. x * sterm_sem I (f1 fid2 vid1) (?flow t) + sterm_sem I (f1 fid3 vid1) (?flow t))" apply(rule continuous_on_add) apply(rule continuous_on_mult_left) apply(rule con_fid[of fid2]) by(rule con_fid[of fid3]) let ?axis = "(\ i. Blinfun(axis i))" have bounded_linear_deriv:"\t. bounded_linear (\y' . y' *\<^sub>R sterm_sem I (f1 fid2 vid1) (ll_old.flow 0 (sol 0) t))" using bounded_linear_scaleR_left by blast have ll:"local_lipschitz (ll_old.existence_ivl 0 (sol 0)) UNIV (\t y. y * sterm_sem I (f1 fid2 vid1) (?flow t) + sterm_sem I (f1 fid3 vid1) (?flow t))" apply(rule c1_implies_local_lipschitz[where f'="(\ (t,y). Blinfun(\y' . y' *\<^sub>R sterm_sem I (f1 fid2 vid1) (ll_old.flow 0 (sol 0) t)))"]) apply auto subgoal for t x apply(rule has_derivative_add_const) proof - have deriv:"((\x. x * sterm_sem I (f1 fid2 vid1) (ll_old.flow 0 (sol 0) t)) has_derivative (\x. x * sterm_sem I (f1 fid2 vid1) (ll_old.flow 0 (sol 0) t))) (at x)" by(auto intro: derivative_eq_intros) have eq:"(\x. x * sterm_sem I (f1 fid2 vid1) (ll_old.flow 0 (sol 0) t)) = blinfun_apply (Blinfun (\y'. y' * sterm_sem I (f1 fid2 vid1) (ll_old.flow 0 (sol 0) t)))" apply(rule ext) using bounded_linear_deriv[of t] by (auto simp add: bounded_linear_Blinfun_apply) show "((\x. x * sterm_sem I (f1 fid2 vid1) (ll_old.flow 0 (sol 0) t)) has_derivative blinfun_apply (Blinfun (\y'. y' * sterm_sem I (f1 fid2 vid1) (ll_old.flow 0 (sol 0) t)))) (at x)" using deriv eq by auto qed apply(auto intro: continuous_intros simp add: split_beta') proof - have bounded_linear:"\x. bounded_linear (\y'. y' * sterm_sem I (f1 fid2 vid1) x)" by (simp add: bounded_linear_mult_left) have eq:"(\x. Blinfun (\y'. y' * sterm_sem I (f1 fid2 vid1) x)) = (\x. (sterm_sem I (f1 fid2 vid1) x) *\<^sub>R id_blinfun)" apply(rule ext, rule blinfun_eqI) subgoal for x i using bounded_linear[of x] apply(auto simp add: bounded_linear_Blinfun_apply) by (simp add: blinfun.scaleR_left) done have conFlow:"continuous_on (ll_old.existence_ivl 0 (sol 0)) (ll_old.flow 0 (sol 0))" using ll_old.general.flow_continuous_on by blast have conF':"continuous_on (ll_old.flow 0 (sol 0)  ll_old.existence_ivl 0 (sol 0)) (\x. (sterm_sem I (f1 fid2 vid1) x) *\<^sub>R id_blinfun)" apply(rule continuous_on_scaleR) apply(auto intro: continuous_intros) apply(rule sterm_continuous') apply(rule good_interp) by(auto simp add: f1_def intro: dfree.intros) have conF:"continuous_on (ll_old.flow 0 (sol 0)  ll_old.existence_ivl 0 (sol 0)) (\x. Blinfun (\y'. y' * sterm_sem I (f1 fid2 vid1) x))" apply(rule continuous_on_compose2[of "UNIV" "(\x. Blinfun (\y'. y' * x))" "(ll_old.flow 0 (sol 0)  ll_old.existence_ivl 0 (sol 0))" "sterm_sem I (f1 fid2 vid1)"]) subgoal by (metis blinfun_mult_left.abs_eq bounded_linear_blinfun_mult_left continuous_on_eq linear_continuous_on) apply(rule sterm_continuous') apply(rule good_interp) by(auto simp add: f1_def intro: dfree.intros) show "continuous_on (ll_old.existence_ivl 0 (sol 0) \ UNIV) (\x. Blinfun (\y'. y' * sterm_sem I (f1 fid2 vid1) (ll_old.flow 0 (sol 0) (fst x))))" apply(rule continuous_on_compose2[of "ll_old.existence_ivl 0 (sol 0)" "(\x. Blinfun (\y'. y' * sterm_sem I (f1 fid2 vid1) (ll_old.flow 0 (sol 0) x)))" "(ll_old.existence_ivl 0 (sol 0) \ UNIV)" "fst"]) apply(rule continuous_on_compose2[of "(ll_old.flow 0 (sol 0)  ll_old.existence_ivl 0 (sol 0))" "(\x. Blinfun (\y'. y' * sterm_sem I (f1 fid2 vid1) x))" "(ll_old.existence_ivl 0 (sol 0))" "(ll_old.flow 0 (sol 0))"]) using conF conFlow by (auto intro!: continuous_intros) qed let ?ivl = "ll_old.existence_ivl 0 (sol 0)" \ \Construct solution to ODE for \y'\ here:\ let ?yode = "(\t y. y * sterm_sem I (f1 fid2 vid1) (?flow t) + sterm_sem I (f1 fid3 vid1) (?flow t))" let ?ysol0 = r interpret ll_new: ll_on_open_it "?ivl" "?yode" "UNIV" 0 apply(standard) apply(auto) apply(rule ll) by(rule con) have sol_new:"(ll_new.flow 0 r solves_ode ?yode) (ll_new.existence_ivl 0 r) UNIV" by(rule ll_new.flow_solves_ode, auto) have more_lipschitz:"\tm tM. tm \ ll_old.existence_ivl 0 (sol 0) \ tM \ ll_old.existence_ivl 0 (sol 0) \ \M L. \t\{tm..tM}. \x. \x * sterm_sem I (f1 fid2 vid1) (?flow t) + sterm_sem I (f1 fid3 vid1) (?flow t)\ \ M + L * \x\" proof - fix tm tM assume tm:"tm \ ll_old.existence_ivl 0 (sol 0)" assume tM:"tM \ ll_old.existence_ivl 0 (sol 0)" let ?f2 = "(\t. sterm_sem I (f1 fid2 vid1) (ll_old.flow 0 (sol 0) t))" let ?f3 = "(\t. sterm_sem I (f1 fid3 vid1) (ll_old.flow 0 (sol 0) t))" let ?boundLP = "(\L t . (tm \ t \ t \ tM \ \?f2 t\ \ L))" let ?boundL = "(SOME L. (\t. ?boundLP L t))" have compactT:"compact {tm..tM}" by auto have sub:"{tm..tM} \ ll_old.existence_ivl 0 (sol 0)" by (metis atLeastatMost_empty_iff empty_subsetI ll_old.general.segment_subset_existence_ivl real_Icc_closed_segment tM tm) let ?f2abs = "(\x. abs(?f2 x))" have neg_compact:"\S::real set. compact S \ compact ((\x. -x)  S)" by(rule compact_continuous_image, auto intro: continuous_intros) have compactf2:"compact (?f2  {tm..tM})" apply(rule compact_continuous_image) apply(rule continuous_on_compose2[of UNIV "sterm_sem I (f1 fid2 vid1)" "{tm..tM}" "ll_old.flow 0 (sol 0)"]) apply(rule sterm_continuous) apply(rule good_interp) subgoal by (auto intro: dfree.intros simp add: f1_def) apply(rule continuous_on_subset) prefer 2 apply (rule sub) subgoal using ll_old.general.flow_continuous_on by blast by auto then have boundedf2:"bounded (?f2  {tm..tM})" using compact_imp_bounded by auto then have boundedf2neg:"bounded ((\x. -x)  ?f2  {tm..tM})" using compact_imp_bounded neg_compact by auto then have bdd_above_f2neg:"bdd_above ((\x. -x)  ?f2  {tm..tM})" by (rule bounded_imp_bdd_above) then have bdd_above_f2:"bdd_above ( ?f2  {tm..tM})" using bounded_imp_bdd_above boundedf2 by auto have bdd_above_f2_abs:"bdd_above (abs  ?f2  {tm..tM})" using bdd_above_f2neg bdd_above_f2 unfolding bdd_above_def apply auto subgoal for M1 M2 apply(rule exI[where x="max M1 M2"]) by fastforce done then have theBound:"\L. (\t. ?boundLP L t)" unfolding bdd_above_def norm_conv_dist - apply (auto simp add: norm_conv_dist real_norm_def norm_bcontfun_def dist_0_norm dist_blinfun_def) - by fastforce + by (auto simp add: Ball_def Bex_def norm_conv_dist image_iff norm_bcontfun_def dist_blinfun_def) then have boundLP:"\t. ?boundLP (?boundL) t" using someI[of "(\ L. \t. ?boundLP L t)"] by blast let ?boundMP = "(\M t. (tm \ t \ t \ tM \ \?f3 t\ \ M))" let ?boundM = "(SOME M. (\t. ?boundMP M t))" have compactf3:"compact (?f3  {tm..tM})" apply(rule compact_continuous_image) apply(rule continuous_on_compose2[of UNIV "sterm_sem I (f1 fid3 vid1)" "{tm..tM}" "ll_old.flow 0 (sol 0)"]) apply(rule sterm_continuous) apply(rule good_interp) subgoal by (auto intro: dfree.intros simp add: f1_def) apply(rule continuous_on_subset) prefer 2 apply (rule sub) subgoal using ll_old.general.flow_continuous_on by blast by auto then have boundedf3:"bounded (?f3  {tm..tM})" using compact_imp_bounded by auto then have boundedf3neg:"bounded ((\x. -x)  ?f3  {tm..tM})" using compact_imp_bounded neg_compact by auto then have bdd_above_f3neg:"bdd_above ((\x. -x)  ?f3  {tm..tM})" by (rule bounded_imp_bdd_above) then have bdd_above_f3:"bdd_above ( ?f3  {tm..tM})" using bounded_imp_bdd_above boundedf3 by auto have bdd_above_f3_abs:"bdd_above (abs  ?f3  {tm..tM})" using bdd_above_f3neg bdd_above_f3 unfolding bdd_above_def apply auto subgoal for M1 M2 apply(rule exI[where x="max M1 M2"]) by fastforce done - then have theBound:"\L. (\t. ?boundMP L t)" - unfolding bdd_above_def norm_conv_dist - apply (auto simp add: norm_conv_dist real_norm_def norm_bcontfun_def dist_0_norm dist_blinfun_def) - by fastforce + then have theBound:"\L. (\t. ?boundMP L t)" + unfolding bdd_above_def norm_conv_dist + by (auto simp add: Ball_def Bex_def norm_conv_dist image_iff norm_bcontfun_def dist_blinfun_def) then have boundMP:"\t. ?boundMP (?boundM) t" using someI[of "(\ M. \t. ?boundMP M t)"] by blast show "\M L. \t\{tm..tM}. \x. \x * ?f2 t + ?f3 t\ \ M + L * \x\" apply(rule exI[where x="?boundM"]) apply(rule exI[where x="?boundL"]) apply auto proof - fix t and x :: real assume ttm:"tm \ t" assume ttM:"t \ tM" from ttm ttM have ttmM:"tm \ t \ t \ tM" by auto have leqf3:"\?f3 t\ \ ?boundM" using boundMP ttmM by auto have leqf2:"\?f2 t\ \ ?boundL" using boundLP ttmM by auto have gr0:" \x\ \ 0" by auto have leqf2x:"\?f2 t\ * \x\ \ ?boundL * \x\" using gr0 leqf2 by (metis (no_types, lifting) real_scaleR_def scaleR_right_mono) - have "\x * ?f2 t + ?f3 t\ \ \x\ * \?f2 t\ + \?f3 t\" + have "\x * ?f2 t + ?f3 t\ \ \x\ * \?f2 t\ + \?f3 t\" proof - have f1: "\r ra. \r::real\ * \ra\ = \r * ra\" by (metis norm_scaleR real_norm_def real_scaleR_def) have "\r ra. $$r::real) + ra\ \ \r\ + \ra\" by (metis norm_triangle_ineq real_norm_def) then show ?thesis using f1 by presburger qed moreover have "... = \?f3 t\ + \?f2 t\ * \x\" by auto moreover have "... \ ?boundM + \?f2 t\ * \x\" using leqf3 by linarith moreover have "... \ ?boundM + ?boundL * \x\" using leqf2x by linarith ultimately show "\x * ?f2 t + ?f3 t\ \ ?boundM + ?boundL * \x\" by linarith qed qed have ivls_eq:"(ll_new.existence_ivl 0 r) = (ll_old.existence_ivl 0 (sol 0))" apply(rule ll_new.existence_ivl_eq_domain) apply auto apply (rule more_lipschitz) by auto have sub':"{0--t} \ ll_new.existence_ivl 0 r" using sub ivls_eq by auto have sol_new':"(ll_new.flow 0 r solves_ode ?yode) {0--t} UNIV" by(rule solves_ode_subset, rule sol_new, rule sub') let ?soly = "ll_new.flow 0 r" - let ?sol' = "(\t. \ i. if i = vid2 then ?soly t else sol t i)" + let ?sol' = "(\t. \ i. if i = vid2 then ?soly t else sol t i)" let ?aaba' = "mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) - (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) - (\ y. if vid2 = y then r else fst (a, b) y, b) + (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) + (\ y. if vid2 = y then r else fst (a, b) y, b) (?sol' t)" have duh:"(fst ?aaba', snd ?aaba') = ?aaba'" by auto note bigEx = spec[OF spec[OF bigAll, where x="fst ?aaba'"], where x="snd ?aaba'"] have sol_deriv:"\s. s \ {0..t} \ (sol has_derivative (\xa. xa *\<^sub>R (\ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) (sol s) else 0))) (at s within {0..t})" using sol apply simp by(drule solves_odeD(1), auto simp add: has_vderiv_on_def has_vector_derivative_def) have silly_eq1:"(\t. \ i. sol t i) = sol" by(rule ext, rule vec_extensionality, auto) have silly_eq2:"\s. (\xa. \ i. (xa *\<^sub>R (\ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) (sol s) else 0)) i) = (\xa. xa *\<^sub>R (\ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) (sol s) else 0))" by(rule ext, rule vec_extensionality, auto) have sol_proj_deriv:"\s i. s \ {0..t} \ ((\ t. sol t i) has_derivative (\xa. (xa *\<^sub>R (\ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) (sol s) else 0)) i)) (at s within {0..t})" subgoal for s i apply(rule has_derivative_proj) using sol_deriv[of s] silly_eq1 silly_eq2[of s] by auto done have sol_proj_deriv_vid1:"\s. s \ {0..t} \ ((\ t. sol t vid1) has_derivative (\xa. xa * sterm_sem I (f1 fid1 vid1) (sol s))) (at s within {0..t})" subgoal for s using sol_proj_deriv[of s vid1] by auto done have sol_proj_deriv_other:"\s i. s \ {0..t} \ i \ vid1 \ ((\ t. sol t i) has_derivative (\xa. 0)) (at s within {0..t})" subgoal for s i using sol_proj_deriv[of s i] by auto done have fact:"\x. x \{0..t} \ (ll_new.flow 0 r has_derivative (\xa. xa *\<^sub>R (ll_new.flow 0 r x * sterm_sem I (f1 fid2 vid1) (ll_old.flow 0 (sol 0) x) + sterm_sem I (f1 fid3 vid1) (ll_old.flow 0 (sol 0) x)))) (at x within {0 .. t})" using sol_new' apply simp apply(drule solves_odeD(1)) using tclosed unfolding has_vderiv_on_def has_vector_derivative_def by auto have new_sol_deriv:"\s. s \ {0..t} \ (ll_new.flow 0 r has_derivative (\xa. xa *\<^sub>R (ll_new.flow 0 r s * sterm_sem I (f1 fid2 vid1) (sol s) + sterm_sem I (f1 fid3 vid1) (sol s)))) (at s within {0.. t})" subgoal for s using fact[of s] tclosed sol_eq_flow[of s] by auto done have sterm_agree:"\s. Vagree (\ i. if i = vid2 then ll_new.flow 0 r s else sol s i, undefined) (sol s, undefined) {Inl vid1}" subgoal for s unfolding Vagree_def using vne12 by auto done have FVF:"(FVT (f1 fid2 vid1)) = {Inl vid1}" unfolding f1_def expand_singleton apply auto subgoal for x xa by (cases "xa = vid1", auto) done have FVF2:"(FVT (f1 fid3 vid1)) = {Inl vid1}" unfolding f1_def expand_singleton apply auto subgoal for x xa by (cases "xa = vid1", auto) done have sterm_agree_FVF:"\s. Vagree (\ i. if i = vid2 then ll_new.flow 0 r s else sol s i, undefined) (sol s, undefined) (FVT (f1 fid2 vid1))" using sterm_agree FVF by auto have sterm_agree_FVF2:"\s. Vagree (\ i. if i = vid2 then ll_new.flow 0 r s else sol s i, undefined) (sol s, undefined) (FVT (f1 fid3 vid1))" using sterm_agree FVF2 by auto have y_component_sem_eq2:"\s. sterm_sem I (f1 fid2 vid1) (\ i. if i = vid2 then ll_new.flow 0 r s else sol s i) = sterm_sem I (f1 fid2 vid1) (sol s)" using coincidence_sterm[OF sterm_agree_FVF, of I] by auto have y_component_sem_eq3:"\s. sterm_sem I (f1 fid3 vid1) (\ i. if i = vid2 then ll_new.flow 0 r s else sol s i) = sterm_sem I (f1 fid3 vid1) (sol s)" using coincidence_sterm[OF sterm_agree_FVF2, of I] by auto have y_component_ode_eq:"\s. s \ {0..t} \ (\xa. xa * (ll_new.flow 0 r s * sterm_sem I (f1 fid2 vid1) (sol s) + sterm_sem I (f1 fid3 vid1) (sol s))) = (\xa. xa * (sterm_sem I (f1 fid2 vid1) (\ i. if i = vid2 then ll_new.flow 0 r s else sol s i) * ll_new.flow 0 r s + sterm_sem I (f1 fid3 vid1) (\ i. if i = vid2 then ll_new.flow 0 r s else sol s i)))" subgoal for s apply(rule ext) subgoal for xa using y_component_sem_eq2 y_component_sem_eq3 by auto done done have agree_vid1:"\s. Vagree (sol s, undefined) (\ i. if i = vid2 then ll_new.flow 0 r s else sol s i, undefined) {Inl vid1}" unfolding Vagree_def using vne12 by auto have FVT_vid1:"FVT(f1 fid1 vid1) = {Inl vid1}" apply(auto simp add: f1_def) subgoal for x xa apply(cases "xa = vid1") by auto done have agree_vid1_FVT:"\s. Vagree (sol s, undefined) (\ i. if i = vid2 then ll_new.flow 0 r s else sol s i, undefined) (FVT (f1 fid1 vid1))" using FVT_vid1 agree_vid1 by auto have sterm_eq_vid1:"\s. sterm_sem I (f1 fid1 vid1) (sol s) = sterm_sem I (f1 fid1 vid1) (\ i. if i = vid2 then ll_new.flow 0 r s else sol s i)" subgoal for s using coincidence_sterm[OF agree_vid1_FVT[of s], of I] by auto done have vid1_deriv_eq:"\s. (\xa. xa * sterm_sem I (f1 fid1 vid1) (sol s)) = (\xa. xa * sterm_sem I (f1 fid1 vid1) (\ i. if i = vid2 then ll_new.flow 0 r s else sol s i))" subgoal for s apply(rule ext) subgoal for x' using sterm_eq_vid1[of s] by auto done done have inner_deriv:"\s. s \ {0..t} \ ((\t. \ i. if i = vid2 then ll_new.flow 0 r t else sol t i) has_derivative (\xa. (\ i. xa * (if i = vid1 then sterm_sem I (f1 fid1 vid1) (\ i. if i = vid2 then ll_new.flow 0 r s else sol s i) else if i = vid2 then sterm_sem I (Plus (Times (f1 fid2 vid1) (trm.Var vid2)) (f1 fid3 vid1)) (\ i. if i = vid2 then ll_new.flow 0 r s else sol s i) else 0)))) (at s within {0..t})" subgoal for s apply(rule has_derivative_vec) subgoal for i apply(cases "i = vid2") subgoal using vne12 using new_sol_deriv[of s] using y_component_ode_eq by auto subgoal apply(cases "i = vid1") using sol_proj_deriv_vid1[of s] vid1_deriv_eq[of s] sol_proj_deriv_other[of s i] by auto done done done have deriv_eta:"\s. (\xa. xa *\<^sub>R ((\ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) (\ i. if i = vid2 then ll_new.flow 0 r s else sol s i) else 0) + (\ i. if i = vid2 then sterm_sem I (Plus (Times (f1 fid2 vid1) (trm.Var vid2)) (f1 fid3 vid1)) (\ i. if i = vid2 then ll_new.flow 0 r s else sol s i) else 0))) = (\xa. (\ i. xa * (if i = vid1 then sterm_sem I (f1 fid1 vid1) (\ i. if i = vid2 then ll_new.flow 0 r s else sol s i) else if i = vid2 then sterm_sem I (Plus (Times (f1 fid2 vid1) (trm.Var vid2)) (f1 fid3 vid1)) (\ i. if i = vid2 then ll_new.flow 0 r s else sol s i) else 0))) " subgoal for s apply(rule ext) apply(rule vec_extensionality) using vne12 by auto done have sol'_deriv:"\s. s \ {0..t} \ ((\t. \ i. if i = vid2 then ll_new.flow 0 r t else sol t i) has_derivative (\xa. xa *\<^sub>R ((\ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) (\ i. if i = vid2 then ll_new.flow 0 r s else sol s i) else 0) + (\ i. if i = vid2 then sterm_sem I (Plus (Times (f1 fid2 vid1) (trm.Var vid2)) (f1 fid3 vid1)) (\ i. if i = vid2 then ll_new.flow 0 r s else sol s i) else 0)))) (at s within {0..t})" subgoal for s using inner_deriv[of s] deriv_eta[of s] by auto done have FVT:"\i. FVT (if i = vid1 then trm.Var vid1 else Const 0) \ {Inl vid1}" by auto have agree:"\s. Vagree (mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) (sol s)) (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) (\ y. if vid2 = y then r else fst (a, b) y, b) (\ i. if i = vid2 then ll_new.flow 0 r s else sol s i)) {Inl vid1}" subgoal for s using mk_v_agree [of "I" "(OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))" "(a, b)" "(sol s)"] using mk_v_agree [of I "(OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0)))))" "(\ y. if vid2 = y then r else fst (a, b) y, b)" "(\ i. if i = vid2 then ll_new.flow 0 r s else sol s i)"] unfolding Vagree_def using vne12 by simp done have agree':"\s i. Vagree (mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) (sol s)) (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) (\ y. if vid2 = y then r else fst (a, b) y, b) (\ i. if i = vid2 then ll_new.flow 0 r s else sol s i)) (FVT (if i = vid1 then trm.Var vid1 else Const 0))" subgoal for s i using agree_sub[OF FVT[of i] agree[of s]] by auto done have safe:"\i. dsafe (if i = vid1 then trm.Var vid1 else Const 0)" subgoal for i apply(cases "i = vid1", auto) done done have dterm_sem_eq:"\s i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) (sol s)) = dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) (\ y. if vid2 = y then r else fst (a, b) y, b) (\ i. if i = vid2 then ll_new.flow 0 r s else sol s i))" subgoal for s i using coincidence_dterm[OF safe[of i] agree'[of s i], of I] by auto done have dterm_vec_eq:"\s. (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) (sol s))) = (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) (\ y. if vid2 = y then r else fst (a, b) y, b) (\ i. if i = vid2 then ll_new.flow 0 r s else sol s i)))" subgoal for s apply(rule vec_extensionality) subgoal for i using dterm_sem_eq[of i s] by auto done done have pred_same:"\s. s \ {0..t} \ Predicates I vid1 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) (sol s))) \ Predicates I vid1 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) (\ y. if vid2 = y then r else fst (a, b) y, b) (\ i. if i = vid2 then ll_new.flow 0 r s else sol s i)))" subgoal for s using dterm_vec_eq[of s] by auto done have sol'_domain:"\s. 0 \ s \ s \ t \ Predicates I vid1 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) (\ y. if vid2 = y then r else fst (a, b) y, b) (\ i. if i = vid2 then ll_new.flow 0 r s else sol s i)))" subgoal for s using sol apply simp apply(drule solves_odeD(2)) using pred_same[of s] by auto done have sol':"(?sol' solves_ode (\a b. (\ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) b else 0) + (\ i. if i = vid2 then sterm_sem I (Plus (Times (f1 fid2 vid1) (trm.Var vid2)) (f1 fid3 vid1)) b else 0))) {0..t} {x. Predicates I vid1 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) (\ y. if vid2 = y then r else fst (a, b) y, b) x))}" apply(rule solves_odeI) subgoal unfolding has_vderiv_on_def has_vector_derivative_def using sol'_deriv by auto by(auto, rule sol'_domain, auto) have set_eq:"{y. y = vid2 \ y = vid1 \ y = vid2 \ y = vid1 \ (\x. Inl y \ FVT (if x = vid1 then trm.Var vid1 else Const 0))} = {vid1, vid2}" by auto have "VSagree (?sol' 0) (\ y. if vid2 = y then r else fst (a, b) y) {vid1, vid2}" using VSA unfolding VSagree_def by simp then have VSA':" VSagree (?sol' 0) (\ y. if vid2 = y then r else fst (a, b) y) {y. y = vid2 \ y = vid1 \ y = vid2 \ y = vid1 \ (\x. Inl y \ FVT (if x = vid1 then trm.Var vid1 else Const 0))} " by (auto simp add: set_eq) have bigPre:"(\sol t. (fst ?aaba', snd ?aaba') = mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) ((\ y. if vid2 = y then r else fst (a,b) y), b) (sol t) \ 0 \ t \ (sol solves_ode (\a b. (\ i. if i = vid1 then sterm_sem I (f1 fid1 vid1) b else 0) + (\ i. if i = vid2 then sterm_sem I (Plus (Times (f1 fid2 vid1) (trm.Var vid2)) (f1 fid3 vid1)) b else 0))) {0..t} {x. Predicates I vid1 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0))))) ((\ y. if vid2 = y then r else (fst (a,b)) y), b) x))} \ VSagree (sol 0) (\ y. if vid2 = y then r else fst (a,b) y) {uu. uu = vid2 \ uu = vid1 \ uu = vid2 \ uu = vid1 \ Inl uu \ Inl  ({x. \xa. Inl x \ FVT (if xa = vid1 then trm.Var vid1 else Const 0)} \ {x. x = vid2 \ (\xa. Inl x \ FVT (if xa = vid1 then trm.Var vid1 else Const 0))}) \ (\x. Inl uu \ FVT (if x = vid1 then trm.Var vid1 else Const 0))})" apply(rule exI[where x="?sol'"]) apply(rule exI[where x=t]) apply(rule conjI) subgoal by simp apply(rule conjI) subgoal by (rule t) apply(rule conjI) apply(rule sol') using VSA' unfolding VSagree_def by auto have pred_sem:"Predicates I vid2 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) ?aaba')" using mp[OF bigEx bigPre] by auto let ?other_state = "(mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) (sol t))" have agree:"Vagree (?aaba') (?other_state) {Inl vid1} " using mk_v_agree [of "I" "(OProd (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (OSing vid2 (Plus (Times (f fid2 (\i. if i = vid1 then trm.Var vid1 else Const 0)) (trm.Var vid2)) (f fid3 (\i. if i = vid1 then trm.Var vid1 else Const 0)))))" "(\ y. if vid2 = y then r else fst (a, b) y, b)" "(?sol' t)"] using mk_v_agree [of "I" "(OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0)))" "(a, b)" "(sol t)"] unfolding Vagree_def using vne12 by simp have sub:"\i. FVT (if i = vid1 then trm.Var vid1 else Const 0) \ {Inl vid1}" by auto have agree':"\i. Vagree (?aaba') (?other_state) (FVT (if i = vid1 then trm.Var vid1 else Const 0)) " subgoal for i using agree_sub[OF sub[of i] agree] by auto done have silly_safe:"\i. dsafe (if i = vid1 then trm.Var vid1 else Const 0)" subgoal for i apply(cases "i = vid1") by (auto simp add: dsafe_Var dsafe_Const) done have dsem_eq:"(\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) ?aaba') = (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) ?other_state)" apply(rule vec_extensionality) subgoal for i using coincidence_dterm[OF silly_safe[of i] agree'[of i], of I] by auto done show "Predicates I vid2 (\ i. dterm_sem I (if i = vid1 then trm.Var vid1 else Const 0) (mk_v I (OSing vid1 (f fid1 (\i. if i = vid1 then trm.Var vid1 else Const 0))) (a, b) (sol t)))" using pred_sem dsem_eq by auto qed done qed 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,3044 +1,3044 @@ section"Example: Lorenz attractor" theory Lorenz_Approximation imports "HOL-ODE-Numerics.ODE_Numerics" Result_File_Coarse begin text \\label{sec:lorenz}\ text \TODO: move to isabelle? \ lifting_update blinfun.lifting lifting_forget blinfun.lifting lemma eventually_uniformly_on: "(\\<^sub>F x in uniformly_on T l. P x) = (\e>0. \f. (\x\T. dist (f x) (l x) < e) \ 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 *: "(\e\E. {f. \t\T. dist (f t) (l t) < e}) = {f. \t\T. dist (f t) (l t) < Min E}" using 1 apply (auto simp: ) 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 "\f. (\x\T. dist (f x) (l x) < Min E) \ P f" unfolding * by simp then show ?case using 1(4)[rule_format, OF \0 < Min E$ 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]: "(\x. x, op_cast_image::'a::executable_euclidean_space set \ 'b::executable_euclidean_space set) \ aform.appr_rel \ 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 \\<^sub>L 'a) = (blinfun_of_list xs::'b\\<^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]: "(\x. x, op_cast_eucl1_image::'a::executable_euclidean_space c1_info set \ 'b::executable_euclidean_space c1_info set) \ aform.appr1_rel \ 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) \ i = 0 \ i = 1 \ i = 2" by arith definition mat3_of_vec::"R3 \ 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 \This should prove that the expansion estimates are sufficient.\ 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 \following \vector_field.h\ / \vector_field.cc\\ abbreviation "S \ 10::real" abbreviation "B \ 8/3::real" abbreviation "TEMP \ sqrt((S + 1) * (S + 1) + 4 * S * (28 - 1))" abbreviation "K1 \ S / TEMP" abbreviation "K2 \ (S - 1 + TEMP) / (2 * S)" abbreviation "K3 \ (S - 1 - TEMP) / (2 * S)" abbreviation "E1 \ (- (S + 1) + TEMP) / 2" abbreviation "E2 \ (- (S + 1) - TEMP) / 2" abbreviation "E3 \ - B" abbreviation "C1 \ \X. X ! 0 + X ! 1" abbreviation "C2 \ \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 "\(X0, X1, X2). (E1 * X0 - K1 * (X0 + X1) * X2, E2 * X1 + K1 * (X0 + X1) * X2, E3 * X2 + (X0 + X1) * (K2 * X0 + K3 * X1))::real*real*real" "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 ((fst o the) ((approx p (Norm (map (Num o float_of o (mig_aform p)) x))) []))" +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 (\i. the (snd x) ! i) (map (\i. i * N + j) [0..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 = (\a b. let (s1, n) = ((-6), False); _ = print_fun (String.implode (''# gen(''@ show a@''): ''@ shows_aforms_hr (b) '''' @ ''\'')); _ = print_fun (String.implode (''# box(''@ show a@''): ''@ shows_box_of_aforms_hr (b) '''' @ ''\'')); ((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]) \ ((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)'''') ''\'')); _ = 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)'''') ''\'')); _ = 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)'''') ''\'')); 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))) '''') ''\'')) in if \ a \ 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 (\i. b ! i) [3,6,9])) (mig_aforms 30 (map (\i. b ! i) [4,7,10]))) else 1)) \ \always length \2^s!\\ ''# 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 (\_ _. ()) (map_option print_lorenz_aform_std print_funo); tf = the_default (\_ _. ()) (map_option (\print_fun a b. let _ = print_fun (String.implode (''# '' @ a @ ''\'')) in case b of Some b \ (print_fun (String.implode (''# '' @ shows_box_of_aforms_hr (b) '''' @ ''\''))) | None \ ()) print_funo) in \ 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$$" definition lorenz_optns' where "lorenz_optns' pf m N rk2p a = lorenz_optns pf \ default_reduce := correct_girard 30 m N, rk2_param := rk2p, adaptive_atol := a, adaptive_rtol := a \" definition mirror_irects where "mirror_irects = map (\irect. case irect of [i, j, k] \ [if j < 0 then - i else i , abs j, k] | irect \ irect)" definition "print_irects irects = (let _ = map (\is. let _ = map (\j. let _ = print (String.implode (show j)) in print (STR '' '')) is in print (STR ''\'')) irects in ())" abbreviation "aforms_of_ivl \ \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 \ 'a \ 'a \\<^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) \\<^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) \ ((real^3)\\<^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 (\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 \ (R3 \\<^sub>L R3)) set) l u = do { let DX = (cast_eucl1  DX::3 eucl1 set); DXo \ aform.vec1rep DX; DX \ (case DXo of None \ do { let _ = aform.print_msg (''# approx_conefield_bounds failed DXo...''); SUCCEED } | Some DX \ 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) \ Id \ Id \ Id " by auto lemma [autoref_rules_raw]: "DIM_precond TYPE((real, 3) vec \ ((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) \ aform.appr1_rel" assumes [autoref_rules]: "(li, l) \ Id" assumes [autoref_rules]: "(ui, u) \ 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) \ \bool_rel\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) \ ereal_rel \ rnv_rel" "(\, \) \ ereal_rel" by auto end lemma interpret_form_true_form[simp]: "interpret_form true_form \ \_. 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] \ (0 < ux \ -90 < L \ L \ U \ U < 90 \ uz = 0 \ uy \ tan (rad_of U) * ux \ tan (rad_of L) * ux \ uy)" if "U \ float" "L \ float" "e \ float" "em \ 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) \ ((real^3)\\<^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) \ ((real^3)\\<^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 \ -90 < L \ L \ U \ U < 90 \ uz = 0 \ (uy / ux) \ {tan (rad_of L) .. tan (rad_of U)} )" if "L \ float" "U \ 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 \ SPEC (\b. b \ ($$x, dx) \ cast_eucl1  DX::3 eucl1 set. let u' = dx (eucl_of_list [1, 0, 0]) in vec_nth u' 1 / vec_nth u' 0 \ {tan (rad_of L) .. tan (rad_of U)} \ vec_nth u' 2 = 0 \ vec_nth u' 0 > 0 \ -90 < L \ L \ U \ U < 90) )" if "L \ float" "U \ 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 \ SPEC (\b. b \ (\(x, dx) \ DX::R3 c1_info set. let (u'1, u'2, u'3) = dx ((1, 0, 0)) in u'2 / u'1 \ {tan (rad_of l) .. tan (rad_of u)} \ u'3 = 0 \ u'1 > 0 \ -90 < l \ l \ u \ u < 90) )" if "l \ float" "u \ 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 \ those (map (\f. approx p f xs) fas); - Some (map (real_of_float o fst) res, map (real_of_float o snd) res) + 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)) \ 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 \ (result, None) | Some DX \ 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)) \ let \ \ASSERTING that \Y\ straddles zero\ (x0, y0, _) = case map (Inf_aform' p) X of [x,y,z] \ (x, y, z); (x1, y1, _) = case map (Sup_aform' p) X of [x,y,z] \ (x, y, z); splitting = x0 = 0 \ 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, \::ereal), (case DX of None \ (result, None) | Some DX \ 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) \ \No need for \Hull(0)\ because \y\ straddles zero\ 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) \ \No need for \Hull($$\ because scaling afterwards\ 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 = ($$x0, x1). aforms_of_ivls [x0, y0, z0] [x1, y1, z1]); coord = (\x0 n i. i * x0 * FloatR 1 (-int n)); us = map (coord x0 n) (rev [0..<(2^n)]) @ map (coord x1 n) [Suc 0..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) \ 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) \ 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) \ scaleR2_rep eX; let fX = fst  X; fentry \ op_image_fst_ivl (cube_enter::3 vec1 set); interrupt \ aform.op_subset (fX:::aform.appr_rel) fentry; (ol, ou) \ ivl_rep fentry; aform.CHECKs (ST ''asdf'') (0 < el \ ol \ 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 \b \ \interrupt then RETURN (op_empty_coll, mk_coll eX) else do { vX \ 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 \ u); let CX = mk_coll ({l .. u}:::aform.appr_rel); (C0::3 eucl1 set) \ scaleRe_ivl_coll_spec el eu (fst  cube_exitv \ UNIV); (C1::3 eucl1 set) \ scaleRe_ivl_coll_spec el eu (cube_exitv); case vX of None \ RETURN (CX, C0) | Some vX \ do { b \ 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) \ int_rel \ rnv_rel" "(ldec, ldec) \ Id \ rnv_rel" "(udec, udec) \ Id \ rnv_rel" by auto schematic_goal lorenz_interrupti: includes autoref_syntax assumes[autoref_rules]: "(bi, b) \ bool_rel" "(Xi, X::3 eucl1 set) \ aform.appr1e_rel" "(optnsi, optns) \ Id" shows "(nres_of ?r, lorenz_interrupt optns b X) \ \clw_rel aform.appr_rel \\<^sub>r clw_rel aform.appr1e_rel\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 = "\_ _ _ _ _ _ _ _. optnsi" and optnsb = "\_ _ _ _ _ _ _ _ _. optnsi" and optnsc = "\_ _ _ _ _ _ _ _ _ _ _. optnsi" and optnsd = "\_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _. optnsi" and optnse = "\_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _. optnsi" and optnsf = "\_ _ _ _ _ _ _ _ _. optnsi" and optns = "\_ _ _ _ _. optnsi" for optnsi] lemma lorenz_interrupti_refine[autoref_rules]: includes autoref_syntax shows "(\optnsi bi Xi. (lorenz_interrupti optnsi bi Xi), lorenz_interrupt) \ num_optns_rel \ bool_rel \ aform.appr1e_rel \ \clw_rel aform.appr_rel \\<^sub>r clw_rel aform.appr1e_rel\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} \ {-1/4 .. 1/4} \ {-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 \protect locale parameters\ 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: ) lemma poincare_map_cong[cong]: "auto_ll_on_open.poincare_map ode X = auto_ll_on_open.poincare_map ode X" by (auto simp: ) lemma eq_nth_iff_index: "distinct xs \ n < length xs \ i = xs ! n \ index xs i = n" using index_nth_id by fastforce lemma cast_in_BasisI: "(cast i::'a) \ Basis" if "(i::'c) \ 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) \ y \ x \ 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) \ cast y \ x \ 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 \ UNIV = scaleR2 d e (X - Y \ 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 \ UNIV) (scaleR2 d e Y)" if "flowsto (X0) T (CX \ 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 \::"(real*real*real) set" where "\ = {(-6, -6, 27) .. (6, 6, 27)}" definition \\<^sub>l\<^sub>e::"(real*real*real) set" where "\\<^sub>l\<^sub>e = {(x, y, z). z \ 27}" definition "results = symmetrize coarse_results" definition "results_at x = {res \ set results. x \ source_of_res res}" text \a part of the stable manifold (up to the (backward) first intersection with \\$$\ definition \::"(real*real*real) set" where "\ = {x. {0..} \ lorenz.existence_ivl0 x \ (\t>0. lorenz.flow0 x t \ \) \ (lorenz.flow0 x \ 0) at_top}" definition "\\<^sub>i intr = (if intr then \ else {})" definition "\\<^sub>i\<^sub>v intr = cast  (\\<^sub>i intr)" definition "sourcei_of_res res = source_of_res res - (\\<^sub>i (invoke_nf res))" definition "resultsi_at x = {res \ set results. x \ sourcei_of_res res}" definition "N = $$source_of_res  (set results))" definition "\ x = \(conefield_of_res  (results_at x))" definition "R = lorenz.poincare_map \" definition "DR x = frechet_derivative (lorenz.poincare_map$$ (at x within \\<^sub>l\<^sub>e)" definition "\ x = Min (expansion  results_at x)" definition "\\<^sub>p x = Min (preexpansion  results_at x)" abbreviation returns_to (infixl "returns'_to" 50) where "(x returns_to P) \ lorenz.returns_to P x" lemma closed_$intro, simp]: "closed \" by (auto simp: \_def) lemma \_stable: "lorenz.stable_on (- \) \" unfolding lorenz.stable_on_def proof (intro allI impI) fix t x0 assume outside: "\s\{0<..t}. lorenz.flow0 x0 s \ - \" assume assms: "lorenz.flow0 x0 t \ \" "t \ lorenz.existence_ivl0 x0" "0 < t" from assms have *: "{0..} \ lorenz.existence_ivl0 (lorenz.flow0 x0 t)" "(lorenz.flow0 (lorenz.flow0 x0 t) \ 0) at_top" by (auto simp: \_def) have nonneg_exivl: "s \ lorenz.existence_ivl0 x0" if "s \ 0" for s proof (cases "s \ t") case True then show ?thesis using \0 \ s\ 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 \ lorenz.existence_ivl0 x0" apply (rule lorenz.existence_ivl_trans) apply fact using * \u > 0\ by auto finally show ?thesis . qed show "x0 \ \" unfolding \_def proof (safe intro!: nonneg_exivl) have "\\<^sub>F s in at_top. (s::real) \ 0" using eventually_ge_at_top by blast then have "\\<^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 \ lorenz.existence_ivl0 x0" using nonneg_exivl[OF \0 \ s$ 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 "((\s. (lorenz.flow0 x0 (s + t))) \ 0) at_top" by (blast intro: * Lim_transform_eventually) then show "(lorenz.flow0 x0 \ 0) at_top" unfolding aform.tendsto_at_top_translate_iff . next fix s::real assume s: "0 < s" "lorenz.flow0 x0 s \ \" show False proof (cases "s \ t") case True then show ?thesis using outside s by (auto simp: \_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 "\ = 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 \0 < s\ by simp subgoal by simp done also from assms(1) \u > 0\ have "\ \ \" by (auto simp: \_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 \\<^sub>i_stable: "lorenz.stable_on (- \) (\\<^sub>i b)" using \_stable unfolding \\<^sub>i_def apply (cases b) subgoal by auto subgoal using lorenz.stable_on_empty by (auto simp: \\<^sub>i_def) done definition "\\<^sub>v = (cast  \)" definition "NF = lorenz.flowsto (cube_entry - \ \ UNIV) {0..} (large_cube \ UNIV) cube_exit" lemma NF0: "lorenz.flowsto ((fst  cube_entry - \) \ UNIV) {0..} (large_cube \ UNIV) (fst  cube_exit \ 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 "(\_. (), \\<^sub>i\<^sub>v) \ bool_rel \ ghost_rel" by (auto simp: ghost_rel_def) lemma lorenz_interrupt[le, refine_vcg]: "lorenz_interrupt optns b X \ SPEC ($$CX, R). lorenz.flowsto ((cast_eucl1  X::R3 c1_info set) - (\\<^sub>i b \ UNIV)) {0..} (cast  CX \ 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 \ fst  (cube_enter::3 vec1 set)" by auto with \(u, v) \ c\ obtain w where "((u, w)::3 vec1) \ cube_enter" by auto from _ this have "cast u \ (\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: \\<^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 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 "\ _") 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 \vec1_of_flow1 (u, v) \ cube_enter\ by auto from _ this have "(cast u, cast_bl v) \ (\x. (cast (fst (x::3 vec1)), cast_bl (snd (flow1_of_vec1 x))))  cube_enter" by (rule image_eqI) (auto simp: ) then show ?thesis using prems by blast qed subgoal by (auto simp: \\<^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) \ (-x, -y, z))" lemma lorenz_symI: "((\t. lorenz_S (f t)) has_vderiv_on lf') T" if "(f has_vderiv_on f') T" "\t. t \ T \ 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 \ lorenz.existence_ivl0 (lorenz_S X)" (is ?th1) "lorenz.flow0 (lorenz_S X) t = lorenz_S (lorenz.flow0 X t)" (is ?th2) if "t \ lorenz.existence_ivl0 X" proof - have 1: "((\t. lorenz_S (lorenz.flow0 X t)) solves_ode (\_ (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 \ {0--t}" "{0--t} \ UNIV" by auto from lorenz.maximal_existence_flow[OF 1 2] show ?th1 ?th2 by fast+ qed lemma \\<^sub>l\<^sub>e_impl[autoref_rules]: "(Sctn [0, 0, 1] 27, \\<^sub>l\<^sub>e) \ \lv_rel\below_rel" apply (auto simp: below_rel_def \\<^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]: "((), \\<^sub>v) \ ghost_rel" by (auto intro!: ghost_relI) no_notation vec_nth (infixl "" 90) and vec_lambda (binder "\" 10) abbreviation "guards_rel \ \clw_rel (\\lv_rel\ivl_rel, \lv_rel\plane_rel\inter_rel) \\<^sub>r aform.reach_optns_rel\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 \ (XSi, XS::'b::enum eucl1 set) \ clw_rel aform.appr1e_rel \ (sctni, sctn) \ \lv_rel\sctn_rel \ (ivli, ivl) \ \lv_rel\ivl_rel \ (Si, Sa) \ \lv_rel\halfspaces_rel \ (guardsi, guards) \ guards_rel \ (symstartd, symstart) \ aform.appr1e_rel \ \clw_rel aform.appr_rel \\<^sub>r clw_rel aform.appr1e_rel\dres_nres_rel \ ((), trap) \ ghost_rel \ (roi, roptn) \ aform.reach_optns_rel \ (odoi, odo) \ ode_ops_rel \ (optnsi, optns) \ num_optns_rel \ (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) \ \clw_rel aform.appr1e_rel\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 "(\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) \ 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) (\\<^sub>i\<^sub>v interrupt:::ghost_rel) ((below_halfspaces {Sctn (eucl_of_list [0, 0, 1]) 27}::(real^3) set):::\lv_rel\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 \\<^sub>i\<^sub>v ::: bool_rel \ ghost_rel)  (OP intr ::: bool_rel)) \ ghost_rel" by (auto simp: ghost_rel_def) schematic_goal lorenz_poincare_impl[autoref_rules]: includes autoref_syntax assumes [autoref_rules]: "(XSi, XS) \ clw_rel aform.appr1e_rel" "(intri, intr) \ bool_rel" "(guardsi, guards) \ guards_rel" "(roi, roptn) \ aform.reach_optns_rel" "(optnsi, optns) \ num_optns_rel" shows "(nres_of ?r, lorenz_poincare  optns  intr  guards  roptn  XS) \ \clw_rel aform.appr1e_rel\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_$transfer_rule]: "(rel_set lorenz.rel_ve) \\<^sub>v \" unfolding \\<^sub>v_def by (auto simp: lorenz.rel_ve_cast' intro!: rel_setI) lemma transfer_\\<^sub>l\<^sub>e[transfer_rule]: "(rel_set lorenz.rel_ve) (cast  \\<^sub>l\<^sub>e) \\<^sub>l\<^sub>e" by (auto simp: lorenz.rel_ve_cast' intro!: rel_setI) lemma transfer_\\<^sub>i[transfer_rule]: "(rel_fun (=) (rel_set lorenz.rel_ve)) \\<^sub>i\<^sub>v \\<^sub>i" unfolding \\<^sub>i\<^sub>v_def by (auto simp: lorenz.rel_ve_cast' intro!: rel_setI) lemma transfer_\[transfer_rule]: "(rel_set lorenz.rel_ve) (cast $$ \" 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 \ SPEC (\R. aform.poincare_mapsto lorenz.odo (cast  \) (XS - (\\<^sub>i\<^sub>v intr \ UNIV)) (cast  \\<^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 \ lorenz.v.existence_ivl0 x0" using lorenz.vex_ivl_eq by simp from 1 have f: "lorenz.v.flow0 x0 t \ \\<^sub>i\<^sub>v intr" using lorenz.vflow_eq[OF t] by simp from 1 have "lorenz.v.flow0 x0 s \ - cast  \" if "s\{0<..t}" for s proof - from that t have s: "s \ 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 \ aform.Csafe lorenz.odo - op_atLeastAtMost_ivl (eucl_of_list [- 6, - 6, 27]) (eucl_of_list [6, 6, 27]) \ 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 "\ \ - cast  \" 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 \_def plane_of_def eucl_of_list_inner_eq inner_lv_rel_def) finally show "lorenz.v.flow0 x0 s \ - cast  \" . qed show "x0 \ \\<^sub>i\<^sub>v intr" by (rule \\<^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} \ plane_of (Sctn (eucl_of_list [0, 0, - 1]) (- 27))) = cast  \" apply auto apply (auto simp: \_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  \\<^sub>l\<^sub>e)" apply (auto simp: \\<^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 \ 3 rvec set \ 3 eucl1 set nres" where "mat1_nres X v = do { Xv \ 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') \ aform.appr_rel \ 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) \ \Id\list_rel" by auto schematic_goal mat1_impl: includes autoref_syntax assumes [autoref_rules]: "(Xi, X) \ aform.appr_rel" "(vi, v) \ aform.appr_rel" shows "(nres_of ?r, mat1_nres  X  v) \ \aform.appr1_rel\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 \ SPEC (\M. X \ v \ (\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'': "$$fst ab, a')\R1; (snd ab, b')\R2\ \ (ab,(a', b'))\\R1,R2\prod_rel" by (auto simp: prod_rel_def) lemma strange_aux_lemma: "(b, b') \ A \ (b, snd (a'a, b')) \ 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 "(\x. x, (op_image_cast_eucl1e::('a::executable_euclidean_space c1_info set \ 'b::executable_euclidean_space c1_info set))) \ aform.appr1e_rel \ aform.appr1e_rel" (is ?th1) and "(\x. x, op_image_cast_eucl1e_coll::'a::executable_euclidean_space c1_info set \ 'b::executable_euclidean_space c1_info set) \ clw_rel aform.appr1e_rel \ 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: "(\x. x) = (map (\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 \ (if c1 then do { R \ mat1_nres (cast  X0) (cast  tangents); RETURN (R::3 eucl1 set) } else RETURN (cast  X0 \ UNIV)); XDX0 \ scaleRe_ivl_spec 1 1 (X0tanmat); let _ = aform.trace_set1e ''START'' (Some XDX0); let _ = aform.print_set1e False (XDX0); P \ 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 \ real \ real) = DIM((real, 3) vec)" by auto schematic_goal lorenz_poincare_tangents_impl: includes autoref_syntax assumes [autoref_rules]: "(optnsi, optns) \ Id" "(intrri, intr) \ bool_rel" "(guardsi, guards) \ guards_rel" "(roi, roptn) \ aform.reach_optns_rel" "(c1i, c1) \ bool_rel" "(X0i, X0) \ aform.appr_rel" "(tangentsi, tangents) \ aform.appr_rel" shows "(nres_of ?r, lorenz_poincare_tangents optns intr guards roptn c1 (X0::R3 set) tangents) \ \clw_rel aform.appr1e_rel\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 = "\_ _ _ _ _ _ _ _. optns" and optnsb = "\_ _ _ _ _ _ _ _ _. optns" and optnsi = "optns" and optnsc = "optns" and optns = "\_ _ _ _ _ _ _. optns" for optns optnsc] lemma lorenz_poincare_tangents_impl_refine[autoref_rules]: includes autoref_syntax shows "(\optnsi intrri guardsi roi c1i X0i tangentsi. nres_of (lorenz_poincare_tangents_impl optnsi intrri guardsi roi c1i X0i tangentsi), lorenz_poincare_tangents) \ num_optns_rel \ bool_rel \ guards_rel \ aform.reach_optns_rel \ bool_rel \ aform.appr_rel \ aform.appr_rel \ \clw_rel aform.appr1e_rel\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_\[intro, simp]: "closed (cast  \::3 rvec set)" by (auto simp: \_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 \ SPEC (\x. (if c1 then \tans. X0 \ tangents \ (\(x, y). (x, blinfun_apply y (1, 0, 0)))  tans \ lorenz.poincare_mapsto \ (tans - \\<^sub>i intr \ UNIV) (\\<^sub>l\<^sub>e) UNIV x else lorenz.poincare_mapsto \ ((X0 - \\<^sub>i intr) \ UNIV) (\\<^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 (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: ) done qed definition of_mat1_image::"R3 c1_info set \ R3 set nres" where [refine_vcg_def]: "of_mat1_image X = SPEC (\R. R = (\x. blinfun_apply (snd x) (1, 0, 0))  X)" lemma of_mat1_image_impl[autoref_rules]: "(\x. (case x of (_, Some xs) \ RETURN [xs ! 0, xs ! 3, xs ! 6] | (_, None) \ SUCCEED), of_mat1_image) \ aform.appr1_rel \ \aform.appr_rel\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: ) 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 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 (\_::unit. min_deg res \ float \ max_deg res \ float)" definition [simp]: "isinfloat x \ x \ float" lemma [code]: "isinfloat (real_of_float x) = True" by (auto) lemma floatdegs_impl[autoref_rules]: includes autoref_syntax shows "(\res. (if isinfloat (min_deg res) \ isinfloat (max_deg res) then RETURN () else SUCCEED), floatdegs) \ Id \ \unit_rel\nres_rel" by (auto simp: nres_rel_def floatdegs_def) definition "check_c1_entry optns em P (res0::result) (res::result) = do { uv_ret \ of_mat1_image P; nuv \ aform.mig_set 3 uv_ret; floatdegs res0; floatdegs res; let e' = em * ereal nuv; b1 \ approx_conefield_bounds P (min_deg res) (max_deg res); let b2 = e' \ preexpansion res; let b3 = e' \ 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 \ 0 \ b1 \ b2 \ b3) }" lemma [autoref_itype]: "shows_prec ::\<^sub>i i_nat \\<^sub>i A \\<^sub>i i_string \\<^sub>i i_string" by auto lemma [autoref_rules]: includes autoref_syntax shows "PREFER_id A \ (shows_list, shows_list) \ \A\list_rel \ string_rel \ string_rel" "(shows_prec, shows_prec) \ nat_rel \ string_rel \ string_rel \ string_rel" "(shows_prec, shows_prec) \ nat_rel \ ereal_rel \ string_rel \ string_rel" "(shows_prec, shows_prec::_\result \_) \ nat_rel \ Id \ string_rel \ string_rel" "(shows_space, shows_space) \ string_rel \ string_rel" by (auto simp: string_rel_def) lemma [autoref_rules]: includes autoref_syntax shows "(expansion, expansion) \ Id \ rnv_rel" "(preexpansion, preexpansion) \ Id \ rnv_rel" "(min_deg, min_deg) \ Id \ rnv_rel" "(max_deg, max_deg) \ Id \ rnv_rel" by auto interpretation autoref_op_pat_def aform.mig_set . lemma [autoref_rules_raw]: "DIM_precond TYPE(real \ real \ real) (OP 3 ::: nat_rel)" by simp schematic_goal check_c1_entry_impl: includes autoref_syntax assumes [autoref_rules]: "(optnsi, optns) \ Id" "(res0i, res0) \ Id" "(resi, res) \ Id" "(emi, em) \ ereal_rel" "(Pei, P) \ aform.appr1_rel" shows "(nres_of ?r, check_c1_entry optns em P res0 res) \ \bool_rel\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 = "\_ . optnsi" and optnsi="optnsi" and optnsc=optns and optnsa="\_ _ _ _ _. optnsi" and optnsb="\_ _ _ _ _ _ _ _ . optnsi" and optns="\_. 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 = (\(_, d)\P. case (d (1, 0, 0)) of (dx, dy, dz) \ dz = 0 \ dx > 0 \ -90 < min_deg res \ min_deg res \ max_deg res \ max_deg res < 90 \ ereal (preexpansion res) \ em * (norm (dx, dy, dz)) \ ereal (expansion res0) \ em * (norm (dx, dy, dz)) \ dy / dx \ {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 \ SPEC (\b. b \ 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 \options for the lorenz system\ definition aform_numeric_optns::"_ \ _ \ _ \ _ \ _ \ _ \ _ \ _ \ _ \ _ \ _ \ _ \ real aform numeric_options" where "aform_numeric_optns = numeric_options.fields" fun zbucket::"real \ real \ real \ real \ real \ real \ real \ ((real list \ real list) \ real list sctn) list" where "zbucket d (x0,x1) (y0, y1) (z0, z1) = [zsec' (x0 - d, x0 + d) (y0 - d, y1 + d) z0, \ \bottom\ xsec' x0 (y0 - d, y1 + d) (z0 - d, z1), \ \left\ xsec x1 (y0 - d, y1 + d) (z0 - d, z1), \ \right\ ysec' (x0 - d, x1 + d) y0 (z0 - d, z1), \ \backno\ ysec (x0 - d, x1 + d) y1 (z0 - d, z1)] \ \front\" subsubsection \Hybridizations\ 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) \ ro (w + 1) m n w w (-5))" definition "ro_split_weak' c1 w = (case reduce_weak_params c1 of (m, n) \ ro w m n w w (-5))" definition "ro_split_weak'' c1 w = (case reduce_weak_params c1 of (m, n) \ ro (w + 2) m n w w (-5))" definition "ro_split_weak4' c1 w = (case reduce_weak_params c1 of (m, n) \ ro (w + 4) m n w w (-5))" definition "ro_split_weak2 c1 w w2 = (case reduce_weak_params c1 of (m, n) \ ro (w + 1) m n w w2 (-5))" definition "ro_split_weak2' c1 w w2 = (case reduce_weak_params c1 of (m, n) \ ro (w) m n w w2 (-5))" definition "ro_split_hard c1 w0 w1 = (case reduce_hard_params c1 of (m, n) \ ro (w0 + 1) m n w0 w1 (-5))" definition "ro_split_hard'' c1 w0 w1 = (case reduce_hard_params c1 of (m, n) \ ro (w0 + 2) m n w0 w1 (-5))" definition "ro_split_not c1 w = (case reduce_weak_params c1 of (m, n) \ ro 0 m n w w (-5))" definition "ro_split_not2 c1 w w2 = (case reduce_weak_params c1 of (m, n) \ 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 \ nat) \ int \ (((real list \ real list) \ real list sctn) list \ real aform reach_options) list \ real aform reach_options" abbreviation "p1 \ ldec 0.1" definition mode_middle::"_ \ 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)), \ \To collect after interrupt\ ([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\bool\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 \ real \ 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) \ ro w m n (-6) (-6) (-5))" definition mode_outer::"bool\_\_\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 \ result \ _" where "lookup_mode c1 i = (if gridx0 i \ - 1024 then mode_outer c1 (-3) 16 else if gridx0 i \ - 120 then mode_outer c1 (-3) 14 else if gridx0 i \ 107 then mode_inner2 c1 (4) else if gridx0 i \ 169 then mode_inner3 c1 False else if gridx0 i \ 196 then mode_inner3 c1 True else if gridx0 i \ 201 then mode_middle c1 else if gridx0 i \ 235 then mode_inner3 c1 True else if gridx0 i \ 290 then mode_inner3 c1 False else if gridx0 i \ 450 then mode_inner2 c1 4 else mode_outer c1 (-3) 14)" definition mode_ro_spec::"bool \ result \ ((nat \ nat) \ int \ ((real, 3) vec set \ unit) list \ unit) nres" where [refine_vcg_def]: "mode_ro_spec c1 res = SPEC (\_. True)" lemma reach_options_rel_br: "reach_options_rel TYPE('ty) = br (\_. ()) (\_. True)" by (auto simp: reach_options_rel_def br_def) lemma mode_ro_spec_impl[autoref_rules]: includes autoref_syntax shows "(\b x. RETURN (lookup_mode b x), mode_ro_spec) \ bool_rel \ Id \ \(nat_rel \\<^sub>r nat_rel) \\<^sub>r int_rel \\<^sub>r guards_rel \\<^sub>r aform.reach_optns_rel\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) \ Id \ \rnv_rel\list_rel \\<^sub>r \rnv_rel\list_rel" by auto lemma [autoref_rules]: includes autoref_syntax shows "(Polygon.pairself, Polygon.pairself) \ (A \ C) \ (A \\<^sub>r A) \ (C \\<^sub>r C)" by (auto dest: fun_relD) lemma set_of_ivl_impl[autoref_rules]: includes autoref_syntax shows "(\x. x, set_of_ivl) \ (A \\<^sub>r A) \ \A\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 \ (\xs. take D xs @ replicate (D - length xs) 0, eucl_of_list::_\'a) \ rl_rel \ 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) \ Id \ \lv_rel\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 \ result \ 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 \ 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) \ nat_rel \ Id" by auto schematic_goal tangent_seg_of_res_impl: includes autoref_syntax assumes [autoref_rules]: "(resi, res) \ Id" "(optnsi, optns) \ num_optns_rel" shows "(nres_of ?r, tangent_seg_of_res optns res) \ \aform.appr_rel\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="\_ _ _. optnsi" for optns optnsi, autoref_higher_order_rule] lemma return_of_res_impl: includes autoref_syntax shows "(\results res. (get_results (inf_retx res) (inf_rety res) (sup_retx res) (sup_rety res) results), return_of_res) \ \Id\list_rel \ Id \ \Id\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') \ \Id \ unit_rel\option_rel \ nat_rel \ nat_rel \ rnv_rel \ rnv_rel \ num_optns_rel" by auto lemma [autoref_rules]: includes autoref_syntax shows "(results, results) \ \Id\list_rel" "(invoke_nf, invoke_nf) \ Id \ bool_rel" by auto definition "check_line_nres print_fun m0 n0 c1 res0 = do { let X0 = source_of_res res0; (X0l, X0u) \ ivl_rep X0; ((m::nat, n::nat), a::int, modes, ro) \ 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 \ tangent_seg_of_res optns res0; aform.CHECKs (ST ''check_line_nres le'') (X0l \ X0u); sp \ aform.subset_spec_plane X0 (Sctn (eucl_of_list [0, 0, 1]) 27); aform.CHECKs (ST ''check_line_nres le'') sp; ASSERT (X0l \ X0u); Pe \ lorenz_poincare_tangents optns interrupt modes ro c1 ({X0l .. X0u}) tangents; PeS \ sets_of_coll Pe; let RETs = (return_of_res results res0); let RET = \((mk_coll  (source_of_res  RETs:::\lvivl_rel\list_wset_rel):::\clw_rel lvivl_rel\list_wset_rel)); every \ WEAK_ALL\<^bsup>\Pe. \P em eM Rivls. em > 0 \ Pe = scaleR2 em eM P \ fst  P \ \Rivls \ (\Rivl \ Rivls. (\res\RETs. Rivl \ source_of_res res \ (c1 \ c1_entry_correct em P res0 res)))\<^esup> PeS (\Pe. do { let _ = aform.trace_set1e (ST ''# Return Element: '') (Some Pe); ((em, eM), P) \ scaleR2_rep Pe; aform.CHECKs (ST ''check_line_nres pos'') (0 < em); let R = (fst  P:::aform.appr_rel); (Ri, Rs) \ op_ivl_rep_of_set R; let Rivl = (op_atLeastAtMost_ivl Ri Rs); Rivls \ aform.split_along_ivls2 3 (mk_coll Rivl) RET; Rivlss \ sets_of_coll Rivls; WEAK_ALL\<^bsup>\Rivl. \res\RETs. Rivl \ source_of_res res \ (c1 \ c1_entry_correct em P res0 res)\<^esup> Rivlss (\Rivl. do { b \ WEAK_EX\<^bsup>\res. Rivl \ source_of_res res \ (c1 \ c1_entry_correct em P res0 res)\<^esup> RETs (\res. do { let src = (source_of_res res:::lvivl_rel); let subs = Rivl \ src; cones \ if \(c1 \ subs) then RETURN True else check_c1_entry optns em P res0 res; RETURN (subs \ 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 \ (Xi, X::'a set) \ \lv_rel\ivl_rel \ (sctni, sctn) \ \lv_rel\sctn_rel \ (optnsi, optns) \ num_optns_rel \ (nres_of (subset_spec_plane_impl_aform optnsi D Xi sctni), aform_subset_spec_plane optns X sctn) \ \bool_rel\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) \ \Id \ unit_rel\option_rel" "(c1i, c1) \ bool_rel" "(res0i, res0) \ Id" "(m0i, m0) \ \nat_rel\option_rel" "(n0i, n0) \ \nat_rel\option_rel" shows "(nres_of ?r, check_line_nres pf m0 n0 c1 res0) \ \bool_rel \\<^sub>r clw_rel aform.appr1e_rel \\<^sub>r clw_rel lvivl_rel\nres_rel" unfolding check_line_nres_def including art by autoref_monadic concrete_definition check_line_impl uses check_line_impl[where optns = "\_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ . lorenz_optns pfi" and optnsa = "\_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _. lorenz_optns pfi" and optnsb = "\_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _. lorenz_optns pfi" and optnsc = "\_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _. lorenz_optns pfi" and optnsd = "\_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _. lorenz_optns pfi" and optnse = "\_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _. lorenz_optns pfi" and optnsf = "\ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _. 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 \ SPEC (\(every, Pe, RET). \P. Pe = \P \ (if c1 then \tans. source_of_res res0 \ {tangent_of_deg (min_deg res0)--tangent_of_deg (max_deg res0)} \ (\(x, y). (x, blinfun_apply y (1, 0, 0)))  tans \ lorenz.poincare_mapsto \ (tans - \\<^sub>i (invoke_nf res0) \ UNIV) \\<^sub>l\<^sub>e UNIV (Pe) else lorenz.poincare_mapsto \ ((sourcei_of_res res0) \ UNIV) \\<^sub>l\<^sub>e UNIV (\P)) \ source_of_res res0 \ plane_of (Sctn (0, 0, 1) 27) \ (every \ (\x\P. \P em. em > 0 \ (\eM. x = scaleR2 em eM P) \ (\Rivls. fst  P \ \Rivls \ (\Rivl\Rivls. \res\return_of_res results res0. Rivl \ source_of_res res \ (c1 \ 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 \ 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 (\a _. print_fun (String.implode (shows_segments_of_aform 0 1 a c ''\''))) aforms ()" lemma print_sets_color_impl[autoref_rules]: includes autoref_syntax shows "(\print_fun c X. print_aforms print_fun c X, print_sets_color) \ (Id \ unit_rel) \ string_rel \ clw_rel aform.appr_rel \ unit_rel" by auto lemma print_lorenz_color_impl[autoref_rules]: includes autoref_syntax shows "(\print_fun cx cy cz ci cd1 cd2 P. fold (\(_, x) b. print_lorenz_aform print_fun cx cy cz ci cd1 cd2 False (fst x @ the_default [] (snd x)) ) P (), print_lorenz_color) \ (Id \ unit_rel) \ string_rel \ string_rel \ string_rel \ string_rel \ \\string_rel\list_rel, \\string_rel\list_rel, (\clw_rel aform.appr1e_rel, unit_rel\fun_rel)\fun_rel\fun_rel" by auto definition check_line_core where "check_line_core print_funo m0 n0 c1 i = do { let print_fun = the_default (\_. ()) print_funo; CHECK (\_. print_fun (STR ''Hey, out of bounds!'')) (i < length results); let res = ((results:::\Id\list_rel) ! (i:::nat_rel)); (r, P, B) \ check_line_nres print_funo m0 n0 c1 res; let _ = print_sets_color print_fun (ST ''0x007f00'') (aform.sets_of_ivls B); (_, Pu) \ 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 ''\'')))) else print_fun (String.implode ((show (ST ''# Failed to verify '') @ show i @ show (ST ''\'')) ))); RETURN r }" lemma [autoref_rules]: includes autoref_syntax shows "(shows_prec, shows_prec) \ nat_rel \ nat_rel \ string_rel \ string_rel" "(shows_prec, shows_prec) \ nat_rel \ string_rel \ string_rel \ string_rel" "(String.implode, String.implode) \ string_rel \ Id" by (auto simp: string_rel_def) schematic_goal check_line_core_impl: includes autoref_syntax assumes [autoref_rules]: "(pfi, pf) \ \Id \ unit_rel\option_rel" "(c1i, c1) \ bool_rel" "(ii, i) \ nat_rel" "(m0i, m0) \ \nat_rel\option_rel" "(n0i, n0) \ \nat_rel\option_rel" shows "(nres_of ?f, check_line_core pf m0 n0 c1 i) \ \bool_rel\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 \ conefield_of_res res" definition "correct_res res = ((\(x, dx) \ c1i_of_res res. x \ plane_of (Sctn (0, 0, 1) 27) \ dx \ plane_of (Sctn (0, 0, 1) 0) \ ((lorenz.returns_to \ x \ lorenz.return_time \ differentiable at x within \\<^sub>l\<^sub>e \ (\D. (lorenz.poincare_map \ has_derivative D) (at x within \\<^sub>l\<^sub>e) \ norm (D dx) \ expansion res * norm dx \ (\res2 \ return_of_res results res. (lorenz.poincare_map \ x, D dx) \ c1_of_res res2 \ norm (D dx) \ preexpansion res2 * norm dx))))))" lemma check_line_nres_c0_correct: "check_line_nres pf m0 n0 c1 res \ SPEC (\(every, Pe, RET). every \ (\x \ sourcei_of_res res. lorenz.poincare_map \ x \ \(source_of_res  return_of_res results res)))" if NF apply (rule check_line_nres[OF \NF\, 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) \ tans - \\<^sub>i (invoke_nf res) \ UNIV" "((c, d, e), tangent_of_deg (min_deg res)) = (\(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 \" "fst  (tans - \\<^sub>i (invoke_nf res) \ UNIV) \ \\<^sub>l\<^sub>e" "lorenz.return_time \ differentiable at (c, d, e) within \\<^sub>l\<^sub>e" "(lorenz.poincare_map \ has_derivative blinfun_apply D) (at (c, d, e) within \\<^sub>l\<^sub>e)" "x \ b" "(lorenz.poincare_map \ (c, d, e), D o\<^sub>L t) \ x" by auto with prems show ?thesis subgoal apply (auto dest!: bspec[OF _ \x \ b$) apply (auto simp: scaleR2_def image_def vimage_def) apply (auto simp: subset_iff) by fastforce \\slow\ 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\ \slow\ 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 \ {a -- b} \ norm c \ 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 \ SPEC (\(correct, Pe, RET). correct \ correct_res res)" if NF proof (rule check_line_nres[OF \NF\, 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 \ UNIV \ UNIV \ {0}" by (auto simp: in_segment tangent_of_deg_def) from P have *: "x \ plane_of (Sctn (0, 0, 1) 27)" if "x \ sourcei_of_res res" for x using that by (auto simp: that sourcei_of_res_def) from tans_plane P have **: "dx \ plane_of (Sctn (0, 0, 1) 0)" if "x \ sourcei_of_res res" "dx \ 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) \ ?tans" "c \ 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) \ ?tans" "c \ 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) \ 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 \" "fst  (tans - \\<^sub>i (invoke_nf res) \ UNIV) \ \\<^sub>l\<^sub>e" "lorenz.return_time \ differentiable at (x, y, z) within \\<^sub>l\<^sub>e" "(lorenz.poincare_map \ has_derivative blinfun_apply D) (at (x, y, z) within \\<^sub>l\<^sub>e)" "Re \ P" "(lorenz.poincare_map \ (x, y, z), D o\<^sub>L t) \ Re" by (auto simp: lorenz.poincare_mapsto_def dest!: bspec) from P(5)[rule_format, OF \Re \ P\] obtain R em eM Rivls where R: "Re = scaleR2 em eM R" "em > 0" "fst  R \ \Rivls" "\Rivl. Rivl\Rivls \ \resa\return_of_res results res. Rivl \ source_of_res resa \ c1_entry_correct em R res resa" by auto have "lorenz.poincare_map \ (x, y, z) \ fst  R" and s2: "(lorenz.poincare_map \ (x, y, z), D o\<^sub>L t) \ scaleR2 em eM R" using Re R by (auto simp: scaleR2_def) then obtain Rivl res' where Rivl: "lorenz.poincare_map \ (x, y, z) \ Rivl" "Rivl \ Rivls" "res' \ return_of_res results res" "Rivl \ 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 \ ereal ed" "ereal ed \ eM" "D o\<^sub>L t = ed *\<^sub>R Dt" "(lorenz.poincare_map \ (x, y, z), Dt) \ R" by (force simp: scaleR2_def) then have Dt_simp[simp]: "Dt = inverse ed *\<^sub>R (D o\<^sub>L t)" using \0 < em\ 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') \ em * ereal (norm (dxr, dyr, 0::real))" "ereal (expansion res) \ em * ereal (norm (dxr, dyr, 0::real))" "-90 < min_deg res'" "min_deg res' \ max_deg res'" "tan (rad_of (min_deg res')) \ (dyr / dxr)" "(dyr / dxr) \ 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 \ ed" "(preexpansion res') \ emr * (norm (dxr, dyr, 0::real))" "(expansion res) \ emr * (norm (dxr, dyr, 0::real))" using \0 < em\ 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 \0 < em\ Dt by (cases em) (auto simp: simp: blinfun.bilinear_simps divide_simps prod_eq_iff) note \(x, y, z) returns_to \\ moreover note \lorenz.return_time \ differentiable at (x, y, z) within \\<^sub>l\<^sub>e\ moreover note \(lorenz.poincare_map \ has_derivative D) (at (x, y, z) within \\<^sub>l\<^sub>e)\ moreover note \res' \ return_of_res results res\ moreover have "lorenz.poincare_map \ (x, y, z) \ source_of_res res'" using Rivl by force moreover have \0 \ ed\ using Dt \0 < em\ by (cases em) auto have \D (dx, dy, dz) \ conefield_of_res res'\ unfolding c blinfun.bilinear_simps conefield_of_res_def Ddx'dy' apply (intro mem_cone, simp_all add: \0 \ ed\ \0 \ c\ 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) * (\c\ * norm (dxr, dyr, 0::real)) \ \ed\ * (\c\ * norm (dxr, dyr, 0::real))" proof - from c(2)[THEN in_segment_norm_bound] have "norm (dx', dy', 0::real) \ 1" by auto also have "\ \ 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) \ 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) \ 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 \ {}" by (auto simp: conefield_def conesegment_def cone_hull_empty_iff[symmetric]) lemma in_return_of_resD: "res' \ return_of_res results res \ res' \ 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 \" "R x \ N" "(R has_derivative DR x) (at x within \\<^sub>l\<^sub>e)" "\c. c \ \ x \ DR x c \ \ (R x)" "\c. c \ \ x \ norm (DR x c) \ \ x * norm c" "\c. c \ \ x \ norm (DR x c) \ \\<^sub>p (R x) * norm c" if "x \ N - \" NF "\res. res \ set results \ correct_res res" proof - from \x \ N - \\ obtain res where res: "res \ set results" "x \ sourcei_of_res res" by (auto simp: N_def sourcei_of_res_def \\<^sub>i_def) then have ne: "c1i_of_res res \ {}" by (auto simp: c1i_of_res_def conefield_of_res_def) from res this obtain dx where dx: "(x, dx) \ c1i_of_res res" by (auto simp: c1i_of_res_def) from that(3)[OF \res \ set _\] 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 \" "lorenz.return_time \ differentiable at x within \\<^sub>l\<^sub>e" "(lorenz.poincare_map \ has_derivative D) (at x within \\<^sub>l\<^sub>e)" "expansion res * norm dx \ norm (D dx)" "res' \ return_of_res results res" "(lorenz.poincare_map \ x, D dx) \ c1_of_res res'" "preexpansion res' * norm dx \ norm (D dx)" by auto show "x returns_to \" by fact show "R x \ 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 \\<^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 \ \ x" then obtain res where res: "res \ set results" and dx: "(x, dx) \ c1_of_res res" by (auto simp: \_def results_at_def c1_of_res_def ) then have dx: "(x, dx) \ c1i_of_res res" using \x \ N - _\ by (auto simp: c1i_of_res_def sourcei_of_res_def c1_of_res_def \\<^sub>i_def) from res dx have ne: "c1i_of_res res \ {}" by (auto simp: c1_of_res_def conefield_of_res_def) from that(3)[OF \res \ set _\] 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 \" "x \ plane_of (Sctn (0, 0, 1) 27)" "lorenz.return_time \ differentiable at x within \\<^sub>l\<^sub>e" "(lorenz.poincare_map \ has_derivative D) (at x within \\<^sub>l\<^sub>e)" "expansion res * norm dx \ norm (D dx)" "res' \ return_of_res results res" "(lorenz.poincare_map \ x, D dx) \ c1_of_res res'" "preexpansion res' * norm dx \ 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 \x \ plane_of _\ apply safe subgoal for _ _ _ e by (auto simp: \\<^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' \ results_at (lorenz.poincare_map \ 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 \ results_at x" using res dx by (auto simp: c1i_of_res_def results_at_def sourcei_of_res_def) show "DR x dx \ \ (R x)" unfolding DRD \_def using res' by (auto simp: c1_of_res_def R_def) have "\ x * norm dx \ expansion res * norm dx" by (rule mult_right_mono) (auto simp: \_def) also have "\ \ norm (DR x dx)" unfolding DRD by fact finally show "\ x * norm dx \ norm (DR x dx)" . have "\\<^sub>p (R x) * norm dx \ preexpansion res' * norm dx" by (rule mult_right_mono) (auto simp: \\<^sub>p_def R_def) also have "\ \ norm (DR x dx)" unfolding DRD by fact finally show "\\<^sub>p (R x) * norm dx \ norm (DR x dx)" . qed lemma check_line_core_correct: "check_line_core pf m0 n0 True i \ SPEC (\correct. correct \ 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 \The symmetric reduction\ lemma source_of_res_mirror: "(x, y, z) \ source_of_res (mirror_result res) \ (-x, -y, z) \ 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) \ conefield_of_res (mirror_result res) \ (x, y, z) \ 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) \ c1_of_res (mirror_result res) \ ((-x, -y, z), dx, dy, dz) \ 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 \ (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) \ lorenz_S x returns_to P" apply (auto simp: lorenz.returns_to_def) subgoal premises prems for t proof - have " \\<^sub>F s in at_right 0. s < t" using tendsto_ident_at \0 < t\ by (rule order_tendstoD) then have " \\<^sub>F s in at_right 0. s \ lorenz.existence_ivl0 x" unfolding eventually_at_filter apply eventually_elim using \0 < t\ 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 \ 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  \ = \" apply (auto simp: \_def lorenz_S_def) apply (rule image_eqI) apply (rule lorenz_S_idem[symmetric]) apply (auto simp: \_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 \ _) 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 \ t1" " t1 \ lorenz.existence_ivl0 x" "lorenz.flow0 x t1 \ lorenz_S  P" "\t. 0 < t \ t < t0 \ lorenz.flow0 x t \ lorenz_S  P" by auto have [simp]: "lorenz.return_time (lorenz_S  P) x \ 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 \ 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 \ 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::_\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) \(at (lorenz_S x::R3) within P)"\ \TODO: generalize!\ 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) \ 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\_) F = bot \ F = bot" apply (auto simp: ) 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 \ bot \ 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  \\<^sub>l\<^sub>e = \\<^sub>l\<^sub>e" apply (auto simp: \\<^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 \\<^sub>l\<^sub>e = \\<^sub>l\<^sub>e" proof (rule closure_closed) have "\\<^sub>l\<^sub>e = {x. x \ (0, 0, 1) \ 27}" by (auto simp: \\<^sub>l\<^sub>e_def ) also have "closed \" by (rule closed_halfspace_component_le) finally show "closed \\<^sub>l\<^sub>e" . qed lemma closure_Sigma_le[simp]: "closure (\\<^sub>l\<^sub>e - {x}) = \\<^sub>l\<^sub>e" proof (cases "x \ \\<^sub>l\<^sub>e") case that: True have "closure \\<^sub>l\<^sub>e \ closure (insert x (\\<^sub>l\<^sub>e - {x}))" by (rule closure_mono) auto also have "\ = insert x (closure (\\<^sub>l\<^sub>e - {x}))" apply (subst closure_insert) by simp also have "x \ closure (\\<^sub>l\<^sub>e - {x})" apply (rule closed_sequentially[where f="\n. x - (0, 0, inverse (Suc n))"]) apply (rule closed_closure) subgoal apply (auto simp: ) apply (rule subsetD) apply (rule closure_subset) using that apply (auto simp: \\<^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 (\\<^sub>l\<^sub>e - {x})) \ closure (\\<^sub>l\<^sub>e - {x})" by auto finally have "closure \\<^sub>l\<^sub>e \ closure (\\<^sub>l\<^sub>e - {x})" . moreover have "closure (\\<^sub>l\<^sub>e - {x}) \ closure (\\<^sub>l\<^sub>e)" by (rule closure_mono) auto ultimately have "closure (\\<^sub>l\<^sub>e - {x}) = closure (\\<^sub>l\<^sub>e)" by simp also have "\ = \\<^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 \ has_derivative D) (at x within \\<^sub>l\<^sub>e)" and "lorenz.returns_to \ x" and "x \ \\<^sub>l\<^sub>e" shows "(lorenz.return_time \ has_derivative D o lorenz_S) (at (lorenz_S x) within \\<^sub>l\<^sub>e)" proof - have [simp]: "\trivial_limit (at x within \\<^sub>l\<^sub>e)" unfolding at_within_eq_bot_iff using assms by simp interpret bounded_linear "lorenz_S::R3\_" by (rule bl_lorenz_S) have "\\<^sub>F x in at x within \\<^sub>l\<^sub>e. (x::R3) returns_to \" by (blast intro: lorenz.eventually_returns_to_continuousI has_derivative_continuous assms) then have "\\<^sub>F y in at x within \\<^sub>l\<^sub>e. inverse (norm (y - x)) * (lorenz.return_time \ y - lorenz.return_time \ x - D (y - x)) = inverse (norm (lorenz_S y - lorenz_S x)) * (lorenz.return_time \ (lorenz_S y) - lorenz.return_time \ (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 \ differentiable at (lorenz_S x) within \\<^sub>l\<^sub>e" if "lorenz.return_time \ differentiable at x within \\<^sub>l\<^sub>e" "lorenz.returns_to \ x" "x \ \\<^sub>l\<^sub>e" proof - from that obtain D where "(lorenz.return_time \ has_derivative D) (at x within \\<^sub>l\<^sub>e)" by (auto simp: differentiable_def) then have "(lorenz.return_time \ has_derivative D o lorenz_S) (at (lorenz_S x) within \\<^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 \ has_derivative D) (at x within \\<^sub>l\<^sub>e)" "(lorenz.return_time \ has_derivative Dr) (at x within \\<^sub>l\<^sub>e)" "lorenz.returns_to \ x" "x \ \\<^sub>l\<^sub>e" shows "(lorenz.poincare_map \ has_derivative lorenz_S o D o lorenz_S) (at (lorenz_S x) within \\<^sub>l\<^sub>e)" proof - have [simp]: "\trivial_limit (at x within \\<^sub>l\<^sub>e)" unfolding at_within_eq_bot_iff using assms by simp interpret bounded_linear "lorenz_S::R3\_" by (rule bl_lorenz_S) have "\\<^sub>F x in at x within \\<^sub>l\<^sub>e. (x::R3) returns_to \" by (blast intro: lorenz.eventually_returns_to_continuousI has_derivative_continuous assms) then have "\\<^sub>F y in at x within \\<^sub>l\<^sub>e. (lorenz_S (lorenz.poincare_map \ y) - lorenz_S (lorenz.poincare_map \ x) - lorenz_S (D (y - x))) /\<^sub>R norm (y - x) = (lorenz.poincare_map \ (lorenz_S y) - lorenz.poincare_map \ (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 \ set results \ mirror_result x \ set results" by (auto simp: results_def symmetrize_def) lemma mirror_result_in: "mirror_result res2 \ return_of_res results (mirror_result res)" if "res2 \ return_of_res results res" proof - from that have "res2 \ set results" by (rule in_return_of_resD) from mirror_in_set[OF this] have "mirror_result res2 \ 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) \ source_of_res (mirror_result (r))" if "lorenz_S x \ 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: ) lemma lorenz_S_tendsto_0I: "(lorenz.flow0 (lorenz_S x) \ 0) at_top" if "{0..} \ lorenz.existence_ivl0 x" "(lorenz.flow0 x \ 0) at_top" proof (rule Lim_transform_eventually) have "\\<^sub>F s in at_top. (s::real) \ 0" using eventually_ge_at_top by blast then show "\\<^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 "((\s. lorenz_S (lorenz.flow0 x s)) \ 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) \ 0) at_top \ (lorenz.flow0 x \ 0) at_top" if "{0..} \ 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 \ y = x" for x y::"real*real*real" by (auto simp: lorenz_S_def split: prod.splits) lemma lorenz_S_\: "lorenz_S x \ \ \ x \ \" apply (auto simp: \_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) \ sourcei_of_res (mirror_result res) \ (-x, -y, z) \ sourcei_of_res res" using lorenz_S_$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 \\<^sub>i_def lorenz_S_def) lemma c1i_of_res_mirror: "((x, y, z), dx, dy, dz) \ c1i_of_res (mirror_result res) \ ((-x, -y, z), dx, dy, dz) \ 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) \ 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)) \ plane_of (Sctn (0, 0, 1) 27)" "(dx, dy, dz) \ plane_of (Sctn (0, 0, 1) 0)" by auto then have plane: "(x, y, z) \ plane_of (Sctn (0, 0, 1) 27)" "(dx, dy, dz) \ 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 \" "lorenz.return_time \ differentiable at (lorenz_S (x, y, z)) within \\<^sub>l\<^sub>e" "(lorenz.poincare_map \ has_derivative D) (at (lorenz_S (x, y, z)) within \\<^sub>l\<^sub>e)" "expansion res * norm (dx, dy, dz) \ norm (D (dx, dy, dz))" "res2 \ return_of_res results res" "(lorenz.poincare_map \ (lorenz_S (x, y, z)), D (dx, dy, dz)) \ c1_of_res res2" "preexpansion res2 * norm (dx, dy, dz) \ norm (D (dx, dy, dz))" by auto from plane have S_le: "lorenz_S (x, y, z) \ \\<^sub>l\<^sub>e" by (auto simp: \\<^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 \" using D(1) lorenz_S_returns_to by simp moreover have "lorenz.return_time \ differentiable at (x, y, z) within \\<^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 \ has_derivative Dr) (at (lorenz_S (x, y, z)) within \\<^sub>l\<^sub>e)" by (auto simp: differentiable_def) let ?D = "lorenz_S \ D \ lorenz_S" have "(lorenz.poincare_map \ has_derivative ?D) (at (x, y, z) within \\<^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) \ norm (?D (dx, dy, dz))" using D(4) apply (auto simp: ) unfolding lorenz_S_on_plane neg by simp moreover have \mirror_result res2 \ return_of_res results (mirror_result res)\ using D(5) by (rule mirror_result_in) moreover have "(lorenz.poincare_map \ (x, y, z), ?D (dx, dy, dz)) \ 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) \ norm (?D (dx, dy, dz))" using D(7) apply (auto simp: ) 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 \Code Generation\ definition [code_abbrev]: "my_divide_integer (i::integer) (j::integer) = i div j" code_printing constant my_divide_integer \ (SML) "IntInf.div/ (_,/ _)" subsection \Tuning code equations\ definition mult_twopow_int::"int \ int \ int" where "mult_twopow_int x n = x * (power_int 2 n)" definition div_twopow_int :: "int \ int \ int" where "div_twopow_int x n = x div (power_int 2 n)" context includes integer.lifting begin lift_definition mult_twopow_integer :: "integer \ integer \ integer" is mult_twopow_int . lift_definition div_twopow_integer :: "integer \ integer \ integer" is div_twopow_int . end lemma compute_float_round_down[code]: "float_round_down prec (Float m e) = (let d = bitlen \m\ - 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 \m\ - 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 \ e2 then (let k1 = Suc p - nat (bitlen \m1$$ in if bitlen \m2\ > 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 \Codegen\ definition "is_dRETURN_True x = (case x of dRETURN b \ b | _ \ False)" definition "file_output_option s f = (case s of None \ f None | Some s \ file_output (String.implode s) (\pf. f (Some pf)))" definition "check_line_lookup_out s m0 n0 c1 i = is_dRETURN_True (file_output_option s (\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])" \ \the hard ones first'', potentially useless due to nondeterministic \Parallel.map\\ definition "parallel_check filenameo m n c1 ns = Parallel.forall (\i. let _ = print (String.implode (''# Starting '' @ show i @ ''\'')); b = check_line_lookup_out (map_option (\f. f @ show i) filenameo) (Some m) (Some n) c1 i; _ = if b then print (String.implode (''# Success: '' @ show i @ ''\'')) else print (String.implode (''# Failed: '' @ show i @ ''\'')) in b ) ns" ML \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\nat" (* int / integer*) "numeral::num\int" "numeral::num\integer" "uminus::_\int" "uminus::_\integer" int_of_integer integer_of_int "0::int" "1::int" (* Pairs *) "Pair::_ \ _\ (real list \ real list)" "Pair::_\_$$real list \ real list) \ real list sctn" "Pair::_\_\((real list \ real list) \ real list sctn) list \ real aform reach_options" (* Option *) "None::nat option" "Some::_\nat option" "None::string option" "Some::_\string option" (* Lists *) "Nil::real list" "Cons::_\_\real list" "Nil::nat list" "Cons::_\_\nat list" "Nil::real aform list" "Cons::_\_\real aform list" "Nil::((real list \ real list) \ real list sctn) list" "Cons::_\_\((real list \ real list) \ real list sctn) list" "Nil::(((real list \ real list) \ real list sctn) list \ real aform reach_options)list" "Cons::_\_\(((real list \ real list) \ real list sctn) list \ real aform reach_options)list" (* String *) String.Char String.implode "Cons::char \ char list \ char list" "Nil::char list" (* float *) Float float_of_int float_of_nat (* real *) "numeral::num\real" "real_of_float" "(/)::real\real\real" "uminus::real\_" real_divl real_divr real_of_int (* section *) "Sctn::_\_\real list sctn" (* aform *) "aforms_of_ivls::_\_\real aform list" (* input *) coarse_results (* modes *) xsec xsec' ysec ysec' zsec zsec' zbucket lookup_mode ro ro_outer mode_outer (* unit *) "()" }\ lemma is_dRETURN_True_iff[simp]: "is_dRETURN_True x \ (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 \ NF \ 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 "\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 (\i. \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 \Automate generation of lemmas\ lemma length_coarse_results[simp]: "length coarse_results = 400" by (simp add: coarse_results_def) lemma correct_res_coarse_resultsI: "correct_res (results ! i) \ i < 400 \ 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 \map_option (using_master_directory_term @{context}) (SOME "a")\ ML \ 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 ([], [("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} \ method_setup parallel_check = \ 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)) \ lemma lorenz_bounds_lemma_asym: "\x \ N - \. x returns_to \" "R  (N -$$ \ N" "\x \ N - \. (R has_derivative DR x) (at x within \\<^sub>l\<^sub>e)" "\x \ N - \. DR x  \ x \ \ (R x)" "\x \ N - \. \c \ \ x. norm (DR x c) \ \ x * norm c" "\x \ N - \. \c \ \ x. norm (DR x c) \ \\<^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/Ex/Lorenz/Result_Elements.thy b/thys/Ordinary_Differential_Equations/Ex/Lorenz/Result_Elements.thy --- a/thys/Ordinary_Differential_Equations/Ex/Lorenz/Result_Elements.thy +++ b/thys/Ordinary_Differential_Equations/Ex/Lorenz/Result_Elements.thy @@ -1,154 +1,154 @@ theory Result_Elements imports "HOL-Analysis.Analysis" "HOL-ODE-Numerics.ODE_Numerics" "HOL-Library.Float" begin datatype result = Result (invoke_nf : bool) (min_deg : real) (max_deg : real) (expansion : real) (preexpansion : real) (gridx0 : int) (gridx1 : int) (gridy0 : int) (gridy1 : int) (inf_retx : int) (inf_rety : int) (sup_retx : int) (sup_rety : int) derive "show" result definition "get_results LX LY UX UY fgs = [fg \ fgs. LX \ gridx1 fg \ gridx0 fg \ UX \ LY \ gridy1 fg \ gridy0 fg \ UY]" primrec mirror_result where "mirror_result (Result nf u v e ep x0 x1 y0 y1 rx0 ry0 rx1 ry1) = Result nf u v e ep (-x1) (-x0) (-y1) (-y0) (-rx1) (-ry1) (-rx0) (-ry0)" definition "upper_result fg \ 5 * gridy1 fg \ 2 * gridx0 fg" definition "symmetrize upper_list = upper_list @ map mirror_result upper_list" definition "mirror_upper fg = (if upper_result fg then fg else mirror_result fg)" definition "tangent_of_deg deg = (cos (rad_of (deg)), sin (rad_of (deg)), 0::real)" definition "tangent_seg_of_res_spec res = SPEC (\r. closed_segment (tangent_of_deg (min_deg res)) (tangent_of_deg (max_deg res)) \ r)" definition "conefield_of_res res = conefield (tangent_of_deg (min_deg res)) (tangent_of_deg (max_deg res))" definition "ivl_of_resultrect x0 x1 y0 y1 = (let scale = FloatR 1 (-8) in ([scale * real_of_int (x0 - 1), scale * real_of_int (y0 - 1), 27], [scale * real_of_int (x1 + 1), scale * real_of_int (y1 + 1), 27]))" definition "ivl_of_res res = ivl_of_resultrect (gridx0 res) (gridx1 res) (gridy0 res) (gridy1 res)" definition "source_of_res res = (set_of_ivl (pairself eucl_of_list (ivl_of_res res))::(real*real*real) set)" definition "c1_of_res res = source_of_res res \ conefield_of_res res" definition "return_of_res results res = set (get_results (inf_retx res) (inf_rety res) (sup_retx res) (sup_rety res) results)" subsection \Validate (in a non-verified way) the expansion estimates (following expansion.cc)\ subsubsection \\Generate_F_0_List\\ definition "assert_option s x = (if x then Some () else (let _ = print (String.implode s) in None))" -definition "get_return_grids tlist upper fg = +definition "get_return_grids tlist uppr fg = (let ret = get_results (inf_retx fg) (inf_rety fg) (sup_retx fg) (sup_rety fg) tlist - in if upper then map mirror_upper ret else ret)" + in if uppr then map mirror_upper ret else ret)" definition "generate_f0_list total_list upper_list u_min u_max = (do { let f0_list = [fg\upper_list. u_min \ gridx0 fg \ gridx1 fg \ u_max]; let mme = Min (expansion  set f0_list); assert_option ''ERROR: mme > 1\'' (mme > 1); let rgs = get_return_grids total_list True (last f0_list); let fd = set rgs \ set f0_list; assert_option ''ERROR: fundamental domain\'' fd; Some (f0_list, mme) })" subsubsection \\Find_F_0_Inv_Sets\\ definition "find_f0_inv_sets f0_list = (let space_list = symmetrize f0_list; factors = map (\it. if it \ set (get_return_grids space_list True it) then ereal (max (expansion it) (preexpansion it)) else \) f0_list in real_of_ereal (Min (set factors)))" subsubsection \\Generate_F_1_List\\ abbreviation "println s \ print (String.implode (s @ ''\''))" definition "compute_image total_list source_list = (let r = (fold (\it res. (get_return_grids total_list False it @ res)) source_list []); rd = remdups r in rd)" definition "generate_f1_list total_list f0_list = (let f1_list = remdups (map mirror_upper (compute_image total_list f0_list)) in fold (\f0 f1_list. List.remove1 f0 f1_list) f0_list f1_list)" subsection \\Flow_Along\\ definition "flow_along i f1_it f0_list total_list = (let (_, _, all_good, its, min_acc_exp) = while ($$iterate_list, acc_exp, all_good, its, min_min_exp). iterate_list \ [] \ all_good) (\(iterate_list, acc_exp, _, its, min_acc_exp). let min_exp = Min (expansion  set iterate_list); acc_exp = truncate_down 30 (acc_exp * min_exp); image_list = compute_image total_list iterate_list; _ = println (''flow_along: '' @ show i @ '' -- '' @ show (gridx0 f1_it, gridx1 f1_it)); _ = println (''|image_list|: '' @ show (length image_list)); (mem_f0_list, iterate_list) = List.partition (\it. it \ set f0_list) image_list; _ = println (''|mem_f0_list|: '' @ show (length mem_f0_list)); _ = println (''acc_exp = '' @ show (acc_exp)); min_acc_exp = (if mem_f0_list \ [] then min min_acc_exp (ereal acc_exp) else min_acc_exp); res = (iterate_list, acc_exp, mem_f0_list \ [] \ acc_exp \ 2, Suc its, min_acc_exp) in res) ([f1_it], preexpansion f1_it, True, 0,$$ in (all_good, its, min_acc_exp))" subsubsection \\Iteration\\ definition "expansion_main upper_list = do { let total_list = symmetrize upper_list; (f0_list, exp_f0) \ generate_f0_list total_list upper_list (-128) (512); let exp_f0_inv = find_f0_inv_sets f0_list; assert_option ''ERROR: find_f0_inv_sets: '' (exp_f0_inv > ub_sqrt 30 2); let f1_list = generate_f1_list total_list f0_list; let f0_list = symmetrize f0_list; (_, max_its, min_acc_exp) \ fold (\f1_it i. do { (i, max_its, min_min_acc_exp) \ i; let _ = println ((shows ''Grid # '' o shows i o shows ''/'' o shows (length f1_list)) ''''); let (all_good, its, min_acc_exp) = flow_along i f1_it f0_list total_list; assert_option ''flow_along failed'' all_good; Some (Suc i, max max_its its, min min_min_acc_exp min_acc_exp) }) f1_list (Some (0, 0, \)); let _ = println (show ''EXPANSION_MAIN finished''); let _ = println ((shows ''smallest accumulated expansion for orbits returning to F: '' o shows (real_of_ereal min_acc_exp)) ''''); let _ = println ((shows ''the smallest expansion factor for orbits confined to F: '' o shows exp_f0_inv) ''''); let _ = println ((shows ''minimal expansion in F: '' o shows exp_f0) ''''); let _ = println ((shows ''longest number of iterates: '' o shows max_its) ''''); Some True }" end diff --git a/thys/Ordinary_Differential_Equations/Numerics/Abstract_Reachability_Analysis.thy b/thys/Ordinary_Differential_Equations/Numerics/Abstract_Reachability_Analysis.thy --- a/thys/Ordinary_Differential_Equations/Numerics/Abstract_Reachability_Analysis.thy +++ b/thys/Ordinary_Differential_Equations/Numerics/Abstract_Reachability_Analysis.thy @@ -1,1158 +1,1159 @@ theory Abstract_Reachability_Analysis imports Abstract_Rigorous_Numerics Affine_Arithmetic.Affine_Arithmetic "../Refinement/Refine_String" "../Refinement/Refine_Folds" Ordinary_Differential_Equations.Flow Runge_Kutta begin subsection \Misc\ lemma nth_concat_exists: "\k j. concat xs ! i = xs ! k ! j \ k < length xs \ j < length (xs ! k)" if "i < length (concat xs)" using that proof (induction xs arbitrary: i) case Nil then show ?case by auto next case (Cons xs xss) from Cons.prems consider "i < length xs" | "i \ length xs" "i < length xs + length (concat xss)" by (cases "i < length xs") auto then show ?case proof cases case 1 then show ?thesis by (force simp: nth_append intro: exI[where x=i] exI[where x=0]) next case 2 then have "i - length xs < length (concat xss)" by arith with Cons.IH[of "i - length xs"] obtain k j where "concat xss ! (i - length xs) = xss ! k ! j" "k < length xss" "j < length (xss ! k)" by auto then show ?thesis using 2 by (fastforce simp: nth_append nth_Cons split: nat.splits intro: exI[where x=j] exI[where x="k + 1"]) qed qed lemma nth_concatE: assumes "i < length (concat xs)" obtains k j where "concat xs ! i = xs ! k ! j" "k < length xs" "j < length (xs ! k)" apply atomize_elim using assms nth_concat_exists by blast lemma max_Var_floatariths_concat: "max_Var_floatariths (concat xs) \ k" if "\x. x \ set xs \ max_Var_floatariths x \ k" using that max_Var_floatarith_le_max_Var_floatariths_nthI by (fastforce simp: in_set_conv_nth intro!: max_Var_floatariths_leI elim!: nth_concatE) lemma max_Var_floatariths_list_update: "max_Var_floatariths (xs[xa := y]) \ k" if "max_Var_floatariths (xs) \ k" and "max_Var_floatarith y \ k" by (metis neq_le_trans linorder_le_cases list_update_beyond max_Var_floatariths_list_updateI that) lemma max_Var_floatarith_0[simp]: "max_Var_floatarith 0 = 0" and max_Var_floatarith_1[simp]: "max_Var_floatarith 1 = 0" by (auto simp: zero_floatarith_def one_floatarith_def) lemma list_set_rel_br: "\Id\list_set_rel = br set distinct" by (auto simp: list_set_rel_def) lemma br_list_relD: shows "(x, y) \ \br a i\list_set_rel \ y = a  set x \ list_all i x" apply (auto simp: list_set_rel_def br_def list_rel_def) subgoal premises prems for s t using prems by (induction arbitrary: y rule: list.rel_induct) auto subgoal premises prems for s t using prems by (induction arbitrary: y rule: list.rel_induct) auto subgoal premises prems for s using prems by (induction arbitrary: y rule: list.rel_induct) auto done lemma sctn_rel_br: "\br a I\sctn_rel = br (\x. case x of Sctn n p \ Sctn (a n) p) (\x. I (normal x))" apply (auto simp: sctn_rel_def br_def in_rel_def[abs_def] split: sctn.splits) subgoal for b x1 x2 by (cases b) auto subgoal for a b by (cases a; cases b) auto done lemma br_list_rel: "\br a I\list_rel = br (map a) (list_all I)" by (fastforce simp: list_rel_def br_def list_all2_iff Ball_def in_set_zip list_all_length intro!: nth_equalityI) lemma list_set_rel_brp: "\br a I\list_set_rel = br (\xs. a  set xs) (\xs. list_all I xs \ distinct (map a xs))" unfolding list_set_rel_def br_list_rel br_chain o_def o_def by (auto) declare INF_cong_simp [cong] SUP_cong_simp [cong] image_cong_simp [cong del] context auto_ll_on_open begin definition "stable_on CX trap \ (\t x0. flow0 x0 t \ trap \ t \ existence_ivl0 x0 \ t > 0 \ (\s\{0<..t}. flow0 x0 s \ CX) \ x0 \ trap)" lemma stable_onD: "\t x0. flow0 x0 t \ trap \ t \ existence_ivl0 x0 \ t > 0 \ (\s. 0 < s \ s \ t \ flow0 x0 s \ CX) \ x0 \ trap" if "stable_on CX trap" using that by (auto simp: stable_on_def) lemma nonneg_interval_mem_existence_ivlI[intro]:\ \TODO: move!\ "0 \ t1 \ t1 \ t2 \ t2 \ existence_ivl0 x0 \ {t1..t2} \ existence_ivl0 x0" "t1 \ t2 \ t2 \ 0 \ t1 \ existence_ivl0 x0 \ {t1..t2} \ existence_ivl0 x0" "t1 \ 0 \ 0 \ t2 \ t1 \ existence_ivl0 x0 \ t2 \ existence_ivl0 x0 \ {t1..t2} \ existence_ivl0 x0" apply auto apply (drule ivl_subset_existence_ivl) apply auto apply (drule ivl_subset_existence_ivl') apply auto apply (drule segment_subset_existence_ivl, assumption) apply (auto simp: closed_segment_eq_real_ivl) done lemma interval_subset_existence_ivl: "t \ existence_ivl0 x0 \ s \ existence_ivl0 x0 \ t \ s \ {t .. s} \ existence_ivl0 x0" using segment_subset_existence_ivl[of s x0 t] by (auto simp: closed_segment_eq_real_ivl) end lemma(in c1_on_open_euclidean) diff_existence_ivl_iff[simp]:\ \TODO: move!, also to @{term auto_ll_on_open}\ "t2 - t1 \ existence_ivl0 (flow0 x0 t1) \ t2 \ existence_ivl0 x0" if "t1 \ t2" "t1 \ existence_ivl0 x0" apply auto apply (drule existence_ivl_trans[OF that(2)]) apply (auto intro!: diff_existence_ivl_trans that) done lemma (in auto_ll_on_open) flow_trans': "flow0 (flow0 x0 t1) t2 = flow0 x0 (t1 + t2)" if "t1 \ existence_ivl0 x0" "t1 + t2 \ existence_ivl0 x0" apply (subst flow_trans) using that by (auto intro!: existence_ivl_trans') context auto_ll_on_open begin definition "flowpipe0 X0 hl hu CX X1 \ 0 \ hl \ hl \ hu \ X0 \ X \ CX \ X \ X1 \ X \ ($$x0) \ X0. \h \ {hl .. hu}. h \ existence_ivl0 x0 \ (flow0 x0 h) \ X1 \ (\h' \ {0 .. h}. (flow0 x0 h') \ CX))" lemma flowpipe0D: assumes "flowpipe0 X0 hl hu CX X1" shows flowpipe0_safeD: "X0 \ CX \ X1 \ X" and flowpipe0_nonneg: "0 \ hl" "hl \ hu" and flowpipe0_exivl: "hl \ h \ h \ hu \ (x0) \ X0 \ h \ existence_ivl0 x0" and flowpipe0_discrete: "hl \ h \ h \ hu \ (x0) \ X0 \ (flow0 x0 h) \ X1" and flowpipe0_cont: "hl \ h \ h \ hu \ (x0) \ X0 \ 0 \ h' \ h' \ h \ (flow0 x0 h') \ CX" using assms by (auto simp: flowpipe0_def) lemma flowpipe0_source_subset: "flowpipe0 X0 hl hu CX X1 \ X0 \ CX" apply (auto dest: bspec[where x=hl] bspec[where x=0] simp: flowpipe0_def) apply (drule bspec) apply (assumption) apply (drule bspec[where x=hl]) apply auto apply (drule bspec[where x=0]) by (auto simp: flow_initial_time_if) end subsection \Options\ definition [refine_vcg_def]: "precision_spec = SPEC (\prec::nat. True)" definition [refine_vcg_def]: "adaptive_atol_spec = SPEC (\x::real. True)" definition [refine_vcg_def]: "adaptive_rtol_spec = SPEC (\x::real. True)" definition [refine_vcg_def]: "method_spec = SPEC (\m::nat. True)" definition [refine_vcg_def]: "start_stepsize_spec = SPEC (\x::real. x > 0)" definition [refine_vcg_def]: "iterations_spec = SPEC (\n::nat. True)" definition [refine_vcg_def]: "halve_stepsizes_spec = SPEC (\n::nat. True)" definition [refine_vcg_def]: "widening_mod_spec = SPEC (\n::nat. True)" definition [refine_vcg_def]: "rk2_param_spec = SPEC (\r::real. 0 < r \ r \ 1)" typedef ode_ops = "{(ode_e::floatarith list, safe_form::form). open_form safe_form \ max_Var_floatariths ode_e \ length ode_e \ max_Var_form safe_form \ length ode_e}" \ \ode on open domain, welldefined\ by (auto intro!: exI[where x="[floatarith.Num 0]"] exI[where x="Less (floatarith.Num 0) (floatarith.Num 1)"]) setup_lifting type_definition_ode_ops lift_definition ode_expression::"ode_ops \ floatarith list" is fst . lift_definition safe_form_expr::"ode_ops \ form" is snd . \ \TODO: should better called it domain of definition of ODE, its main use is to exclude e.g. division by zero on the rhs.\ lemma open_form_ode_op[intro, simp]: "open_form (safe_form_expr odo)" and max_Var_ode_expression: "max_Var_floatariths (ode_expression odo) \ length (ode_expression odo)" and max_Var_form_safe_form_expr: "max_Var_form (safe_form_expr odo) \ length (ode_expression odo)" by (transfer, auto)+ lift_definition (code_dt) mk_ode_ops::"floatarith list \ form \ ode_ops option" is "\ode_e safe_form. if (open_form safe_form \ max_Var_floatariths ode_e \ length ode_e \ max_Var_form safe_form \ length ode_e) then Some (ode_e, safe_form) else None" by (auto simp:) lemma assumes "mk_ode_ops e s = Some odo" shows ode_expression_mk_ode_ops: "ode_expression odo = e" and safe_form_expr_mk_ode_ops: "safe_form_expr odo = s" using assms by (transfer, simp split: if_splits prod.splits)+ locale ode_operations = fixes ode_ops::ode_ops begin definition "ode_e = ode_expression ode_ops" definition "safe_form = safe_form_expr ode_ops" definition ode::"'a \ 'a::executable_euclidean_space" where "ode x = eucl_of_list (interpret_floatariths ode_e (list_of_eucl x))" definition "ode_d_expr_nth N n i = FDERIV_floatarith (FDERIV_n_floatarith (ode_e ! i) [0.. 'a \ 'a \ 'a \ 'a::executable_euclidean_space" where "ode_d_raw n x dn d = eucl_of_list (interpret_floatariths (ode_d_expr DIM('a) n) (list_of_eucl x @ list_of_eucl dn @ list_of_eucl d))" definition "ode_fa_nth xs i = subst_floatarith (\i. xs ! i) (ode_e ! i)" definition "ode_fa xs = map (subst_floatarith (\i. xs ! i)) ode_e" definition "ode_d_fa_nth n xs ds i = subst_floatarith (\i. (xs@ds@ds) ! i) (ode_d_expr_nth (length xs) n i)" definition "ode_d_fa n xs ds = map (subst_floatarith (\i. (xs@ds@ds) ! i)) (ode_d_expr (length xs) n)" definition safe::"'a::executable_euclidean_space \ bool" where "safe x \ length ode_e = DIM('a) \ max_Var_floatariths ode_e \ DIM('a) \ open_form safe_form \ max_Var_form safe_form \ DIM('a) \ interpret_form safe_form (list_of_eucl x) \ isFDERIV DIM('a) [0..e 2) / floatarith.Num 2) * ode_d_fa_nth 0 CX (ode_fa CX) i" definition "euler_err_fas X0 h CX = map (euler_err_fas_nth X0 h CX) [0..i. (euler_incr_fas_nth X0 h X0 i + euler_err_fas_nth X0 h CX i)) [0..e 3 / 6) * (ode_d_fa_nth 1 cx (ode_fa cx) i + ode_d_fa_nth 0 cx (ode_d_fa 0 cx (ode_fa cx)) i))) - ((h ^\<^sub>e 3 * rkp / 4) * ode_d_fa_nth 1 (euler_incr_fas x0 (s2 * h * rkp) x0) (ode_fa x0) i))" definition "rk2_fas_err rkp x0 h cx s2 = map (rk2_fas_err_nth rkp x0 h cx s2) [0..i. ((x0 ! i + h * ((1 - (1 / (rkp * 2))) * ode_fa_nth x0 i + (1 / (rkp * 2)) * ode_fa_nth (euler_incr_fas x0 (h * rkp) x0) i)) + rk2_fas_err_nth rkp x0 h cx s2 i)) [0.. ode_d_expr_nth N n i = ode_d_expr N n ! i " by (auto simp: ode_d_expr_nth_def ode_d_expr_def FDERIV_n_floatariths_nth) lemma length_ode_d_expr[simp]: "length (ode_d_expr f n) = length ode_e" by (induction n) (auto simp: ode_d_expr_def FDERIV_n_floatariths_def) lemma ode_fa_nth: "i < length ode_e \ ode_fa xs ! i = ode_fa_nth xs i" by (auto simp: ode_fa_nth_def ode_fa_def) lemma ode_d_fa_nth: "i < length ode_e \ ode_d_fa_nth n xs ds i = ode_d_fa n xs ds ! i" by (auto simp: ode_d_fa_def ode_d_fa_nth_def ode_d_expr_nth) lemma length_ode_d_fa[simp]: "length (ode_d_fa n xs ds) = length ode_e" by (auto simp: ode_d_fa_def FDERIV_n_floatariths_def) lemma length_rk2_fas_err[simp]: "length (rk2_fas_err rkp x0 h cx s2) = length x0" by (simp add: rk2_fas_err_def) lemma length_euler_incr_fas[simp]: "length (euler_incr_fas X0 h CX) = length X0" by (auto simp: euler_incr_fas_def) lemma length_euler_err_fas[simp]: "length (euler_err_fas X0 h CX) = length X0" by (auto simp: euler_err_fas_def) lemma length_euler_floatarith[simp]: "length (euler_fas X0 h CX) = 2 * length X0" by (auto simp: euler_fas_def) lemma length_rk2_fas[simp]: "length (rk2_fas rkp x0 h cx s2) = 2 * length x0" by (simp add: rk2_fas_def) lemma open_safe: "open Csafe" proof - have leq: "list_updates [0.. max_Var_floatariths ode_e \ DIM('a) \ max_Var_form safe_form \ DIM('a) \ open_form safe_form then {x. interpret_form safe_form (list_of_eucl x)} \ {x. isFDERIV DIM('a) [0.." apply (auto intro!: open_Int) subgoal premises prems using open_form[OF prems(4), where 'a='a, of "[0.. Csafe" shows "interpret_form safe_form (list_of_eucl x)" and safe_isFDERIV: "isFDERIV DIM('a) [0.. Csafe \ max_Var_floatariths ode_e \ DIM('a)" and safe_length: "x \ Csafe \ length ode_e = DIM('a)" and safe_max_Var_form: "x \ Csafe \ max_Var_form safe_form \ DIM('a)" by (auto simp: safe_def Csafe_def) lemma safe_isFDERIV_append: fixes x::"'a::executable_euclidean_space" shows "x \ Csafe \ isFDERIV DIM('a) [0.. Csafe" shows "(ode has_derivative ode_d_raw 0 x d) (at x)" using assms safe_max_Var[OF assms] safe_length[OF assms] unfolding ode_def ode_d_raw_def ode_d_expr_def apply (intro interpret_floatarith_FDERIV_floatariths[THEN has_derivative_eq_rhs]) apply (auto simp: isFDERIV_def FDERIV_n_floatariths_def safe_max_Var nth_append max_Var_floatariths_Max Csafe_def safe_def intro!: arg_cong[where f=eucl_of_list] ext interpret_floatariths_FDERIV_floatariths_cong freshs_floatariths_max_Var_floatarithsI max_Var_floatarith_le_max_Var_floatariths[le]) apply (rule interpret_floatariths_max_Var_cong) apply (auto simp: max_Var_floatariths_Max Max_gr_iff nth_append dest!: less_le_trans[OF _ max_Var_floatarith_DERIV_floatarith]) apply (drule max_Var_floatariths_lessI) apply simp apply (auto dest!: less_le_trans[OF _ safe_max_Var[OF assms]]) apply (drule max_Var_floatariths_lessI) apply simp apply (auto dest!: less_le_trans[OF _ safe_max_Var[OF assms]]) done lemma not_fresh_odeD: "x \ Csafe \ \fresh_floatariths ode_e i \ i < DIM('a)" for x::"'a::executable_euclidean_space" using fresh_floatariths_max_Var[of ode_e i] safe_max_Var[of x] by arith lemma safe_isnFDERIV: fixes x::"'a::executable_euclidean_space" assumes "x \ Csafe" shows "isnFDERIV DIM('a) ode_e [0.. Csafe" assumes [simp]: "length xs = DIM('a)" "length ds = DIM('a)" shows "isnFDERIV DIM('a) ode_e [0.. fa = floatarith.Num x" by (cases fa) auto lemma ode_d_raw_Suc: includes floatarith_notation assumes "x \ Csafe" shows "((\x. ode_d_raw n x d d) has_derivative ode_d_raw (Suc n) x d) (at x)" proof - let ?shift = "\x. floatarith.Var (if 2 * DIM('a) \ x \ x < 3 * DIM('a) then x - DIM('a) else x)" have subst_ode_e[simp]: "map (subst_floatarith ?shift) ode_e = ode_e" apply (auto intro!: nth_equalityI) apply (rule subst_floatarith_Var_max_Var_floatarith) by (auto dest!: max_Var_floatariths_lessI less_le_trans[OF _ safe_max_Var[OF assms]]) have map_shift[simp]: "(map ?shift [DIM('a)..<2 * DIM('a)]) = (map floatarith.Var [DIM('a)..<2 * DIM('a)])" "(map ?shift [2 * DIM('a)..<3 * DIM('a)]) = (map floatarith.Var [DIM('a)..<2 * DIM('a)])" by (auto intro!: nth_equalityI) show ?thesis unfolding ode_def ode_d_raw_def ode_d_expr_def apply (rule interpret_floatarith_FDERIV_floatariths_append[THEN has_derivative_eq_rhs]) subgoal proof - let ?shift = "\x. if 2 * DIM('a) \ x \ x < 3 * DIM('a) then x - DIM('a) else x" have mv: "max_Var_floatariths (FDERIV_floatariths (FDERIV_n_floatariths ode_e [0.. 3 * DIM('a)" and mv2: "max_Var_floatariths (FDERIV_floatariths (FDERIV_n_floatariths ode_e [0.. 2 * DIM('a)" by (auto intro!: max_Var_floatarith_FDERIV_floatariths[le] max_Var_floatarith_FDERIV_n_floatariths[le] safe_max_Var[OF assms, le]) have eq: "(map (subst_floatarith (\i. floatarith.Var (if 2 * DIM('a) \ i \ i < 3 * DIM('a) then i - DIM('a) else i))) ((FDERIV_floatariths (FDERIV_n_floatariths ode_e [0..i. interpret_floatarith (?shift i) (list_of_eucl x @ list_of_eucl d @ list_of_eucl d @ list_of_eucl h)) [0..<4 * DIM('a)])" by (auto intro!: nth_equalityI simp: nth_append) have mv_le: "max_Var_floatarith (DERIV_floatarith j (FDERIV_floatarith (FDERIV_n_floatariths ode_e [0.. 2 * DIM('a)" "max_Var_floatarith (DERIV_floatarith j (FDERIV_floatarith (FDERIV_n_floatariths ode_e [0.. 3 * DIM('a)" by (auto intro!: prems safe_max_Var[OF assms, le] max_Var_floatarith_le_max_Var_floatariths_nth[le] max_Var_floatarith_DERIV_floatarith[le] max_Var_floatarith_FDERIV_floatarith[le] max_Var_floatarith_FDERIV_n_floatariths[le]) show ?thesis apply (subst *) apply (subst interpret_floatarith_subst_floatarith[symmetric]) apply (auto intro!: prems mv_le[le]) apply (subst subst_floatarith_Var_DERIV_floatarith, use prems in force) apply (subst subst_floatarith_Var_FDERIV_floatarith[where 'a='a], force, force, force) apply (subst subst_floatarith_Var_FDERIV_n_nth[where 'a='a], force, force, force, use prems in force) apply (auto simp: o_def prems nth_append intro!: interpret_floatarith_max_Var_cong dest!: less_le_trans[OF _ mv_le(1)]) done qed done done qed lift_definition ode_d::"nat \ 'a::executable_euclidean_space \ 'a \ 'a \\<^sub>L 'a" is "\n x dn d. if x \ Csafe then ode_d_raw n x dn d else 0" subgoal for n x dn apply (cases n) subgoal by (cases "x \ Csafe") (auto intro: has_derivative_bounded_linear[OF ode_d_raw_0]) subgoal for n' apply (cases "x \ Csafe") subgoal apply (simp del: isnFDERIV.simps) apply (rule has_derivative_bounded_linear) apply (rule ode_d_raw_Suc) apply assumption done subgoal by (simp del: isnFDERIV.simps) done done done definition "ode_d1 x = ode_d 0 x 0" lemma ode_has_derivative: assumes "isFDERIV DIM('a) [0.. Csafe" shows "(ode has_derivative ode_d1 x) (at x)" proof - from assms(1) have *: "x \ Csafe \ isFDERIV DIM('a) [0.. Csafe" shows "(ode has_derivative ode_d1 x) (at x)" using assms by (auto simp: safe_def Csafe_def intro!: ode_has_derivative) lemma ode_d1_eq: "ode_d1 x = ode_d 0 x j" unfolding ode_d1_def proof (transfer fixing: x j, rule ext, cases "x \ Csafe", clarsimp_all, goal_cases) case (1 d) have "isFDERIV DIM('a) [0.. Csafe" shows "((\x. ode_d n x d d) has_derivative ode_d (Suc n) x d) (at x)" apply (transfer fixing: n d x) using assms apply (simp del: isnFDERIV.simps) apply (rule if_eventually_has_derivative) subgoal by (rule ode_d_raw_Suc) subgoal by (rule eventually_Collect_open) (auto simp: safe_max_Var[OF assms] open_safe intro!: safe_max_Var[OF assms, le]) subgoal by (simp add: isnFDERIV.simps) subgoal by simp done lemma ode_d1_has_derivative: assumes "x \ Csafe" shows "(ode_d1 has_derivative ode_d (Suc 0) x) (at x)" proof (rule blinfun_has_derivative_componentwiseI[THEN has_derivative_eq_rhs]) fix i::'a assume "i \ Basis" show "((\x. blinfun_apply (ode_d1 x) i) has_derivative ode_d (Suc 0) x i) (at x)" unfolding ode_d1_eq[of _ i] apply (rule ode_d_has_derivative) apply fact done next show "(\xa. \i\Basis. blinfun_scaleR (blinfun_inner_left i) (blinfun_apply (ode_d (Suc 0) x i) xa)) = ode_d (Suc 0) x" apply (rule ext) apply (auto intro!: ext euclidean_eqI[where 'a='a] blinfun_euclidean_eqI simp: blinfun.bilinear_simps inner_sum_left inner_Basis if_distrib if_distribR sum.delta' cong: if_cong) apply (rule arg_cong[where f="\x. x \ b" for b]) proof goal_cases case (1 j i b) from eventually_isFDERIV[where params=Nil, simplified, OF safe_isFDERIV[OF assms] order_trans[OF safe_max_Var[of x]]] have "\\<^sub>F x in at x. isFDERIV DIM('a) [0.. S" "open S" "S \ Csafe" and "\xa. xa \ S \ xa \ x \ isFDERIV DIM('a) [0..s. s \ S \ isFDERIV DIM('a) [0.. S" with S have "a \ Csafe" by auto from S_FDERIV[OF \a \ S$ have "isFDERIV DIM('a) [0..a \ Csafe\ by (rule ode_has_derivative) next fix i interpret linear "ode_d (Suc 0) x" proof fix y z have 1: "((\x. ode_d 0 x (y + z) (y + z)) has_derivative ode_d (Suc 0) x (y + z)) (at x)" apply (rule ode_d_has_derivative) apply (rule assms) done have *: "ode_d 0 x (y + z) (y + z) = ode_d 0 x y y + ode_d 0 x z z" for x by (auto simp: blinfun.bilinear_simps ode_d1_eq[symmetric]) have 2: "((\x. ode_d 0 x (y + z) (y + z)) has_derivative ode_d (Suc 0) x y + ode_d (Suc 0) x z) (at x)" apply (subst *) apply (rule derivative_eq_intros) apply (rule ode_d_has_derivative) apply fact apply (rule ode_d_has_derivative) apply fact apply (auto simp: blinfun.bilinear_simps) done from has_derivative_unique[OF 1 2] show "ode_d (Suc 0) x (y + z) = ode_d (Suc 0) x y + ode_d (Suc 0) x z" by (auto intro!: blinfun_eqI) next fix r y have 1: "((\x. ode_d 0 x (r *\<^sub>R y) (r *\<^sub>R y)) has_derivative ode_d (Suc 0) x (r *\<^sub>R y)) (at x)" by (rule ode_d_has_derivative; fact) have *: "ode_d 0 x (r *\<^sub>R y) (r *\<^sub>R y) = r *\<^sub>R ode_d 0 x y y" for x by (auto simp: blinfun.bilinear_simps ode_d1_eq[symmetric]) have 2: "((\x. ode_d 0 x (r *\<^sub>R y) (r *\<^sub>R y)) has_derivative r *\<^sub>R ode_d (Suc 0) x y) (at x)" apply (subst *) apply (rule derivative_eq_intros) apply (rule ode_d_has_derivative; fact) apply (auto simp: blinfun.bilinear_simps) done from has_derivative_unique[OF 1 2] show "(ode_d (Suc 0) x (r *\<^sub>R y)) = (r *\<^sub>R ode_d (Suc 0) x y)" by (auto intro!: blinfun_eqI) qed show "((\x. blinfun_apply (ode_d1 x) i) has_derivative blinfun_apply (ode_d (Suc 0) x i)) (at x)" apply (subst euclidean_representation[of i, symmetric]) apply (subst (2) euclidean_representation[of i, symmetric]) apply (auto simp: blinfun.bilinear_simps) apply (rule derivative_eq_intros) apply (rule derivative_eq_intros) apply (subst_tac j = i in ode_d1_eq) apply (rule ode_d_has_derivative) apply (rule assms) apply force apply (auto simp: blinfun.bilinear_simps[symmetric] intro!: ext euclidean_eqI[where 'a='a] blinfun_euclidean_eqI) apply (rule arg_cong[where f="\x. x \ b" for b]) by (auto simp: sum scaleR) next show "x \ S" "open S" by fact+ qed show ?case by (rule symmetric_second_derivative) fact qed qed lemma ode_d1_has_derivative_safeI: assumes "x \ Csafe" shows "(ode_d1 has_derivative ode_d (Suc 0) x) (at x)" apply (rule ode_d1_has_derivative) using assms by (auto simp: safe_def) sublocale c1_on_open_euclidean ode ode_d1 Csafe by unfold_locales (auto simp: continuous_on_eq_continuous_within at_within_open[OF _ open_safe] intro!: derivative_eq_intros continuous_at_imp_continuous_on open_safe ode_has_derivative_safeI continuous_blinfun_componentwiseI has_derivative_continuous ode_d1_has_derivative_safeI) definition ivlflows :: "'a::executable_euclidean_space sctn set \ (('a \ 'a \\<^sub>L 'a) set \ ('a \ 'a \\<^sub>L 'a) set \ ('a \ 'a \\<^sub>L 'a) set) \ ('a \ 'a \\<^sub>L 'a) set \ 'a sctn \ bool" where "ivlflows stops stopcont trap rsctn = (\ivl. ivl \ \(plane_of  stops) \ UNIV \ ivl \ (snd (stopcont ivl)) \ fst (stopcont ivl) \ snd (stopcont ivl) \ (fst (stopcont ivl)) \ sbelow_halfspace rsctn \ UNIV \ (snd (stopcont ivl)) \ sbelow_halfspace rsctn \ UNIV \ flowsto (ivl) {0..} ((snd (stopcont ivl))) ((fst (stopcont ivl)) \ trap))" lift_definition ode_d2::"'a::executable_euclidean_space \ 'a \\<^sub>L 'a \\<^sub>L 'a" is "\x. if x \ Csafe then ode_d 1 x else (\_. 0)" by (auto intro!: has_derivative_bounded_linear ode_d1_has_derivative) definition ode_na::"real \ _ \ _" where "ode_na = (\a. ode (snd a))" definition ode_d_na::"real \ _ \ (real \ _) \\<^sub>L _" where "ode_d_na = (\tx. ode_d1 (snd tx) o\<^sub>L snd_blinfun)" definition ode_d2_na::"real \ _ \ (real \ _) \\<^sub>L (real \ _) \\<^sub>L _" where "ode_d2_na = (\tx. flip_blinfun (flip_blinfun (ode_d2 (snd tx) o\<^sub>L snd_blinfun) o\<^sub>L snd_blinfun))" definition "euler_incr_fas' D = (map fold_const_fa (euler_incr_fas (map floatarith.Var [0.. nat_rel \ fas_rel" "(euler_fas', euler_fas') \ nat_rel \ fas_rel" "(rk2_fas', rk2_fas') \ nat_rel \ fas_rel" by auto definition "solve_poincare_fas n = (let D = length ode_e in map floatarith.Var [0..i \ \(row)\. map (\j \ \(column)\. (if i \ n then floatarith.Var (D + i * D + j) - (floatarith.Var(D + n * D + j) * (ode_e ! i) / (ode_e ! n)) else 0) ) [0.. X \ {}" definition pad_zeroes :: "nat \ real list set \ real list set" where [simp]: "pad_zeroes n X = (\xs. xs @ replicate n (0::real))  X" locale approximate_sets_ode = approximate_sets where ops = ops + ode_operations where ode_ops = ode_ops for ops:: "'b approximate_set_ops" and ode_ops::"ode_ops" begin definition "D = (length ode_e)" definition "ode_slp = slp_of_fas ode_e" definition "euler_slp = slp_of_fas (euler_fas' D)" definition "euler_incr_slp = slp_of_fas (euler_incr_fas' D)" definition "rk2_slp = slp_of_fas (rk2_fas' D)" definition "solve_poincare_slp = map (\i. slp_of_fas (map fold_const_fa (solve_poincare_fas i))) [0.. approx_form_spec safe_form (list_of_eucl  X); b2 \ isFDERIV_spec D [0.. b2) }" definition "wd TYPE('a::executable_euclidean_space) \ length ode_e = DIM('a)" \ \TODO: should be renamed\ lemma open_safe_form[intro, simp]: "open_form safe_form" by (auto simp: safe_form_def) lemma max_Var_floatariths_ode_e_le: "max_Var_floatariths ode_e \ D" and max_Var_form_safe_form_le: "max_Var_form safe_form \ D" using max_Var_ode_expression[of ode_ops] max_Var_form_safe_form_expr[of ode_ops] by (auto simp: ode_e_def safe_form_def D_def) lemma wdD: assumes "wd TYPE('a::executable_euclidean_space)" shows "length ode_e = DIM('a)" "max_Var_floatariths ode_e \ DIM('a)" "max_Var_form safe_form \ DIM('a)" "ode_e \ []" "D = DIM('a)" using assms max_Var_floatariths_ode_e_le max_Var_form_safe_form_le by (auto simp: wd_def D_def safe_form_def ode_e_def) definition "mk_safe (X::'a::executable_euclidean_space set) = do { ASSERT (wd TYPE('a)); s \ safe_set (X:::appr_rel::'a set); if s then RETURN (X:::appr_rel) else SUCCEED }" definition "mk_safe_coll X = do { XS \ (sets_of_coll X); FORWEAK XS (RETURN op_empty_coll) (\x. do { s \ mk_safe (x); RETURN (mk_coll s) }) (\b c. RETURN (b \ c)) }" definition ode_set::"'a::executable_euclidean_space set \ 'a set nres" where "ode_set X = do { _ \ mk_safe X; approx_slp_appr ode_e ode_slp (list_of_eucl  (X)) }" definition "Picard_step X0 t0 h X = SPEC (\R. case R of Some R \ nonempty R \ compact R \ (R \ Csafe) \ (\x0 \ X0. \h'\{t0 .. t0 + h}. \phi\cfuncset t0 h' X. x0 + integral {t0 .. h'} (\t. ode (phi t)) \ R) | None \ True)" lemmas [refine_vcg_def] = approx_form_spec_def isFDERIV_spec_def lemma safe_set_spec[THEN order.trans, refine_vcg]: assumes "wd TYPE('a::executable_euclidean_space)" shows "safe_set X \ SPEC (\r. r \ (X::'a set) \ Csafe)" unfolding safe_set_def by (refine_vcg) (auto simp del: isnFDERIV.simps simp add: Csafe_def safe_def replicate_eq_list_of_eucl_zero wdD[OF \wd _\]) definition Picard_step_ivl :: "'a::executable_euclidean_space set \ real \ real \ 'a set \ 'a set option nres" where "Picard_step_ivl X0 t0 h X = do { ASSERT (0 \ h); ASSERT (wd TYPE('a)); let H = lv_ivl [0] [h]; let D = DIM('a); let env = concat  listset [list_of_eucl  X0, H, list_of_eucl  X]; env \ approx_slp_spec (euler_incr_fas' D) D euler_incr_slp env; (case env of Some env \ do { (l, u) \ op_ivl_rep_of_set ((eucl_of_list  env::'a set)); ASSERT (l \ u); r \ mk_safe ({l .. u}:::appr_rel); RETURN (Some (r:::appr_rel)) } | None \ RETURN None) }" definition "do_widening_spec (i::nat) = SPEC (\b::bool. True)" primrec P_iter::"'a::executable_euclidean_space set \ real \ nat \ ('a) set \ ('a) set option nres" where "P_iter X0 h 0 X = do { let _ = trace_set (ST ''P_iter failed (0)'') (Some (X)); RETURN None }" | "P_iter X0 h (Suc i) X = do { ASSERT (0 \ h); (l, u) \ op_ivl_rep_of_set (X); ASSERT (l \ u); ivl \ mk_safe ({l .. u}:::appr_rel); X' \ Picard_step_ivl X0 0 h ivl; (case X' of Some X' \ do { (l', u') \ op_ivl_rep_of_set (X'); do_widening \ do_widening_spec i; let l' = inf l' l - (if do_widening then abs (l' - l) else 0); let u' = sup u' u + (if do_widening then abs (u' - u) else 0); ASSERT (l' \ u'); ivl' \ mk_safe {l' .. u'}; if (l \ l' \ u' \ u) then RETURN (Some ivl) else P_iter X0 h i ivl' } | None \ do { let _ = trace_set (ST ''P_iter failed (Picard_step)'') (Some (X)); RETURN None } ) }" context fixes m::"('a::executable_euclidean_space set \ real \ real \ 'a set \ ('a set \ 'c) option nres)" begin primrec cert_stepsize:: "'a set \ real \ nat \ nat \ (real \ 'a set \ 'a set \ 'c) nres" where "cert_stepsize X0 h n 0 = do { let _ = trace_set (ST ''cert_stepsize failed'') (Some (X0)); SUCCEED}" | "cert_stepsize X0 h n (Suc i) = do { (l, u) \ op_ivl_rep_of_set (X0); ASSERT (0 \ h); ASSERT (l \ u); ivl \ mk_safe {l .. u}; ASSERT (ivl \ {}); X' \ P_iter X0 h n ivl; case X' of Some X' \ do { r1 \ m X0 h h X'; r2 \ m X0 0 h X'; (case (r1, r2) of (Some (res, err), Some (res_ivl, _)) \ do { _ \ mk_safe res; _ \ mk_safe res_ivl; RETURN (h, res, res_ivl, err) } | _ \ do { let _ = trace_set (ST ''cert_stepsize method failed'') (Some (X')); cert_stepsize X0 (h / 2) n i } ) } | None \ cert_stepsize X0 (h / 2) n i }" end definition "one_step_method m \ (\X0 CX hl hu. m X0 hl hu CX \ SPEC (\r. case r of None \ True | Some (res, err) \ nonempty res \ (\x0 \ X0. \h \ {hl .. hu}. x0 \ Csafe \ h \ 0 \ h \ existence_ivl0 x0 \ (\h' \ {0 .. h}. flow0 x0 h' \ CX) \ x0 + h *\<^sub>R ode x0 \ CX \ flow0 x0 h \ res)))" definition "one_step X0 h m = do { CHECKs ''one_step nonneg'' (0 < h); its \ iterations_spec; halvs \ halve_stepsizes_spec; (h, res, res_ivl, err) \ cert_stepsize m X0 h its halvs; ASSERT (0 < h); RETURN (h, err, res_ivl, res) }" definition [refine_vcg_def]: "default_reduce_argument_spec = SPEC (\x::unit. True)" definition "euler_step X0 h = one_step X0 h (\X0 hl hu CX. do { let H = lv_ivl [min hl hu] [max hl hu]; _ \ mk_safe CX; let env = concat  listset [list_of_eucl  X0, list_of_eucl  CX, H]; env \ approx_slp_spec (euler_fas' DIM('a)) (2 * DIM('a)) euler_slp env; case env of None \ RETURN None | Some env \ do { let res' = take DIM('a)  env; ASSERT (env_len res' DIM('a)); let res = (eucl_of_list  res'); ASSUME (ncc res); let err' = drop DIM('a)  take (DIM('a) * 2)  env; ASSERT (env_len err' DIM('a)); let err = (eucl_of_list  err'::'a::executable_euclidean_space set); ra \ default_reduce_argument_spec; res \ reduce_spec ra res; ASSUME (ncc res); s \ safe_set res; if s then do { res \ mk_safe res; RETURN (Some (res::'a set, err)) } else RETURN None } })" definition "rk2_step X0 h = one_step X0 h (\X0 hl hu CX. do { let H = lv_ivl [min hl hu] [max hl hu]; rps \ rk2_param_spec; let rkp = lv_ivl [rps] [rps]; let s2 = lv_ivl [0] [1]; _ \ mk_safe CX; ASSUME (ncc CX); let env = concat  listset [list_of_eucl  X0, list_of_eucl  CX, rkp, H, s2]; env \ approx_slp_spec (rk2_fas' DIM('a)) (2 * DIM('a)) rk2_slp env; case env of None \ RETURN None | Some env \ do { let res' = take DIM('a)  env; ASSERT (env_len res' DIM('a)); let res = (eucl_of_list  res'::'a::executable_euclidean_space set); ASSUME (ncc res); let err' = drop DIM('a)  take (DIM('a) * 2)  env; ASSERT (env_len err' DIM('a)); let err = (eucl_of_list  err'::'a set); ra \ default_reduce_argument_spec; res \ reduce_spec ra res; ASSUME (ncc res); s \ safe_set res; if s then do { res \ mk_safe res; RETURN (Some (res, err)) } else RETURN None } })" definition "choose_step X0 h = do { mid \ method_spec; (if mid = 2 then rk2_step X0 h else euler_step X0 h) }" definition "ode_e' = (ode_e @ mmult_fa D D D (concat (map (\j. map (\i. (FDERIV_floatarith (ode_e ! j) [0.. op_ivl_rep_of_set f; RETURN (sum_list (map (\b. (if I \ b \ 0 then if S \ b \ 0 then S \ b else 0 else if S \ b \ 0 then I \ b else 0) *\<^sub>R b) (Basis_list::'a::executable_euclidean_space list))) }" definition "intersects_sctns X' sctns = do { ASSUME (finite sctns); FOREACH\<^bsup>\sctns' b. \b \ X' \ \(plane_of  (sctns - sctns')) = {}\<^esup> sctns (\sctn b. do {b' \ op_intersects ( X') sctn; RETURN (b \ b')}) False }" definition "trace_sets s X = do { XS \ sets_of_coll (X:::clw_rel (appr_rel)); FORWEAK XS (RETURN ()) (\X. RETURN (trace_set s (Some X))) (\_ _. RETURN ()) }" definition "print_sets s X = do { XS \ sets_of_coll (X:::clw_rel (appr_rel)); FORWEAK XS (RETURN ()) (\X. RETURN (print_set s (X))) (\_ _. RETURN ()) }" definition "intersects_sctns_spec_clw R sctns = do { Rs \ sets_of_coll ((R:::clw_rel appr_rel):::clw_rel(appr_rel)); FORWEAK Rs (RETURN False) (\R. intersects_sctns R sctns) (\a b. RETURN (a \ b)) }" definition [simp]: "nonneg_reals = ({0..}::real set)" definition [simp]: "pos_reals = ({0<..}::real set)" definition "nonzero_component s X n = do { I \ Inf_inner X n; S \ Sup_inner X n; CHECKs s (I > 0 \ S < 0) }" definition "disjoints_spec X Y = do { Xi \ ivls_of_sets X; IS \ inter_overappr (Xi:::clw_rel lvivl_rel) (Y:::clw_rel lvivl_rel); RETURN (is_empty IS) }" definition subset_spec_plane :: "'a::executable_euclidean_space set \ 'a sctn \ bool nres" where "subset_spec_plane X sctn = do { CHECKs ''subset_spec_plane: not in Basis'' (abs (normal sctn) \ set Basis_list); (i, s) \ ivl_rep X; RETURN (i \ normal sctn = pstn sctn \ s \ normal sctn = pstn sctn) }" definition "op_eventually_within_sctn X sctn S = do { (l, u) \ ivl_rep S; (xl, xu) \ op_ivl_rep_of_set X; CHECKs (ST ''op_eventually_within_sctn: empty ivl'') (l \ u); CHECKs (ST ''op_eventually_within_sctn: not in Basis'') (abs (normal sctn) \ set Basis_list); b \ subset_spec_plane S sctn; CHECKs (ST ''op_eventually_within_sctn: subset_spec_plane 1'') b; b \ subset_spec_plane ({xl .. xu}:::lvivl_rel) sctn; CHECKs (ST ''op_eventually_within_sctn: subset_spec_plane 2'') b; RETURN (b \ (\i \ set Basis_list - {abs (normal sctn)}. l \ i < xl \ i \ xu \ i < u \ i)) }" definition [simp]: "uninfo X = X" definition [simp]: "op_subset_ivl a b \ a \ b" definition [simp]: "op_eq_ivl a b \ a = b" abbreviation "iplane_rel \ \A. \A, \lv_rel\plane_rel\inter_rel" abbreviation "isbelow_rel \ \A. \A, \lv_rel\sbelow_rel\inter_rel" abbreviation "isbelows_rel \ \A. \A, \lv_rel\sbelows_rel\inter_rel" definition [refine_vcg_def]: "get_plane X = SPEC (\sctn. X = plane_of sctn)" definition "tolerate_error Y E = do { (ei, es) \ op_ivl_rep_of_set (E); (yi, ys) \ op_ivl_rep_of_set (Y); let ea = sup (abs ei) (abs es); let ya = sup (abs yi) (abs ys); rtol \ adaptive_rtol_spec; atol \ adaptive_atol_spec; let errtol = sup (rtol *\<^sub>R ya) (atol *\<^sub>R sum_list Basis_list); RETURN (ea \ errtol, infnorm ea) }" -definition "adapt_stepsize_fa rtol mid e h' = - floatarith.Num (float_of h') * floatarith.Powr (floatarith.Num (float_of (rtol)) / floatarith.Num (float_of e)) - (inverse (floatarith.Num (float_of (real_of_nat mid) + 1)))" +definition "adapt_stepsize_fa rtol m e h' = + floatarith.Num (float_of h') * + floatarith.Powr (floatarith.Num (float_of (rtol)) / floatarith.Num (float_of e)) + (inverse (floatarith.Num (float_of (real_of_nat m) + 1)))" end text \With ODE operations for variational equation\ locale approximate_sets_ode' = approximate_sets_ode\ \TODO: this prevents infinite chain of interpretations (?!)\ where ops = ops and ode_ops = ode_ops for ops :: "'b approximate_set_ops" and ode_ops begin lift_definition var_ode_ops::ode_ops is "(ode_e', safe_form)" using max_Var_floatariths_ode_e_le max_Var_form_safe_form_le by (auto simp: ode_e'_def D_def length_concat o_def sum_list_triv intro!: max_Var_floatariths_mmult_fa[le] max_Var_floatariths_concat max_Var_floatariths_mapI max_Var_floatarith_FDERIV_floatarith[le] max_Var_floatariths_list_update max_Var_floatariths_replicateI max_Var_floatarith_le_max_Var_floatariths_nth[le]) sublocale var: approximate_sets_ode where ode_ops = var_ode_ops by unfold_locales end lifting_update ode_ops.lifting lifting_forget ode_ops.lifting end \ No newline at end of file diff --git a/thys/Ordinary_Differential_Equations/Numerics/Abstract_Reachability_Analysis_C1.thy b/thys/Ordinary_Differential_Equations/Numerics/Abstract_Reachability_Analysis_C1.thy --- a/thys/Ordinary_Differential_Equations/Numerics/Abstract_Reachability_Analysis_C1.thy +++ b/thys/Ordinary_Differential_Equations/Numerics/Abstract_Reachability_Analysis_C1.thy @@ -1,1108 +1,1109 @@ theory Abstract_Reachability_Analysis_C1 imports Abstract_Reachability_Analysis "../Refinement/Weak_Set" "../Refinement/Refine_Parallel" "../Refinement/Refine_Default" "../Refinement/Refine_Phantom" "../Refinement/Refine_ScaleR2" begin definition blinfun_of_list :: "real list \ 'a \\<^sub>L 'a::executable_euclidean_space" where "blinfun_of_list xs = blinfun_of_matrix (\i j. xs ! ((index Basis_list i) * DIM('a) + (index Basis_list j)))" definition vec1_of_list :: "real list \ 'n::{finite, one, plus} vec1" where "vec1_of_list xs = (vector (take CARD('n) xs), vector (map (\i. vector (nths xs {CARD('n)*i..CARD('n)*Suc i})) [1.. ('n rvec * ('n rvec \\<^sub>L 'n::finite rvec))" where "flow1_of_vec1 xs = (fst xs, blinfun_of_vmatrix (snd xs))" definition vec1_of_flow1 :: "('n::finite eucl1) \ 'n vec1" where "vec1_of_flow1 xs = (fst xs, matrix (snd xs))" lemma vec1_of_flow1_flow1_of_vec1[simp]: "vec1_of_flow1 (flow1_of_vec1 X) = X" unfolding vec1_of_flow1_def flow1_of_vec1_def by (transfer) (auto simp: matrix_of_matrix_vector_mul) definition "flow1_of_list xs = (eucl_of_list (take DIM('a::executable_euclidean_space) xs)::'a, blinfun_of_list (take (DIM('a)*DIM('a)) (drop DIM('a) xs @ replicate (DIM('a)*DIM('a) - (length xs - DIM('a))) 0))::'a\\<^sub>L'a)" lemma blinfun_of_list_eq_blinfun_of_vmatrix: assumes "length xs = CARD('n)*CARD('n::enum)" shows "blinfun_of_list xs = blinfun_of_vmatrix (eucl_of_list xs::((real, 'n) vec, 'n) vec)" using assms apply (auto simp: blinfun_of_list_def) apply (auto intro!: simp: blinfun_ext blinfun_of_vmatrix.rep_eq blinfun_of_matrix.rep_eq) subgoal for i apply (subst (2) eucl_of_list_list_of_eucl[symmetric, of i]) apply (subst eucl_of_list_matrix_vector_mult_eq_sum_nth_Basis_list) by (auto simp: sum_Basis_sum_nth_Basis_list scaleR_sum_left intro!: sum.cong) done definition "ghost_rel = Pair ()  UNIV" consts i_ghost::interface lemmas [autoref_rel_intf] = REL_INTFI[of ghost_rel i_ghost] lemma ghost_relI: "((), x) \ ghost_rel" by (auto simp: ghost_rel_def) definition [refine_vcg_def]: "GSPEC x = SPEC x" lemma [autoref_op_pat_def]: "GSPEC x \ Autoref_Tagging.OP (GSPEC x)" by auto lemma GSPEC_impl[autoref_rules]: assumes "SIDE_PRECOND (Ex P)" shows "(RETURN (), GSPEC P) \ \ghost_rel\nres_rel" using assms by (auto simp: nres_rel_def ghost_rel_def GSPEC_def intro!: RETURN_SPEC_refine) context approximate_sets_ode' begin definition "c1_info_of_appr XD = (case snd XD of None \ eucl_of_list  set_of_appr (fst XD) \ UNIV | Some DD \ flow1_of_list  set_of_appr (fst XD @ DD))" definition "c1_info_of_apprs x = \(set (map c1_info_of_appr x))" definition "c1_info_of_appr' x = Affine_Code.the_default UNIV (map_option c1_info_of_apprs x)" definition "c1_info_of_appre X = scaleR2 (fst (fst X)) (snd (fst X)) (c1_info_of_appr (snd X))" definition "c1_info_of_apprse x = \(set (map c1_info_of_appre x))" definition [simp]: "op_image_flow1_of_vec1 = () flow1_of_vec1" definition [simp]: "op_image_flow1_of_vec1_coll = () flow1_of_vec1" definition [simp]: "op_image_fst = () fst" definition [refine_vcg_def]: "vec1rep CX = SPEC (\R. case R of None \ True | Some X \ X = vec1_of_flow1  CX)" definition [simp]: "op_times_UNIV X = X \ UNIV" definition appr1_rel::"(('b list \ 'b list option) \ ('a::executable_euclidean_space c1_info set)) set" where appr1_rel_internal: "appr1_rel = {((xs, None), X \ UNIV) |xs X. (xs, X) \ appr_rel} \ {((xs, Some ys), X::('a c1_info) set) |xs ys X. X = flow1_of_list  set_of_appr (xs @ ys) \ length xs = DIM('a::executable_euclidean_space) \ length ys = DIM('a) * DIM('a)}" abbreviation "appr1e_rel \ \appr1_rel\scaleR2_rel" text \TODO: remove \...:::relation\ from this file\ definition "solve_poincare_plane (n::'n::enum rvec) (CX::'n eucl1 set) = do { X \ mk_safe ((() fst CX::'n rvec set)); F \ ode_set (X); nonzero_component (ST ''solve_poincare_map: not nonzero!'') F n; let i = index Basis_list n; ASSERT (i < length solve_poincare_slp); vCX \ vec1rep CX; case vCX of None \ do { RETURN (op_times_UNIV (X)) } | Some vCX \ do { (R::'n vec1 set) \ approx_slp_appr (map fold_const_fa (solve_poincare_fas i)) (solve_poincare_slp ! i) (list_of_eucl  vCX); let R = (op_image_flow1_of_vec1 (R:::appr_rel):::appr1_rel); X \ mk_safe (op_image_fst R); F \ ode_set (X); nonzero_component (ST ''solve_poincare_map: not nonzero!'') (F) n; RETURN (R::'n eucl1 set) } }" definition embed1::"'n::enum rvec \ ('n rvec * (real^'n::enum^'n::enum))" where [simp]: "embed1 x = (x, 0)" definition "choose_step1 (X::'n::enum eucl1 set) h = do { lX \ vec1rep X; case lX of None \ do { sX \ mk_safe (fst  X); (h, err, CX', X') \ choose_step sX h; \<^cancel>\err \ width_spec (err:::appr_rel);\ RETURN (h, err \ UNIV, (CX') \ UNIV, (X') \ UNIV) } | Some vX \ do { sX \ var.mk_safe vX; (h, err, CX', X') \ var.choose_step sX h; let CX' = flow1_of_vec1  ((CX':::appr_rel):::appr_rel); let X' = flow1_of_vec1  ((X':::appr_rel):::appr_rel); let err' = flow1_of_vec1  (err:::appr_rel); \<^cancel>\err \ width_spec (fst  (flow1_of_vec1  (err:::appr_rel)):::appr_rel);\ RETURN (h, err', CX', X'::'n eucl1 set) } }" definition "plane1_of x = plane_of x \ UNIV" definition "below1_halfspaces x = below_halfspaces x \ UNIV" definition "sbelow1_halfspaces x = sbelow_halfspaces x \ UNIV" abbreviation "plane1_invar_rel \ \A. \(\lv_rel\sctn_rel), A\invar_rel plane1_of " definition "c1_info_invar N XD \ length (fst XD) = N \ (case snd XD of Some DD \ length DD = (length (fst XD))\<^sup>2 | None \ True)" definition op_image_zerofst :: "('a \ 'c) set \ ('a::zero \ 'c) set" where [simp]: "op_image_zerofst \ \X. (\x. (0, snd x))  X" definition op_image_zerofst_vec :: "('n::enum vec1) set \ ('n::enum vec1) set" where [simp]: "op_image_zerofst_vec \ \X. (\x. (0, snd x))  X" definition [simp]: "op_image_embed1 X = embed1  X" definition "inter_sctn1_spec (X::'n::enum eucl1 set) (sctn::'n rvec sctn) = do { R \ inter_sctn_spec (fst  X) sctn; vX \ vec1rep X; case vX of None \ do { let R1 = R \ UNIV; RETURN (R1, R1) } | Some X \ do { let sctn = ((Sctn (embed1 (normal sctn)) (pstn sctn)::'n vec1 sctn)); R1 \ inter_sctn_spec X sctn; let R2 = op_image_zerofst_vec X + op_image_embed1 R; RETURN ((flow1_of_vec1  R1), (flow1_of_vec1  R2)) } }" definition "op_image_fst_coll_nres XS = do { XSs \ sets_of_coll XS; FORWEAK XSs (RETURN op_empty_coll) (\X. RETURN (mk_coll (op_image_fst X:::appr_rel))) (\A B. RETURN (B \ A)) }" lemma op_image_fst_coll_nres_spec[le, refine_vcg]: "op_image_fst_coll_nres X \ SPEC (\R. R = fst  X)" unfolding op_image_fst_coll_nres_def by (refine_vcg FORWEAK_mono_rule[where I="\it s. fst  \it \ s \ s \ fst  X"]) (auto, force+) definition [simp]: "op_image_fst_coll = () fst" definition "fst_safe_coll XS = do { C \ op_image_fst_coll_nres XS; mk_safe_coll (C:::clw_rel appr_rel) }" definition [refine_vcg_def]: "vec1reps X = do { XS \ sets_of_coll X; FORWEAK XS (RETURN (Some op_empty_coll)) (\x. do { x \ vec1rep x; RETURN (map_option mk_coll x:::\clw_rel appr_rel\option_rel) }) (\a b. case (a, b) of (Some a, Some b) \ RETURN (Some (b \ a)) | _ \ RETURN None) }" definition "do_intersection_spec S guards ivl sctn X0 = (\(PS, CXS). poincare_mapsto {x \ ivl. x \ plane_of sctn} X0 S CXS PS \ CXS \ guards = {} \ CXS \ ivl \ plane_of sctn = {} \ fst  PS \ guards = {} \ fst  PS \ {x \ ivl. x \ plane_of sctn} \ fst  PS \ CXS \ Csafe \ 0 \ (\x. ode x \ normal sctn)  fst  PS \ (\x\PS. (\\<^sub>F x in at (fst x) within plane_of sctn. x \ ivl)))" abbreviation "inter_sbelows X sctns \ mk_inter X (sbelow_halfspaces sctns)" definition "list_of_appr1 X = fst X @ the_default [] (snd X)" definition print_set1::"bool \ 'a set \ unit" where "print_set1 _ _ = ()" definition "nonzero_component_within ivl sctn PDP = do { fPDP \ mk_safe (fst  PDP); F \ ode_set (fPDP); nonzero_component (ST ''solve_poincare_map: not nonzero!'') F (normal sctn); op_eventually_within_sctn (op_image_fst PDP:::appr_rel) sctn ivl }" definition "do_intersection_invar guards GUARDS ivl sctn X \ \(X', T, PS, PS2, CXS, intersects, inside). (inside \ (fst  X \ GUARDS = {} \ fst  X \ sbelow_halfspace sctn \ ivl \ plane_of sctn \ fst  X \ CXS \ fst  PS \ fst  PS2 \ CXS \ fst  X' \ Csafe \ T \ nonneg_reals \ (\intersects \ (fst  X' \ plane_of sctn = {} \ T = pos_reals)) \ CXS \ (sbelow_halfspace sctn - guards) \ X' \ (- guards) \ UNIV \ fst  (PS \ PS2) \ guards = {} \ (0 \ (\x. ode x \ normal sctn)  fst  (PS \ PS2)) \ ((\x\PS \ PS2. (\\<^sub>F x in at (fst x) within plane_of sctn. x \ ivl))) \ (\A B. X = A \ B \ flowsto A T (CXS \ UNIV) (X' \ (sbelow_halfspace sctn) \ UNIV) \ poincare_mapsto {x \ ivl. x \ normal sctn = pstn sctn} B UNIV CXS PS \ poincare_mapsto {x \ ivl. x \ normal sctn = pstn sctn} B UNIV CXS PS2)))" definition "list_of_appr1e X = fst (snd X) @ the_default [] (snd (snd X)) @ (let (l, u) = fst X; roer = (\x. if x = - \ then FloatR 1 (-88) else if x = \ then FloatR 1 88 else real_of_ereal x) in appr_of_ivl ops [roer l] [roer u] )" definition print_set1e::"bool \ 'a set \ unit" where "print_set1e _ _ = ()" definition trace_set1e::"string\'a set option\unit" where "trace_set1e _ _ = ()" definition trace_set1::"string\'a set option\unit" where "trace_set1 _ _ = ()" definition "split_spec_param1 X = do { (vX) \ vec1rep X; let D = CARD('n); case vX of None \ do { (a, b) \ split_spec_param D (fst  X::'n::finite rvec set); RETURN (a \ UNIV, b \ UNIV) } | Some X \ do { (a, b) \ split_spec_param D X; RETURN (op_image_flow1_of_vec1 a, op_image_flow1_of_vec1 b) } }" abbreviation iinfo_rel :: "('c \ 'a set) set \ ((real \ 'c) \ 'a::real_normed_vector set) set" where "iinfo_rel \ \s. \rnv_rel, s\info_rel" definition "split_spec_param1e X = do { ((l, u), Y) \ scaleR2_rep X; (a, b) \ split_spec_param1 Y; a \ scaleRe_ivl_spec l u a; b \ scaleRe_ivl_spec l u b; RETURN (a, b) }" definition "reduce_spec1 C X = do { vX \ vec1rep X; case vX of None \ do { X \ reduce_spec C (fst  X); RETURN (X \ UNIV) } | Some vX \ do { vX \ reduce_spec C vX; RETURN (flow1_of_vec1  vX) } }" definition "reduce_spec1e C X = do { ((l, u), X) \ scaleR2_rep X; X \ reduce_spec1 C X; scaleRe_ivl_spec l u X }" definition [refine_vcg_def]: "pre_split_reduce_spec (ro::unit) = SPEC (\x::unit. True)" definition split_under_threshold::"_ \ real \ 'n::enum eucl1 set \ 'n eucl1 set nres" where "split_under_threshold ro th X = do { (_, Ys) \ WHILE\<^bsup>\(Xs, Ys). X \ Xs \ Ys\<^esup> (\(Xs, Ys). \ op_coll_is_empty Xs) (\(Xs, Ys). do { (X, Xs') \ (split_spec_coll (Xs:::clw_rel (\appr1_rel\scaleR2_rel)):::\\appr1_rel\scaleR2_rel \\<^sub>r clw_rel (\appr1_rel\scaleR2_rel)\nres_rel); w \ width_spec (op_image_fste X:::appr_rel); if w \ th then RETURN (Xs', mk_coll X \ Ys) else do { ra \ pre_split_reduce_spec ro; X \ reduce_spec1e ra X; (a, b) \ split_spec_param1e (X:::\appr1_rel\scaleR2_rel); RETURN (mk_coll (a:::\appr1_rel\scaleR2_rel) \ mk_coll (b:::\appr1_rel\scaleR2_rel) \ Xs', Ys) } }) (X:::clw_rel (\appr1_rel\scaleR2_rel), op_empty_coll:::clw_rel (\appr1_rel\scaleR2_rel)); RETURN Ys }" definition "choose_step1e X h = do { ((l, u), X) \ scaleR2_rep X; (h', error, CY, Y) \ choose_step1 X h; Y \ scaleRe_ivl_spec l u Y; RETURN (h', error, fst  CY, Y) }" definition "step_split ro (X::'n::enum eucl1 set) = do { ra \ pre_split_reduce_spec ro; X \ reduce_spec1e ra X; (a, b) \ split_spec_param1e (X:::appr1e_rel); _ \ mk_safe (op_image_fste a); _ \ mk_safe (op_image_fste b); width_X \ width_spec (op_image_fste X:::appr_rel); wa \ width_spec (op_image_fste a:::appr_rel); wb \ width_spec (op_image_fste b:::appr_rel); let _ = trace_set (ST ''splitting: '' @ show (lfloat10 width_X) @ ST ''-->'' @ show (lfloat10 wa) @ ST '', '' @ show (lfloat10 wb)) (None::'n::enum eucl1 set option); RETURN (mk_coll a \ mk_coll b) }" definition "width_spec_appr1 X = do { vX \ vec1rep X; case vX of None \ width_spec (fst  X:::appr_rel) | Some vX \ width_spec (vX:::appr_rel) }" definition "tolerate_error1 Y E = tolerate_error (fst  Y) (fst  E)" definition "step_adapt_time (X::'n::enum eucl1 set) h = do { let X0 = fst  X; _ \ mk_safe (X0:::appr_rel); (h', error, CY, Y) \ choose_step1e X h; (te, e) \ tolerate_error1 Y error; let _ = trace_set1 (ST ''discrete time step: stepsize = '' @ show (lfloat10 h)) (None::'n eucl1 set option); let _ = trace_set1 (ST ''discrete time step: stepsize' = '' @ show (lfloat10 h')) (None::'n eucl1 set option); let _ = trace_set1 (ST ''error estimation: '' @ show (lfloat10 e)) (None::'n eucl1 set option); if \ te then do { let _ = trace_set (ST ''revoking step'') (None::'n eucl1 set option); RETURN (0, fst  X, X, 3 * h' / 2 / 2) } else do { let _ = trace_set1 (ST ''error OK, step_adapt_time stepped '') (None::'n eucl1 set option); let _ = trace_set (ST ''interpolated step:'') (Some (CY)); let _ = print_set True CY; let _ = trace_set1e (ST ''discrete step:'') (Some (Y)); let _ = print_set1e False Y; rtol \ adaptive_rtol_spec; method_id \ method_spec; prec \ precision_spec; case approx prec (adapt_stepsize_fa rtol method_id e h') [] - of Some (h'', _) \ - let _ = trace_set1 (ST ''increase step: stepsize = '' @ show (lfloat10 h'')) (None::'n eucl1 set option) + of Some ivl_h'' \ + let h'' = lower ivl_h''; + _ = trace_set1 (ST ''increase step: stepsize = '' @ show (lfloat10 h'')) (None::'n eucl1 set option) in RETURN (h', CY, Y, 15/2/2/2/2 * h'') | None \ let _ = trace_set1 (ST ''increase time step (failure): stepsize = '' @ show (lfloat10 h')) (None::'n eucl1 set option) in RETURN (h', CY, Y, h' * 5 / 2 / 2) } }" definition [simp]: "eq_spec x y = SPEC (\r. r \ x = y)" lemma [autoref_itype]: "eq_spec ::\<^sub>i A \\<^sub>i A \\<^sub>i \i_bool\\<^sub>ii_nres" by simp definition "select_with_inter ci a = do { CIs \ (sets_of_coll ci); As \ sets_of_coll a; FORWEAK CIs (RETURN op_empty_coll) (\ci. do { (c, I) \ (get_inter ci); FORWEAK As (RETURN op_empty_coll) (\a. do { b \ eq_spec a c; if b then RETURN (mk_coll ci) else RETURN (op_empty_coll) }) (\CIS CIS'. RETURN (CIS' \ CIS)) }) (\CIS CIS'. RETURN (CIS' \ CIS)) }" abbreviation "fst_safe_colle XS \ (mk_safe_coll (op_image_fst_colle XS:::clw_rel appr_rel):::\clw_rel appr_rel\nres_rel)" definition "do_intersection_body GUARDS ivl sctn h \ \(X, T, PDPS, PDPS2, CXS, _, _). do { (_, _, CX', X') \ choose_step1 (X:::appr1_rel) (h:::rnv_rel); let _ = trace_set1 (ST ''interpolated step during intersection:'') (Some (CX')); let _ = print_set1 True (CX'); let _ = trace_set1 (ST ''step during intersection:'') (Some (X')); let _ = print_set1 False (X'); CHECKs (ST ''unnormal intersection'') (abs (normal sctn) \ set Basis_list); CPDP \ solve_poincare_plane (abs (normal sctn)) CX'; let _ = trace_set1 (ST ''CPDP: '') (Some CPDP); let _ = print_set1 False (CPDP); (PDP, PDP2) \ inter_sctn1_spec CPDP sctn; b1 \ disjoints_spec (mk_coll (op_image_fst X')) (GUARDS); b2 \ disjoints_spec (mk_coll (op_image_fst CX')) (GUARDS); b3 \ disjoints_spec (mk_coll (op_image_fst PDP)) (GUARDS); b4 \ disjoints_spec (mk_coll (op_image_fst PDP2)) (GUARDS); CHECKs (ST ''do_intersection: hitting several planes :('') (b1 \ b2 \ b3 \ b4); intersects \ op_intersects (op_image_fst X') sctn; CX's \ mk_safe (op_image_fst CX'); c1 \ nonzero_component_within ivl sctn PDP; c2 \ nonzero_component_within ivl sctn PDP2; RETURN (X', pos_reals:::\Id\phantom_rel, mk_coll PDP \ PDPS, mk_coll PDP2 \ PDPS2, mk_coll (inter_sbelows (CX's:::appr_rel) {sctn}) \ CXS, intersects, c1 \ c2) }" definition "do_intersection guards ivl sctn (X::'n::enum eucl1 set) (h::real) = do { ASSUME (closed ivl); sp \ subset_spec_plane ivl sctn; sX \ mk_safe (op_image_fst (X:::appr1_rel)); GUARDS \ unintersect_coll guards; a \ sbelow_sctn (op_image_fst X) sctn; b \ disjoints_spec (mk_coll (op_image_fst X)) GUARDS; let inside = sp \ a \ b; \ \this is a bit of a hack: if the \ivl\ is not subset of the plane,\ \ \then do not do intersections\ (X, T, PDPS, PDPS2, CXS, intersects, inside) \ WHILE\<^bsup>do_intersection_invar guards GUARDS ivl sctn X\<^esup> (\(X, T, PDPS, PDPS2, CXS, intersects, inside). intersects \ inside) (do_intersection_body GUARDS ivl sctn h) (X, nonneg_reals:::\Id\phantom_rel, op_empty_coll:::clw_rel appr1_rel::'n eucl1 set, op_empty_coll:::clw_rel appr1_rel::'n eucl1 set, mk_coll (inter_sbelows (sX:::appr_rel) {sctn}), True, inside); a \ above_sctn (op_image_fst X) sctn; b \ subset_spec_coll (op_image_fst_coll PDPS) ivl; b2 \ subset_spec_coll (op_image_fst_coll PDPS2) ivl; RETURN (inside \ b \ b2 \ a, PDPS, PDPS2, CXS) }" definition "resolve_step roptns X h = do { width_X \ width_spec (op_image_fste X:::appr_rel); mtdt \ max_tdev_thres_spec roptns; if \ width_X \ mtdt then do { Y \ step_split roptns X; RETURN (h, fst  Y, Y, h) } else do { (h0, CY, Y, h') \ step_adapt_time (X::'n::enum eucl1 set) h; RETURN (h0, mk_coll (fst  Y) \ mk_coll CY, mk_coll Y, h') } }" definition "pre_intersection_step ro X h = do { mis \ max_intersection_step_spec ro; if h > mis then RETURN (with_infos (h/2) (mk_coll X), mk_coll (fst  X), op_empty_coll:::clw_rel (iinfo_rel appr1e_rel)) else do { width_X \ width_spec (op_image_fste X:::appr_rel); pig \ pre_inter_granularity_spec ro; if width_X \ pig then RETURN (with_infos h (op_empty_coll:::clw_rel appr1e_rel), mk_coll (fst  X), with_infos (5 * h / 2 / 2) (mk_coll X)) else do { X' \ step_split ro X; RETURN (with_infos h X', fst  X', op_empty_coll:::clw_rel (iinfo_rel appr1e_rel)) } } }" definition "reach_cont ro (guardsi::'n::enum rvec set) XS0 = do { startstep \ start_stepsize_spec; (_, XS0') \ scaleR2_rep_coll XS0; sXS0 \ fst_safe_coll XS0'; let fX0 = op_image_fst_colle XS0; guards \ (unintersect_coll (guardsi:::clw_rel (iplane_rel lvivl_rel)):::\clw_rel lvivl_rel\nres_rel); d \ disjoints_spec fX0 (guards); CHECKs (ST ''reach_cont: starting from guarded set'') d; (_, CXS, GS) \ WHILE\<^bsup>(\(XS, CXS, GS). flowsto XS0 {0..} (CXS \ UNIV) (XS \ GS) \ (XS \ GS \ CXS \ UNIV) \ (Csafe - guards) \ UNIV \ XS0 \ GS \ CXS \ UNIV)\<^esup> (\(XS, CXS, GS). \ op_coll_is_empty XS) (\(XS, CXS, GS). do { (hX, XS') \ (split_spec_exact XS:::\iinfo_rel (appr1e_rel) \\<^sub>r clw_rel (iinfo_rel (appr1e_rel))\nres_rel); (h::real, X) \ get_info hX; let _ = trace_set1e (ST ''next step in resolve_sctns using'') (Some X); cXS::nat \ card_info XS; cGS::nat \ card_info GS; let _ = trace_set1 (ST ''XS: '' @ show cXS) (None::'n eucl1 set option); let _ = trace_set1 (ST ''GS: '' @ show cGS) (None::'n eucl1 set option); (h0, fCX', X', h') \ resolve_step ro X h; sfCX' \ (mk_safe_coll (fCX':::clw_rel appr_rel):::\clw_rel appr_rel\nres_rel); let fX' = (fst  X'); fXS \ ivls_of_sets (fCX' \ fX'); IS \ inter_overappr guards fXS; let d = op_coll_is_empty IS; if d then RETURN (with_infos h' X' \ XS':::clw_rel (iinfo_rel appr1e_rel), sfCX' \ CXS, GS) else do { (hX', fCX', hG') \ pre_intersection_step ro X h0; sfCX' \ (mk_safe_coll (fCX':::clw_rel appr_rel):::\clw_rel appr_rel\nres_rel); _ \ fst_safe_colle (uninfo hX'); _ \ fst_safe_colle (uninfo hG'); fGs \ ivls_of_sets (op_image_fst_colle (uninfo hG') \ fCX' \ op_image_fst_colle (uninfo hX')); d \ disjoints_spec (sets_of_ivls guards) fGs; CHECKs (ST ''reach_cont: pre_intersection_step should not change disjointness condition!'') d; iguards \ select_with_inter guardsi IS; iG' \ with_coll_infos iguards hG'; RETURN (hX' \ XS', sfCX' \ CXS, iG' \ GS) } }) (with_infos startstep (XS0:::clw_rel appr1e_rel):::clw_rel (iinfo_rel appr1e_rel), sXS0:::clw_rel appr_rel, op_empty_coll:::clw_rel (\iplane_rel (lvivl_rel::(_\'n rvec set)set), iinfo_rel appr1e_rel\info_rel)); RETURN (CXS, GS) }" definition "reach_cont_par roptns guards XS = do { XS \ sets_of_coll XS; PARS \ PAR_IMAGE (\X (CX, G). G \ (CX \ UNIV) \ (Csafe - guards) \ UNIV \ X \ G \ CX \ UNIV \ flowsto X {0..} (CX \ UNIV) G) (\X. reach_cont roptns guards (mk_coll X)) XS; RETURN (\(fst  snd  PARS), \(snd  snd  PARS)) }" definition "subset_iplane_coll x ics = do { X \ unintersect x; ics \ sets_of_coll ics; FORWEAK ics (RETURN False) (\ic. do { (i, c) \ get_inter ic; sctn \ get_plane c; b1 \ subset_spec_plane X sctn; RETURN (b1 \ op_subset_ivl X i) }) (\b c. RETURN (b \ c)) }" definition "subsets_iplane_coll xs ics = FORWEAK xs (RETURN True) (\x. subset_iplane_coll x ics) (\a b. RETURN (a \ b))" definition "stable_set p = {x. {0..} \ existence_ivl0 x \ (flow0 x \ p) at_top}" definition symstart_coll::"('n::enum eucl1 set \ ('n rvec set \ 'n eucl1 set)nres) \ 'n eucl1 set \ ('n rvec set \ 'n eucl1 set)nres" where "symstart_coll symstart X0 = do { _ \ (fst_safe_colle (X0:::clw_rel appr1e_rel):::\clw_rel appr_rel\nres_rel); X0s \ sets_of_coll X0; (CX1, X1) \ FORWEAK X0s (RETURN (op_empty_coll, op_empty_coll)) (symstart) (\(CX, X) (CX', X'). RETURN (CX' \ CX, X' \ X)); RETURN (CX1, X1) }" definition reach_cont_symstart :: "_ \ _ \ 'n::enum rvec set \ 'n eucl1 set \ ('n rvec set \ 'n eucl1 set) nres" where "reach_cont_symstart ro symstart (guards::'n rvec set) X0 = do { let fX0 = op_image_fst_colle X0; GUARDS \ unintersect_coll guards; d \ disjoints_spec fX0 GUARDS; CHECKs (ST ''reach_cont_symstart: starting from guarded set'') d; (CY, Y0) \ symstart_coll symstart X0; sCY \ (mk_safe_coll (op_image_fst_colle X0 \ CY:::clw_rel appr_rel):::\clw_rel appr_rel\nres_rel); b \ disjoints_spec (op_image_fst_colle Y0 \ CY) GUARDS; CHECKs ''reach_cont_symstart with a stupid guard'' b; (CX, GS) \ (reach_cont_par ro guards Y0:::\clw_rel appr_rel \\<^sub>r clw_rel (\iplane_rel lvivl_rel::(_ \ 'n rvec set) set, iinfo_rel appr1e_rel\info_rel)\nres_rel); let CZ = sCY \ CX; RETURN (CZ, GS) }" context includes autoref_syntax begin\ \TODO: should not be annotating relations here\ definition reach_conts :: "_ \ _ \ _ \ 'n::enum rvec set \ 'n eucl1 set \ ('n rvec set \ ('n rvec set \ 'n eucl1 set) set \ ('n eucl1 set \ 'n eucl1 set)) nres" where "reach_conts ro symstart trap (guardsi::'n rvec set) X0 = do { (CX, GS) \ (reach_cont_symstart ro (symstart:::appr1e_rel \ \clw_rel appr_rel \\<^sub>r clw_rel appr1e_rel\nres_rel) guardsi X0::: \clw_rel appr_rel \\<^sub>r clw_rel (\iplane_rel lvivl_rel::(_\'n rvec set) set, iinfo_rel appr1e_rel\info_rel)\nres_rel); (IGSs:: ('n rvec set \ 'n eucl1 set) set) \ explicit_info_set GS; let GSs = snd  IGSs; ASSUME (finite GSs); CHECKs '''' (GSs \ {}); ASSERT (\f. X0 = \(f  GSs) \ (\G \ GSs. flowsto (f G - trap \ UNIV) {0..} (CX \ UNIV) (G))); X0f \ GSPEC (\f. X0 = \(f  GSs) \ (\G \ GSs. flowsto (f G - trap \ UNIV) {0..} (CX \ UNIV) (G))); let K = (fst  IGSs); b \ subsets_iplane_coll K guardsi; CHECKs (ST ''reach_conts: subsets_iplane_coll'') b; RETURN (CX, IGSs:::\iplane_rel lvivl_rel \\<^sub>r clw_rel (iinfo_rel appr1e_rel)\list_wset_rel, X0f) }" end definition [refine_vcg_def]: "get_sctns X = SPEC (\R. X = below_halfspaces R)" definition "leaves_halfspace S X = do { sctns \ get_sctns S; sctnss \ op_set_to_list sctns; (case sctnss of [] \ RETURN None | [sctn] \ do { (Xi, Xs) \ ivl_rep_of_set_coll X; ASSERT (Xi \ Xs); b \ subset_spec_plane ({Xi .. Xs}:::lvivl_rel) sctn; CHECKs (ST ''leaves_halfspace: not subset of plane'') b; F \ ode_set ({Xi .. Xs}:::appr_rel); sF \ Sup_inner F (normal sctn); CHECKs (ST ''leaves_halfspace: not down from plane'') (sF < 0); RETURN (Some sctn) } | _ \ do {CHECKs (ST ''leaves_halfspace: not a good halfspace'') False; SUCCEED}) }" definition "poincare_start_on guards sctn X0S = do { X0SS \ sets_of_coll X0S; (FORWEAK X0SS (RETURN (op_empty_coll:::clw_rel appr1e_rel, op_empty_coll:::clw_rel appr_rel)) (\X0. do { mk_safe (fst  X0); startstep \ start_stepsize_spec; (h, err, CX1, X1) \ choose_step1e X0 (startstep); let _ = trace_set (ST ''interpolated start step:'') (Some CX1); let _ = print_set True CX1; let _ = trace_set1e (ST ''discrete start step:'') (Some X1); let _ = print_set1e False X1; let fX1 = op_image_fste X1; c0 \ below_sctn (op_image_fste X0) (sctn); c1 \ sbelow_sctn (fX1) (sctn); c2 \ disjoints_spec (mk_coll (fX1)) guards; c3 \ disjoints_spec (mk_coll (CX1)) guards; mk_safe (fX1); mk_safe (CX1); D \ (ode_set (CX1):::\appr_rel\nres_rel); d \ Sup_inner D (normal sctn); let _ = trace_set (ST ''poincare_start_on: D '') (Some D); CHECKs (ST ''poincare_start_on: is away and really moves away'') (c0 \ c1 \ c2 \ c3 \ d < 0); RETURN (mk_coll X1:::clw_rel appr1e_rel, (mk_coll CX1):::clw_rel appr_rel) }) (\(X1, CX1) (X1S, CX1S). RETURN (op_union_coll X1 X1S:::clw_rel appr1e_rel, op_union_coll CX1 CX1S:::clw_rel appr_rel))) }" definition [simp]: "isets_of_iivls x = x" abbreviation "inter_plane A B \ mk_inter A (plane_of B)" definition "do_intersection_core guards ivl sctn hX = do { (h, eX) \ get_info hX; ((l, u), X) \ scaleR2_rep eX; (b, PS1, PS2, CXS) \ do_intersection (guards:::clw_rel (iplane_rel lvivl_rel)) ivl sctn X h; if b then do { PS1e \ scaleRe_ivl_coll_spec l u PS1; PS2e \ scaleRe_ivl_coll_spec l u PS2; RETURN (PS1e, PS2e, CXS, op_empty_coll) } else RETURN (op_empty_coll, op_empty_coll, op_empty_coll, mk_coll eX) }" definition "do_intersection_coll guards ivl sctn X = do { Xs \ sets_of_coll X; CHECKs ''nonempty inter nonfinite: '' (Xs \ {}); RS \ PAR_IMAGE (\X. \(P1, P2, CX, X0s). do_intersection_spec UNIV guards ivl sctn (X - X0s) (P1, CX) \ do_intersection_spec UNIV guards ivl sctn (X - X0s) (P2, CX) \ fst  (X - X0s) \ CX \ X0s \ X) (do_intersection_core guards ivl sctn) Xs; ASSUME (finite RS); RETURN ((\(X, (P1, P2, CX, X0s))\RS. P1), (\(X, (P1, P2, CX, X0s))\RS. P2), (\(X, (P1, P2, CX, X0s))\RS. CX), (\(X, (P1, P2, CX, X0s))\RS. X0s)) }" definition "op_enlarge_ivl_sctn ivl sctn d = do { (l, u) \ ivl_rep ivl; CHECKs ''op_enlarge_ivl_sctn: trying to shrink'' (d \ 0); CHECKs ''op_enlarge_ivl_sctn: empty ivl'' (l \ u); CHECKs ''op_enlarge_ivl_sctn: not in Basis'' (abs (normal sctn) \ set Basis_list); let dOne = sum_list (map (\i. d *\<^sub>R i) Basis_list) - d *\<^sub>R abs (normal sctn); ASSERT (l - dOne \ u + dOne); RETURN (op_atLeastAtMost_ivl (l - dOne) (u + dOne)) }" definition "guardset guards = Union (case_prod ($$  ($$x, y). (x, plane_of y))  guards)" definition "resolve_ivlplanes (guards::'n::enum rvec set) (ivlplanes::'n::enum rvec set) XS = FORWEAK XS (RETURN ({})) (\(ivlplane, X). do { (ivl, plane) \ (get_inter (ivlplane)); ASSUME (closed ivl); sctn \ (get_plane plane); b \ subset_iplane_coll ivlplane ivlplanes; CHECKs ''reach_conts: subsets_iplane_coll'' b; (PS1, PS2, CXS, RS) \ (do_intersection_coll guards ivl sctn X); RETURN {(uninfo X, PS1, PS2, RS, ivl, sctn, CXS)} }) (\(PS) (PS'). RETURN (PS' \ PS))" context includes autoref_syntax begin definition "poincare_onto ro \ \options\ symstart trap \ \symbolic start and trap\ (guards::'n::enum rvec set) \ \avoiding guards\ (ivlplanes::'n::enum rvec set) \ \target sections\ (XS0::'n eucl1 set) (CXS0::'n rvec set) = do { (CXS, XS, X0s) \ (reach_conts ro (symstart:::appr1e_rel \ \clw_rel appr_rel \\<^sub>r clw_rel appr1e_rel\nres_rel) trap (ivlplanes \ guards) XS0::: \clw_rel appr_rel \\<^sub>r \iplane_rel lvivl_rel \\<^sub>r clw_rel (iinfo_rel appr1e_rel)\list_wset_rel \\<^sub>r ghost_rel\nres_rel); PS \ resolve_ivlplanes guards ivlplanes XS; _ \ mk_safe_coll CXS0; RETURN ((\(X, P1, P2, R, ivl, sctn, CX). (X, P1, P2, R, ivl, sctn, CX, CXS \ CXS0))  PS) }" definition "empty_remainders PS = FORWEAK PS (RETURN True) (\(X, P1, P2, R, ivl, sctn, CX, CXS). do { e \ isEmpty_spec R; RETURN e}) (\a b. RETURN (a \ b))" definition [simp]: "empty_trap = {}" definition empty_symstart::"((real, 'a) vec \ (real, 'a) vec \\<^sub>L (real, 'a) vec) set \ ((real, 'a) vec set \ ((real, 'a) vec \ (real, 'a) vec \\<^sub>L (real, 'a) vec) set) nres" where [simp]: "empty_symstart \ \X. RETURN (op_empty_coll, mk_coll X)" definition "poincare_onto_empty ro \ \options\ (guards::'n::enum rvec set) \ \avoiding guards\ (ivlplanes::'n::enum rvec set) \ \target sections\ (XS0::'n eucl1 set) = poincare_onto ro (OP empty_symstart:::appr1e_rel \ \clw_rel appr_rel \\<^sub>r clw_rel appr1e_rel\nres_rel) empty_trap guards ivlplanes XS0" definition "poincare_onto2 ro \ \options\ symstart trap \ \symbolic start and trap\ (guards::'n::enum rvec set) \ \avoiding guards\ (ivlplanes::'n::enum rvec set) \ \target sections\ (XS0::'n eucl1 set) = do { (PS) \ (poincare_onto ro (symstart:::appr1e_rel \ \clw_rel appr_rel \\<^sub>r clw_rel appr1e_rel\nres_rel) trap guards ivlplanes XS0 op_empty_coll::: \\clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r lvivl_rel \\<^sub>r \lv_rel\sctn_rel \\<^sub>r clw_rel (isbelows_rel appr_rel) \\<^sub>r clw_rel appr_rel\list_wset_rel\nres_rel); (PS2) \ FORWEAK PS (RETURN ({})) (\(X, P1, P2, R, ivl, sctn, CX, CXS). if op_coll_is_empty R then RETURN ({}) else do { ivlplaness \ (sets_of_coll ivlplanes:::\\iplane_rel lvivl_rel\list_wset_rel\nres_rel); ivlplaness' \ op_set_ndelete (mk_inter ivl (plane_of sctn)) ivlplaness; let ivlplanes' = (\(mk_coll  ivlplaness':::\clw_rel (iplane_rel lvivl_rel)\list_wset_rel)); PS' \ (poincare_onto_empty ro (guards) ivlplanes' R CXS::: \\clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r lvivl_rel \\<^sub>r \lv_rel\sctn_rel \\<^sub>r clw_rel (isbelows_rel appr_rel) \\<^sub>r clw_rel appr_rel\list_wset_rel\nres_rel); b \ empty_remainders PS'; CHECKs (ST ''poincare_onto2: empty remainders!'') b; ASSUME (finite PS'); RETURN PS' }) (\PS PS'. RETURN (PS' \ PS)); RETURN (Pair True  PS2 \ Pair False  PS) }" definition "width_spec_ivl M x = do { (i, s) \ ivl_rep x; RETURN (\(i, s)\zip (take M (list_of_eucl i)) (take M (list_of_eucl s)). abs (s - i)) }" definition partition_ivl::"_ \ 'a::executable_euclidean_space set \ 'a::executable_euclidean_space set nres" where "partition_ivl roptns xs = (if op_coll_is_empty xs then RETURN (op_empty_coll:::clw_rel lvivl_rel) else do { (i, s) \ ivl_rep_of_set_coll (sets_of_ivls (xs:::clw_rel lvivl_rel):::clw_rel appr_rel); ASSERT (i \ s); let r = (op_atLeastAtMost_ivl i s); (rs, ps) \ WHILE\<^bsup>(\(rs, ps). (xs) \ rs \ ps)\<^esup> (\(rs, ps). \ op_coll_is_empty (rs:::clw_rel lvivl_rel)) (\(rs, ps). do { (r, rs') \ (split_spec_exact rs:::\lvivl_rel \\<^sub>r clw_rel lvivl_rel\nres_rel); (ri, rs) \ ivl_rep r; CHECKs (ST ''partition_ivl with strange ivl'') (ri \ rs); width \ width_spec ({ri .. rs}:::appr_rel); pig \ post_inter_granularity_spec roptns; if width \ pig then RETURN (rs', mk_coll r \ ps) else do { (a, b) \ split_spec_ivl (DIM('a)) r; let isa = (op_inter_ivl_coll (xs:::clw_rel lvivl_rel) (a:::lvivl_rel)); let isb = (op_inter_ivl_coll(xs:::clw_rel lvivl_rel) (b:::lvivl_rel)); ra' \ (if op_coll_is_empty isa then RETURN op_empty_coll else do { (i', s') \ ivl_rep_of_set_coll (sets_of_ivls isa); RETURN (mk_coll (({i' .. s'}:::lvivl_rel) \ a)) }); rb' \ (if op_coll_is_empty isb then RETURN op_empty_coll else do { (i', s') \ ivl_rep_of_set_coll (sets_of_ivls isb); RETURN (mk_coll (({i' .. s'}:::lvivl_rel) \ b)) }); RETURN (ra' \ rb' \ rs', ps) } }) (mk_coll r:::clw_rel lvivl_rel, op_empty_coll :::clw_rel lvivl_rel); RETURN ps })" definition "vec1repse X = do { XS \ sets_of_coll X; FORWEAK XS (RETURN (Some op_empty_coll)) (\x. do { ((l, u), x) \ scaleR2_rep x; xo \ vec1rep x; case xo of None \ RETURN None | Some x \ do { xe \ scaleRe_ivl_spec l u x; RETURN (Some (mk_coll xe)) } }) (\a b. case (a, b) of (Some a, Some b) \ RETURN (Some (b \ a)) | _ \ RETURN None) }" abbreviation "appre_rel \ \appr_rel\scaleR2_rel" definition "scaleR2_rep1 (Y::('a::executable_euclidean_space\_) set) = do { let D = DIM('a); ((l, u), X) \ scaleR2_rep Y; (i, s) \ op_ivl_rep_of_set X; let mig = inf (abs i) (abs s); CHECKs (ST ''scaleR2_rep1: strange'') (i \ s); (N::real set) \ approx_slp_appr [floatarith.Inverse (norm2\<^sub>e D)] (norm2_slp D) (list_of_eucl  ({mig .. mig}:::appr_rel)); (sl, su) \ op_ivl_rep_of_set (N:::appr_rel); let scale = (rnv_of_lv sl + rnv_of_lv su)/2; CHECKs (ST ''scaleR2_rep1: scale 0'') (scale > 0); CHECKs (ST ''scaleR2_rep1: l 0'') (l > 0); CHECKs (ST ''scaleR2_rep1: u 0'') (u > 0); precision \ precision_spec; let scalel = real_divl (precision) 1 scale; let scaleu = real_divr (precision) 1 scale; CHECKs (ST ''scaleR2_rep1: scalel 0'') (scalel > 0); CHECKs (ST ''scaleR2_rep1: scaleu 0'') (scaleu > 0); (i, s) \ op_ivl_rep_of_set X; let (i0, i1) = split_lv_rel i; let (s0, s1) = split_lv_rel s; scaleRe_ivl_spec (scalel * l) (scaleu * u) (op_atLeastAtMost_ivl (Pair_lv_rel i0 (scale *\<^sub>R i1)) (Pair_lv_rel s0 (scale *\<^sub>R s1))) }" definition "ivlse_of_setse X = do { Xs \ sets_of_coll X; FORWEAK Xs (RETURN op_empty_coll) (\X. do { I \ scaleR2_rep1 X; I \ reduces_ivle I; RETURN (mk_coll I) }) (\X' X. RETURN (X' \ X)) }" definition [simp]: "op_image_flow1_of_vec1_colle \ op_image_flow1_of_vec1_coll" definition "okay_granularity ro r = do { (ri, rs) \ ivl_rep r; CHECKs (ST ''partition_ivle with strange ivl'') (ri \ rs); width \ width_spec ({ri .. rs}:::appr_rel); pig \ post_inter_granularity_spec ro; RETURN (width\pig) }" definition partition_set::"unit \ 'n::enum eucl1 set \ 'n eucl1 set nres" where "partition_set ro xs = (if op_coll_is_empty xs then RETURN (op_empty_coll:::clw_rel appr1e_rel) else do { ASSERT (xs \ {}); pcg \ pre_collect_granularity_spec ro; xs \ split_under_threshold ro pcg (xs:::clw_rel appr1e_rel); vxs \ vec1repse xs; case vxs of None \ do { xs \ ivls_of_sets (op_image_fst_colle xs); ps \ partition_ivl ro xs; scaleRe_ivl_coll_spec 1 1 (sets_of_ivls ps \ UNIV:::clw_rel appr1_rel) } | Some xs \ do { xs \ ivlse_of_setse xs; ps \ (OP partition_ivle)  ro  xs; ps \ setse_of_ivlse ps; RETURN (op_image_flow1_of_vec1_colle ps) } })" definition partition_sets::"unit \ (bool \ 'a::enum eucl1 set \ 'a::enum eucl1 set \ 'a::enum eucl1 set \ 'a::enum eucl1 set \ 'a rvec set \ 'a rvec sctn \ 'a rvec set \ 'a rvec set) set \ 'a eucl1 set nres" where "partition_sets ro xs = FORWEAK xs (RETURN op_empty_coll) (\(b, X, PS1, PS2, R, ivl', sctn', CX, CXS). do { PS \ partition_set ro PS1; RETURN PS }) (\a b. RETURN (b \ a))" definition "ivlsctn_to_set xs = (\(ivl, sctn)\set xs. ivl \ plane_of sctn)" definition [refine_vcg_def]: "singleton_spec X = SPEC (\x. X = {x})" primrec poincare_onto_series where "poincare_onto_series interrupt trap [] XS0 ivl sctn ro = do { let guard0 = mk_coll (mk_inter ivl (plane_of sctn)); ASSUME (closed guard0); XS1 \ (poincare_onto2 (ro:::Id) (interrupt:::appr1e_rel \ \clw_rel appr_rel \\<^sub>r clw_rel appr1e_rel\nres_rel) trap (op_empty_coll:::clw_rel (iplane_rel lvivl_rel)) guard0 XS0::: \\bool_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r lvivl_rel \\<^sub>r \lv_rel\sctn_rel \\<^sub>r clw_rel (isbelows_rel appr_rel) \\<^sub>r clw_rel appr_rel\list_wset_rel\nres_rel); (b, X, PS1, PS2, R, ivl', sctn', CX, CXS) \ singleton_spec XS1; CHECKs (ST ''poincare_onto_series: last return!'') (ivl' = ivl \ sctn' = sctn); RETURN PS2 }" | "poincare_onto_series interrupt trap ((guardro)#guards) XS0 ivl sctn ro0 = (case guardro of (guard, ro) \ do { ASSUME (closed ivl); let guard0 = mk_coll (mk_inter ivl (plane_of sctn)); ASSUME (closed guard0); ASSUME (\(guard, ro) \ set (guardro#guards). closed guard); let guardset = (\(guard, ro)\set ((guard0, ro0)#guards). guard); XS1 \ (poincare_onto2 ro (interrupt:::appr1e_rel \ \clw_rel appr_rel \\<^sub>r clw_rel appr1e_rel\nres_rel) trap (guardset:::clw_rel (iplane_rel lvivl_rel)) guard XS0 ::: \\bool_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r lvivl_rel \\<^sub>r \lv_rel\sctn_rel \\<^sub>r clw_rel (isbelows_rel appr_rel) \\<^sub>r clw_rel appr_rel\list_wset_rel\nres_rel); ASSUME (\(b, X, PS1, PS1, R, ivl, sctn, CX, CXS) \ XS1. closed ivl); XS2 \ partition_sets ro XS1; _ \ fst_safe_colle XS2; XS3 \ poincare_onto_series interrupt trap guards XS2 ivl sctn (ro0:::Id); RETURN XS3 })" definition "poincare_onto_from interrupt trap S \ \leaving this (half)space in the beginning\ (guards) \ \avoiding guards\ (ivl::'n rvec set) \ \onto \ivl\\ sctn \ \which is part of \sctn\\ ro (XS0::'n::enum eucl1 set) = do { ASSUME (closed ivl); let guardset = (\(ivlsctn, ro)\set (guards). ivlsctn:::clw_rel (iplane_rel lvivl_rel)); lsctn \ leaves_halfspace S (op_image_fst_colle XS0); XS0 \ (case lsctn of None \ RETURN XS0 | Some lsctn => do { CHECKs (ST ''poincare_onto_from: section only makes sense if start section = end section'') (lsctn = sctn \ normal lsctn = - normal sctn \ pstn lsctn = - pstn sctn); guards \ unintersect_coll guardset; b \ subset_spec_coll (op_image_fst_colle XS0) ivl; CHECKs (ST ''poincare_onto_from: section only makes sense if we start from there'') b; (XS0, _) \ poincare_start_on guards lsctn (XS0); RETURN XS0 } ); PS \ poincare_onto_series interrupt trap guards XS0 ivl sctn ro; RETURN PS }" definition "subset_spec1 R P dP = do { R1 \ vec1rep R; dP \ default_rep UNIV dP; case (R1, dP) of (_, None) \ op_subset (fst  R) P | (Some RdR, Some dP) \ op_subset RdR (P \ dP) | (None, Some _) \ RETURN False }" definition "subset_spec1_coll R P dP = do { XS \ sets_of_coll R; WEAK_ALL (\x. x \ flow1_of_vec1  (P \ dP)) XS (\X. subset_spec1 X P dP) }" definition "one_step_until_time X0 (ph::bool) (t1::real) = do { CHECKs ''one_step_until_time optns'' (0 \ t1); startstep \ start_stepsize_spec; rk2param \ rk2_param_spec; let fX0 = fst  X0; mk_safe (fX0); (t, _, X, CX) \ WHILE (\(t, _, _, _). t < t1) (\(t, h, X, CXs). do { let _ = trace_set1e (ST ''choose step from:'') (Some X); (h0, CX, X, h') \ step_adapt_time X (min h (t1 - t)); CHECKs (ST ''one_step negative step'') (h0 \ 0 \ h' > 0 \ h0 \ min h (t1 - t)); let _ = trace_set (ST ''interpolated step:'') (Some CX); let _ = print_set True CX; let _ = trace_set1e (ST ''step:'') (Some X); let _ = print_set1e False X; let fCX = CX; mk_safe fCX; let fX = fst  X; mk_safe fX; RETURN (t + h0, h', X, mk_phantom (mk_coll CX) \ CXs) }) (0::real, startstep, X0, op_union_phantom (mk_phantom (mk_coll fX0)) (op_empty_phantom ph)); RETURN (X, CX) }" definition "ivl_of_eucl_coll CY = do { (i, s) \ ivl_rep_of_set_coll CY; ASSERT (i \ s); RETURN (({i .. s}\UNIV):::appr1_rel) }" definition "one_step_until_time_ivl X0 (ph::bool) (t1::real) (t2::real) = do { (X, CX) \ one_step_until_time X0 ph t1; CHECKs (ST ''one_step_until_time_ivl empty time interval'') (0 \ t1 \ t1 \ t2); (if t2 = t1 then RETURN (X, CX) else do { (Y, CYp) \ one_step_until_time X False (t2 - t1); CY \ get_phantom CYp; R \ ivl_of_eucl_coll CY; mk_safe (fst  R); R \ scaleRe_ivl_spec 1 1 R; RETURN (R, CYp \ CX) }) }" definition "c1_info_invare n X = (let l = (fst (fst X)); u = (snd (fst X)) in (c1_info_invar n (snd X)) \ (l < u \ -\ < l \ l \ u \ u <$$)" definition "c0_info_of_appr X = eucl_of_list  set_of_appr X" definition "c0_info_of_apprs X = (\x\set X. c0_info_of_appr x)" definition "c0_info_of_appr' X = the_default UNIV (map_option c0_info_of_apprs X)" lemma the_default_eq: "the_default a x = (case x of None \ a | Some b \ b)" by (auto split: option.splits) definition "poincare_onto_from_in_ivl interrupt trap S \ \leaving this (half)space in the beginning\ (guards) \ \avoiding guards\ (ivl::'n rvec set) \ \onto \ivl\\ sctn \ \which is part of \sctn\\ ro (XS0::'n::enum eucl1 set) P dP = do { RS \ poincare_onto_from interrupt trap S guards ivl sctn ro XS0; ((l, u), R) \ scaleR2_rep_coll RS; CHECKs (ST ''poincare_onto_from_in: there should not be scaleR2'') (l = 1 \ u = 1); (l, u) \ ivl_rep P; CHECKs (ST ''poincare_onto_from_in: strange interval'') (l \ u); _ \ mk_safe {l .. u}; subset_spec1_coll R P dP }" definition "set_of_lvivl' x = (case x of None \ UNIV | Some x \ set_of_lvivl x)" definition "lvivl'_invar n x = (case x of None \ True | Some (l, u) \ length l = length u \ length u = n)" definition "one_step_until_time_ivl_in_ivl X0 (t1::real) (t2::real) R dR = do { (X, CX) \ one_step_until_time_ivl X0 True t1 t2; ((l, u), X) \ scaleR2_rep X; CHECKs (ST ''one_step_until_time_ivl_in_ivl: there should not be scaleR2'') (l = 1 \ u = 1); (l, u) \ ivl_rep R; CHECKs (ST ''one_step_until_time_ivl_in_ivl: strange interval'') (l \ u); _ \ mk_safe {l .. u}; let _ = trace_set1 (ST ''final step to:'') (Some X); let _ = trace_set (ST ''contained in?'') (Some {l .. u}); let _ = print_set1 False X; let _ = print_set False {l .. u}; subset_spec1 X R dR }" definition "poincare_onto_in_ivl (guards) \ \avoiding guards\ (ivl::'n rvec set) \ \onto \ivl\\ sctn \ \which is part of \sctn\\ ro (XS0::'n::enum eucl1 set) P dP = do { RS \ poincare_onto_series empty_symstart empty_trap guards XS0 ivl sctn ro; ((l, u), R) \ scaleR2_rep_coll RS; CHECKs (ST ''poincare_onto_in_ivl: there should not be scaleR2'') (l = 1 \ u = 1); (l, u) \ ivl_rep P; CHECKs (ST ''poincare_onto_in_ivl: strange interval'') (l \ u); (lR, uR) \ ivl_rep_of_set_coll (op_image_fst_coll R); CHECKs (ST ''poincare_onto_in_ivl: strange interval2'') (lR \ uR); let _ = trace_set (ST ''final step to:'') (Some {lR .. uR}); let _ = trace_set (ST ''contained in?'') (Some {l .. u}); _ \ mk_safe {l .. u}; subset_spec1_coll R P dP }" definition "poincare_maps_onto \ X0 X1 \ poincare_mapsto \ X0 UNIV (Csafe - \) X1" end end end \ No newline at end of file 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 \ (Id::'b numeric_options rel)" consts i_flow1::interface consts i_appr1::interface abbreviation "float10_rel \ Id::(float10 \ float10) set" lemma inj_on_nat_add_square: "inj_on (\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 \ 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)\num_optns_rel \ nat_rel" "(start_stepsize, start_stepsize)\num_optns_rel \ rnv_rel" "(iterations, iterations)\ num_optns_rel\ nat_rel" "(halve_stepsizes, halve_stepsizes)\ (num_optns_rel) \ nat_rel" "(widening_mod, widening_mod)\ (num_optns_rel) \nat_rel" "(rk2_param, rk2_param)\ (num_optns_rel) \ rnv_rel" "(method_id, method_id)\ (num_optns_rel) \ nat_rel" "(adaptive_atol, adaptive_atol)\ (num_optns_rel) \ rnv_rel" "(adaptive_rtol, adaptive_rtol)\ (num_optns_rel) \ rnv_rel" "(printing_fun, printing_fun)\ (num_optns_rel) \ bool_rel \ I \ unit_rel" "(tracing_fun, tracing_fun)\ (num_optns_rel) \ string_rel \ \I\option_rel \ unit_rel" by auto end lemma [autoref_op_pat_def]: includes autoref_syntax shows "(\xs. xs @ replicate D 0)  X \ OP (pad_zeroes D) $X" "pad_zeroes D X \ OP (pad_zeroes D)$ X" by simp_all subsection \Relation Implementing \ode_ops\: Caching \slp_of\-Programs.\ 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 \ init = init_ode_ops True False ode_ops \ 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) \ bool_rel \ A \ Id" by auto lemma trace_set_impl[autoref_rules]: shows "(tracing_fun optns, trace_set) \ string_rel \ \A\option_rel \ 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) \ string_rel \ 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 \ rk \ 1 then rk else 1)" lemma options_impl[autoref_rules]: "(RETURN (precision optns), precision_spec) \ \nat_rel\nres_rel" "(RETURN (adaptive_atol optns), adaptive_atol_spec) \ \rnv_rel\nres_rel" "(RETURN (adaptive_rtol optns), adaptive_rtol_spec) \ \rnv_rel\nres_rel" "(RETURN (method_id optns), method_spec) \ \nat_rel\nres_rel" "(RETURN start_stepsize_impl, start_stepsize_spec) \ \rnv_rel\nres_rel" "(RETURN (iterations optns), iterations_spec) \ \nat_rel\nres_rel" "(RETURN (widening_mod optns), widening_mod_spec) \ \nat_rel\nres_rel" "(RETURN (halve_stepsizes optns), halve_stepsizes_spec) \ \nat_rel\nres_rel" "(RETURN (rk2_param_impl), rk2_param_spec) \ \rnv_rel\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) \ string_rel" "(Xi, X) \ clw_rel appr_rel" shows "(RETURN ?f, trace_sets s X) \ \unit_rel\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) \ bool_rel" "(Xi, X) \ clw_rel appr_rel" shows "(RETURN ?f, print_sets s X) \ \unit_rel\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, _, _, _, _), _, _) \ x)" definition "euler_incr_slp_impl ode_ops = (case ode_ops of (_, (_, x, _, _, _), _, _) \ x)" definition "euler_slp_impl ode_ops = (case ode_ops of (_, (_, _, x, _, _), _, _) \ x)" definition "rk2_slp_impl ode_ops = (case ode_ops of (_, (_, _, _, x, _), _, _) \ x)" definition "D_impl ode_ops = (case ode_ops of (_, (_, _, _, _, x), _, _) \ x)" definition "poincare_slp_impl ode_ops = (case ode_ops of (ode_ops, (_, _, _, _, _), x, _) \ (case x of None \ let _ = print_msg_impl (''ODE solver not initialized: pslp missing'') in solve_poincare_slp ode_ops | Some pslp \ pslp))" lemma autoref_parameters[autoref_rules]: "(ode_slp_impl, ode_slp) \ ode_ops_rel \ slp_rel" "(euler_incr_slp_impl, euler_incr_slp) \ ode_ops_rel \ slp_rel" "(euler_slp_impl, euler_slp) \ ode_ops_rel \ slp_rel" "(rk2_slp_impl, rk2_slp) \ ode_ops_rel \ slp_rel" "(poincare_slp_impl, solve_poincare_slp) \ ode_ops_rel \ \slp_rel\list_rel" "(D_impl, D) \ ode_ops_rel \ 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 = ($$ode_ops, _). ode_expression ode_ops)" lemma ode_e_impl[autoref_rules]: "(ode_e_impl, ode_e) \ ode_ops_rel \ fas_rel" by (auto simp: ode_e_impl_def ode_e_def ode_ops_rel_def init_ode_ops_def) definition "safe_form_impl = (\(ode_ops, _). safe_form ode_ops)" lemma safe_form_impl[autoref_rules]: "(safe_form_impl, safe_form) \ ode_ops_rel \ 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) \ appr_rel" assumes [autoref_rules]: "(odoi, odo) \ ode_ops_rel" notes [autoref_rules] = autoref_parameters shows "(nres_of ?f, safe_set odo X) \ \bool_rel\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) \ ode_ops_rel" assumes [autoref_rules]: "(Ri, R) \ appr_rel" shows "(nres_of ?f, mk_safe odo (R::'a::executable_euclidean_space set)) \ \appr_rel\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) \ clw_rel appr_rel" assumes [autoref_rules]: "(odoi, odo) \ ode_ops_rel" shows "(nres_of (?f), mk_safe_coll odo (IS::'a::executable_euclidean_space set)) \ \clw_rel appr_rel\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) \ appr_rel" assumes [autoref_rules]: "(odoi, odo) \ ode_ops_rel" notes [autoref_rules] = autoref_parameters shows "(nres_of ?f, ode_set odo X::'a set nres) \ \appr_rel\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) \ ode_ops_rel" assumes [autoref_rules]: "(X0i,X0)\appr_rel" "(hi, h) \ rnv_rel" "(t0i, t0) \ rnv_rel" "(PHIi,PHI)\appr_rel" notes [autoref_rules] = autoref_parameters shows "(nres_of ?f, Picard_step_ivl odo X0 t0 h PHI::'a set option nres) \ \\appr_rel\option_rel\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 \ 'a::executable_euclidean_space) \ rnv_rel \ rnv_rel" by simp_all lemma widening_spec[autoref_rules]: "(\i. RETURN (widening_mod optns mod i = 0), do_widening_spec) \ nat_rel \ \bool_rel\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) \ ode_ops_rel" assumes [autoref_rules]: "(X0i,X0)\appr_rel" "(PHIi,PHI)\appr_rel" "(hi, h) \ Id" "(i_i, i) \ Id" notes [autoref_rules] = autoref_parameters shows "(nres_of (?f::?'r dres), P_iter odo X0 h i PHI::'a set option nres) \ ?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)\(appr_rel \ rnv_rel \ rnv_rel \ appr_rel \ \\appr_rel \\<^sub>r R\ option_rel\nres_rel)" "(X0i,X0)\appr_rel" "(hi, h) \ rnv_rel" "(ni, n) \ nat_rel" "(i_i, i) \ nat_rel" assumes [autoref_rules]: "(odoi, odo) \ ode_ops_rel" shows "(?f::?'r nres, cert_stepsize odo m (X0::'a set) h n i) \ ?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]: "\a b c d. nres_of (m a b c d) \ m' a b c d" shows "nres_of ?f \ 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: ) lemma default_reduce_argument_spec_impl[autoref_rules]: "(RETURN (default_reduce optns), default_reduce_argument_spec) \ \reduce_argument_rel TYPE('b)\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) \ appr_rel" "(hi, h) \ Id" assumes [autoref_rules]: "(odoi, odo) \ ode_ops_rel" shows "(nres_of (?f::?'r dres), euler_step odo (X::'a set) h) \ ?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) \ appr_rel" "(hi, h) \ Id" notes [simp] = ncc_precondD[OF ncc] assumes [autoref_rules]: "(odoi, odo) \ ode_ops_rel" shows "(nres_of (?f::?'r dres), rk2_step odo (X::'a set) h) \ ?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) \ appr_rel" "(hi, h) \ rnv_rel" assumes [autoref_rules]: "(odoi, odo) \ ode_ops_rel" shows "(nres_of (?f), choose_step odo (X::'a set) h) \ \rnv_rel \\<^sub>r appr_rel \\<^sub>r appr_rel \\<^sub>r appr_rel\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) \ rnv_rel \ 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) \ lv_rel" shows "(?f, strongest_direction (x::'a)) \ lv_rel \\<^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) \ nat_rel \ rnv_rel \ rnv_rel \ rnv_rel" "(truncate_down, truncate_down) \ nat_rel \ rnv_rel \ rnv_rel" "(eucl_truncate_down, eucl_truncate_down) \ nat_rel \ rnv_rel \ rnv_rel" "(truncate_up, truncate_up) \ nat_rel \ rnv_rel \ rnv_rel" "(eucl_truncate_up, eucl_truncate_up) \ nat_rel \ rnv_rel \ rnv_rel" "(max, max) \ rnv_rel \ rnv_rel \ rnv_rel" "(min, min) \ rnv_rel \ rnv_rel \ rnv_rel" "((/), (/)) \ rnv_rel \ rnv_rel \ rnv_rel" "(lfloat10, lfloat10) \ rnv_rel \ float10_rel" "(ufloat10, ufloat10) \ rnv_rel \ float10_rel" "(shows_prec, shows_prec) \ nat_rel \ nat_rel \ string_rel \ string_rel" "(shows_prec, shows_prec) \ nat_rel \ int_rel \ string_rel \ string_rel" "(shows_prec, shows_prec) \ nat_rel \ float10_rel \ string_rel \ string_rel" "(int, int) \ nat_rel \ int_rel" by (auto simp: string_rel_def) schematic_goal intersects_sctns_spec_impl: assumes [autoref_rules]: "(ai, a) \ appr_rel" assumes sctns[autoref_rules]: "(sctnsi, sctns) \ sctns_rel" notes [simp] = list_set_rel_finiteD[OF sctns] shows "(nres_of (?x::_ dres), intersects_sctns (a::'a::executable_euclidean_space set) sctns) \ \bool_rel\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 \ \rnv_rel\nres_rel)" assumes "\x. TRANSFER (RETURN (wsd x) \ ws x)" shows width_spec_invar_rel[autoref_rules]: "(\(a, b). RETURN (wsd a), width_spec) \ \S, A\invar_rel b \ \rnv_rel\nres_rel" and width_spec_inter_rel[autoref_rules]: "(\(a, b). RETURN (wsd a), width_spec) \ \S, A\inter_rel \ \rnv_rel\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 \ \rnv_rel\nres_rel)" assumes "\x. TRANSFER (RETURN (wsd x) \ ws x)" shows "(\xs. RETURN (sum_list (map wsd xs)), width_spec) \ clw_rel A \ \rnv_rel\nres_rel" by (auto simp: nres_rel_def width_spec_def) schematic_goal intersects_sections_spec_clw[autoref_rules]: assumes [autoref_rules]: "(Ri, R) \ clw_rel appr_rel" "(sctnsi, sctns) \ sctns_rel" shows "(nres_of (?r::_ dres), intersects_sctns_spec_clw  R  sctns) \ \bool_rel\nres_rel" unfolding intersects_sctns_spec_clw_def including art by autoref_monadic schematic_goal nonzero_component_impl: assumes [autoref_rules]: "(Xi, X) \ appr_rel" "(ni, n) \ lv_rel" "(si, s) \ string_rel" shows "(nres_of ?f, nonzero_component s X n) \ \unit_rel\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 \ set_of_appr XS" "tXS = take d XS" "d < length xs" shows "take d xs \ set_of_appr tXS" using set_of_appr_project[OF assms(1), of "[0.. single_valued Y \ Domain X \ Domain Y = {} \ single_valued (X \ 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 ($$ (A \ A \ bool_rel)" shows "($$x, y). \ le x y, is_empty) \ \A\ivl_rel \ 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) \ nat_rel \ rnv_rel" by auto lemma map_option_autoref[autoref_rules]: "(map_option, map_option) \ (A \ B) \ \A\option_rel \ \B\option_rel" by (rule map_option_param) lemma sv_plane_rel[relator_props]: "single_valued A \ single_valued (\A\plane_rel)" by (auto simp: plane_rel_def intro!: relator_props) lemma sv_below_rel[relator_props]: "single_valued A \ single_valued (\A\below_rel)" by (auto simp: below_rel_def intro!: relator_props) lemma sv_sbelow_rel[relator_props]: "single_valued A \ single_valued (\A\sbelow_rel)" by (auto simp: sbelow_rel_def intro!: relator_props) lemma sv_sbelows_rel[relator_props]: "single_valued A \ single_valued (\A\sbelows_rel)" by (auto simp: sbelows_rel_def intro!: relator_props) lemma closed_ivl_rel[intro, simp]: "(a, b) \ lvivl_rel \ closed b" by (auto simp: ivl_rel_def br_def set_of_ivl_def) lemma [autoref_rules]: "(float_of, float_of) \ rnv_rel \ Id" - "(approx, approx) \ nat_rel \ Id \ \\Id \\<^sub>r Id\option_rel\list_rel \ \Id \\<^sub>r Id\option_rel" + "(approx, approx) \ nat_rel \ Id \ \\Id\option_rel\list_rel \ \Id\option_rel" by auto lemma uninfo_autoref[autoref_rules]: assumes "PREFER single_valued X" assumes "PREFER single_valued R" shows "(map snd, uninfo) \ clw_rel (\R, X\info_rel) \ 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]: "($$ \ 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 (\) (A \ A \ bool_rel)" shows "($$a, b) (c, d). le a b \ le c a \ le b d, op_subset_ivl) \ \A\ivl_rel \ \A\ivl_rel \ 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]: "(=) \ 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 ($$ (A \ A \ bool_rel)" shows "($$a, b) (c, d). (le a b \ le c a \ le b d) \ (le c d \ le a c \ le d b), op_eq_ivl) \ \A\ivl_rel \ \A\ivl_rel \ 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: ) done concrete_definition eq_ivl_impl uses eq_ivl_impl lemmas [autoref_rules] = eq_ivl_impl.refine lemma [autoref_rules]: "(RETURN, get_plane) \ \A\plane_rel \ \\A\sctn_rel\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 \ OP (get_inter p)" by auto lemma inform_autoref[autoref_rules]: "(\x. Max (abs  set x), (infnorm::'a::executable_euclidean_space\real)) \ lv_rel \ 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) \ appr_rel" assumes [autoref_rules]: "(Ei, E) \ appr_rel" shows "(nres_of ?r, tolerate_error Y E) \ \bool_rel \\<^sub>r rnv_rel\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) \ rnv_rel \ nat_rel \ rnv_rel \ rnv_rel \ Id" by auto lemma list_wset_rel_finite: assumes "single_valued A" shows "(xs, X) \ \A\list_wset_rel \ 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) \ nat_rel \ Id" and [autoref_itype del]: "norm2_slp ::\<^sub>i i_nat \\<^sub>i i_of_rel (Id::(floatarith list \ floatarith list) set)" by auto lemma [autoref_rules]: "(norm2_slp, norm2_slp) \ nat_rel \ slp_rel" by auto lemma [autoref_rules_raw]: "DIM_precond TYPE(real) (Suc 0)" by auto lemma [autoref_rules]: "(real_divr, real_divr) \ nat_rel \ rnv_rel \ rnv_rel \ rnv_rel" by auto lemma length_norm2_slp_ge: "length (norm2_slp E) \ 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) \ clw_rel (iplane_rel lvivl_rel) \ 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') \ clw_rel (iplane_rel lvivl_rel) \\<^sub>r A" assumes "(xa, x'a) \ \clw_rel (iplane_rel lvivl_rel) \\<^sub>r B\list_rel" shows "\(guard, ro)\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 "\x xs a. snd (h x xs a) = snd a" shows "rec_list z (\x xs r xa. f x xs xa (r (h x xs xa))) xs ab = rec_list (\a. z (a, snd ab)) (\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 "\x xs a. fst (h x xs a) = fst a" shows "rec_list z (\x xs r xa. f x xs xa (r (h x xs xa))) xs ab = rec_list (\b. z (fst ab, b)) (\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 \\<^sub>i i_bool" by auto lemma lvivl_rel_compact[autoref_rules]: "(\_::_\_. True, compact) \ lvivl_rel \ bool_rel" "(\_::(_\_)list. True, compact) \ clw_rel lvivl_rel \ 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,1712 +1,1716 @@ 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) \ 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)) \ 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 ..\ \parametrized by \ode_ops\\ end context approximate_sets begin lemma nonneg_reals_autoref[autoref_rules]: "(None, nonneg_reals) \ \Id\phantom_rel" and pos_reals_autoref[autoref_rules]: "(None, pos_reals) \ \Id\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)) \ 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::_\('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) \ appr_rel \ length ys = (length xs)\<^sup>2} O \br flow1_of_vec1 top\set_rel = {((xs, Some ys), X::'n eucl1 set) |xs ys X. X = (\xs. flow1_of_vec1 (eucl_of_list xs))  set_of_appr (xs @ ys) \ length xs = DIM((real, 'n::enum) vec) \ 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 \ UNIV)| xs X. (xs, X) \ appr_rel} \ {((xs, Some ys), X)| xs ys X. (xs @ ys, X) \ appr_rel \ length ys = (length xs)\<^sup>2} O \br flow1_of_vec1 top\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 \ OP op_image_flow1_of_vec1" by auto lemma op_image_flow1_of_vec1[autoref_rules]: assumes "DIM_precond TYPE('a rvec) E" shows "(\xs. (take E xs, Some (drop E xs)), op_image_flow1_of_vec1::('a::enum) vec1 set\_) \ appr_rel \ 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) \ \lv_rel\list_rel \ lv_rel \ 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 \ OP op_image_fst" by auto lemma op_image_fst_flow1[autoref_rules]: shows "(\x. fst x, op_image_fst::_\'n::executable_euclidean_space set) \ appr1_rel \ 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]: "((\(_, x, _). x), op_image_fste) \ appr1e_rel \ 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: ) lemma vec1rep_impl[autoref_rules]: "(\(a, bs). RETURN (map_option ((@) a) bs), vec1rep) \ appr1_rel \ \\appr_rel\option_rel\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 \ UNIV \ OP op_times_UNIV  X" by simp lemma op_times_UNIV_impl[autoref_rules]: "(\x. (x, None), op_times_UNIV) \ appr_rel \ 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) \ lv_rel" and CX[autoref_rules]: "(CXi, CX) \ appr1_rel" assumes [autoref_rules]: "(odoi, odo) \ ode_ops_rel" shows "(nres_of (?R), solve_poincare_plane odo n (CX::'n eucl1 set)) \ \appr1_rel\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 "((\x. x @ replicate (E * E) 0), embed1::'n rvec\_) \ lv_rel \ lv_rel" using assms by (auto simp: lv_rel_def br_def eucl_of_list_prod) definition "var_ode_ops_impl = (\(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) \ ode_ops_rel \ 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) \ appr1_rel" "(hi, h) \ rnv_rel" assumes [autoref_rules]: "(odoi, odo) \ ode_ops_rel" notes [autoref_post_simps] = fst_conv shows "(nres_of ?f, choose_step1 odo X h) \ \rnv_rel \\<^sub>r appr1_rel \\<^sub>r appr1_rel \\<^sub>r appr1_rel\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]: "(\(_, x). (appr_of_ivl ops (replicate E 0) (replicate E 0), x), op_image_zerofst::'n c1_info set \ _) \ appr1_rel \ 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]: "(\x. (appr_of_ivl ops (replicate E 0) (replicate E 0) @ drop E x), op_image_zerofst_vec::'n vec1 set \ _) \ appr_rel \ 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 \ OP op_image_embed1  X" by auto lemma op_image_embed1_impl[autoref_rules]: assumes "DIM_precond TYPE((real, 'n::enum) vec) E" shows "(\x. x@appr_of_ivl ops (replicate (E*E) 0) (replicate (E*E) 0), op_image_embed1::'n rvec set \ _) \ appr_rel \ 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)) \ appr1_rel" "(hi, h) \ \lv_rel\sctn_rel" shows "(nres_of ?f, inter_sctn1_spec X h) \ \appr1_rel \\<^sub>r appr1_rel\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)) \ clw_rel appr1_rel" shows "(RETURN ?r, op_image_fst_coll_nres XS) \ \clw_rel appr_rel\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 \ 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::_\'n set) \ clw_rel appr1_rel \ 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)) \ clw_rel appr1_rel" assumes [autoref_rules]: "(odoi, odo) \ ode_ops_rel" shows "(nres_of ?r, fst_safe_coll odo XS) \ \clw_rel appr_rel\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 \ OP op_image_flow1_of_vec1_coll" by auto lemma op_image_flow1_of_vec1_coll[autoref_rules]: "(map (\x. (take E x, Some (drop E x))), op_image_flow1_of_vec1_coll::_\'n eucl1 set) \ clw_rel appr_rel \ 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) \ clw_rel appr1_rel" shows "(RETURN ?r, vec1reps X) \ \\clw_rel appr_rel\option_rel\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]: "(\x. RETURN (vec1reps_impl x), vec1reps) \ clw_rel appr1_rel \ \\clw_rel appr_rel\option_rel\nres_rel" using vec1reps_impl.refine by force sublocale autoref_op_pat_def vec1reps . abbreviation "intersection_STATE_rel \ (appr1_rel \\<^sub>r \Id\phantom_rel \\<^sub>r clw_rel appr1_rel \\<^sub>r clw_rel appr1_rel \\<^sub>r clw_rel (\appr_rel, \lv_rel\sbelows_rel\inter_rel) \\<^sub>r bool_rel \\<^sub>r bool_rel)" lemma print_set_impl1[autoref_rules]: shows "(\a s. printing_fun optns a (list_of_appr1 s), print_set1) \ bool_rel \ A \ Id" by auto sublocale autoref_op_pat_def print_set1 . lemma trace_set1_impl1[autoref_rules]: shows "(\s a. tracing_fun optns s (map_option list_of_appr1 a), trace_set1) \ string_rel \ \A\option_rel \ Id" by auto sublocale autoref_op_pat_def trace_set1 . lemma print_set_impl1e[autoref_rules]: shows "(\a s. printing_fun optns a (list_of_appr1e s), print_set1e) \ bool_rel \ A \ Id" by auto sublocale autoref_op_pat_def print_set1e . lemma trace_set1_impl1e[autoref_rules]: shows "(\s a. tracing_fun optns s (map_option (list_of_appr1e) a), trace_set1e) \ string_rel \ \A\option_rel \ 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) \ appr1_rel" notes [autoref_post_simps] = case_prod_eta shows "(nres_of (?f), split_spec_param1 (X::'a eucl1 set)) \ \appr1_rel \\<^sub>r appr1_rel\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]: "{} \ OP op_empty_default" "{} \ OP op_empty_coll" and [autoref_op_pat_def del]: "get_inter p \ OP (get_inter p)" by simp_all lemma fst_image_c1_info_of_appr: "c1_info_invar (DIM('a)) X \ (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 (\(_, x, _). x), op_image_fst_colle) \ clw_rel appr1e_rel \ 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]: "(\_. False, is_empty) \ appr1_rel \ 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) \ \appr1_rel\scaleR2_rel" notes [autoref_post_simps] = case_prod_eta shows "(nres_of (?f), split_spec_param1e (X::'a eucl1 set)) \ \\appr1_rel\scaleR2_rel \\<^sub>r \appr1_rel\scaleR2_rel\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) \ \appr1_rel\nres_rel" if [autoref_rules_raw]: "DIM_precond TYPE((real, 'n::enum) vec) E" and [autoref_rules]: "(Xi, X::'n eucl1 set) \ appr1_rel" "(Ci, C) \ 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) \ \\appr1_rel\scaleR2_rel\nres_rel" if [autoref_rules_raw]: "DIM_precond TYPE((real, 'n::enum) vec) E" and [autoref_rules]: "(Xi, X::'n eucl1 set) \ \appr1_rel\scaleR2_rel" "(Ci, C) \ 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]: "(\a b. RETURN (a = b), eq_spec) \ A \ A \ \bool_rel\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) \ clw_rel (\A, P\inter_rel)" "(ai, a) \ clw_rel A" shows "(RETURN ?r, select_with_inter  c  a) \ \clw_rel (\A, P\inter_rel)\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) \ appr1e_rel" "(hi, h) \ rnv_rel" assumes [autoref_rules]: "(odoi, odo) \ ode_ops_rel" shows "(nres_of ?r, choose_step1e odo X h) \ \rnv_rel \\<^sub>r appr1_rel \\<^sub>r appr_rel \\<^sub>r appr1e_rel\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]: "(\ro. RETURN (pre_split_reduce ro), pre_split_reduce_spec) \ reach_optns_rel \ \reduce_argument_rel TYPE('b)\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) \ appr1e_rel" and [autoref_rules]: "(odoi, odo) \ ode_ops_rel" and [autoref_rules]: "(roi, ro) \ reach_optns_rel" shows "(nres_of (?f), step_split odo ro X)\\clw_rel appr1e_rel\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) \ appr1_rel" shows "(?r, width_spec_appr1 X) \ \rnv_rel\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) \ rnv_rel" "(Xi, X) \ clw_rel (\appr1_rel\scaleR2_rel)" and [autoref_rules]: "(roi, ro) \ reach_optns_rel" shows "(nres_of ?x, split_under_threshold ro th (X::'n eucl1 set)) \ \clw_rel (\appr1_rel\scaleR2_rel)\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) \ appr1e_rel" "(hi, (h::real)) \ rnv_rel" and [autoref_rules]: "(roptnsi, roptns) \ reach_optns_rel" "(odoi, odo) \ ode_ops_rel" shows "(nres_of ?r, pre_intersection_step odo roptns X h) \ \clw_rel (iinfo_rel appr1e_rel) \\<^sub>r clw_rel appr_rel \\<^sub>r clw_rel (iinfo_rel appr1e_rel)\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) \ lvivl_rel" "(sctni, sctn) \ \lv_rel\sctn_rel" shows "(nres_of ?R, subset_spec_plane X sctn) \ \bool_rel\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) \ appr_rel" "(sctni, sctn) \ \lv_rel\sctn_rel" "(Si, S) \ lvivl_rel" shows "(nres_of ?R, op_eventually_within_sctn X sctn S) \ \bool_rel\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)) \ \bool_rel\nres_rel" if [autoref_rules_raw]: "DIM_precond TYPE((real, 'n::enum) vec) E" and [autoref_rules]: "(ivli, ivl) \ lvivl_rel" "(sctni, sctn) \ \lv_rel\sctn_rel" "(PDPi, PDP) \ appr1_rel" "(odoi, odo) \ 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)) \ clw_rel appr_rel" "(Yi, (Y::'n rvec set)) \ clw_rel lvivl_rel" shows "(nres_of ?f, disjoints_spec X Y) \ \bool_rel\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) \ ode_ops_rel" assumes [autoref_rules]: "(hi, h) \ rnv_rel" and osctns[autoref_rules]: "(guardsi, guards) \ clw_rel lvivl_rel" and civl[autoref_rules]: "(ivli, ivl::'n rvec set) \ lvivl_rel" and csctns[autoref_rules]: "(sctni, sctn::'n rvec sctn) \ \lv_rel\sctn_rel" and [autoref_rules]: "(STATEi, STATE) \ 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) \ \intersection_STATE_rel\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) \ ode_ops_rel" assumes [autoref_rules]: "(Xi, X) \ appr1_rel" "(hi, h) \ rnv_rel" and osctns[autoref_rules]: "(guardsi, guards) \ clw_rel (\lvivl_rel, \lv_rel\plane_rel\inter_rel)" and civl[autoref_rules]: "(ivli, ivl::'n rvec set) \ lvivl_rel" and csctns[autoref_rules]: "(sctni, sctn::'n rvec sctn) \ \lv_rel\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)\ \bool_rel \\<^sub>r clw_rel appr1_rel \\<^sub>r clw_rel appr1_rel \\<^sub>r clw_rel (\appr_rel, \lv_rel\sbelows_rel\inter_rel)\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) \ appr1e_rel" assumes [autoref_rules]: "(Ei, E) \ appr1_rel" shows "(nres_of ?r, tolerate_error1 Y E) \ \bool_rel \\<^sub>r rnv_rel\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) \ Id \ Id" + and upper_impl[autoref_rules]: "(lower, lower) \ Id \ 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) \ ode_ops_rel" assumes [autoref_rules]: "(hi, h) \ rnv_rel" "(Xi, X::'n eucl1 set) \ (appr1e_rel)" shows "(nres_of ?f, step_adapt_time odo X h)\\rnv_rel \\<^sub>r appr_rel \\<^sub>r appr1e_rel \\<^sub>r rnv_rel\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) \ ode_ops_rel" assumes [autoref_rules]: "(hi, h) \ rnv_rel" "(Xi, X::'n eucl1 set) \ (appr1e_rel)" "(roptnsi, roptns) \ reach_optns_rel" shows "(nres_of ?f, resolve_step odo roptns X h)\\rnv_rel \\<^sub>r clw_rel appr_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r rnv_rel\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) \ ode_ops_rel" assumes [autoref_rules]: "(XSi, XS) \ clw_rel appr1e_rel" "(guardsi, guards::'n rvec set) \ clw_rel (iplane_rel lvivl_rel)" and [autoref_rules]: "(roptnsi, roptns) \ reach_optns_rel" notes [relator_props, autoref_rules_raw] = sv_appr1_rel shows "(nres_of (?f::?'f dres), reach_cont odo roptns guards XS)\?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) \ ode_ops_rel" assumes [autoref_rules]: "(XSi, XS) \ clw_rel appr1e_rel" "(guardsi, guards::'n rvec set) \ clw_rel (iplane_rel lvivl_rel)" and [autoref_rules]: "(roptnsi, roptns) \ reach_optns_rel" shows "(nres_of (?f::?'f dres), reach_cont_par odo roptns guards XS)\?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) \ iplane_rel lvivl_rel" assumes [autoref_rules]: "(icsi, ics) \ clw_rel (iplane_rel lvivl_rel)" shows "(nres_of ?r, subset_iplane_coll x ics) \ \bool_rel\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) \ \iplane_rel lvivl_rel\list_wset_rel" assumes [autoref_rules]: "(icsi, ics) \ clw_rel (iplane_rel lvivl_rel)" shows "(nres_of ?r, subsets_iplane_coll x ics) \ \bool_rel\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) \ ode_ops_rel" assumes [autoref_rules]: "(XSi, XS::'n eucl1 set) \ clw_rel appr1e_rel" assumes [autoref_rules]: "(symstarti, symstart::'n eucl1 set \ ('n rvec set \ 'n eucl1 set)nres) \ appr1e_rel \ \clw_rel appr_rel \\<^sub>r clw_rel appr1e_rel\nres_rel" assumes [unfolded autoref_tag_defs, refine_transfer]: "\X. TRANSFER (nres_of (symstartd X) \ symstarti X)" shows "(nres_of ?r, symstart_coll  odo  symstart  XS) \ \clw_rel appr_rel \\<^sub>r clw_rel appr1e_rel\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) \ ode_ops_rel" assumes [autoref_rules]: "(XSi, XS::'n eucl1 set) \ clw_rel appr1e_rel" "(guardsi, guards::'n rvec set) \ clw_rel (iplane_rel lvivl_rel)" "(roptnsi, roptns) \ reach_optns_rel" assumes [autoref_rules]: "(symstarti, symstart::'n eucl1 set \ ('n rvec set \ 'n eucl1 set)nres) \ appr1e_rel \ \clw_rel appr_rel \\<^sub>r clw_rel appr1e_rel\nres_rel" assumes [unfolded autoref_tag_defs, refine_transfer]: "\X. TRANSFER (nres_of (symstartd X) \ symstarti X)" shows "(nres_of (?r), reach_cont_symstart  odo  roptns  symstart  guards  XS) \ \clw_rel appr_rel \\<^sub>r clw_rel (\iplane_rel lvivl_rel::(_ \ 'n rvec set)set, iinfo_rel appr1e_rel\info_rel)\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 \ ('n rvec set \ 'n eucl1 set)nres) \ appr1e_rel \ \clw_rel appr_rel \\<^sub>r clw_rel appr1e_rel\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) \ ode_ops_rel" assumes [autoref_rules]: "(XSi, XS) \ clw_rel appr1e_rel" "(guardsi, guards::'n rvec set) \ clw_rel (iplane_rel lvivl_rel)" and [autoref_rules]: "(roptnsi, roptns) \ reach_optns_rel" notes [simp] = list_wset_rel_finite[OF sv_reach_conts_impl_aux] assumes "(trapi, trap) \ ghost_rel" assumes [unfolded autoref_tag_defs, refine_transfer]: "\X. TRANSFER (nres_of (symstartd X) \ symstarti X)" shows "(nres_of (?f::?'f dres), reach_conts  odo  roptns  symstart  trap  guards  XS)\?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]: "(\x. RETURN x, get_sctns) \ \R\halfspaces_rel \ \\\R\sctn_rel\list_set_rel\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) \ ode_ops_rel" assumes [autoref_rules]: "(Si, S) \ \lv_rel\halfspaces_rel" assumes [autoref_rules]: "(Xi, X::'n rvec set) \ clw_rel appr_rel" shows "(nres_of ?r, leaves_halfspace  odo  S  X) \ \\\lv_rel\sctn_rel\option_rel\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) \ ode_ops_rel" assumes [autoref_rules]: "(sctni, sctn) \ \lv_rel\sctn_rel" "(guardsi, guards) \ clw_rel lvivl_rel" "(X0i, X0::'n eucl1 set) \ clw_rel (appr1e_rel)" shows "(nres_of (?f), poincare_start_on  odo  guards  sctn  X0) \ \clw_rel appr1e_rel \\<^sub>r clw_rel appr_rel\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 ($$ ((lv_rel::(_ \ 'a::executable_euclidean_space)set) \ lv_rel \ bool_rel)" shows "(\xs. map ($$(i, s), x). (appr_of_ivl ops i s, x)) [((i,s), x) \ xs. le i s], isets_of_iivls::_\'a set) \ clw_rel (\lvivl_rel, A\inter_rel) \ clw_rel (\appr_rel, A\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 apply (drule order_trans) apply assumption apply simp 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 \ UNIV \ OP op_times_UNIV_coll  X" by simp lemma op_times_UNIV_coll_impl[autoref_rules]: "(map (\x. (x, None)), op_times_UNIV_coll) \ clw_rel appr_rel \ 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) \ ode_ops_rel" assumes [autoref_rules]: "(Xi, X::'n eucl1 set) \ iinfo_rel appr1e_rel" and osctns[autoref_rules]: "(guardsi, guards) \ clw_rel (iplane_rel lvivl_rel)" and csctns[autoref_rules]: "(sctni, sctn) \ \lv_rel\sctn_rel" and csctns[autoref_rules]: "(ivli, ivl) \ lvivl_rel" notes [simp] = list_set_rel_finiteD shows "(nres_of ?f, do_intersection_core odo guards ivl sctn X) \ \clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel (isbelows_rel appr_rel) \\<^sub>r clw_rel appr1e_rel\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) \ \\rnv_rel, appr1e_rel\info_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel (\appr_rel, \lv_rel\sbelows_rel\inter_rel) \\<^sub>r clw_rel appr1e_rel\list_wset_rel \ 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) \ ode_ops_rel" assumes [autoref_rules]: "(Xi, X::'n eucl1 set) \ clw_rel (iinfo_rel appr1e_rel)" and osctns[autoref_rules]: "(guardsi, guards) \ clw_rel (iplane_rel lvivl_rel)" and csctns[autoref_rules]: "(sctni, sctn) \ \lv_rel\sctn_rel" and csctns[autoref_rules]: "(ivli, ivl) \ lvivl_rel" notes [simp] = finite_ra1eicacacslsbicae1lw[where 'n='n] shows "(nres_of ?f, do_intersection_coll odo guards ivl sctn X) \ \clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel (isbelows_rel appr_rel) \\<^sub>r clw_rel appr1e_rel\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) \ lvivl_rel" "(sctni, sctn) \ \lv_rel\sctn_rel" "(di, d) \ rnv_rel" shows "(nres_of ?R, op_enlarge_ivl_sctn  ivl  sctn  d) \ \lvivl_rel\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) \ ode_ops_rel" assumes [autoref_rules]: "(XSi, XS::('n rvec set \ 'n eucl1 set) set) \ \iplane_rel lvivl_rel \\<^sub>r clw_rel (iinfo_rel appr1e_rel)\list_wset_rel" and osctns[autoref_rules]: "(guardsi, guards) \ clw_rel (iplane_rel lvivl_rel)" and osctns[autoref_rules]: "(ivlplanesi, ivlplanes) \ clw_rel (iplane_rel lvivl_rel)" notes [intro, simp] = list_set_rel_finiteD shows "(nres_of ?r, resolve_ivlplanes odo guards ivlplanes XS) \ \\clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r lvivl_rel \\<^sub>r \lv_rel\sctn_rel \\<^sub>r clw_rel (isbelows_rel appr_rel)\list_wset_rel\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) \ ode_ops_rel" assumes [autoref_rules]: "(XSi, XS::'n eucl1 set) \ clw_rel appr1e_rel" assumes [autoref_rules]: "(CXSi, CXS::'n rvec set) \ clw_rel appr_rel" and osctns[autoref_rules]: "(guardsi, guards) \ clw_rel (iplane_rel lvivl_rel)" and osctns[autoref_rules]: "(ivlplanesi, ivlplanes) \ clw_rel (iplane_rel lvivl_rel)" and [autoref_rules]: "(roi, ro) \ reach_optns_rel" assumes [autoref_rules]: "((), trap) \ ghost_rel" assumes [autoref_rules]: "(symstarti, symstart::'n eucl1 set \ ('n rvec set \ 'n eucl1 set)nres) \ appr1e_rel \ \clw_rel appr_rel \\<^sub>r clw_rel appr1e_rel\nres_rel" assumes [unfolded autoref_tag_defs, refine_transfer]: "\X. TRANSFER (nres_of (symstartd X) \ symstarti X)" notes [intro, simp] = list_set_rel_finiteD shows "(nres_of ?r, poincare_onto  odo  ro  symstart  trap  guards  ivlplanes  XS  CXS) \ \\clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r lvivl_rel \\<^sub>r \lv_rel\sctn_rel \\<^sub>r clw_rel (isbelows_rel appr_rel) \\<^sub>r clw_rel appr_rel\list_wset_rel\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) \ \clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r lvivl_rel \\<^sub>r \lv_rel\sctn_rel \\<^sub>r clw_rel (isbelows_rel appr_rel) \\<^sub>r clw_rel appr_rel\list_wset_rel" shows "(nres_of ?r, empty_remainders PS) \ \bool_rel\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) \ ghost_rel" by (auto intro!: ghost_relI) sublocale autoref_op_pat_def empty_trap . lemma empty_symstart_impl:\ \why this? \ "((\x. nres_of (dRETURN ([], [x]))), empty_symstart) \ appr1e_rel \ \clw_rel appr_rel \\<^sub>r clw_rel appr1e_rel\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]: "((\x. RETURN ([], [x])), empty_symstart::'n::enum eucl1 set\_) \ appr1e_rel \ \clw_rel appr_rel \\<^sub>r clw_rel appr1e_rel\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: "((\x. dRETURN ([], [x])), empty_symstart::'n::enum eucl1 set\_) \ (appr1e_rel) \ \clw_rel appr_rel \\<^sub>r clw_rel appr1e_rel\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) \ ode_ops_rel" assumes [autoref_rules]: "(XSi, XS::'n eucl1 set) \ clw_rel appr1e_rel" assumes [autoref_rules]: "(CXSi, CXS::'n rvec set) \ clw_rel appr_rel" and osctns[autoref_rules]: "(guardsi, guards) \ clw_rel (iplane_rel lvivl_rel)" and osctns[autoref_rules]: "(ivlplanesi, ivlplanes) \ clw_rel (iplane_rel lvivl_rel)" and [autoref_rules]: "(roi, ro) \ reach_optns_rel" notes [intro, simp] = list_set_rel_finiteD shows "(nres_of (?r), poincare_onto_empty odo ro guards ivlplanes XS CXS) \ \\clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r lvivl_rel \\<^sub>r \lv_rel\sctn_rel \\<^sub>r clw_rel (isbelows_rel appr_rel) \\<^sub>r clw_rel appr_rel\list_wset_rel\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)\ \TODO: what is going wrong here?\ 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 \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r \lv_rel\ivl_rel \\<^sub>r \lv_rel\sctn_rel \\<^sub>r clw_rel (\appr_rel, \lv_rel\sbelows_rel\inter_rel) \\<^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) \ ode_ops_rel" assumes [autoref_rules]: "(symstarti, symstart::'n eucl1 set \ ('n rvec set \ 'n eucl1 set)nres) \ appr1e_rel \ \clw_rel appr_rel \\<^sub>r clw_rel appr1e_rel\nres_rel" assumes [unfolded autoref_tag_defs, refine_transfer]: "\X. TRANSFER (nres_of (symstartd X) \ symstarti X)" assumes [autoref_rules]: "(XSi, XS::'n eucl1 set) \ clw_rel appr1e_rel" and osctns[autoref_rules]: "(guardsi, guards) \ clw_rel (iplane_rel lvivl_rel)" and osctns[autoref_rules]: "(ivlplanesi, ivlplanes) \ clw_rel (iplane_rel lvivl_rel)" and [autoref_rules]: "(roi, ro) \ reach_optns_rel" assumes [autoref_rules]: "((), trap) \ 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) \ \\bool_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r lvivl_rel \\<^sub>r \lv_rel\sctn_rel \\<^sub>r clw_rel (isbelows_rel appr_rel) \\<^sub>r clw_rel appr_rel\list_wset_rel\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) \ nat_rel" "(xi, x) \ lvivl_rel" shows "(RETURN ?r, width_spec_ivl M x) \ \rnv_rel\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)\ clw_rel lvivl_rel" "(roi, ro) \ reach_optns_rel" shows "(nres_of (?f), partition_ivl ro xs)\\clw_rel lvivl_rel\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) \ clw_rel appr1e_rel" shows "(nres_of ?r, vec1repse X) \ \\clw_rel appre_rel\option_rel\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) \ appre_rel" shows "(nres_of ?r, scaleR2_rep1 Y) \ \elvivl_rel\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) \ \clw_rel elvivl_rel\nres_rel" if [autoref_rules_raw]:"DIM_precond TYPE('n::enum rvec) E" and [autoref_rules]: "(Xi, X::'n vec1 set) \ 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) \ \clw_rel (appre_rel)\nres_rel" if [autoref_rules]: "(Xi, X) \ 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 (\(lu, x). (lu, (take E x, Some (drop E x)))), op_image_flow1_of_vec1_colle::_\'n eucl1 set) \ clw_rel appre_rel \ 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)\ lvivl_rel" and [autoref_rules]: "(roi, ro) \ reach_optns_rel" shows "(nres_of ?f, okay_granularity ro ivl) \ \bool_rel\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]: "(\roi (ls, us). RETURN (width_appr ops optns (appr_of_ivl ops ls us) \ post_inter_granularity roi), (le_post_inter_granularity_op::_\'a::executable_euclidean_space set\_)) \ (reach_optns_rel \ lvivl_rel \ \bool_rel\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)\ clw_rel appr1e_rel" and [autoref_rules]: "(roi, ro) \ reach_optns_rel" shows "(nres_of (?f), partition_set ro xs) \ \clw_rel appr1e_rel\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 \ 'n eucl1 set \ _)set)\ \bool_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r lvivl_rel \\<^sub>r \lv_rel\sctn_rel \\<^sub>r clw_rel (isbelows_rel appr_rel) \\<^sub>r clw_rel appr_rel\list_wset_rel" and [autoref_rules]: "(roi, ro) \ reach_optns_rel" shows "(nres_of (?f), partition_sets ro xs)\\clw_rel appr1e_rel\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 "(\xs. case xs of [x] \ RETURN x | _ \ SUCCEED, singleton_spec) \ \A\list_wset_rel \ \A\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) \ \bool_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r \lv_rel\ivl_rel \\<^sub>r \lv_rel\sctn_rel \\<^sub>r clw_rel (\appr_rel, \lv_rel\sbelows_rel\inter_rel) \\<^sub>r clw_rel appr_rel\list_wset_rel" shows "(\(b, X, PS1, PS2, R, ivl, sctn, CX, CXS)\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:\ \TODO: here is a problem if interrupt gets uncurried, too\ "poincare_onto_series odo interrupt trap guards XS ivl sctn ro = rec_list (\(((((trap), XS0), ivl), sctn), ro). let guard0 = mk_coll (mk_inter ivl (plane_of sctn)) in ASSUME (closed guard0) \ (\_. (poincare_onto2 odo (ro ::: reach_optns_rel) (interrupt:::appr1e_rel \ \clw_rel appr_rel \\<^sub>r clw_rel appr1e_rel\nres_rel) trap (op_empty_coll ::: clw_rel (\\lv_rel\ivl_rel, \lv_rel\plane_rel\inter_rel)) guard0 XS0 ::: \\bool_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r lvivl_rel \\<^sub>r \lv_rel\sctn_rel \\<^sub>r clw_rel (isbelows_rel appr_rel) \\<^sub>r clw_rel appr_rel\list_wset_rel\nres_rel) \ (\(XS1). singleton_spec XS1 \ (\(b, X, PS1, PS2, R, ivl', sctn', CX, CXS). CHECKs ''poincare_onto_series: last return!'' (ivl' = ivl \ sctn' = sctn) \ (\_. RETURN PS2))))) (\x xs rr (((((trap), XS0), ivl), sctn), ro0). case x of (guard, ro) \ ASSUME (closed ivl) \ (\_. let guard0 = mk_coll (mk_inter ivl (plane_of sctn)) in ASSUME (closed guard0) \ (\_. ASSUME (\(guard, ro)\set (x # xs). closed guard) \ (\_. let guardset = \(guard, ro)\set ((guard0, ro0) # xs). guard in (poincare_onto2 odo ro (interrupt:::appr1e_rel \ \clw_rel appr_rel \\<^sub>r clw_rel appr1e_rel\nres_rel) trap (guardset ::: clw_rel (\\lv_rel\ivl_rel, \lv_rel\plane_rel\inter_rel)) guard XS0 ::: \\bool_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r clw_rel appr1e_rel \\<^sub>r lvivl_rel \\<^sub>r \lv_rel\sctn_rel \\<^sub>r clw_rel (isbelows_rel appr_rel) \\<^sub>r clw_rel appr_rel\list_wset_rel\nres_rel) \ (\(XS1). ASSUME (\(b, X, PS, PS2, R, ivl, sctn, CX, CXS)\XS1. closed ivl) \ (\_. partition_sets ro XS1 \ (\XS2. fst_safe_colle odo XS2 \ (\_. rr (((((trap), XS2), ivl), sctn), ro0 ::: reach_optns_rel) \ 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) \ ode_ops_rel" assumes [autoref_rules]: "(XSi, XS::'n eucl1 set) \ clw_rel appr1e_rel" and osctns[autoref_rules]: "(guardsi, guards) \ \clw_rel (iplane_rel lvivl_rel)\\<^sub>rreach_optns_rel\list_rel" and [autoref_rules]: "(roi, ro) \ reach_optns_rel" "(ivli, ivl) \ lvivl_rel" "(sctni, sctn) \ \lv_rel\sctn_rel" assumes [autoref_rules]: "(symstarti, symstart::'n eucl1 set \ ('n rvec set \ 'n eucl1 set)nres) \ appr1e_rel \ \clw_rel appr_rel \\<^sub>r clw_rel appr1e_rel\nres_rel" assumes [unfolded autoref_tag_defs, refine_transfer]: "\X. TRANSFER (nres_of (symstartd X) \ symstarti X)" and [autoref_rules]: "((), trap) \ 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) \ \clw_rel appr1e_rel\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) \ ode_ops_rel" assumes [autoref_rules]: "(XSi, XS) \ clw_rel appr1e_rel" and [autoref_rules]: "(Si, S) \ \lv_rel\halfspaces_rel" and osctns[autoref_rules]: "(guardsi, guards) \ \clw_rel (iplane_rel lvivl_rel)\\<^sub>rreach_optns_rel\list_rel" and civl[autoref_rules]: "(ivli, ivl::'n rvec set) \ lvivl_rel" and csctns[autoref_rules]: "(sctni, sctn::'n rvec sctn) \ \lv_rel\sctn_rel" and [autoref_rules]: "(roi, ro) \ reach_optns_rel" assumes [autoref_rules]: "(symstarti, symstart::'n eucl1 set \ ('n rvec set \ 'n eucl1 set)nres) \ appr1e_rel \ \clw_rel appr_rel \\<^sub>r clw_rel appr1e_rel\nres_rel" assumes [unfolded autoref_tag_defs, refine_transfer]: "\X. TRANSFER (nres_of (symstartd X) \ symstarti X)" and [autoref_rules]: "((), trap) \ 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) \ \clw_rel appr1e_rel\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) \ \bool_rel\nres_rel" if [autoref_rules]: "(Ri, R) \ appr1_rel" "(Pimpl, P) \ lvivl_rel" "(dPi, dP) \ \lvivl_rel\(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) \ \bool_rel\nres_rel" if [autoref_rules]: "(Ri, R) \ clw_rel appr1_rel" "(Pimpl, P) \ lvivl_rel" "(dPi, dP) \ \lvivl_rel\(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) \ ode_ops_rel" assumes [autoref_rules]: "(X0i, X0::'n eucl1 set) \ appr1e_rel" assumes [autoref_rules]: "(phi, ph) \ bool_rel" assumes [autoref_rules]: "(t1i, t1) \ 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)\\appr1e_rel \\<^sub>r \clw_rel appr_rel\phantom_rel\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) \ clw_rel appr_rel" shows "(nres_of ?r, ivl_of_eucl_coll X) \ \appr1_rel\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) \ ode_ops_rel" assumes [autoref_rules]: "(X0i, X0::'n eucl1 set) \ appr1e_rel" assumes [autoref_rules]: "(phi, ph) \ bool_rel" assumes [autoref_rules]: "(t1i, t1) \ rnv_rel" assumes [autoref_rules]: "(t2i, t2) \ rnv_rel" shows "(nres_of ?r, one_step_until_time_ivl odo X0 ph t1 t2) \ \appr1e_rel \\<^sub>r \clw_rel appr_rel\phantom_rel\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) \ ode_ops_rel" assumes [autoref_rules]: "(XSi, XS) \ clw_rel appr1e_rel" and [autoref_rules]: "(Si, S) \ \lv_rel\halfspaces_rel" and osctns[autoref_rules]: "(guardsi, guards) \ \clw_rel (iplane_rel lvivl_rel)\\<^sub>rreach_optns_rel\list_rel" and civl[autoref_rules]: "(ivli, ivl::'n rvec set) \ lvivl_rel" and csctns[autoref_rules]: "(sctni, sctn::'n rvec sctn) \ \lv_rel\sctn_rel" and [autoref_rules]: "(roi, ro) \ reach_optns_rel" assumes [autoref_rules]: "(symstarti, symstart::'n eucl1 set \ ('n rvec set \ 'n eucl1 set)nres) \ appr1e_rel \ \clw_rel appr_rel \\<^sub>r clw_rel appr1e_rel\nres_rel" assumes [unfolded autoref_tag_defs, refine_transfer]: "\X. TRANSFER (nres_of (symstartd X) \ symstarti X)" and [autoref_rules]: "((), trap) \ ghost_rel" "(Pimpl, P) \ lvivl_rel" "(dPi, dP) \ \lvivl_rel\(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) \ \bool_rel\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 \ TRANSFER x" by simp lemma dres_nres_rel_nres_relD: "(symstartd, symstart) \ A \ \B\dres_nres_rel \ (\x. nres_of (symstartd x), symstart) \ A \ \B\nres_rel" by (auto simp: dres_nres_rel_def nres_rel_def dest!: fun_relD) lemma c1_info_of_apprsI: assumes "(b, a) \ clw_rel appr1_rel" assumes "x \ a" shows "x \ 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 "\X. X \ set XS \ c1_info_invar CARD('n::enum) X" shows "(XS, c1_info_of_apprs XS::('n rvec\_)set) \ 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) \ \clw_rel appr1_rel\phantom_rel" assumes "x \ a" shows "x \ 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) \ 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) \ appr1_rel" assumes "x \ a" shows "x \ 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) \ appr1e_rel" assumes "x \ a" shows "x \ 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) \ clw_rel appr1e_rel" assumes "x \ a" shows "x \ 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 "\X. X \ set XS \ c1_info_invare CARD('n::enum) X" shows "(XS, c1_info_of_apprse XS::('n rvec\_)set) \ 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) \ ode_ops_rel" assumes [autoref_rules]: "(X0i, X0::'n eucl1 set) \ appr1e_rel" assumes [autoref_rules]: "(t1i, t1) \ rnv_rel" assumes [autoref_rules]: "(t2i, t2) \ rnv_rel" "(Ri, R) \ lvivl_rel" "(dRi, dR) \ \lvivl_rel\(default_rel UNIV)" shows "(nres_of ?r, one_step_until_time_ivl_in_ivl odo X0 t1 t2 R dR) \ \bool_rel\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) \ ode_ops_rel" assumes [autoref_rules]: "(XSi, XS) \ clw_rel appr1e_rel" and osctns[autoref_rules]: "(guardsi, guards) \ \clw_rel (iplane_rel lvivl_rel)\\<^sub>rreach_optns_rel\list_rel" and civl[autoref_rules]: "(ivli, ivl::'n rvec set) \ lvivl_rel" and csctns[autoref_rules]: "(sctni, sctn::'n rvec sctn) \ \lv_rel\sctn_rel" and [autoref_rules]: "(roi, ro) \ reach_optns_rel" "(Pimpl, P::'n rvec set) \ lvivl_rel" "(dPi, dP:: ((real, 'n) vec, 'n) vec set) \ \lvivl_rel\(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) \ \bool_rel\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])\ \TODO: why?\ 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 \Main (executable) interfaces to the ODE solver, with initialization\ 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 \ 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 (\x. dRETURN ([], [x])) [S]" definition "one_step_until_time_ivl_in_ivl_check odo X t0 t1 Ri dRi \ 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 \ 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) \ c1_info_of_appre ((1, 1), X0, None)" if "list_of_eucl x \ 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) \ length u = n" by (auto simp: c1_info_invar_def) lemma c1_info_invare_None: "c1_info_invare n ((l, u), x, None) \((l < u \ -\ < l \ l \ u \ u <$$ \ 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/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,2707 @@ 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 = (\_. 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 (\_. ()) 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 (\i. map (\j. if i = j then 1 else 0::real) [0..) l x \ list_all2 (\) 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 ===> (=)) (\) (\)" "bi_total A" unfolding list_interval_def by transfer_prover end lemma in_list_interval_lengthD: "x \ list_interval a b \ 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..b. (map (\i. (Num (C i)) + Var (D + D * D) * (mvmult_fa D D (map Var [D..i. (map (\j. (Num (C i)) + Var (D + D * D) * Var (D + D * i + j)) [0.. \for illustration\ assumes[simp]: "D=3" "rf = real_of_float" shows "interpret_floatariths (varvec_fas D (\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 \ \dimension\ ps \ \pairs of coordinates to project onto\ ds \ \partial derivatives w.r.t. which variables\ cs \ $$color) coding for partial derivatives\ = [(i + n * (x + 1)::nat, i + n * (y + 1), c). (i, c) \ zip ds cs, (x, y) \ ps]" definition "varvec_aforms_line D X line = approx_floatariths 30 (varvec_fas D (\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 (\x. (fst x, zero_pdevs)) X) [aform_of_ivl 0 s]" definition "shows_aforms_vareq n \ \dimension\ ps \ \pairs of coordinates to project onto\ ds \ \partial derivatives w.r.t. which variables\ csl \ \color coding for partial derivatives ('arrow' heads)\ csh \ \color coding for partial derivatives (lines)\ s \ \scale vectors for partial derivatives\ (no_str::string) \ \default string if no C1 info is present\ X \ \affine form with C1 info\ = (case (varvec_aforms_head n X s, varvec_aforms_vec n X s) of (Some X, Some Y) \ shows_sep (\(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 (\(x, y, c). shows_segments_of_aform x y Y c) shows_nl (vareq_projections n ps ds csh) o shows_nl | _ \ shows_string no_str o shows_nl)" abbreviation "print_string s \ print (String.implode s)" abbreviation "print_show s \ print_string (s '''')" value [code] "print_show (shows_aforms_vareq 3 [(x, y). x \ [0..<3], y \ [0..<3], x < y] [0..<3] [''0x0000ff'', ''0x00ff00'', ''0xff0000''] [''0x0000ff'', ''0x00ff00'', ''0xff0000''] (FloatR 1 (-1)) ''# no C1 info'' ((((\(a, b). aforms_of_ivls a b) (with_unit_matrix 3 ([10, 20, 30], [12, 22, 32]))))))" method_setup guess_rhs = \ 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 ([], [(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 \ 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 \ 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 \ 'a \ 'a" assumes f': "\t x. t \ T \ x \ X \ (f t has_derivative f' t x) (at x)" assumes cont_f': "\i. i \ Basis \ continuous_on (T \ X) (\(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'="\(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 \ nat \ nat \ (real aform) list list" where "split_aforms_list Xs i 0 = Xs" | "split_aforms_list Xs i (Suc n) = split_aforms_list (concat (map (\x. (let (a, b) = split_aforms x i in [a, b])) Xs)) i n" definition "shows_aforms x y c X = shows_lines (map (\b. (shows_segments_of_aform x y b c ''\'')) 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 \ '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: "\x. x \ safe_set \ einterpret ode_fas (list_of_eucl x) = ode x" assumes odo: "mk_ode_ops ode_fas safe_form \ None" assumes isFDERIV: "\xs. interpret_form safe_form xs \ isFDERIV (length ode_fas) [0.. 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: "\x. x \ safe_set \ 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 \ 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 "\\<^sub>F x' in at x. x' \ safe_set" . then have "\\<^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 \ existence_ivl0 x \ aform.flow0 odo x t = flow0 x t" and Dflow_eq: "t \ existence_ivl0 x \ aform.Dflow odo x t = Dflow x t" and ex_ivl_eq: "t \ aform.existence_ivl0 odo x \ aform.existence_ivl0 odo x = existence_ivl0 x" and poincare_mapsto_eq: "closed a \ 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 \ \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) (\x xb xa. if xb \ aform.Csafe x then aform.ode_d_raw x 0 xb 0 xa else 0) (\x xb xa. if xb \ 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\\<^sub>L'a) = (aform.ode_d1 odo x::'n rvec \\<^sub>L 'n rvec)" by transfer simp end definition "vf \ \x. cast (ode (cast x))" definition "vf' \ \x::'n rvec. cast_bl (aform.ode_d1 odo (cast x::'a)) ::'n rvec \\<^sub>L 'n rvec" definition "vX \ 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 \ v.existence_ivl0 x \ 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 \ v.existence_ivl0 x \ 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 \ aform.existence_ivl0 odo x \ 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: "(\x. x) = (\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)) (\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 \ 'a \\<^sub>L 'a) set" "cast  c::'a set" "cast  d::'a set" "cast_eucl1  e::('a \ 'a \\<^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 "\ = 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 \ _)" 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 \ _)" 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 "\ = 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 \ real list \ ('b \\<^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 \ UNIV | Some x \ 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 ===> (=)) ($$ (\)" "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 ===> (=)) (\) (\)" "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 "\ = (\ij 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 "\ = (\i\Basis. \j\Basis. (b \ 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 \\<^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 \\<^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 \ (x0, d0) \ aform.c1_info_of_appre X0i \ t \ {t1 .. t2} \ set_of_lvivl E \ S \ blinfuns_of_lvivl' dE \ dS \ length (fst E) = CARD('n) \ length (snd E) = CARD('n) \ aform.lvivl'_invar (CARD('n) * CARD('n)) dE \ aform.c1_info_invare DIM('a) X0i \ aform.D odo = DIM('a) \ (t \ existence_ivl0 (x0::'a) \ flow0 x0 t \ S) \ Dflow x0 t o\<^sub>L d0 \ dS" apply (transfer fixing: optns X0i t1 t2 t E dE) subgoal premises prems for x0 d0 S dS proof - have "t \ aform.existence_ivl0 odo x0 \ aform.flow0 odo x0 t \ S \ aform.Dflow odo x0 t o\<^sub>L d0 \ 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 ===> (=)) (\) (\)" "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 ===> (=)) (\) (\)" "bi_total A" unfolding below_halfspace_def le_halfspace_def by transfer_prover definition "rel_nres A a b \ (a, b) \ \{(a, b). A a b}\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) \ A \ B \ (\x. dRETURN (fi x), (\x. RETURN (f x))) \ A \ \B\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 \ ('c \ 'd) set) set \ (((ereal \ ereal) \ 'b) \ ('c \ '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 \ B) = A \ 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 (\x. dRETURN (symstart x)) [S] guards ivl sctn roi XS RET dRET \ (symstart, symstarta) \ fun_rel (aform.appr1e_rel) (clw_rel aform.appr_rel \\<^sub>r clw_rel aform.appr1e_rel) \ (\X0. ($$CX, X). flowsto (X0 - trap \ UNIV) {0..} (CX \ UNIV) X) (symstarta X0)) \ stable_on (aform.Csafe odo - set_of_lvivl ivl \ plane_of (map_sctn eucl_of_list sctn)) trap \ (\X. X \ set XS \ aform.c1_info_invare DIM('a) X) \ aform.D odo = DIM('a) \ length (normal sctn) = DIM('a) \ length (fst ivl) = DIM('a) \ length (snd ivl) = DIM('a) \ length (normal S) = DIM('a) \ (\a xs b ba ro. (xs, ro) \ set guards \ ((a, b), ba) \ set xs \ length a = DIM('a) \ length b = DIM('a) \ length (normal ba) = DIM('a)) \ length (fst RET) = CARD('n) \ length (snd RET) = CARD('n) \ aform.lvivl'_invar (CARD('n) * CARD('n)) dRET \ poincare_mapsto ((set_of_lvivl ivl::('a set)) \ plane_of (map_sctn eucl_of_list sctn)) (aform.c1_info_of_apprse XS - trap \ UNIV) (below_halfspace (map_sctn eucl_of_list S)) (aform.Csafe odo - set_of_lvivl ivl \ plane_of (map_sctn eucl_of_list sctn)) (set_of_lvivl RET \ 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 \ plane_of (map_sctn eucl_of_list sctn)) (aform.c1_info_of_apprse XS - trap \ UNIV) (below_halfspace (map_sctn eucl_of_list S)) (aform.Csafe odo - set_of_lvivl ivl \ plane_of (map_sctn eucl_of_list sctn)) (flow1_of_vec1  ({eucl_of_list (fst RET)..eucl_of_list (snd RET)} \ 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 \ v.existence_ivl0 x0" using vex_ivl_eq by blast with 1 have b: "v.flow0 x0 t \ trap" using vflow_eq by simp have c: "v.flow0 x0 s \ vX - set_of_lvivl ivl \ plane_of (map_sctn eucl_of_list sctn)" if s: "s \ {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\ (\X. X \ set XS \ aform.c1_info_invare DIM('a) X) \ aform.D odo = DIM('a) \ length (normal sctn) = DIM('a) \ length (fst ivl) = DIM('a) \ length (snd ivl) = DIM('a) \ length (normal S) = DIM('a) \ (\a xs b ba ro. (xs, ro) \ set guards \ ((a, b), ba) \ set xs \ length a = DIM('a) \ length b = DIM('a) \ length (normal ba) = DIM('a)) \ length (fst RET) = CARD('n) \ length (snd RET) = CARD('n) \ aform.lvivl'_invar (CARD('n) * CARD('n)) dRET \ poincare_mapsto ((set_of_lvivl ivl::('a set)) \ 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 \ plane_of (map_sctn eucl_of_list sctn)) (set_of_lvivl RET \ 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\ (\X. X \ set XS \ aform.c1_info_invare DIM('a) X) \ aform.D odo = DIM('a) \ length (normal sctn) = DIM('a) \ length (fst ivl) = DIM('a) \ length (snd ivl) = DIM('a) \ (\a xs b ba ro. (xs, ro) \ set guards \ ((a, b), ba) \ set xs \ length a = DIM('a) \ length b = DIM('a) \ length (normal ba) = DIM('a)) \ length (fst RET) = CARD('n) \ length (snd RET) = CARD('n) \ aform.lvivl'_invar (CARD('n) * CARD('n)) dRET \ poincare_mapsto ((set_of_lvivl ivl::('a set)) \ plane_of (map_sctn eucl_of_list sctn)) (aform.c1_info_of_apprse XS) UNIV (aform.Csafe odo - set_of_lvivl ivl \ plane_of (map_sctn eucl_of_list sctn)) (set_of_lvivl RET \ 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 \Example Utilities!\ hide_const floatarith.Max floatarith.Min lemma degree_sum_pdevs_scaleR_Basis: "degree (sum_pdevs (\i. pdevs_scaleR (a i) i) (Basis::'b::euclidean_space set)) = Max ((\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 \ Affine (eucl_of_list_aform a::'b::executable_euclidean_space aform)" assumes "length a = DIM('b)" shows "eucl_of_list (map Inf_aform a) \ 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 \ Affine (eucl_of_list_aform a::'b::executable_euclidean_space aform)" assumes "length a = DIM('b)" shows "x \ 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 \ Joints (xs @ ys)" obtains x1 x2 where "x = x1 @ x2" "x1 \ Joints xs" "x2 \ 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))} \ X1" assumes len: "length (fst R) = DIM('b)" shows "aform.c1_info_of_appr R \ X1 \ 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 \ (real aform) list \ (real aform) list" (infixr "\\<^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)) \ 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 \ Basis_list ! k = (\x\UNIV. \xa\UNIV. if enum_class.enum ! (k mod CARD('n)) = xa \ 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 "\ = 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 (\i. map (\j. M  (enum_class.enum ! i) (enum_class.enum ! j) ) [0.. real_of_float (lapprox_rat 20 i j))" definition "udec x = (case quotient_of x of (i, j) \ real_of_float (rapprox_rat 20 i j))" lemma ldec: "ldec x \ real_of_rat x" and udec: "real_of_rat x \ 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 = \ 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 = (\a b. let _ = fold (\(x, y, c) _. print_fun (String.implode (shows_segments_of_aform (x) (y) b c ''\''))) projs (); _ = print_fun (String.implode (''# '' @ shows_box_of_aforms_hr (b) '''' @ ''\'')) in () ), tracing_fun = (\a b. let _ = print_fun (String.implode (''# '' @ a @ ''\'')) in case b of Some b \ (let _ = () in print_fun (String.implode (''# '' @ shows_box_of_aforms_hr (b) '''' @ ''\''))) | None \ ()) \" definition "num_options_c1 p sstep m N a projs dcolors print_fun = (let no = num_options p sstep m N a (map (\(x, y, c, ds). (x, y, c)) projs) print_fun; D = length dcolors in no \printing_fun:= (\a b. let _ = printing_fun no a b in if a then () else fold (\(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 () )$$" 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 ($$i, j, k). (nat_of_integer i, nat_of_integer j, k)) projs) print_fun" definition "ro s n M g0 g1 inter_step = \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\" 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 \ real \ real \ real \ real \ (real list \ real list) \ real list sctn" where "xsec x (y0, y1) (z0, z1) = (([x, y0, z0], [x, y1, z1]), Sctn [1,0,0] x)" fun xsec':: "real \ real \ real \ real \ real \ (real list \ real list) \ real list sctn" where "xsec' x (y0, y1) (z0, z1) = (([x, y0, z0], [x, y1, z1]), Sctn [-1,0,0] (-x))" fun ysec:: "real \ real \ real \ real \ real \ (real list \ real list) \ real list sctn" where "ysec (x0, x1) y (z0, z1) = (([x0, y, z0], [x1, y, z1]), Sctn [0, 1,0] y)" fun ysec':: "real \ real \ real \ real \ real \ (real list \ real list) \ real list sctn" where "ysec' (x0, x1) y (z0, z1) = (([x0, y, z0], [x1, y, z1]), Sctn [0, -1,0] (-y))" fun zsec:: "real \ real \ real \ real \ real \ (real list \ real list) \ real list sctn" where "zsec (x0, x1) (y0, y1) z = (([x0, y0, z], [x1, y1, z]), Sctn [0, 0, 1] z)" fun zsec':: "real \ real \ real \ real \ real \ (real list \ real list) \ real list sctn" where "zsec' (x0, x1) (y0, y1) z = (([x0, y0, z], [x1, y1, z]), Sctn [0, 0, -1] (-z))" fun xsec2:: "real \ real \ real \ (real list \ real list) \ real list sctn" where "xsec2 x (y0, y1) = (([x, y0], [x, y1]), Sctn [1,0] x)" fun xsec2':: "real \ real \ real \(real list \ real list) \ real list sctn" where "xsec2' x (y0, y1) = (([x, y0], [x, y1]), Sctn [-1,0] (-x))" fun ysec2:: "real \ real \ real \ (real list \ real list) \ real list sctn" where "ysec2 (x0, x1) y = (([x0, y], [x1, y]), Sctn [0, 1] y)" fun ysec2':: "real \ real \ real \ (real list \ real list) \ real list sctn" where "ysec2' (x0, x1) y = (([x0, y], [x1, y]), Sctn [0, -1] (-y))" fun ysec4:: "real \ real \ real \ real \ real \ real \ real \ (real list \ real list) \ 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 \ real \ real \ real \ real \ real \ real \ (real list \ real list) \ 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 \ ((String.literal \ unit) \ (real aform) numeric_options)) = True" lemma TAG_optns: "P \ (TAG_optns optns \ P)" by (auto simp: ) definition [simp]: "TAG_reach_optns (roi::real aform reach_options) = True" lemma TAG_reach_optns: "P \ (TAG_reach_optns optns \ P)" by (auto simp: ) definition [simp]: "TAG_sctn (b::bool) = True" lemma TAG_sctn: "P \ (TAG_sctn optns \ P)" by (auto simp: ) subsection \Integrals and Computation\ lemma has_vderiv_on_PairD: assumes "((\t. (f t, g t)) has_vderiv_on fg') T" shows "(f has_vderiv_on (\t. fst (fg' t))) T" "(g has_vderiv_on (\t. snd (fg' t))) T" proof - from assms have "((\x. (f x, g x)) has_derivative (\xa. xa *\<^sub>R fg' t)) (at t within T)" if "t \ 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 (\t. fst (fg' t))) T" "(g has_vderiv_on (\t. snd (fg' t))) T" by (auto simp: has_vderiv_on_def has_vector_derivative_def o_def) qed lemma solves_autonomous_odeI: assumes "((\t. (t, phi t)) solves_ode (\t x. (1, f (fst x) (snd x)))) S (T \ X)" shows "(phi solves_ode f) S X" proof (rule solves_odeI) from solves_odeD[OF assms] have "((\t. (t, phi t)) has_vderiv_on (\t. (1, f (fst (t, phi t)) (snd (t, phi t))))) S" "\t. t \ S \ (phi t) \ X" by (auto simp: ) from has_vderiv_on_PairD(2)[OF this(1)] this(2) show "(phi has_vderiv_on (\t. f t (phi t))) S" "\t. t \ S \ phi t \ X" by auto qed lemma integral_solves_autonomous_odeI: fixes f::"real \ 'a::executable_euclidean_space" assumes "(phi solves_ode (\t _. f t)) {a .. b} X" "phi a = 0" assumes "a \ 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 \ 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 \ = (eucl_of_list (replicate DIM('a) 0)::'a)" by (rule eucl_of_list_append_zeroes) also have "\ = 0" by (rule zero_eq_eucl_of_list_rep_DIM[symmetric]) finally show ?thesis by simp qed lemma one_has_ivl_integral: "((\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 \ Joints (aforms_of_point xs)" by (simp add: aforms_of_point_def) lemma bind_eq_dRETURN_conv: "(f \ g = dRETURN S) \ (\R. f = dRETURN R \ g R = dRETURN S)" by (cases f) auto end lemma list_of_eucl_memI: "list_of_eucl (x::'x::executable_euclidean_space) \ S" if "x \ eucl_of_list  S" "\x. x \ S \ length x = DIM('x)" using that by auto lemma Joints_aforms_of_ivls_append_point: "Joints (xs @ aforms_of_ivls p p) = (\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 \ {t1 .. t2}" assumes X: "X \ {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} \ S" assumes lens: "length ls = DIM('a)" "length us = DIM('a)" \ \TODO: this could be verified\ 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 \ T \ x0 \ X \ t \ existence_ivl0 x0 \ flow0 x0 t \ S" proof (intro impI) assume t: "t \ T" and x0: "x0 \ X" from S have S: "set_of_lvivl (ls, us) \ 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 \ 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 \ {t1 .. t2}" by auto show "t \ existence_ivl0 x0 \ flow0 x0 t \ 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 \ {t1 .. t2}" assumes X: "X \ {eucl_of_list lx .. eucl_of_list ux}" "length lx = DIM('a)" "length ux = DIM('a)" assumes DS: "list_interval lds uds \ 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} \ S" assumes lens0: "length ls = DIM('a)" "length us = DIM('a)" \ \TODO: this could be verified\ "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 \ T \ x0 \ X \ t \ existence_ivl0 x0 \ flow0 x0 t \ S \ Dflow x0 t o\<^sub>L blinfun_of_list dx0s \ blinfuns_of_lvivl (ld, ud)" proof (intro impI) assume t: "t \ T" and x0: "x0 \ X" from S have S: "set_of_lvivl (ls, us) \ 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 \ 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) \ 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 \ {t1 .. t2}" by auto have DS: "blinfuns_of_lvivl' (Some (lds, uds)) \ 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 \aform.D _ = _\] show "t \ existence_ivl0 x0 \ flow0 x0 t \ S \ Dflow x0 t o\<^sub>L blinfun_of_list dx0s \ blinfuns_of_lvivl (ld, ud)" by (auto simp: blinfuns_of_lvivl_def) qed end definition "zero_aforms D = map (\_. (0, zero_pdevs)) [0..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)) (\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)) (\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 (\_. ())) 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 (\_. ())) 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 (\_. ())) 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 \ mk_ode_ops fas safe_form \ None" theorem solve_one_step_until_time_aform_integral_bounds: fixes f::"real \ 'a::executable_euclidean_space" assumes "a \ b" assumes ba: "b - a \ {t1 .. t2}" assumes a: "a \ {a1 .. a2}" assumes ls_us_subset: "{eucl_of_list ls .. eucl_of_list us} \ {l .. u}" assumes fas: "\xs::real list. length xs > 0 \ interpret_form safe_form xs \ (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: "\xs. interpret_form safe_form xs \ isFDERIV (length fas) [0.. {l .. u}" proof - have lens0: "length ((x::real) # replicate (D - 1) 0) = DIM(real \ 'a)" for x using assms by auto have a0: "(a, 0) \ {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\'a. interpret_form safe_form (list_of_eucl x)}" interpret ode_interpretation safe_form ?U fas "\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 \ 'a)" "length (t2 # us) = DIM(real \ 'a)" "aform.D odo = DIM(real \ 'a)" using lenlu by (simp_all add: lfas aform.D_def D aform.ode_e_def ) have D_odo: "aform.D odo = DIM(real \ '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) \ {eucl_of_list (0#ls)..eucl_of_list (t2#us)}" and exivl: "b - a \ existence_ivl0 (a, 0)" by auto have flow: "flow0 (a, 0) (b - a) \ UNIV \ {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] \a \ b\ exivl have "0 \ 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) \ ?U" by simp from flow_solves_ode[OF UNIV_I this] have fs: "((\t. (fst (flow0 (a, 0) t), snd (flow0 (a, 0) t))) solves_ode (\_ x. (1, f (fst x)))) (existence_ivl0 (a, 0)) ?U" by simp with solves_odeD[OF fs] have vdp: "((\t. (fst (flow0 (a, 0) t), snd (flow0 (a, 0) t))) has_vderiv_on (\t. (1, f (fst (flow0 (a, 0) t))))) (existence_ivl0 (a, 0))" by simp have "fst (flow0 (a, 0) t) = a + t" if "t \ existence_ivl0 (a, 0)" for t proof - have "fst (flow0 (a, 0) 0) = a" using safe by (auto simp: ) have "((\t. fst (flow0 (a, 0) t)) has_vderiv_on (\x. 1)) (existence_ivl0 (a, 0))" using has_vderiv_on_PairD[OF vdp] by auto then have "((\t. fst (flow0 (a, 0) t)) has_vderiv_on (\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 "((\t. (t, snd (flow0 (a, 0) t))) solves_ode (\t x. (1, f (a + fst x)))) (existence_ivl0 (a, 0)) ((existence_ivl0 (a, 0)) \ 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: "((\(x, y). (x - a, y::'a)) has_derivative (\x. x)) (at x within t)" for x t by (auto intro!: derivative_eq_intros) from 1 have "((\x. (a + x, snd (flow0 (a, 0) x))) has_derivative (\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 "((\x. (x, snd (flow0 (a, 0) x))) has_derivative (\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 "((\t. snd (flow0 (a, 0) t)) solves_ode (\b c. f (a + b))) (existence_ivl0 (a, 0)) UNIV" by simp \ \TODO: do non-autonomous -- autonomous conversion automatically!\ then have "((\t. snd (flow0 (a, 0) t)) solves_ode (\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 "((\b. f (a + b)) has_integral snd (flow0 (a, 0) (b - a))) (cbox 0 (b - a))" using \a \ b\ 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 "\ \ {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 \ Float (Code_Target_Int.positive x) 0" by (simp add: Float_def float_of_numeral) definition no_print::"String.literal \ 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 (fst (the (approx prec fa [])), snd (the (approx prec fa [])))" + "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 (fst (the (approx p f xs)))" -definition [simp]: "approx2 p f xs = real_of_float (snd (the (approx p f xs)))" +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 \ approx p f xs \ None" definition "approxs p fs xs = those (map (\f. approx p f xs) fs)" definition [simp]: "approxs1 p f xs = - (case approxs p f xs of Some y \ (map (real_of_float o fst) y) | None \ replicate (length f) 0)" + (case approxs p f xs of Some y \ (map (real_of_float o lower) y) | None \ replicate (length f) 0)" definition [simp]: "approxs2 p f xs = - (case approxs p f xs of Some y \ (map (real_of_float o snd) y) | None \ replicate (length f) 0)" + (case approxs p f xs of Some y \ (map (real_of_float o upper) y) | None \ replicate (length f) 0)" definition "approxs_defined p fs xs \ (those (map (\f. approx p f xs) fs) \ 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 \ {(approx1 prec fa []) .. (approx2 prec fa [])}" if "x = interpret_floatarith fa []" "approx_defined prec fa []" using that - by (auto dest: approx_emptyD) - + by (force dest: approx_emptyD simp: set_of_eq) lemma real_subset_approxI: "{a .. b} \ {(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 (auto dest: approx_emptyD) + 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 \ {real_of_float (fst (ys ! ia)) .. (snd (ys ! ia))}" + "interpret_floatarith (fas ! ia) xs \ {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 \ (\f. approx prec f XS)) fas" and ex: "\y. i < length fas \ approx prec (fas ! i) XS = Some y" for i by auto - from ex[of ia] that obtain l u where lu: "Some (l, u) = approx prec (fas ! ia) XS" 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 "real_of_float l \ interpret_floatarith (fas ! ia) xs \ interpret_floatarith (fas ! ia) xs \ real_of_float u" + have "interpret_floatarith (fas ! ia) xs \\<^sub>r ivl" by auto moreover - have "ys ! ia = (l, u)" + have "ys ! ia = ivl" unfolding ys apply (auto simp: o_def) apply (subst nth_map) apply (simp add: that) - using lu[symmetric] by simp + using ivl by simp ultimately show ?thesis using that - by (auto simp: approxs_eq_Some_lengthD split: prod.splits) + 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) \ - {eucl_of_list (map fst ys) .. eucl_of_list (map snd ys)::'a::executable_euclidean_space}" + {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 b + subgoal for a fas aa apply (cases "those (map (\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 \ 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 [])} \ {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} \ {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 []) \ 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) \ eucl_of_list uX0 \ (\i. i < DIM('a) \ t \ Basis_list ! i \ 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 \ (t::'a::executable_euclidean_space) \ (\i. i < DIM('a) \ uX0 ! i \ t \ 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 ($$ 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 \ list_interval lX0 uX0 \ x0 \ {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 \TODO: make a tactic out of this?!\ lemma file_output_iff: "file_output s f = f (\_. ())" 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 \ Y0" "CZ \ CX" "S \ 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 \ 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: "(\a xs b ba ro. (xs, ro) \ set guards \ ((a, b), ba) \ set xs \ length a = DIM('a) \ length b = DIM('a) \ 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 \ {eucl_of_list lX0 .. eucl_of_list uX0}" and nD: "n < DIM('a)" and SS: "SS = {x::'a. x \ Basis_list ! n \ lP ! n}" and R: "{eucl_of_list lR .. eucl_of_list uR} \ R" shows "\x\X0. returns_to P x \ return_time P differentiable at x within SS \ (\D. (poincare_map P has_derivative blinfun_apply D) (at x within SS) \ poincare_map P x \ R \ D o\<^sub>L blinfun_of_list DX0 \ blinfuns_of_lvivl (lDS, uDS))" proof (rule ballI) fix x assume "x \ X0" then have la2: "list_all2 (\) 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: "\X. X \ set [((1::ereal, 1::ereal), aforms_of_ivls lX0 uX0, Some (aforms_of_point DX0))] \ 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) \ 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) \ plane_of (map_sctn eucl_of_list (Sctn (unit_list D n) (lP ! n)))) (set_of_lvivl (lR, uR) \ 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 \ {blinfun_of_list DX0}::('a \ ('a \\<^sub>L 'a)) set) SS UNIV (R \ 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 \ return_time P differentiable at x within SS \ (\D. (poincare_map P has_derivative blinfun_apply D) (at x within SS) \ poincare_map P x \ R \ D o\<^sub>L blinfun_of_list DX0 \ blinfuns_of_lvivl (lDS, uDS))" using \x \ X0\ by (auto simp: poincare_mapsto_def) qed definition guards_invar::"nat \ (((real list \ real list) \ real list sctn) list \ (real \ real pdevs) reach_options) list \ bool" where "guards_invar D guards = ($$xs, ro) \ set guards. \((a, b), ba) \ set xs. length a = D \ length b = D \ 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 \ {eucl_of_list lX0 .. eucl_of_list uX0}" and nD: "n < DIM('a)" and R: "{eucl_of_list lR .. eucl_of_list uR} \ 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 "\x\X0. returns_to P x \ poincare_map P x \ R" proof - note solves = solves[unfolded solves_poincare_map_aform'_fo_def file_output_iff] have 1: "\X. X \ set [((1::ereal, 1::ereal), aforms_of_ivls lX0 uX0, None)] \ 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) \ set guards \ ((a, b), ba) \ set xs \ length a = DIM('a) \ length b = DIM('a) \ 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) \ 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) \ plane_of (map_sctn eucl_of_list (mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n))))) (set_of_lvivl (lR, uR) \ 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 \ UNIV::('a \ ('a \\<^sub>L 'a)) set) (below_halfspace (map_sctn eucl_of_list (((Sctn (unit_list D n) (lP ! n)))))) UNIV (R \ 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 "\x\X0. returns_to P x \ poincare_map P x \ 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 \ {eucl_of_list lX0 .. eucl_of_list uX0}" and nD: "n < DIM('a)" and R: "{eucl_of_list lR .. eucl_of_list uR} \ 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 "\x\X0. returns_to P x \ poincare_map_from_outside P x \ R" proof - note solves = solves[unfolded solves_poincare_map_onto_aform_fo_def file_output_iff] have 1: "\X. X \ set [((1::ereal, 1::ereal), aforms_of_ivls lX0 uX0, None)] \ 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) \ set guards \ ((a, b), ba) \ set xs \ length a = DIM('a) \ length b = DIM('a) \ 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) \ 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) \ plane_of (map_sctn eucl_of_list (mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n))))) (set_of_lvivl (lR, uR) \ 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 \ UNIV::('a \ ('a \\<^sub>L 'a)) set) UNIV UNIV (R \ 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 "\x\X0. returns_to P x \ poincare_map_from_outside P x \ 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: ) end ML \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 \ nat \ nat" "(-) ::nat \ nat \ nat" "(=)::nat\nat\bool" "(^)::nat\nat\nat" (* int / integer*) "(=)::int\int\bool" "(+)::int\int\int" "uminus::_\int" "uminus::_\integer" int_of_integer integer_of_int "0::int" "1::int" "(^)::int\nat\int" (* real *) "(=)::real\real\bool" "real_of_float" "(/)::real\real\real" "(^)::real\nat\real" "uminus::real\_" "(+)::real\real\real" "(-)::real\real\real" "(*)::real\real\real" real_divl real_divr real_of_int "0::real" "1::real" (* rat *) Fract "0::rat" "1::rat" "(+)::rat\rat\rat" "(-)::rat\rat\rat" "(*)::rat\rat\rat" "uminus::rat\_" "(/)::rat\rat\rat" "(^)::rat\nat\rat" (* ereal *) "1::ereal" (* lists: *) "replicate::_\real\_" "unit_list::_\_\real list" "Nil::(nat \ nat \ string) list" "Cons::_\_\(nat \ nat \ string) list" "Nil::(nat \ nat \ string \ nat list) list" "Cons::_\_\(nat \ nat \ string \ nat list) list" "Nil::real list" "Cons::_\_\real list" "Nil::nat list" "Cons::_\_\nat list" "Nil::string list" "Cons::_\_\string list" "Nil::real aform list" "Cons::_\_\real aform list" - "Nil::(float \ float) option list" - "Cons::_\_\(float \ float) option list" + "Nil::(float interval) option list" + "Cons::_\_\(float interval) option list" "nth::_\_\real" "upt" (* products: *) "Pair::_\_\(nat \ string)" "Pair::_\_\(nat \ nat \ string)" "Pair::_\_\char list \ nat list" "Pair::_\_\nat \ char list \ nat list" "Pair::_\_\nat \ nat \ char list \ nat list" "Pair::_\_\char list \ ((String.literal \ unit) \ (real \ real pdevs) numeric_options)" "Pair::_\_\ereal\ereal" "Pair::_\_\real aform list \ real aform list option" "Pair::_\_\(ereal \ ereal) \ real aform list \ real aform list option" "Pair::_\_\real aform" "Pair::_\_\real list \ real list" "Nil::(((real list \ real list) \ real list sctn) list \ (real aform) reach_options) list" "Cons::_\_\(((real list \ real list) \ real list sctn) list \ (real aform) reach_options) list" "Nil::((real list \ real list) \ real list sctn) list" "Cons::_\_\((real list \ real list) \ real list sctn) list" "Pair::_\_\((real list \ real list) \ real list sctn) list \ real aform reach_options" "Nil::((ereal \ ereal) \ (real aform) list \ (real aform) list option) list" "Cons::_\_\((ereal \ ereal) \ (real aform) list \ (real aform) list option) list" (* option *) "None::(real aform) list option" "Some::_\(real aform) list option" "None::(real list \ real list) option" "Some::_\(real list \ real list) option" (* aforms *) "aform_of_ivl::_\_\real aform" aforms_of_ivls aforms_of_point (* pdevs*) "zero_pdevs::real pdevs" "zero_aforms::_ \ real aform list" (* ode_ops *) mk_ode_ops init_ode_ops empty_ode_ops can_mk_ode_ops "the::ode_ops option \ ode_ops" the_odo (* Characters/Strings *) String.Char String.implode "Nil::string" "Cons::_\_\string" (* float *) "(=)::float\float\bool" "(+)::float\float\float" "uminus::_\float" "(-)::_\_\float" Float float_of_int float_of_nat (* approximation... *) approx approx1 approx2 approxs1 approxs2 approx_defined approxs_defined (* floatarith *) "0::floatarith" "1::floatarith" "(+)::_\_\floatarith" "(-)::_\_\floatarith" "(*)::_\_\floatarith" "(/)::_\_\floatarith" "inverse::_\floatarith" "uminus::_\floatarith" "Sum\<^sub>e::_\nat list\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 \ real" } \ ML \fun ode_numerics_tac ctxt = CONVERSION (ode_numerics_conv ctxt) THEN' (resolve_tac ctxt [TrueI])\ 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 \ 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) \ e / f" if "y \ {yl .. yu}" "x \ {yu - real_divl p e f.. yl + real_divl p e f}" for x y e::real proof - note \x \ _\ also have "{yu - real_divl p e f.. yl + real_divl p e f} \ {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 \ {a .. a}" for a::real by auto lemma pi4_bnds: "pi / 4 \ {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: "\x - x'\ \ e" if "x \ {x' - e .. x' + e}" for x e::real using that by (auto simp: ) 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 \ {a .. a}" lemma isFDERIV_compute: "isFDERIV D vs fas xs \ (list_all (\i. list_all (\j. isDERIV (vs ! i) (fas ! j) xs) [0.. length fas = D \ 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]: \ \TODO: replace @{thm solves_poincare_map_aform'_derivI}\ assumes "TAG_optns optns" assumes "TAG_reach_optns roi" assumes "TAG_sctn mirrored" and D: "D = DIM('a)" assumes DS: "list_interval lDR uDR \ 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 \ {eucl_of_list lX0 .. eucl_of_list uX0}" and nD: "n < DIM('a)" and R: "{eucl_of_list lR .. eucl_of_list uR} \ 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 \ Basis_list ! n \ lP ! n else x \ Basis_list ! n \ lP ! n}" assumes solves: "solves_poincare_map_aform'_fo optns odo (mirrored_sctn (\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 "\x\X0. returns_to P x \ return_time P differentiable at x within SS \ (\D. (poincare_map P has_derivative blinfun_apply D) (at x within SS) \ poincare_map P x \ R \ D o\<^sub>L blinfun_of_list DX0 \ blinfuns_of_lvivl (lDS, uDS))" proof (rule ballI) fix x assume "x \ X0" then have la2: "list_all2 ($$ 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: "\X. X \ set [((1::ereal, 1::ereal), aforms_of_ivls lX0 uX0, Some (aforms_of_point DX0))] \ 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 (\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) \ 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 (\mirrored) (Sctn (unit_list D n) (lP ! n))))) (aform.Csafe odo - set_of_lvivl (lP, uP) \ plane_of (map_sctn eucl_of_list (mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n))))) (set_of_lvivl (lR, uR) \ 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 \auto simp: guards_invar_def\) then have "poincare_mapsto P (X0 \ {blinfun_of_list DX0}::('a \ ('a \\<^sub>L 'a)) set) SS UNIV (R \ 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 \ return_time P differentiable at x within SS \ (\D. (poincare_map P has_derivative blinfun_apply D) (at x within SS) \ poincare_map P x \ R \ D o\<^sub>L blinfun_of_list DX0 \ blinfuns_of_lvivl (lDS, uDS))" using \x \ X0\ by (auto simp: poincare_mapsto_def) qed lemmas [DIM_simps] = aform.ode_e_def ML \ 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 = ([], [((("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 = ([], [((("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 = ([], [((("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 = ([((("'i", 0), @{sort "{enum}"}), mk_numeralT (d + 1) |> Thm.ctyp_of ctxt)], [((("optns", 0), @{typ "string \ ((String.literal \ unit) $$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 \ nat \ 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 \ nat \ string \ nat list"} (map mk_proj_c1 projs) fun TAG_optns_thm p sstep m N atol projs filename ctxt = Thm.instantiate ([], [((("optns", 0), @{typ "string \ ((String.literal \ unit) \(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 ([], [((("optns", 0), @{typ "string \ ((String.literal \ unit) \(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 \ lemma (in auto_ll_on_open) Poincare_Banach_fixed_pointI: assumes "convex S" and c: "complete S" "S \ {}" and "S \ T" assumes derivative_bounded: "\x\S. poincare_map \ x \ S \ (\D. (poincare_map \ has_derivative D) (at x within T) \ onorm D \ B)" assumes B: "B < 1" shows "\!x. x \ S \ poincare_map \ x = x" using c _ B proof (rule banach_fix) from derivative_bounded c show "0 \ B" by (auto dest!: has_derivative_bounded_linear onorm_pos_le) from derivative_bounded show "poincare_map \  S \ S" by auto obtain D where D: "\x \ S. (poincare_map \ has_derivative D x) (at x within T) \ onorm (D x) \ B" apply atomize_elim apply (rule bchoice) using derivative_bounded by auto with \S \ T\ have "(\x. x \ S \ (poincare_map \ has_derivative D x) (at x within S))" by (auto intro: has_derivative_within_subset) from bounded_derivative_imp_lipschitz[of S "poincare_map \" D B, OF this] \convex S\ D c \0 \ B\ have "B-lipschitz_on S (poincare_map$$" by auto then show "\x\S. \y\S. dist (poincare_map \ x) (poincare_map \ y) \ B * dist x y" by (auto simp: lipschitz_on_def) qed ML \open ODE_Numerics_Tac\ lemma isFDERIV_product: "isFDERIV n xs fas vs \ length fas = n \ length xs = n \ list_all ($$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 (metis gt_or_eq_0 less_mult_imp_div_less mod_less_divisor not_less0) by auto end 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,1740 +1,1743 @@ theory Refine_Rigorous_Numerics_Aform imports Refine_Rigorous_Numerics "HOL-Types_To_Sets.Types_To_Sets" begin lemma Joints_ne_empty[simp]: "Joints xs \ {}" "{} \ Joints xs" by (auto simp: Joints_def valuate_def) lemma Inf_aform_le_Affine: "x \ Affine X \ Inf_aform X \ x" by (auto simp: Affine_def valuate_def intro!: Inf_aform) lemma Sup_aform_ge_Affine: "x \ Affine X \ x \ 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 \ form \ real aform list \ bool" where "approx_form_aform prec (Less a b) bs = (case (approx_floatariths prec [a - b] bs) of Some [r] \ Sup_aform' prec r < 0 | _ \ False)" | "approx_form_aform prec (LessEqual a b) bs = (case (approx_floatariths prec [a - b] bs) of Some [r] \ Sup_aform' prec r \ 0 | _ \ False)" | "approx_form_aform prec (AtLeastAtMost a b c) bs = (case (approx_floatariths prec [a - b, a - c] bs) of Some [r, s] \ 0 \ Inf_aform' prec r \ Sup_aform' prec s \ 0 | _ \ 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 \ approx_form_aform prec a bs \ approx_form_aform prec b bs" | "approx_form_aform prec (Disj a b) bs \ approx_form_aform prec a bs \ approx_form_aform prec b bs" lemma in_Joints_intervalD: "x \ {Inf_aform' p X .. Sup_aform' p X} \ xs \ Joints XS" if "x#xs \ 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 \ 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 \ real aform list \ real aform list \ 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 \ nat)" abbreviation "msum_aforms' \ \X Y. msum_aforms (degree_aforms_real (X @ Y)) X Y" lemma aform_val_msum_aforms: assumes "degree_aforms xs \ d" shows "aform_vals e (msum_aforms d xs ys) = List.map2 (+) (aform_vals e xs) (aform_vals (\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 \ 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 (\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 \ d" assumes "degree_aforms ys \ d" shows "Joints (msum_aforms d xs ys) = {List.map2 (+) a b |a b. a \ Joints xs \ b \ 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="\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 (\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 \intersection with plane\ definition "project_coord x b n = (\i\Basis_list. (if i = b then n else if i = -b then -n else x \ i) *\<^sub>R i)" lemma inner_eq_abs_times_sgn: "u \ b = abs u \ b * sgn (u \ b)" if "b \ 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 \ Basis \ abs u \ Basis \ x \ \u\ \ x \ 0 \ u \ 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 \ Basis" obtains "abs u = u" | "abs u = - u" proof (cases "u \ abs u = 1") case True have "abs u = (\i\Basis. (if i = abs u then (abs u \ i) *\<^sub>R i else 0))" using assms by (auto simp: ) also have "\ = (\i\Basis. (if i = abs u then (u \ i) *\<^sub>R i else 0))" by (rule sum.cong) (auto simp: True) also have "\ = (\i\Basis. (u \ i) *\<^sub>R i)" by (rule sum.cong) (auto simp: inner_Basis_eq_zero_absI assms) also have "\ = u" by (simp add: euclidean_representation) finally show ?thesis .. next case False then have F: "u \ \u\ = -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 = (\i\Basis. (if i = abs u then (abs u \ i) *\<^sub>R i else 0))" using assms by (auto simp: ) also have "\ = (\i\Basis. (if i = abs u then (- u \ i) *\<^sub>R i else 0))" by (rule sum.cong) (auto simp: F) also have "\ = (\i\Basis. (- u \ i) *\<^sub>R i)" by (rule sum.cong) (auto simp: inner_Basis_eq_zero_absI assms) also have "\ = - u" by (subst euclidean_representation) simp finally show ?thesis .. qed lemma abs_in_Basis_iff: fixes u::"'a::ordered_euclidean_space" shows "abs u \ Basis \ u \ Basis \ - u \ Basis" proof - have u: "u = (\i\Basis. (u \ i) *\<^sub>R i)" by (simp add: euclidean_representation) have u': "- u = (\i\Basis. (- (u \ i)) *\<^sub>R i)" by (subst u) (simp add: sum_negf) have au: "abs u = (\i\Basis. \u \ i\ *\<^sub>R i)" by (simp add: eucl_abs[where 'a='a]) have "(u \ Basis \ - u \ Basis)" if "(\u\ \ 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 \ Basis" "abs v \ Basis" shows "inner u v = (if u = v then 1 else if u = -v then -1 else 0)" proof - define i where "i \ if u \ Basis then u else -u" define j where "j \ if v \ Basis then v else -v" have u: "u = (if u \ Basis then i else - i)" and v: "v = (if v \ Basis then j else - j)" by (auto simp: i_def j_def) have "i \ Basis" "j \ 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 \ Basis" shows "(project_coord x b n) \ i = (if i = b then n else if i = -b then -n else x \ i)" proof - have "project_coord x b n \ i = (\j\Basis. (if j = b then n else if j = -b then -n else x \ j) * (if j = i then 1 else 0))" using assms by (auto simp: project_coord_def inner_sum_left inner_Basis) also have "\ = (\j\Basis. (if j = i then (if j = b then n else if j = -b then -n else x \ j) else 0))" by (rule sum.cong) auto also have "\ = (if i = b then n else if i = -b then -n else x \ i)" using assms by (subst sum.delta) auto finally show ?thesis by simp qed lemma project_coord_inner: assumes "abs i \ Basis" shows "(project_coord x b n) \ i = (if i = b then n else if i = -b then -n else x \ i)" proof - consider "i \ Basis" | "- i \ 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 \ i = - (project_coord x b n \ - i)" by simp also have "\ = - (if - i = b then n else if - i = -b then -n else x \ - i)" using 2 by (subst project_coord_inner_Basis) simp_all also have "\ = (if i = b then n else if i = -b then -n else x \ 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 \ 'a pdevs \ 'a pdevs" is "\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 \ nat \ real \ 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. (\x\s. f x i) \ 0} \ {i. \x\s. f x i \ 0}" proof - have "{i. (\x\s. f x i) \ 0} = - {i. (\x\s. f x i) = 0}" by auto also have "\ \ - {i. \x \ s. f x i = 0}" by auto also have "\ = {i. \x \ s. f x i \ 0}" by auto finally show ?thesis by simp qed lift_definition sum_pdevs::"('i \ 'a::comm_monoid_add pdevs) \ 'i set \ 'a pdevs" is "\f X. if finite X then (\i. \x\X. f x i) else (\_. 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 = (\x\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 \ sum_pdevs f (insert a xs) = (if a \ 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 \ sum_pdevs f X = zero_pdevs" by transfer auto lemma compute_sum_pdevs[code]: "sum_pdevs f (set XS) = foldr (\a b. add_pdevs (f a) b) (remdups XS) zero_pdevs" by (induction XS) (auto simp: ) lemma degree_sum_pdevs_le: "degree (sum_pdevs f X) \ Max (degree  f  X)" apply (rule degree_le) apply auto apply (cases "X = {}") subgoal by (simp add: ) subgoal by (cases "finite X") simp_all done lemma pdevs_val_sum_pdevs: "pdevs_val e (sum_pdevs f X) = (\x\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 \ real pdevs) list \ 'a::executable_euclidean_space aform" where "eucl_of_list_aform xs = (eucl_of_list (map fst xs), sum_pdevs (\i. pdevs_scaleR (snd (xs ! index Basis_list i)) i) Basis)" definition lv_aforms_rel::"(((real \ real pdevs) list) \ ('a::executable_euclidean_space aform)) set" where "lv_aforms_rel = br eucl_of_list_aform (\xs. length xs = DIM('a))" definition "inner_aforms' p X Y = (let fas = [inner_floatariths (map floatarith.Var [0..d x y. Some (F d x y)) f" assumes "[x, y] \ Joints [X, Y]" assumes "d \ degree_aform X" assumes "d \ degree_aform Y" shows "f x y \ Affine (F d X Y)" proof - from assms(2) obtain e where e: "e \ 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' \ funcset UNIV {- 1..1}" "f (aform_val e X) (aform_val e Y) = aform_val e' (F d X Y)" "\n. n < d \ 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 \ 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]: "(($$, (\)) \ \S\option_rel \ (S \ \R\option_rel) \ \R\option_rel" unfolding Option.bind_def by parametricity lemma zip_Basis_list_pat[autoref_op_pat_def]: "$$b, m)\zip Basis_list ms. m *\<^sub>R b \ OP eucl_of_list  ms" proof (rule eq_reflection) have z: "zip ms (Basis_list::'a list) = map (\(x, y). (y, x)) (zip Basis_list ms)" by (subst zip_commute) simp show "(\(b, m)\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) \ lv_rel \ 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) \ lv_rel \ b \ Basis \ xs ! index (Basis_list) b = x \ 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) \ lv_rel \ lv_rel \ 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) \ nat_rel \ ((rnv_rel \\<^sub>r rnv_rel) \\<^sub>r Id) \ rnv_rel \ \rnv_rel \\<^sub>r rnv_rel\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) \ \rnv_rel\list_rel" shows "(xsi, eucl_of_list  xs::'a) \ 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, ($$) \ lv_rel \ lv_rel \ rnv_rel" using lv_rel_inner[unfolded inner_lv_rel_def[symmetric]] by auto lemma inner_lv_rel_eq: "\length xs = DIM('a::executable_euclidean_space); (xa, x'a) \ lv_rel\ \ inner_lv_rel xs xa = eucl_of_list xs \ (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 (\i. scaleR_pdevs (ys ! i) (xs ! i)) {..xs a b. (inner2s (map fst xs) a b, pdevs_inner2s (map snd xs) a b)), inner2_aform) \ lv_aforms_rel \ lv_rel \ lv_rel \ ((rnv_rel \\<^sub>r rnv_rel)\\<^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 (\b. bound_intersect_2d_ud p (inner2_aform Z n b) g) Basis_list) of Some mMs \ do { ASSERT (length mMs = DIM('a::executable_euclidean_space)); let l = ($$b, m)\zip Basis_list (map fst mMs). m *\<^sub>R b); let u = (\(b, M)\zip Basis_list (map snd mMs). M *\<^sub>R b); RETURN (Some (aform_of_ivl l u)) } | None \ 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) \ nat_rel" "(Zi, Z) \ lv_aforms_rel" "(ni, n) \ lv_rel" "(gi, g) \ rnv_rel" notes [autoref_rules] = those_param param_map shows "(nres_of (?f::?'a dres), inter_aform_plane_ortho_nres  p  Z  n  g) \ ?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) \ lv_aforms_rel" "(ni, n) \ nat_rel" assumes "SIDE_PRECOND (n < DIM('a))" shows "(project_coord_aform_lv xs ni, project_ncoord_aform  x  n) \ rnv_rel \ 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: ) 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: ) 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 \ inter_aform_plane_ortho_nres (prec) (Xs) (normal sctn) (pstn sctn); case cxs of Some cxs \ (if normal sctn \ 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 \ 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 \ SUCCEED }" lemma [autoref_rules]: assumes [THEN GEN_OP_D, param]: "GEN_OP (=) (=) (A \ A \ bool_rel)" shows "(index, index) \ \A\list_rel \ A \ 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) \ nat_rel" "(Zi, Z) \ lv_aforms_rel" "(sctni, sctn) \ \lv_rel\sctn_rel" notes [autoref_rules] = those_param param_map shows "(nres_of (?f::?'a dres), inter_aform_plane prec Z sctn) \ ?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 \ Basis \ - i \ 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 \ Basis \ - normal sctn \ Basis" assumes "i \ Basis" shows "pdevs_apply (project_coord_pdevs sctn cxs) x \ i = (if i = abs (normal sctn) then 0 else pdevs_apply cxs x \ 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) \ pdevs_domain X" apply (auto simp: ) 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 \ Basis" shows "pdevs_val e (project_coord_pdevs sctn X) \ b = (if b = abs (normal sctn) then 0 else pdevs_val e X \ b)" using assms apply (auto simp: ) 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 \ Basis \ x \ b = (\i\Basis. x \ i * (i \ 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 (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 \ 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 \ Affine X" assumes "x \ plane_of sctn" shows "x \ 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 \ 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 \x = aform_val e X\ . then show ?thesis using \e \ _\ by (auto simp: Affine_def valuate_def) qed lemma mem_Affine_project_coord_aformD: assumes "x \ Affine (project_coord_aform sctn X)" assumes "abs (normal sctn) \ Basis" shows "x \ 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 (\_ _. True) else let Ds = sorted_list_of_set D; ortho_indices = map fst (take (diff + N) (sort_key (\(i, r). r) (map (\i. let xs = M i in (i, sum_list' p (map abs xs) - fold max (map abs xs) 0)) Ds))); _ = () in (\i (xs::real list). i \ 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 \ 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 \ Sup_aform' (prec) (hd Xn))" text \cannot fail\ -lemma approx_un_ne_None: "approx_un p (\l u. Some (f l u)) (Some r) \ None" +lemma approx_un_ne_None: "approx_un p (\ivl. Some (f ivl)) (Some r) \ None" by (auto simp: approx_un_def split_beta') lemma approx_un_eq_Some: - "approx_un p (\l u. Some (f l u)) (Some r) = Some s \ - s = ivl_err ((fst (f (Inf_aform_err p r) (Sup_aform_err p r)))) - ((snd (f (Inf_aform_err p r) (Sup_aform_err p r))))" + "approx_un p (\ivl. Some (f ivl)) (Some r) = Some s \ + 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 \ 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) \ is_float a" "min_range_antimono p F D E X Y = Some ((a, b), c) \ is_float c" "min_range_mono p F D E X Y = Some ((a, b), c) \ is_float a" "min_range_mono p F D E X Y = Some ((a, b), c) \ 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 (x1) (x2) = ((a, b), c)" "is_float x1" "is_float x2" + 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) + using assms by (auto simp: ivl_err_def x1_def x2_def) moreover have "(x1 + x2) / 2 \ float" "(x2 - x1) / 2 \ float" using assms - by (auto simp: is_float_def) + 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 \ is_float a \ is_float b \ is_float c" proof goal_cases case 1 then have "c = (a + b) / 2" by simp also have "\ \ 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) \ list_all (\((a, b), c). is_float a \ is_float c) XS \ is_float a \ 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 by (auto simp: bind_eq_Some_conv uminus_aform_def Let_def is_float_min_range - is_float_ivl_err + 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 \ length XS" "list_all (\((a, b), c). is_float a \ is_float c) XS" shows "approx_floatarith p fa XS \ 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 "\fa. fa \ set fas \ plain_floatarith N fa" "N \ length XS" "list_all (\((a, b), c). is_float a \ is_float c) XS" shows "approx_slp p fas XS \ 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 \ length XS" "list_all (\((a, b), c). is_float a \ 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 \ approx_slp p b ((map (\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 \ 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 \ None" if "\x. x \ set xs \ approx_floatarith p x zs \ None" and "\x. x \ set ys \ approx_floatarith p x zs \ 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..x. (x, 0)) a @ map (\x. (x, 0)) b) \ None" by (rule aiN) (auto simp: nth_append) lemma iaN: "inner_aforms' p a b \ 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 \ 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 \R\set_rel" lemma aform_rel_def: "\rnv_rel\aform_rel = br Affine top" unfolding relAPP_def by (auto simp: aform_rel_internal) definition "aforms_rel = br Joints top" definition aform_rell :: "((real \ real pdevs) list \ real list set) set" where "aform_rell = aforms_rel" definition aforms_relp_internal: "aforms_relp R = aforms_rel O \R\set_rel" lemma aforms_relp_def: "\R\aforms_relp = aforms_rel O \R\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 \ Joints a" assumes "length a = DIM('a::executable_euclidean_space)" shows "eucl_of_list x \ 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 \ Affine (eucl_of_list_aform x::'a aform)" shows "xa \ 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 = \ appr_of_ivl = aforms_of_ivls, product_appr = product_aforms, msum_appr = msum_aforms', inf_of_appr = \optns. inf_aforms (precision optns), sup_of_appr = \optns. sup_aforms (precision optns), split_appr = split_aforms_largest_uncond_take, appr_inf_inner = \optns. aform_inf_inner (precision optns), appr_sup_inner = \optns. aform_sup_inner (precision optns), inter_appr_plane = \optns xs sctn. inter_aform_plane_lv (length xs) (precision optns) xs sctn, reduce_appr = \optns. reduce_aforms (precision optns), width_appr = \optns. width_aforms (precision optns), approx_slp_dres = \optns. aform_slp (precision optns), approx_euclarithform = \optns. aform_form (precision optns), approx_isFDERIV = \optns. aform_isFDERIV (precision optns) \" 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 \ real" assume perm: "?perm X Y" and e: "e \ 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' \ funcset UNIV {- 1..1}" by auto note e'(1) also from pdevs_val_perm[OF perm e'(2)] obtain e'' where e'': "e'' \ 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''' \ funcset UNIV {- 1..1}" by auto note e'''(1) finally have "\e' \ 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 \ y \ (aform_of_ivl x y, atLeastAtMost x y) \ \rnv_rel\aform_rel" by (auto simp: aform_rel_def br_def Affine_aform_of_ivl) lemma aforms_of_ivl_leI1: fixes en::real assumes "-1 \ en" "xsn \ ysn" shows "xsn \ (xsn + ysn) / 2 + (ysn - xsn) * en / 2" proof - have "xsn * (1 + en) \ 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 \ en" "xsn \ ysn" shows "(xsn + ysn) / 2 + (ysn - xsn) * en / 2 \ ysn" proof - have "xsn * (1 - en) \ 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 \ Joints (aforms_of_ivls xs ys) \ list_all2 ($$ xs ys \ list_all2 (\) 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 \ Joints (aforms_of_ivls xs ys) \ list_all2 (\) xs ys \ list_all2 (\) 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 (\) xrs yrs \ (xri, xrs) \ \rnv_rel\list_rel \ (yri, yrs) \ \rnv_rel\list_rel \ (aforms_of_ivls xri yri, lv_ivl xrs yrs) \ 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 (\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="\i. e (i + degree_aforms a)"]) done subgoal for e1 e2 apply (rule image_eqI[where x="\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 \ 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) \ aforms_rel \ aforms_rel \ 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) \ \lv_rel\set_rel \ (z = eucl_of_list  y \ (\x \ 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) \ (x, eucl_of_list x::'a) \ lv_rel" unfolding lv_rel_def by (auto simp: br_def) lemma mem_Joints_msum_aforms'I: "a \ Joints x \ b \ Joints y \ List.map2 (+) a b \ Joints (msum_aforms' x y)" by (auto simp: Joints_msum_aforms degrees_def) lemma mem_Joints_msum_aforms'E: assumes "xa \ Joints (msum_aforms' x y)" obtains a b where "xa = List.map2 (+) a b" "a \ Joints x" "b \ 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 \ Joints x \ b \ Joints y}) \ 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) \ aforms_rel \ b = Joints a" by (auto simp: aforms_rel_def br_def) lemma msum_aforms'_refine: "(msum_aforms', \xs ys. {List.map2 (+) x y |x y. x \ xs \ y \ ys}) \ aforms_rel \ aforms_rel \ 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) \ aforms_rel \ length xi = d \ (RETURN (inf_aforms optns xi), Inf_specs d x) \ \rl_rel\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) \ aforms_rel \ length xi = d \ (RETURN (sup_aforms optns xi), Sup_specs d x) \ \rl_rel\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 "\v. x = Some v \ RETURN v \ y" shows "nres_of (THE_DRES x) \ y" using assms by (auto simp: THE_DRES_def split: option.split) lemma degree_le_fresh_index: "a \ set A \ degree_aform a \ fresh_index_aforms A" by (auto simp: fresh_index_aforms_def intro!: Max_ge) lemma zero_in_JointsI: "xs \ Joints XS \ z = (0, zero_pdevs) \ 0 # xs \ Joints (z # XS)" by (auto simp: Joints_def valuate_def) lemma cancel_nonneg_pos_add_multI: "0 \ c + c * x" if "c \ 0" "1 + x \ 0" for c x::real proof - have "0 \ c + c * x \ 0 \ c * (1 + x)" by (auto simp: algebra_simps) also have "\ \ 0 \ 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 \ Joints (map (\a. fst (split_aform a i)) x) \ Joints (map (\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 \ funcset UNIV {-1 .. 1}" "xs = map (aform_val e) x" by (auto simp: Joints_def valuate_def) consider "e i \ 0" | "e i \ 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 (\b. snd (split_aform b i)) x)" by (auto simp: aform_val_def split_aform_def Let_def divide_simps algebra_simps) also have "\ \ Joints (map (\b. snd (split_aform b i)) x)" using e \0 \ e i\ 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 (\b. fst (split_aform b i)) x)" by (auto simp: aform_val_def split_aform_def Let_def divide_simps algebra_simps) also have "\ \ Joints (map (\b. fst (split_aform b i)) x)" using e \0 \ e i\ 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) \ aforms_rel" assumes "z \ y" assumes "l = (length x)" shows "\a b. (split_aforms x i, a, b) \ aforms_rel \\<^sub>r aforms_rel \ env_len a l \ env_len b l \ z \ a \ b" using assms apply (auto simp: split_aforms_def o_def) apply (rule exI[where x="Joints (map (\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 (\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) \ nat_rel \ (xi::real aform list, x) \ aforms_rel \ length xi = d \ (RETURN (split_aforms_largest_uncond_take ni xi), split_spec_params d n x) \ \aforms_rel \\<^sub>r aforms_rel\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 = ($$x, y) \ (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 \ (\Y. approx_floatarith p fa (map (\x. (x, 0)) XS) = Some Y \ [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 \ aforms_err e (map (\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 \ (\i. i < degree_aform d \ a i = c i) \ aform_val a b = aform_val c d" by (auto simp: aform_val_def intro!: pdevs_val_degree_cong) lemma mem_degree_aformD: "x \ set XS \ degree_aform x \ degree_aforms XS" by (auto simp: degrees_def) lemma degrees_append_leD1: "(degrees xs) \ 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 \ Joints XS" assumes "inner_aforms' p XS (map pdevs_of_real rs) = Some R" shows "(\(x, y) \ (zip xs rs). x * y) \ Affine (hd R)" (is ?th1) "length R = 1" (is ?th2) proof - from assms obtain e where "e \ 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 \ Joints (XS @ map pdevs_of_real rs)" "length xs = length XS" "e \ 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..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.. aform_err e Y" "degree_aform_err Y \ 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.. err" "err \ 1" by auto let ?e' = "(e(max (degrees (map snd XS @ map (snd \ 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.. 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 "(\(x, y)\zip (map floatarith.Var [0.. Joints (R @ XS @ map pdevs_of_real rs)" apply (subst (asm)interpret_floatarith_inner_eq ) apply (auto simp: ) done also have "(\(x, y)\zip (map floatarith.Var [0..(x, y)\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') \ aforms_rel \ inner_aforms' prec a (map pdevs_of_real a'a) = Some R \ x \ a' \ inner_lv_rel x a'a \ 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="($$", 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) \ aforms_rel \ rl_rel \ \rnv_rel\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) \ aforms_rel \ rl_rel \ \rnv_rel\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 \ \lv_rel\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\)" using bijective_lv_rel by (rule bijective_imp_sv) lemma list_of_eucl_image_lv_rel_inverse: "(x, list_of_eucl  x) \ \lv_rel\\set_rel" unfolding set_rel_sv[OF sv_lv_rel_inverse] apply (auto simp: ) 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::(_\'a::executable_euclidean_space) set) O lv_rel\) = {(x, y). x = y \ 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) \ (xi, x) \ aforms_rel \ (si, s) \ \rl_rel\sctn_rel \ length xi = d \ length (normal si) = d \ (nres_of (inter_aform_plane_lv (length xi) optns xi si), inter_sctn_specs d x s) \ \aforms_rel\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) \ 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) \ \lv_rel\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))) \ \lv_aforms_rel\nres_rel" (is "(_, inter_aform_plane _ ?ea ?se) \ _") 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) \ \br Affine top\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) \ \lv_aforms_rel\nres_rel O \br Affine top\nres_rel" by auto also have "\lv_aforms_rel\nres_rel O \br Affine top\nres_rel \ \\lv_rel\aforms_relp\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))) \ \\lv_rel\aforms_relp\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) \ \\lv_rel\\set_rel\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) \ \\lv_rel::(real list \ 'n rvec)set\aforms_relp\nres_rel O \\lv_rel\\set_rel\nres_rel" by simp also have "\\lv_rel::(real list \ 'n rvec)set\aforms_relp\nres_rel O \\lv_rel\\set_rel\nres_rel \ \aforms_rel O Id\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 \Sign.add_const_constraint (@{const_name "enum_class.enum"}, SOME @{typ "'a list"})\ setup \Sign.add_const_constraint (@{const_name "enum_class.enum_all"}, SOME @{typ "('a \ bool) \ bool"})\ setup \Sign.add_const_constraint (@{const_name "enum_class.enum_ex"}, SOME @{typ "('a \ bool) \ bool"})\ 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 \ d = CARD('a) \ (xi, x) \ aforms_rel \ (si, s) \ \rl_rel\sctn_rel \ length xi = d \ length (normal si) = d \ (nres_of (inter_aform_plane_lv (length xi) optns xi si), inter_sctn_specs d x s) \ \aforms_rel\nres_rel" by (rule inter_aform_plane_refine_unoverloaded0) auto setup \Sign.add_const_constraint (@{const_name "enum_class.enum"}, SOME @{typ "'a::enum list"})\ setup \Sign.add_const_constraint (@{const_name "enum_class.enum_all"}, SOME @{typ "('a::enum \ bool) \ bool"})\ setup \Sign.add_const_constraint (@{const_name "enum_class.enum_ex"}, SOME @{typ "('a::enum \ bool) \ bool"})\ context includes autoref_syntax begin text \TODO: this is a special case of \Cancel_Card_Constraint\ from \AFP/Perron_Frobenius\!\ lemma type_impl_card_n_enum: assumes "$$Rep :: 'a \ 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 \ n = CARD('a)" proof - from assms obtain rep :: "'a \ nat" and abs :: "nat \ 'a" where t: "type_definition rep abs {0 ..< n}" by auto have "card (UNIV :: 'a set) = card {0 ..< n}" using t by (rule type_definition.card) also have "\ = n" by auto finally have bn: "CARD ('a) = n" . let ?enum = "(map abs [0.. n = CARD('a)" by simp then show ?thesis .. qed lemma inter_aform_plane_refine_ex_typedef: "(xi, x) \ aforms_rel \ (si, s) \ \rl_rel\sctn_rel \ length xi = d \ length (normal si) = d \ (nres_of (inter_aform_plane_lv (length xi) optns xi si), inter_sctn_specs d x s) \ \aforms_rel\nres_rel" if "\(Rep :: 'a \ 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 \ (xi, x) \ aforms_rel \ (si, s) \ \Id\sctn_rel \ length xi = d \ length (normal si) = d \ (nres_of (inter_aform_plane_lv (length xi) optns xi si), inter_sctn_specs d x s) \ \aforms_rel\nres_rel" by (rule inter_aform_plane_refine_ex_typedef[cancel_type_definition, simplified]) lemma Joints_reduce_aforms: "x \ Joints X \ x \ 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 \e \ _\ order_refl, of "X" "prec" t] guess e' . 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) \ aforms_rel \ length xi = d \ (RETURN (reduce_aforms prec C xi), reduce_specs d r x) \ \aforms_rel\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) \ Id \ aforms_rel \ \bool_rel\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: "(\N xs fas vs. nres_of (aform_isFDERIV optns N xs fas vs), isFDERIV_spec) \ nat_rel \ \nat_rel\list_rel \ \Id\list_rel \ aforms_rel \ \bool_rel\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 \ 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 \ 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) \ nat_rel \ fas_rel \ aforms_rel \ \\aforms_rel\option_rel\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 \ Joints ((0, zero_pdevs) # XS) \ (x = 0 \ xs \ 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) \ \rnv_rel\aform_rel \ aforms_rel \ 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) \ \lv_rel\set_rel \ 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 (\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:\ \TODO: move!\ "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/Taylor_Models/Experiments.thy b/thys/Taylor_Models/Experiments.thy --- a/thys/Taylor_Models/Experiments.thy +++ b/thys/Taylor_Models/Experiments.thy @@ -1,87 +1,89 @@ theory Experiments imports Taylor_Models Affine_Arithmetic.Affine_Arithmetic begin instantiation interval::("{show, preorder}") "show" begin +context includes interval.lifting begin lift_definition shows_prec_interval:: "nat \ 'a interval \ char list \ char list" is "\p ivl s. (shows_string ''Interval'' o shows ivl) s" . lift_definition shows_list_interval:: "'a interval list \ char list \ char list" is "\ivls s. shows_list ivls s" . instance apply standard subgoal by transfer (auto simp: show_law_simps) subgoal by transfer (auto simp: show_law_simps) done +end end definition split_largest_interval :: "float interval list \ float interval list \ float interval list" where "split_largest_interval xs = (case sort_key (uminus o snd) (zip [0..x. upper x - lower x) xs)) of Nil \ ([], []) | (i, _)#_ \ let x = xs! i in (xs[i:=Ivl (lower x) ((upper x + lower x)*Float 1 (-1))], xs[i:=Ivl ((upper x + lower x)*Float 1 (-1)) (upper x)]))" definition "Inf_tm p params tm = lower (compute_bound_tm p (replicate params (Ivl (-1) (1))) (replicate params (Ivl 0 0)) tm)" primrec prove_pos::"bool \ nat \ nat \ nat \ (nat \ nat \ taylor_model list \ taylor_model option) \ float interval list list \ bool" where "prove_pos prnt 0 p ord F X = (let _ = if prnt then print (STR ''# depth limit exceeded\'') else () in False)" | "prove_pos prnt (Suc i) p ord F XXS = (case XXS of [] \ True | (X#XS) \ let params = length X; R = F p ord (tms_of_ivls X); _ = if prnt then print (String.implode ((shows ''# '' o shows (map (\ivl. (lower ivl, upper ivl)) X)) ''\'')) else () in if R \ None \ 0 < Inf_tm p params (the R) then let _ = if prnt then print (STR ''# Success\'') else () in prove_pos prnt i p ord F XS else let _ = if prnt then print (String.implode ((shows ''# Split ('' o shows ((map_option (Inf_tm p params)) R) o shows '')'') ''\'')) else () in case split_largest_interval X of (a, b) \ prove_pos prnt i p ord F (a#b#XS))" hide_const (open) prove_pos_slp definition "prove_pos_slp prnt prec ord fa i xs = (let slp = slp_of_fas [fa] in prove_pos prnt i prec ord (\p ord xs. case approx_slp prec ord 1 slp xs of None \ None | Some [x] \ Some x | Some _ \ None) xs)" experiment begin unbundle floatarith_notation abbreviation "schwefel \ (5.8806 / 10 ^ 10) + (Var 0 - (Var 1)^\<^sub>e2)^\<^sub>e2 + (Var 1 - 1)^\<^sub>e2 + (Var 0 - (Var 2)^\<^sub>e2)^\<^sub>e2 + (Var 2 - 1)^\<^sub>e2" lemma "prove_pos_slp True 30 0 schwefel 100000 [replicate 3 (Ivl (-10) 10)]" by eval abbreviation "delta6 \ (Var 0 * Var 3 * (-Var 0 + Var 1 + Var 2 - Var 3 + Var 4 + Var 5) + Var 1 * Var 4 * ( Var 0 - Var 1 + Var 2 + Var 3 - Var 4 + Var 5) + Var 2 * Var 5 * ( Var 0 + Var 1 - Var 2 + Var 3 + Var 4 - Var 5) - Var 1 * Var 2 * Var 3 - Var 0 * Var 2 * Var 4 - Var 0 * Var 1 * Var 5 - Var 3 * Var 4 * Var 5)" lemma "prove_pos_slp True 30 3 delta6 10000 [replicate 6 (Ivl 4 (Float 104045 (-14)))]" by eval abbreviation "caprasse \ (3.1801 + - Var 0 * (Var 2) ^\<^sub>e 3 + 4 * Var 1 * (Var 2)^\<^sub>e2 * Var 3 + 4 * Var 0 * Var 2 * (Var 3)^\<^sub>e2 + 2 * Var 1 * (Var 3)^\<^sub>e3 + 4 * Var 0 * Var 2 + 4 * (Var 2)^\<^sub>e2 - 10 * Var 1 * Var 3 + -10 * (Var 3)^\<^sub>e2 + 2)" lemma "prove_pos_slp True 30 2 caprasse 10000 [replicate 4 (Ivl (-Float 1 (-1)) (Float 1 (-1)))]" by eval abbreviation "magnetism \ 0.25001 + (Var 0)^\<^sub>e2 + 2 * (Var 1)^\<^sub>e2 + 2 * (Var 2)^\<^sub>e2 + 2 * (Var 3)^\<^sub>e2 + 2 * (Var 4)^\<^sub>e2 + 2 * (Var 5)^\<^sub>e2 + 2 * (Var 6)^\<^sub>e2 - Var 0" end end diff --git a/thys/Taylor_Models/Horner_Eval.thy b/thys/Taylor_Models/Horner_Eval.thy --- a/thys/Taylor_Models/Horner_Eval.thy +++ b/thys/Taylor_Models/Horner_Eval.thy @@ -1,82 +1,82 @@ section \Horner Evaluation\ theory Horner_Eval - imports Interval + imports "HOL-Library.Interval" begin text \Function and lemmas for evaluating polynomials via the horner scheme. Because interval multiplication is not distributive, interval polynomials expressed as a sum of monomials are not equivalent to their respective horner form. The functions and lemmas in this theory can be used to express interval polynomials in horner form and prove facts about them.\ fun horner_eval' where "horner_eval' f x v 0 = v" | "horner_eval' f x v (Suc i) = horner_eval' f x (f i + x * v) i" definition horner_eval where "horner_eval f x n = horner_eval' f x 0 n" lemma horner_eval_cong: assumes "\i. i < n \ f i = g i" assumes "x = y" assumes "n = m" shows "horner_eval f x n = horner_eval g y m" proof- { fix v have "horner_eval' f x v n = horner_eval' g x v n" using assms(1) by (induction n arbitrary: v, simp_all) } thus ?thesis by (simp add: assms(2,3) horner_eval_def) qed lemma horner_eval_eq_setsum: fixes x::"'a::linordered_idom" shows "horner_eval f x n = (\iii. f (Suc i)) x n)" proof- { fix v have "horner_eval' f x v (Suc n) = f 0 + x * horner_eval' (\i. f (Suc i)) x v n" by (induction n arbitrary: v, simp_all) } thus ?thesis by (simp add: horner_eval_def) qed lemma horner_eval_0[simp]: shows "horner_eval f x 0 = 0" by (simp add: horner_eval_def) lemma horner_eval'_interval: fixes x::"'a::linordered_ring" assumes "\i. i < n \ f i \ set_of (g i)" assumes "x \\<^sub>i I" "v \\<^sub>i V" shows "horner_eval' f x v n \\<^sub>i horner_eval' g I V n" using assms by (induction n arbitrary: v V) (auto intro!: plus_in_intervalI times_in_intervalI) lemma horner_eval_interval: fixes x::"'a::linordered_idom" assumes "\i. i < n \ f i \ set_of (g i)" assumes "x \ set_of I" shows "horner_eval f x n \\<^sub>i horner_eval g I n" unfolding horner_eval_def using assms by (rule horner_eval'_interval) (auto simp: set_of_eq) end diff --git a/thys/Taylor_Models/Interval.thy b/thys/Taylor_Models/Interval.thy deleted file mode 100644 --- a/thys/Taylor_Models/Interval.thy +++ /dev/null @@ -1,840 +0,0 @@ -(* Author: Christoph Traut, TU Muenchen - Fabian Immler, TU Muenchen -*) -section \Interval Type\ -theory Interval - imports - "HOL-Analysis.Multivariate_Analysis" - "HOL-Library.Set_Algebras" - "HOL-Library.Float" -begin - -text \A type of non-empty, closed intervals.\ - -typedef (overloaded) 'a interval = - "{(a::'a::preorder, b). a \ b}" - morphisms bounds_of_interval Interval - by auto - -setup_lifting type_definition_interval - -lift_definition lower::"('a::preorder) interval \ 'a" is fst . - -lift_definition upper::"('a::preorder) interval \ 'a" is snd . - -lemma interval_eq_iff: "a = b \ lower a = lower b \ upper a = upper b" - by transfer auto - -lemma interval_eqI: "lower a = lower b \ upper a = upper b \ a = b" - by (auto simp: interval_eq_iff) - -lemma lower_le_upper[simp]: "lower i \ upper i" - by transfer auto - -lift_definition set_of :: "'a::preorder interval \ 'a set" is "\x. {fst x .. snd x}" . - -lemma set_of_eq: "set_of x = {lower x .. upper x}" - by transfer simp - -context notes [[typedef_overloaded]] begin - -lift_definition(code_dt) Interval'::"'a::preorder \ 'a::preorder \ 'a interval option" - is "\a b. if a \ b then Some (a, b) else None" - by auto - -end - -instantiation "interval" :: ("{preorder,equal}") equal -begin - -definition "equal_class.equal a b \ (lower a = lower b) \ (upper a = upper b)" - -instance proof qed (simp add: equal_interval_def interval_eq_iff) -end - -instantiation interval :: ("preorder") ord begin - -definition less_eq_interval :: "'a interval \ 'a interval \ bool" - where "less_eq_interval a b \ lower b \ lower a \ upper a \ upper b" - -definition less_interval :: "'a interval \ 'a interval \ bool" - where "less_interval x y = (x \ y \ \ y \ x)" - -instance proof qed -end - -instantiation interval :: ("lattice") semilattice_sup -begin - -lift_definition sup_interval :: "'a interval \ 'a interval \ 'a interval" - is "\(a, b) (c, d). (inf a c, sup b d)" - by (auto simp: le_infI1 le_supI1) - -lemma lower_sup[simp]: "lower (sup A B) = inf (lower A) (lower B)" - by transfer auto - -lemma upper_sup[simp]: "upper (sup A B) = sup (upper A) (upper B)" - by transfer auto - -instance proof qed (auto simp: less_eq_interval_def less_interval_def interval_eq_iff) -end - -lemma set_of_interval_union: "set_of A \ set_of B \ set_of (sup A B)" for A::"'a::lattice interval" - by (auto simp: set_of_eq) - -lemma interval_union_commute: "sup A B = sup B A" for A::"'a::lattice interval" - by (auto simp add: interval_eq_iff inf.commute sup.commute) - -lemma interval_union_mono1: "set_of a \ set_of (sup a A)" for A :: "'a::lattice interval" - using set_of_interval_union by blast - -lemma interval_union_mono2: "set_of A \ set_of (sup a A)" for A :: "'a::lattice interval" - using set_of_interval_union by blast - -lift_definition interval_of :: "'a::preorder \ 'a interval" is "\x. (x, x)" - by auto - -lemma lower_interval_of[simp]: "lower (interval_of a) = a" - by transfer auto - -lemma upper_interval_of[simp]: "upper (interval_of a) = a" - by transfer auto - -definition width :: "'a::{preorder,minus} interval \ 'a" - where "width i = upper i - lower i" - - -instantiation "interval" :: ("ordered_ab_semigroup_add") ab_semigroup_add -begin - -lift_definition plus_interval::"'a interval \ 'a interval \ 'a interval" - is "\(a, b). \(c, d). (a + c, b + d)" - by (auto intro!: add_mono) -lemma lower_plus[simp]: "lower (plus A B) = plus (lower A) (lower B)" - by transfer auto -lemma upper_plus[simp]: "upper (plus A B) = plus (upper A) (upper B)" - by transfer auto - -instance proof qed (auto simp: interval_eq_iff less_eq_interval_def ac_simps) -end - -instance "interval" :: ("{ordered_ab_semigroup_add, lattice}") ordered_ab_semigroup_add -proof qed (auto simp: less_eq_interval_def intro!: add_mono) - -instantiation "interval" :: ("{preorder,zero}") zero -begin - -lift_definition zero_interval::"'a interval" is "(0, 0)" by auto -lemma lower_zero[simp]: "lower 0 = 0" - by transfer auto -lemma upper_zero[simp]: "upper 0 = 0" - by transfer auto -instance proof qed -end - -instance "interval" :: ("{ordered_comm_monoid_add}") comm_monoid_add -proof qed (auto simp: interval_eq_iff) - -instance "interval" :: ("{ordered_comm_monoid_add,lattice}") ordered_comm_monoid_add .. - -instantiation "interval" :: ("{ordered_ab_group_add}") uminus -begin - -lift_definition uminus_interval::"'a interval \ 'a interval" is "\(a, b). (-b, -a)" by auto -lemma lower_uminus[simp]: "lower (- A) = - upper A" - by transfer auto -lemma upper_uminus[simp]: "upper (- A) = - lower A" - by transfer auto -instance .. -end - -instantiation "interval" :: ("{ordered_ab_group_add}") minus -begin - -definition minus_interval::"'a interval \ 'a interval \ 'a interval" - where "minus_interval a b = a + - b" -lemma lower_minus[simp]: "lower (minus A B) = minus (lower A) (upper B)" - by (auto simp: minus_interval_def) -lemma upper_minus[simp]: "upper (minus A B) = minus (upper A) (lower B)" - by (auto simp: minus_interval_def) - -instance .. -end - -instantiation "interval" :: (linordered_semiring) times -begin - -lift_definition times_interval :: "'a interval \ 'a interval \ 'a interval" - is "\(a1, a2). \(b1, b2). - (let x1 = a1 * b1; x2 = a1 * b2; x3 = a2 * b1; x4 = a2 * b2 - in (min x1 (min x2 (min x3 x4)), max x1 (max x2 (max x3 x4))))" - by (auto simp: Let_def intro!: min.coboundedI1 max.coboundedI1) - -lemma lower_times: - "lower (times A B) = Min {lower A * lower B, lower A * upper B, upper A * lower B, upper A * upper B}" - by transfer (auto simp: Let_def) - -lemma upper_times: - "upper (times A B) = Max {lower A * lower B, lower A * upper B, upper A * lower B, upper A * upper B}" - by transfer (auto simp: Let_def) - -instance .. -end - -lemma interval_eq_set_of_iff: "X = Y \ set_of X = set_of Y" for X Y::"'a::order interval" - by (auto simp: set_of_eq interval_eq_iff) - - -subsection \Membership\ - -abbreviation (in preorder) in_interval ("(_/ \\<^sub>i _)" [51, 51] 50) - where "in_interval x X \ x \ set_of X" - -lemma in_interval_to_interval[intro!]: "a \\<^sub>i interval_of a" - by (auto simp: set_of_eq) - -lemma plus_in_intervalI: - fixes x y :: "'a :: ordered_ab_semigroup_add" - shows "x \\<^sub>i X \ y \\<^sub>i Y \ x + y \\<^sub>i X + Y" - by (simp add: add_mono_thms_linordered_semiring(1) set_of_eq) - -lemma connected_set_of[intro, simp]: - "connected (set_of X)" for X::"'a::linear_continuum_topology interval" - by (auto simp: set_of_eq ) - -lemma ex_sum_in_interval_lemma: "\xa\{la .. ua}. \xb\{lb .. ub}. x = xa + xb" - if "la \ ua" "lb \ ub" "la + lb \ x" "x \ ua + ub" - "ua - la \ ub - lb" - for la b c d::"'a::linordered_ab_group_add" -proof - - define wa where "wa = ua - la" - define wb where "wb = ub - lb" - define w where "w = wa + wb" - define d where "d = x - la - lb" - define da where "da = max 0 (min wa (d - wa))" - define db where "db = d - da" - from that have nonneg: "0 \ wa" "0 \ wb" "0 \ w" "0 \ d" "d \ w" - by (auto simp add: wa_def wb_def w_def d_def add.commute le_diff_eq) - have "0 \ db" - by (auto simp: da_def nonneg db_def intro!: min.coboundedI2) - have "x = (la + da) + (lb + db)" - by (simp add: da_def db_def d_def) - moreover - have "x - la - ub \ da" - using that - unfolding da_def - by (intro max.coboundedI2) (auto simp: wa_def d_def diff_le_eq diff_add_eq) - then have "db \ wb" - by (auto simp: db_def d_def wb_def algebra_simps) - with \0 \ db\ that nonneg have "lb + db \ {lb..ub}" - by (auto simp: wb_def algebra_simps) - moreover - have "da \ wa" - by (auto simp: da_def nonneg) - then have "la + da \ {la..ua}" - by (auto simp: da_def wa_def algebra_simps) - ultimately show ?thesis - by force -qed - - -lemma ex_sum_in_interval: "\xa\la. xa \ ua \ (\xb\lb. xb \ ub \ x = xa + xb)" - if a: "la \ ua" and b: "lb \ ub" and x: "la + lb \ x" "x \ ua + ub" - for la b c d::"'a::linordered_ab_group_add" -proof - - from linear consider "ua - la \ ub - lb" | "ub - lb \ ua - la" - by blast - then show ?thesis - proof cases - case 1 - from ex_sum_in_interval_lemma[OF that 1] - show ?thesis by auto - next - case 2 - from x have "lb + la \ x" "x \ ub + ua" by (simp_all add: ac_simps) - from ex_sum_in_interval_lemma[OF b a this 2] - show ?thesis by auto - qed -qed - -lemma Icc_plus_Icc: - "{a .. b} + {c .. d} = {a + c .. b + d}" - if "a \ b" "c \ d" - for a b c d::"'a::linordered_ab_group_add" - using ex_sum_in_interval[OF that] - by (auto intro: add_mono simp: atLeastAtMost_iff Bex_def set_plus_def) - -lemma set_of_plus: - fixes A :: "'a::linordered_ab_group_add interval" - shows "set_of (A + B) = set_of A + set_of B" - using Icc_plus_Icc[of "lower A" "upper A" "lower B" "upper B"] - by (auto simp: set_of_eq) - -lemma plus_in_intervalE: - fixes xy :: "'a :: linordered_ab_group_add" - assumes "xy \\<^sub>i X + Y" - obtains x y where "xy = x + y" "x \\<^sub>i X" "y \\<^sub>i Y" - using assms - unfolding set_of_plus set_plus_def - by auto - -lemma set_of_uminus: "set_of (-X) = {- x | x. x \ set_of X}" - for X :: "'a :: ordered_ab_group_add interval" - by (auto simp: set_of_eq simp: le_minus_iff minus_le_iff - intro!: exI[where x="-x" for x]) - -lemma uminus_in_intervalI: - fixes x :: "'a :: ordered_ab_group_add" - shows "x \\<^sub>i X \ -x \\<^sub>i -X" - by (auto simp: set_of_uminus) - -lemma uminus_in_intervalD: - fixes x :: "'a :: ordered_ab_group_add" - shows "x \\<^sub>i - X \ - x \\<^sub>i X" - by (auto simp: set_of_uminus) - -lemma minus_in_intervalI: - fixes x y :: "'a :: ordered_ab_group_add" - shows "x \\<^sub>i X \ y \\<^sub>i Y \ x - y \\<^sub>i X - Y" - by (metis diff_conv_add_uminus minus_interval_def plus_in_intervalI uminus_in_intervalI) - -lemma set_of_minus: "set_of (X - Y) = {x - y | x y . x \ set_of X \ y \ set_of Y}" - for X Y :: "'a :: linordered_ab_group_add interval" - unfolding minus_interval_def set_of_plus set_of_uminus set_plus_def - by force - -lemma times_in_intervalI: - fixes x y::"'a::linordered_ring" - assumes "x \\<^sub>i X" "y \\<^sub>i Y" - shows "x * y \\<^sub>i X * Y" -proof - - define X1 where "X1 \ lower X" - define X2 where "X2 \ upper X" - define Y1 where "Y1 \ lower Y" - define Y2 where "Y2 \ upper Y" - from assms have assms: "X1 \ x" "x \ X2" "Y1 \ y" "y \ Y2" - by (auto simp: X1_def X2_def Y1_def Y2_def set_of_eq) - have "(X1 * Y1 \ x * y \ X1 * Y2 \ x * y \ X2 * Y1 \ x * y \ X2 * Y2 \ x * y) \ - (X1 * Y1 \ x * y \ X1 * Y2 \ x * y \ X2 * Y1 \ x * y \ X2 * Y2 \ x * y)" - proof (cases x "0::'a" rule: linorder_cases) - case x0: less - show ?thesis - proof (cases "y < 0") - case y0: True - from y0 x0 assms have "x * y \ X1 * y" by (intro mult_right_mono_neg, auto) - also from x0 y0 assms have "X1 * y \ X1 * Y1" by (intro mult_left_mono_neg, auto) - finally have 1: "x * y \ X1 * Y1". - show ?thesis proof(cases "X2 \ 0") - case True - with assms have "X2 * Y2 \ X2 * y" by (auto intro: mult_left_mono_neg) - also from assms y0 have "... \ x * y" by (auto intro: mult_right_mono_neg) - finally have "X2 * Y2 \ x * y". - with 1 show ?thesis by auto - next - case False - with assms have "X2 * Y1 \ X2 * y" by (auto intro: mult_left_mono) - also from assms y0 have "... \ x * y" by (auto intro: mult_right_mono_neg) - finally have "X2 * Y1 \ x * y". - with 1 show ?thesis by auto - qed - next - case False - then have y0: "y \ 0" by auto - from x0 y0 assms have "X1 * Y2 \ x * Y2" by (intro mult_right_mono, auto) - also from y0 x0 assms have "... \ x * y" by (intro mult_left_mono_neg, auto) - finally have 1: "X1 * Y2 \ x * y". - show ?thesis - proof(cases "X2 \ 0") - case X2: True - from assms y0 have "x * y \ X2 * y" by (intro mult_right_mono) - also from assms X2 have "... \ X2 * Y1" by (auto intro: mult_left_mono_neg) - finally have "x * y \ X2 * Y1". - with 1 show ?thesis by auto - next - case X2: False - from assms y0 have "x * y \ X2 * y" by (intro mult_right_mono) - also from assms X2 have "... \ X2 * Y2" by (auto intro: mult_left_mono) - finally have "x * y \ X2 * Y2". - with 1 show ?thesis by auto - qed - qed - next - case [simp]: equal - with assms show ?thesis by (cases "Y2 \ 0", auto intro:mult_sign_intros) - next - case x0: greater - show ?thesis - proof (cases "y < 0") - case y0: True - from x0 y0 assms have "X2 * Y1 \ X2 * y" by (intro mult_left_mono, auto) - also from y0 x0 assms have "X2 * y \ x * y" by (intro mult_right_mono_neg, auto) - finally have 1: "X2 * Y1 \ x * y". - show ?thesis - proof(cases "Y2 \ 0") - case Y2: True - from x0 assms have "x * y \ x * Y2" by (auto intro: mult_left_mono) - also from assms Y2 have "... \ X1 * Y2" by (auto intro: mult_right_mono_neg) - finally have "x * y \ X1 * Y2". - with 1 show ?thesis by auto - next - case Y2: False - from x0 assms have "x * y \ x * Y2" by (auto intro: mult_left_mono) - also from assms Y2 have "... \ X2 * Y2" by (auto intro: mult_right_mono) - finally have "x * y \ X2 * Y2". - with 1 show ?thesis by auto - qed - next - case y0: False - from x0 y0 assms have "x * y \ X2 * y" by (intro mult_right_mono, auto) - also from y0 x0 assms have "... \ X2 * Y2" by (intro mult_left_mono, auto) - finally have 1: "x * y \ X2 * Y2". - show ?thesis - proof(cases "X1 \ 0") - case True - with assms have "X1 * Y2 \ X1 * y" by (auto intro: mult_left_mono_neg) - also from assms y0 have "... \ x * y" by (auto intro: mult_right_mono) - finally have "X1 * Y2 \ x * y". - with 1 show ?thesis by auto - next - case False - with assms have "X1 * Y1 \ X1 * y" by (auto intro: mult_left_mono) - also from assms y0 have "... \ x * y" by (auto intro: mult_right_mono) - finally have "X1 * Y1 \ x * y". - with 1 show ?thesis by auto - qed - qed - qed - hence min:"min (X1 * Y1) (min (X1 * Y2) (min (X2 * Y1) (X2 * Y2))) \ x * y" - and max:"x * y \ max (X1 * Y1) (max (X1 * Y2) (max (X2 * Y1) (X2 * Y2)))" - by (auto simp:min_le_iff_disj le_max_iff_disj) - show ?thesis using min max - by (auto simp: Let_def X1_def X2_def Y1_def Y2_def set_of_eq lower_times upper_times) -qed - -lemma times_in_intervalE: - fixes xy :: "'a :: {linordered_semiring, real_normed_algebra, linear_continuum_topology}" - \ \TODO: linear continuum topology is pretty strong\ - assumes "xy \\<^sub>i X * Y" - obtains x y where "xy = x * y" "x \\<^sub>i X" "y \\<^sub>i Y" -proof - - let ?mult = "\(x, y). x * y" - let ?XY = "set_of X \ set_of Y" - have cont: "continuous_on ?XY ?mult" - by (auto intro!: tendsto_eq_intros simp: continuous_on_def split_beta') - have conn: "connected (?mult  ?XY)" - by (rule connected_continuous_image[OF cont]) auto - have "lower (X * Y) \ ?mult  ?XY" "upper (X * Y) \ ?mult  ?XY" - by (auto simp: set_of_eq lower_times upper_times min_def max_def split: if_splits) - from connectedD_interval[OF conn this, of xy] assms - obtain x y where "xy = x * y" "x \\<^sub>i X" "y \\<^sub>i Y" by (auto simp: set_of_eq) - then show ?thesis .. -qed - -lemma set_of_times: "set_of (X * Y) = {x * y | x y. x \ set_of X \ y \ set_of Y}" - for X Y::"'a :: {linordered_ring, real_normed_algebra, linear_continuum_topology} interval" - by (auto intro!: times_in_intervalI elim!: times_in_intervalE) - -instance "interval" :: (linordered_idom) cancel_semigroup_add -proof qed (auto simp: interval_eq_iff) - -lemma interval_mul_commute: "A * B = B * A" for A B:: "'a::linordered_idom interval" - by (simp add: interval_eq_iff lower_times upper_times ac_simps) - -lemma interval_times_zero_right[simp]: "A * 0 = 0" for A :: "'a::linordered_ring interval" - by (simp add: interval_eq_iff lower_times upper_times ac_simps) - -lemma interval_times_zero_left[simp]: - "0 * A = 0" for A :: "'a::linordered_ring interval" - by (simp add: interval_eq_iff lower_times upper_times ac_simps) - -instantiation "interval" :: ("{preorder,one}") one -begin - -lift_definition one_interval::"'a interval" is "(1, 1)" by auto -lemma lower_one[simp]: "lower 1 = 1" - by transfer auto -lemma upper_one[simp]: "upper 1 = 1" - by transfer auto -instance proof qed -end - -instance interval :: ("{one, preorder, linordered_semiring}") power -proof qed - -lemma set_of_one[simp]: "set_of (1::'a::{one, order} interval) = {1}" - by (auto simp: set_of_eq) - -instance "interval" :: - ("{linordered_idom,linordered_ring, real_normed_algebra, linear_continuum_topology}") monoid_mult - apply standard - unfolding interval_eq_set_of_iff set_of_times - subgoal for a b c - by (auto simp: interval_eq_set_of_iff set_of_times; metis mult.assoc) - by auto - -lemma one_times_ivl_left[simp]: "1 * A = A" for A :: "'a::linordered_idom interval" - by (simp add: interval_eq_iff lower_times upper_times ac_simps min_def max_def) - -lemma one_times_ivl_right[simp]: "A * 1 = A" for A :: "'a::linordered_idom interval" - by (metis interval_mul_commute one_times_ivl_left) - -lemma set_of_power_mono: "a^n \ set_of (A^n)" if "a \ set_of A" - for a :: "'a::linordered_idom" - using that - by (induction n) (auto intro!: times_in_intervalI) - -lemma set_of_add_cong: - "set_of (A + B) = set_of (A' + B')" - if "set_of A = set_of A'" "set_of B = set_of B'" - for A :: "'a::linordered_ab_group_add interval" - unfolding set_of_plus that .. - -lemma set_of_add_inc_left: - "set_of (A + B) \ set_of (A' + B)" - if "set_of A \ set_of A'" - for A :: "'a::linordered_ab_group_add interval" - unfolding set_of_plus using that by (auto simp: set_plus_def) - -lemma set_of_add_inc_right: - "set_of (A + B) \ set_of (A + B')" - if "set_of B \ set_of B'" - for A :: "'a::linordered_ab_group_add interval" - using set_of_add_inc_left[OF that] - by (simp add: add.commute) - -lemma set_of_add_inc: - "set_of (A + B) \ set_of (A' + B')" - if "set_of A \ set_of A'" "set_of B \ set_of B'" - for A :: "'a::linordered_ab_group_add interval" - using set_of_add_inc_left[OF that(1)] set_of_add_inc_right[OF that(2)] - by auto - -lemma set_of_neg_inc: - "set_of (-A) \ set_of (-A')" - if "set_of A \ set_of A'" - for A :: "'a::ordered_ab_group_add interval" - using that - unfolding set_of_uminus - by auto - -lemma set_of_sub_inc_left: - "set_of (A - B) \ set_of (A' - B)" - if "set_of A \ set_of A'" - for A :: "'a::linordered_ab_group_add interval" - using that - unfolding set_of_minus - by auto - -lemma set_of_sub_inc_right: - "set_of (A - B) \ set_of (A - B')" - if "set_of B \ set_of B'" - for A :: "'a::linordered_ab_group_add interval" - using that - unfolding set_of_minus - by auto - -lemma set_of_sub_inc: - "set_of (A - B) \ set_of (A' - B')" - if "set_of A \ set_of A'" "set_of B \ set_of B'" - for A :: "'a::linordered_idom interval" - using set_of_sub_inc_left[OF that(1)] set_of_sub_inc_right[OF that(2)] - by auto - -lemma set_of_mul_inc_right: - "set_of (A * B) \ set_of (A * B')" - if "set_of B \ set_of B'" - for A :: "'a::linordered_ring interval" - using that - apply transfer - apply (auto simp: Let_def) - apply (metis linear min.coboundedI1 min.coboundedI2 mult_left_mono mult_left_mono_neg order_trans) - apply (metis linear min.coboundedI1 min.coboundedI2 mult_left_mono mult_left_mono_neg order_trans) - apply (metis linear min.coboundedI1 min.coboundedI2 mult_left_mono mult_left_mono_neg order_trans) - apply (metis linear min.coboundedI1 min.coboundedI2 mult_left_mono mult_left_mono_neg order_trans) - apply (metis linear max.coboundedI1 max.coboundedI2 mult_left_mono mult_left_mono_neg order_trans) - apply (metis linear max.coboundedI1 max.coboundedI2 mult_left_mono mult_left_mono_neg order_trans) - apply (metis linear max.coboundedI1 max.coboundedI2 mult_left_mono mult_left_mono_neg order_trans) - apply (metis linear max.coboundedI1 max.coboundedI2 mult_left_mono mult_left_mono_neg order_trans) - done - -lemma set_of_distrib_left: - "set_of (B * (A1 + A2)) \ set_of (B * A1 + B * A2)" - for A1 :: "'a::linordered_ring interval" - apply transfer - apply (auto simp: Let_def add_mono distrib_left distrib_right) - apply (metis add_mono min.cobounded1 min.left_commute) - apply (metis add_mono min.cobounded1 min.left_commute) - apply (metis add_mono min.assoc min.cobounded2) - apply (meson add_mono_thms_linordered_semiring(1) dual_order.trans max.cobounded1 max.cobounded2) - apply (meson add_mono_thms_linordered_semiring(1) dual_order.trans max.cobounded1 max.cobounded2) - apply (meson add_mono_thms_linordered_semiring(1) dual_order.trans max.cobounded1 max.cobounded2) - done - -lemma set_of_distrib_right: - "set_of ((A1 + A2) * B) \ set_of (A1 * B + A2 * B)" - for A1 A2 B :: "'a::{linordered_ring, real_normed_algebra, linear_continuum_topology} interval" - unfolding set_of_times set_of_plus set_plus_def - apply clarsimp - subgoal for b a1 a2 - apply (rule exI[where x="a1 * b"]) - apply (rule conjI) - subgoal by force - subgoal - apply (rule exI[where x="a2 * b"]) - apply (rule conjI) - subgoal by force - subgoal by (simp add: algebra_simps) - done - done - done - -lemma set_of_mul_inc_left: - "set_of (A * B) \ set_of (A' * B)" - if "set_of A \ set_of A'" - for A :: "'a::{linordered_ring, real_normed_algebra, linear_continuum_topology} interval" - using that - unfolding set_of_times - by auto - -lemma set_of_mul_inc: - "set_of (A * B) \ set_of (A' * B')" - if "set_of A \ set_of A'" "set_of B \ set_of B'" - for A :: "'a::{linordered_ring, real_normed_algebra, linear_continuum_topology} interval" - using that unfolding set_of_times by auto - -lemma set_of_pow_inc: - "set_of (A^n) \ set_of (A'^n)" - if "set_of A \ set_of A'" - for A :: "'a::{linordered_idom, real_normed_algebra, linear_continuum_topology} interval" - using that - by (induction n, simp_all add: set_of_mul_inc) - -lemma set_of_distrib_right_left: - "set_of ((A1 + A2) * (B1 + B2)) \ set_of (A1 * B1 + A1 * B2 + A2 * B1 + A2 * B2)" - for A1 :: "'a::{linordered_idom, real_normed_algebra, linear_continuum_topology} interval" -proof- - have "set_of ((A1 + A2) * (B1 + B2)) \ set_of (A1 * (B1 + B2) + A2 * (B1 + B2))" - by (rule set_of_distrib_right) - also have "... \ set_of ((A1 * B1 + A1 * B2) + A2 * (B1 + B2))" - by (rule set_of_add_inc_left[OF set_of_distrib_left]) - also have "... \ set_of ((A1 * B1 + A1 * B2) + (A2 * B1 + A2 * B2))" - by (rule set_of_add_inc_right[OF set_of_distrib_left]) - finally show ?thesis - by (simp add: add.assoc) -qed - -lemma mult_bounds_enclose_zero1: - "min (la * lb) (min (la * ub) (min (lb * ua) (ua * ub))) \ 0" - "0 \ max (la * lb) (max (la * ub) (max (lb * ua) (ua * ub)))" - if "la \ 0" "0 \ ua" - for la lb ua ub:: "'a::linordered_idom" - subgoal by (metis (no_types, hide_lams) that eq_iff min_le_iff_disj mult_zero_left - mult_zero_right zero_le_mult_iff) - subgoal by (metis that le_max_iff_disj mult_zero_right order_refl zero_le_mult_iff) - done - -lemma mult_bounds_enclose_zero2: - "min (la * lb) (min (la * ub) (min (lb * ua) (ua * ub))) \ 0" - "0 \ max (la * lb) (max (la * ub) (max (lb * ua) (ua * ub)))" - if "lb \ 0" "0 \ ub" - for la lb ua ub:: "'a::linordered_idom" - using mult_bounds_enclose_zero1[OF that, of la ua] - by (simp_all add: ac_simps) - -lemma set_of_mul_contains_zero: - "0 \ set_of (A * B)" - if "0 \ set_of A \ 0 \ set_of B" - for A :: "'a::linordered_idom interval" - using that - by (auto simp: set_of_eq lower_times upper_times algebra_simps mult_le_0_iff - mult_bounds_enclose_zero1 mult_bounds_enclose_zero2) - -instance "interval" :: (linordered_semiring) mult_zero - apply standard - subgoal by transfer auto - subgoal by transfer auto - done - -lift_definition min_interval::"'a::linorder interval \ 'a interval \ 'a interval" is - "\(l1, u1). \(l2, u2). (min l1 l2, min u1 u2)" - by (auto simp: min_def) -lemma lower_min_interval[simp]: "lower (min_interval x y) = min (lower x) (lower y)" - by transfer auto -lemma upper_min_interval[simp]: "upper (min_interval x y) = min (upper x) (upper y)" - by transfer auto - -lemma min_intervalI: - "a \\<^sub>i A \ b \\<^sub>i B \ min a b \\<^sub>i min_interval A B" - by (auto simp: set_of_eq min_def) - -lift_definition max_interval::"'a::linorder interval \ 'a interval \ 'a interval" is - "\(l1, u1). \(l2, u2). (max l1 l2, max u1 u2)" - by (auto simp: max_def) -lemma lower_max_interval[simp]: "lower (max_interval x y) = max (lower x) (lower y)" - by transfer auto -lemma upper_max_interval[simp]: "upper (max_interval x y) = max (upper x) (upper y)" - by transfer auto - -lemma max_intervalI: - "a \\<^sub>i A \ b \\<^sub>i B \ max a b \\<^sub>i max_interval A B" - by (auto simp: set_of_eq max_def) - -lift_definition abs_interval::"'a::linordered_idom interval \ 'a interval" is - "(\(l,u). (if l < 0 \ 0 < u then 0 else min \l\ \u\, max \l\ \u$$)" - by auto - -lemma lower_abs_interval[simp]: - "lower (abs_interval x) = (if lower x < 0 \ 0 < upper x then 0 else min \lower x\ \upper x\)" - by transfer auto -lemma upper_abs_interval[simp]: "upper (abs_interval x) = max \lower x\ \upper x\" - by transfer auto - -lemma in_abs_intervalI1: - "lx < 0 \ 0 < ux \ 0 \ xa \ xa \ max (- lx) (ux) \ xa \ abs  {lx..ux}" - for xa::"'a::linordered_idom" - by (metis abs_minus_cancel abs_of_nonneg atLeastAtMost_iff image_eqI le_less le_max_iff_disj - le_minus_iff neg_le_0_iff_le order_trans) - -lemma in_abs_intervalI2: - "min (\lx\) \ux\ \ xa \ xa \ max \lx\ \ux\ \ lx \ ux \ 0 \ lx \ ux \ 0 \ - xa \ abs  {lx..ux}" - for xa::"'a::linordered_idom" - by (force intro: image_eqI[where x="-xa"] image_eqI[where x="xa"]) - -lemma set_of_abs_interval: "set_of (abs_interval x) = abs  set_of x" - by (auto simp: set_of_eq not_less intro: in_abs_intervalI1 in_abs_intervalI2 cong del: image_cong_simp) - -fun split_domain :: "('a::preorder interval \ 'a interval list) \ 'a interval list \ 'a interval list list" - where "split_domain split [] = [[]]" - | "split_domain split (I#Is) = ( - let S = split I; - D = split_domain split Is - in concat (map (\d. map (\s. s # d) S) D) - )" - -context notes [[typedef_overloaded]] begin -lift_definition(code_dt) split_interval::"'a::linorder interval \ 'a \ ('a interval \ 'a interval)" - is "$$l, u) x. ((min l x, max l x), (min u x, max u x))" - by (auto simp: min_def) -end - -lemma split_domain_nonempty: - assumes "\I. split I \ []" - shows "split_domain split I \ []" - using last_in_set assms - by (induction I, auto) - - -lemma split_intervalD: "split_interval X x = (A, B) \ set_of X \ set_of A \ set_of B" - unfolding set_of_eq - by transfer (auto simp: min_def max_def split: if_splits) - -definition "split_float_interval x = split_interval x ((lower x + upper x) * Float 1 (-1))" - -lemma split_float_intervalD: "split_float_interval X = (A, B) \ set_of X \ set_of A \ set_of B" - by (auto dest!: split_intervalD simp: split_float_interval_def) - -lemmas float_round_down_le[intro] = order_trans[OF float_round_down] - and float_round_up_ge[intro] = order_trans[OF _ float_round_up] - -instantiation interval :: ("{topological_space, preorder}") topological_space -begin - -definition open_interval_def[code del]: "open (X::'a interval set) = - (\x\X. - \A B. - open A \ - open B \ - lower x \ A \ upper x \ B \ Interval  (A \ B) \ X)" - -instance -proof - show "open (UNIV :: ('a interval) set)" - unfolding open_interval_def by auto -next - fix S T :: "('a interval) set" - assume "open S" "open T" - show "open (S \ T)" - unfolding open_interval_def - proof (safe) - fix x assume "x \ S" "x \ T" - from \x \ S\ \open S\ obtain Sl Su where S: - "open Sl" "open Su" "lower x \ Sl" "upper x \ Su" "Interval  (Sl \ Su) \ S" - by (auto simp: open_interval_def) - from \x \ T\ \open T\ obtain Tl Tu where T: - "open Tl" "open Tu" "lower x \ Tl" "upper x \ Tu" "Interval  (Tl \ Tu) \ T" - by (auto simp: open_interval_def) - - let ?L = "Sl \ Tl" and ?U = "Su \ Tu" - have "open ?L \ open ?U \ lower x \ ?L \ upper x \ ?U \ Interval  (?L \ ?U) \ S \ T" - using S T by (auto simp add: open_Int) - then show "\A B. open A \ open B \ lower x \ A \ upper x \ B \ Interval  (A \ B) \ S \ T" - by fast - qed -qed (unfold open_interval_def, fast) - -end - - -definition mid :: "float interval \ float" - where "mid i = (lower i + upper i) * Float 1 (-1)" - -lemma mid_in_interval: "mid i \\<^sub>i i" - using lower_le_upper[of i] - by (auto simp: mid_def set_of_eq powr_minus) - -definition centered :: "float interval \ float interval" - where "centered i = i - interval_of (mid i)" - - -subsection \Quickcheck\ - -lift_definition Ivl::"'a \ 'a::preorder \ 'a interval" is "\a b. (min a b, b)" - by (auto simp: min_def) - -instantiation interval :: ("{exhaustive,preorder}") exhaustive -begin - -definition exhaustive_interval::"('a interval \ (bool \ term list) option) - \ natural \ (bool \ term list) option" - where - "exhaustive_interval f d = - Quickcheck_Exhaustive.exhaustive (\x. Quickcheck_Exhaustive.exhaustive (\y. f (Ivl x y)) d) d" - -instance .. - -end - -definition (in term_syntax) [code_unfold]: - "valtermify_interval x y = Code_Evaluation.valtermify (Ivl::'a::{preorder,typerep}\_) {\} x {\} y" - -instantiation interval :: ("{full_exhaustive,preorder,typerep}") full_exhaustive -begin - -definition full_exhaustive_interval:: - "('a interval \ (unit \ term) \ (bool \ term list) option) - \ natural \ (bool \ term list) option" where - "full_exhaustive_interval f d = - Quickcheck_Exhaustive.full_exhaustive - (\x. Quickcheck_Exhaustive.full_exhaustive (\y. f (valtermify_interval x y)) d) d" - -instance .. - -end - -instantiation interval :: ("{random,preorder,typerep}") random -begin - -definition random_interval :: - "natural - \ natural \ natural - \ ('a interval \ (unit \ term)) \ natural \ natural" where - "random_interval i = - scomp (Quickcheck_Random.random i) - (\man. scomp (Quickcheck_Random.random i) (\exp. Pair (valtermify_interval man exp)))" - -instance .. - -end - -end diff --git a/thys/Taylor_Models/Interval_Approximation.thy b/thys/Taylor_Models/Interval_Approximation.thy deleted file mode 100644 --- a/thys/Taylor_Models/Interval_Approximation.thy +++ /dev/null @@ -1,774 +0,0 @@ -section \Approximate Operations on Intervals of Floating Point Numbers\ -theory Interval_Approximation - imports - "HOL-Decision_Procs.Approximation_Bounds" - Interval -begin - -lifting_update float.lifting \ \TODO: in Float!\ -lifting_forget float.lifting - -text \TODO: many of the lemmas should move to theories Float or Approximation - (the latter should be based on type @{type interval}.\ - -subsection "Intervals with Floating Point Bounds" - -lift_definition round_interval :: "nat \ float interval \ float interval" - is "\p. \(l, u). (float_round_down p l, float_round_up p u)" - by (auto simp: intro!: float_round_down_le float_round_up_le) - -lemma lower_round_ivl[simp]: "lower (round_interval p x) = float_round_down p (lower x)" - by transfer auto -lemma upper_round_ivl[simp]: "upper (round_interval p x) = float_round_up p (upper x)" - by transfer auto - -lemma round_ivl_correct: "set_of A \ set_of (round_interval prec A)" - by (auto simp: set_of_eq float_round_down_le float_round_up_le) - -lift_definition truncate_ivl :: "nat \ real interval \ real interval" - is "\p. \(l, u). (truncate_down p l, truncate_up p u)" - by (auto intro!: truncate_down_le truncate_up_le) - -lemma lower_truncate_ivl[simp]: "lower (truncate_ivl p x) = truncate_down p (lower x)" - by transfer auto -lemma upper_truncate_ivl[simp]: "upper (truncate_ivl p x) = truncate_up p (upper x)" - by transfer auto - -lemma truncate_ivl_correct: "set_of A \ set_of (truncate_ivl prec A)" - by (auto simp: set_of_eq intro!: truncate_down_le truncate_up_le) - -lift_definition real_interval::"float interval \ real interval" - is "\(l, u). (real_of_float l, real_of_float u)" - by auto - -lemma lower_real_interval[simp]: "lower (real_interval x) = lower x" - by transfer auto -lemma upper_real_interval[simp]: "upper (real_interval x) = upper x" - by transfer auto - -definition "set_of' x = (case x of None \ UNIV | Some i \ set_of (real_interval i))" - -lemma real_interval_min_interval[simp]: - "real_interval (min_interval a b) = min_interval (real_interval a) (real_interval b)" - by (auto simp: interval_eq_set_of_iff set_of_eq real_of_float_min) - -lemma real_interval_max_interval[simp]: - "real_interval (max_interval a b) = max_interval (real_interval a) (real_interval b)" - by (auto simp: interval_eq_set_of_iff set_of_eq real_of_float_max) - -subsection \Intervals for standard functions\ - -lift_definition power_float_interval :: "nat \ nat \ float interval \ float interval" - is "\p n (l, u). float_power_bnds p n l u" - using float_power_bnds - by (auto simp: bnds_power dest!: float_power_bnds[OF sym]) - -lemma lower_power_float_interval[simp]: - "lower (power_float_interval p n x) = fst (float_power_bnds p n (lower x) (upper x))" - by transfer auto -lemma upper_power_float_interval[simp]: - "upper (power_float_interval p n x) = snd (float_power_bnds p n (lower x) (upper x))" - by transfer auto - -lemma power_float_intervalI: "x \\<^sub>i real_interval X \ x ^ n \\<^sub>i real_interval (power_float_interval p n X)" - using float_power_bnds[OF prod.collapse] - by (auto simp: set_of_eq ) - -lift_definition mult_float_interval::"nat \ float interval \ float interval \ float interval" - is "\prec. \(a1, a2). \(b1, b2). bnds_mult prec a1 a2 b1 b2" - by (auto dest!: bnds_mult[OF sym]) - -lemma lower_mult_float_interval[simp]: - "lower (mult_float_interval p x y) = fst (bnds_mult p (lower x) (upper x) (lower y) (upper y))" - by transfer auto -lemma upper_mult_float_interval[simp]: - "upper (mult_float_interval p x y) = snd (bnds_mult p (lower x) (upper x) (lower y) (upper y))" - by transfer auto - -lemma mult_float_interval: - "set_of (real_interval A) * set_of (real_interval B) \ - set_of (real_interval (mult_float_interval prec A B))" -proof - - let ?bm = "bnds_mult prec (lower A) (upper A) (lower B) (upper B)" - show ?thesis - using bnds_mult[of "fst ?bm" "snd ?bm", simplified, OF refl] - by (auto simp: set_of_eq set_times_def) -qed - -lemma mult_float_intervalI: - "x * y \\<^sub>i (real_interval (mult_float_interval prec A B))" - if "x \\<^sub>i real_interval A" "y \\<^sub>i real_interval B" - using mult_float_interval[of A B] that - by (auto simp: ) - -lift_definition sqrt_float_interval::"nat \ float interval \ float interval" - is "\prec. \(lx, ux). (lb_sqrt prec lx, ub_sqrt prec ux)" - using bnds_sqrt' - by auto (meson order_trans real_sqrt_le_iff) - -lemma lower_float_interval[simp]: "lower (sqrt_float_interval prec X) = lb_sqrt prec (lower X)" - by transfer auto - -lemma upper_float_interval[simp]: "upper (sqrt_float_interval prec X) = ub_sqrt prec (upper X)" - by transfer auto - -lemma sqrt_float_interval: - "sqrt  set_of (real_interval X) \ set_of (real_interval (sqrt_float_interval prec X))" - using bnds_sqrt - by (auto simp: set_of_eq) - -lemma sqrt_float_intervalI: - "sqrt x \\<^sub>i real_interval (sqrt_float_interval p X)" - if "x \ set_of (real_interval X)" - using sqrt_float_interval[of X p] that - by auto - -lemmas [simp del] = lb_arctan.simps ub_arctan.simps - -lemma lb_arctan: "arctan (real_of_float x) \ y \ real_of_float (lb_arctan prec x) \ y" - and ub_arctan: "y \ arctan x \ y \ ub_arctan prec x" - for x::float and y::real - using arctan_boundaries[of x prec] by auto - -lift_definition arctan_float_interval :: "nat \ float interval \ float interval" - is "\prec. \(lx, ux). (lb_arctan prec lx, ub_arctan prec ux)" - by (auto intro!: lb_arctan ub_arctan arctan_monotone') - -lemma lower_arctan_float_interval[simp]: "lower (arctan_float_interval p x) = lb_arctan p (lower x)" - by transfer auto -lemma upper_arctan_float_interval[simp]: "upper (arctan_float_interval p x) = ub_arctan p (upper x)" - by transfer auto - -lemma arctan_float_interval: - "arctan  set_of (real_interval x) \ set_of (real_interval (arctan_float_interval p x))" - by (auto simp: set_of_eq intro!: lb_arctan ub_arctan arctan_monotone') - -lemma arctan_float_intervalI: - "arctan x \\<^sub>i real_interval (arctan_float_interval p X)" - if "x \ set_of (real_interval X)" - using arctan_float_interval[of X p] that - by auto - -lemma bnds_cos_lower: "\x. real_of_float xl \ x \ x \ real_of_float xu \ cos x \ y \ real_of_float (fst (bnds_cos prec xl xu)) \ y" - and bnds_cos_upper: "\x. real_of_float xl \ x \ x \ real_of_float xu \ y \ cos x \ y \ real_of_float (snd (bnds_cos prec xl xu))" - for xl xu::float and y::real - using bnds_cos[of "fst (bnds_cos prec xl xu)" "snd (bnds_cos prec xl xu)" prec] - by force+ - -lift_definition cos_float_interval :: "nat \ float interval \ float interval" - is "\prec. \(lx, ux). bnds_cos prec lx ux" - using bnds_cos - by auto (metis (full_types) order_refl order_trans) - -lemma lower_cos_float_interval[simp]: "lower (cos_float_interval p x) = fst (bnds_cos p (lower x) (upper x))" - by transfer auto -lemma upper_cos_float_interval[simp]: "upper (cos_float_interval p x) = snd (bnds_cos p (lower x) (upper x))" - by transfer auto - -lemma cos_float_interval: - "cos  set_of (real_interval x) \ set_of (real_interval (cos_float_interval p x))" - by (auto simp: set_of_eq bnds_cos_lower bnds_cos_upper) - -lemma cos_float_intervalI: - "cos x \\<^sub>i real_interval (cos_float_interval p X)" - if "x \ set_of (real_interval X)" - using cos_float_interval[of X p] that - by auto - -lemma lb_exp: "exp x \ y \ lb_exp prec x \ y" - and ub_exp: "y \ exp x \ y \ ub_exp prec x" - for x::float and y::real using exp_boundaries[of x prec] by auto - -lift_definition exp_float_interval :: "nat \ float interval \ float interval" - is "\prec. \(lx, ux). (lb_exp prec lx, ub_exp prec ux)" - by (auto simp: lb_exp ub_exp) - -lemma lower_exp_float_interval[simp]: "lower (exp_float_interval p x) = lb_exp p (lower x)" - by transfer auto -lemma upper_exp_float_interval[simp]: "upper (exp_float_interval p x) = ub_exp p (upper x)" - by transfer auto - -lemma exp_float_interval: - "exp  set_of (real_interval x) \ set_of (real_interval (exp_float_interval p x))" - using exp_boundaries apply (auto simp: set_of_eq) - apply (smt exp_le_cancel_iff) - apply (smt exp_le_cancel_iff) - done - -lemma exp_float_intervalI: - "exp x \\<^sub>i real_interval (exp_float_interval p X)" - if "x \ set_of (real_interval X)" - using exp_float_interval[of X p] that - by auto - -lemmas [simp del] = lb_ln.simps ub_ln.simps - -lemma lb_lnD: - "y \ ln x \ 0 < real_of_float x" if "lb_ln prec x = Some y" - using lb_ln[OF that[symmetric]] by auto - -lemma ub_lnD: - "ln x \ y\ 0 < real_of_float x" if "ub_ln prec x = Some y" - using ub_ln[OF that[symmetric]] by auto - -lift_definition(code_dt) ln_float_interval :: "nat \ float interval \ float interval option" - is "\prec. \(lx, ux). - Option.bind (lb_ln prec lx) (\l. - Option.bind (ub_ln prec ux) (\u. Some (l, u)))" - by (auto simp: pred_option_def bind_eq_Some_conv ln_le_cancel_iff[symmetric] - simp del: ln_le_cancel_iff dest!: lb_lnD ub_lnD) - -lemma ln_float_interval_eq_Some_conv[simp]: - "ln_float_interval p x = Some y \ - lb_ln p (lower x) = Some (lower y) \ ub_ln p (upper x) = Some (upper y)" - by transfer (auto simp: bind_eq_Some_conv) - -lemma ln_float_interval: "ln  set_of (real_interval x) \ set_of (real_interval y)" - if "ln_float_interval p x = Some y" - using that - by (simp add: set_of_eq) - (smt atLeastAtMost_iff bnds_ln image_subset_iff) - -lemma ln_float_intervalI: - "ln x \ set_of' (ln_float_interval p X)" - if "x \\<^sub>i (real_interval X)" - using ln_float_interval[of p X] that - by (auto simp: set_of'_def split: option.splits) - -lift_definition(code_dt) powr_float_interval :: "nat \ float interval \ float interval \ float interval option" - is "\prec. \(l1, u1). \(l2, u2). bnds_powr prec l1 u1 l2 u2" - by (auto simp: pred_option_def dest!: bnds_powr[OF sym]) - -lemma powr_float_interval: - "{x powr y | x y. x \ set_of (real_interval X) \ y \ set_of (real_interval Y)} - \ set_of (real_interval R)" - if "powr_float_interval prec X Y = Some R" - using that - by transfer (auto dest!: bnds_powr[OF sym]) - -lemma powr_float_intervalI: - "x powr y \ set_of' (powr_float_interval p X Y)" - if "x \\<^sub>i real_interval X" "y \\<^sub>i real_interval Y" - using powr_float_interval[of p X Y] that - by (auto simp: set_of'_def split: option.splits) - -lift_definition(code_dt) inverse_float_interval::"nat \ float interval \ float interval option" is - "\prec (l, u). if (0 < l \ u < 0) then Some (float_divl prec 1 u, float_divr prec 1 l) else None" - by (auto intro!: order_trans[OF float_divl] order_trans[OF _ float_divr] - simp: divide_simps) - -lemma inverse_float_interval_eq_Some_conv[simp]: - defines "one \ (1::float)" - shows - "inverse_float_interval p X = Some R \ - (lower X > 0 \ upper X < 0) \ - lower R = float_divl p one (upper X) \ - upper R = float_divr p one (lower X)" - by clarsimp (transfer fixing: one, force simp: one_def split: if_splits) - -lemma inverse_float_interval: - "inverse ` set_of (real_interval X) \ set_of (real_interval Y)" - if "inverse_float_interval p X = Some Y" - using that - apply (clarsimp simp: set_of_eq) - by (intro order_trans[OF float_divl] order_trans[OF _ float_divr] conjI) - (auto simp: divide_simps) - -lemma inverse_float_intervalI: - "x \ set_of (real_interval X) \ inverse x \ set_of' (inverse_float_interval p X)" - using inverse_float_interval[of p X] - by (auto simp: set_of'_def split: option.splits) - - -lift_definition pi_float_interval::"nat \ float interval" is "\prec. (lb_pi prec, ub_pi prec)" - using pi_boundaries - by (auto intro: order_trans) - -lemma lower_pi_float_interval[simp]: "lower (pi_float_interval prec) = lb_pi prec" - by transfer auto -lemma upper_pi_float_interval[simp]: "upper (pi_float_interval prec) = ub_pi prec" - by transfer auto -lemma pi_float_interval: "pi \ set_of (real_interval (pi_float_interval prec))" - using pi_boundaries - by (auto simp: set_of_eq) - -lemma real_interval_abs_interval[simp]: - "real_interval (abs_interval x) = abs_interval (real_interval x)" - by (auto simp: interval_eq_set_of_iff set_of_eq real_of_float_max real_of_float_min) - -lift_definition floor_float_interval::"float interval \ float interval" is - "\(l, u). (floor_fl l, floor_fl u)" - by (auto intro!: floor_mono simp: floor_fl.rep_eq) - -lemma lower_floor_float_interval[simp]: "lower (floor_float_interval x) = floor_fl (lower x)" - by transfer auto -lemma upper_floor_float_interval[simp]: "upper (floor_float_interval x) = floor_fl (upper x)" - by transfer auto - -lemma floor_float_intervalI: "\x\ \\<^sub>i real_interval (floor_float_interval X)" - if "x \\<^sub>i real_interval X" - using that by (auto simp: set_of_eq floor_fl_def floor_mono) - - -lemma in_intervalI: - "x \\<^sub>i X" if "lower X \ x" "x \ upper X" - using that by (auto simp: set_of_eq) - -abbreviation in_real_interval ("(_/ \\<^sub>r _)" [51, 51] 50) where - "x \\<^sub>r X \ x \\<^sub>i real_interval X" - -lemma in_real_intervalI: - "x \\<^sub>r X" if "lower X \ x" "x \ upper X" for x::real and X::"float interval" - using that - by (intro in_intervalI) auto - -lemma lower_Interval: "lower (Interval x) = fst x" - and upper_Interval: "upper (Interval x) = snd x" - if "fst x \ snd x" - using that - by (auto simp: lower_def upper_def Interval_inverse split_beta') - -definition all_in_i :: "'a::preorder list \ 'a interval list \ bool" - (infix "(all'_in\<^sub>i)" 50) - where "x all_in\<^sub>i I = (length x = length I \ (\i < length I. x ! i \\<^sub>i I ! i))" - -definition all_in :: "real list \ float interval list \ bool" - (infix "(all'_in)" 50) - where "x all_in I = (length x = length I \ (\i < length I. x ! i \\<^sub>r I ! i))" - -definition all_subset :: "'a::order interval list \ 'a interval list \ bool" - (infix "(all'_subset)" 50) - where "I all_subset J = (length I = length J \ (\i < length I. set_of (I!i) \ set_of (J!i)))" - -lemmas [simp] = all_in_def all_subset_def - -lemma all_subsetD: - assumes "I all_subset J" - assumes "x all_in I" - shows "x all_in J" - using assms - by (auto simp: set_of_eq; fastforce) - -lemma plus_down_mono: "plus_down p a b \ plus_down p c d" if "a + b \ c + d" - by (auto simp: plus_down_def intro!: truncate_down_mono that) - -lemma plus_up_mono: "plus_up p a b \ plus_up p c d" if "a + b \ c + d" - by (auto simp: plus_up_def intro!: truncate_up_mono that) - -lemma round_interval_mono: "set_of (round_interval prec X) \ set_of (round_interval prec Y)" - if "set_of X \ set_of Y" - using that - by transfer - (auto simp: float_round_down.rep_eq float_round_up.rep_eq truncate_down_mono truncate_up_mono) - -lemma mult_mono_nonpos_nonneg: "a * b \ c * d" - if "a \ c" "a \ 0" "0 \ d" "d \ b" for a b c d::"'a::ordered_ring" - apply (rule order_trans[OF mult_left_mono_neg[OF \d \ b\]]) - subgoal using that by auto - by (rule mult_right_mono; fact) - -lemma mult_mono_nonneg_nonpos: "b * a \ d * c" - if "a \ c" "c \ 0" "0 \ d" "d \ b" for a b c d::"'a::ordered_ring" - apply (rule order_trans[OF mult_right_mono_neg[OF \d \ b\]]) - subgoal using that by auto - by (rule mult_left_mono; fact) - -lemma mult_mono_nonpos_nonpos: "a * b \ c * d" - if "a \ c" "a \ 0" "b \ d" "d \ 0" for a b c d::real - apply (rule order_trans[OF mult_left_mono_neg[OF \d \ b\]]) - subgoal using that by auto - by (rule mult_right_mono_neg; fact) - -lemma mult_float_mono1: - notes mono_rules = plus_down_mono add_mono nprt_mono nprt_le_zero zero_le_pprt pprt_mono - shows "a \ b \ ab \ bb \ - aa \ a \ - b \ ba \ - ac \ ab \ - bb \ bc \ - plus_down prec (nprt aa * pprt bc) - (plus_down prec (nprt ba * nprt bc) - (plus_down prec (pprt aa * pprt ac) - (pprt ba * nprt ac))) - \ plus_down prec (nprt a * pprt bb) - (plus_down prec (nprt b * nprt bb) - (plus_down prec (pprt a * pprt ab) - (pprt b * nprt ab)))" - apply (rule order_trans) - apply (rule mono_rules | assumption)+ - apply (rule mult_mono_nonpos_nonneg) - apply (rule mono_rules | assumption)+ - apply (rule mult_mono_nonpos_nonpos) - apply (rule mono_rules | assumption)+ - apply (rule mult_mono) - apply (rule mono_rules | assumption)+ - apply (rule mult_mono_nonneg_nonpos) - apply (rule mono_rules | assumption)+ - by (rule order_refl)+ - -lemma mult_float_mono2: - notes mono_rules = plus_up_mono add_mono nprt_mono nprt_le_zero zero_le_pprt pprt_mono - shows "a \ b \ - ab \ bb \ - aa \ a \ - b \ ba \ - ac \ ab \ - bb \ bc \ - plus_up prec (pprt b * pprt bb) - (plus_up prec (pprt a * nprt bb) - (plus_up prec (nprt b * pprt ab) - (nprt a * nprt ab))) - \ plus_up prec (pprt ba * pprt bc) - (plus_up prec (pprt aa * nprt bc) - (plus_up prec (nprt ba * pprt ac) - (nprt aa * nprt ac)))" - apply (rule order_trans) - apply (rule mono_rules | assumption)+ - apply (rule mult_mono) - apply (rule mono_rules | assumption)+ - apply (rule mult_mono_nonneg_nonpos) - apply (rule mono_rules | assumption)+ - apply (rule mult_mono_nonpos_nonneg) - apply (rule mono_rules | assumption)+ - apply (rule mult_mono_nonpos_nonpos) - apply (rule mono_rules | assumption)+ - by (rule order_refl)+ - -lemma mult_float_interval_mono: "set_of (mult_float_interval prec A B) \ set_of (mult_float_interval prec X Y)" - if "set_of A \ set_of X" "set_of B \ set_of Y" - using that - apply transfer - unfolding bnds_mult_def atLeastatMost_subset_iff float_plus_down.rep_eq float_plus_up.rep_eq - by (auto simp: float_plus_down.rep_eq float_plus_up.rep_eq mult_float_mono1 mult_float_mono2) - -lemma Ivl_simps[simp]: "lower (Ivl a b) = min a b" "upper (Ivl a b) = b" - subgoal by transfer simp - subgoal by transfer simp - done - -lemmas [simp del] = power_down.simps(2) power_up.simps(2) -lemmas power_down_simp = power_down.simps(2) -lemmas power_up_simp = power_up.simps(2) - -lemma power_down_even_nonneg: "even n \ 0 \ power_down p x n" - by (induct p x n rule: power_down.induct) - (auto simp: power_down_simp simp del: odd_Suc_div_two intro!: truncate_down_nonneg ) - -lemma truncate_down_less_zero_iff[simp]: "truncate_down p x < 0 \ x < 0" - by (metis le_less_trans not_less_iff_gr_or_eq truncate_down truncate_down_pos truncate_down_zero) - -lemma truncate_down_nonneg_iff[simp]: "truncate_down p x \ 0 \ x \ 0" - using truncate_down_less_zero_iff[of p x] truncate_down_nonneg[of x p] - by linarith - -lemma truncate_down_eq_zero_iff[simp]: "truncate_down prec x = 0 \ x = 0" - by (metis not_less_iff_gr_or_eq truncate_down_less_zero_iff truncate_down_pos truncate_down_zero) - -lemma power_down_eq_zero_iff[simp]: "power_down prec b n = 0 \ b = 0 \ n \ 0" -proof (induction n arbitrary: b rule: less_induct) - case (less x) - then show ?case - using power_down_simp[of _ _ "x - 1"] - by (cases x) (auto simp add: div2_less_self) -qed - -lemma power_down_nonneg_iff[simp]: - "power_down prec b n \ 0 \ even n \ b \ 0" -proof (induction n arbitrary: b rule: less_induct) - case (less x) - show ?case - using less(1)[of "x - 1" b] power_down_simp[of _ _ "x - 1"] - by (cases x) (auto simp: algebra_split_simps zero_le_mult_iff) -qed - -lemma power_down_neg_iff[simp]: - "power_down prec b n < 0 \ - b < 0 \ odd n" - using power_down_nonneg_iff[of prec b n] by (auto simp del: power_down_nonneg_iff) - -lemma power_down_nonpos_iff[simp]: - notes [simp del] = power_down_neg_iff power_down_eq_zero_iff - shows "power_down prec b n \ 0 \ b < 0 \ odd n \ b = 0 \ n \ 0" - using power_down_neg_iff[of prec b n] power_down_eq_zero_iff[of prec b n] - by auto - -lemma power_down_mono: - "power_down prec a n \ power_down prec b n" - if "((0 \ a \ a \ b)\(odd n \ a \ b) \ (even n \ a \ 0 \ b \ a))" - using that -proof (induction n arbitrary: a b rule: less_induct) - case (less i) - show ?case - proof (cases i) - case j: (Suc j) - note IH = less[unfolded j even_Suc not_not] - note [simp del] = power_down.simps - show ?thesis - proof cases - assume [simp]: "even j" - have "a * power_down prec a j \ b * power_down prec b j" - by (smt IH(1) IH(2) \even j\ lessI mult_mono' mult_mono_nonpos_nonneg power_down_even_nonneg) - then have "truncate_down (Suc prec) (a * power_down prec a j) \ truncate_down (Suc prec) (b * power_down prec b j)" - by (auto intro!: truncate_down_mono simp: abs_le_square_iff[symmetric] abs_real_def) - then show ?thesis - unfolding j - by (simp add: power_down_simp) - next - assume [simp]: "odd j" - have "power_down prec 0 (Suc (j div 2)) \ - power_down prec b (Suc (j div 2))" - if "b < 0" "even (j div 2)" - apply (rule order_trans[where y=0]) - using IH that by (auto simp: div2_less_self) - then have "truncate_down (Suc prec) ((power_down prec a (Suc (j div 2)))\<^sup>2) - \ truncate_down (Suc prec) ((power_down prec b (Suc (j div 2)))\<^sup>2)" - using IH - by (auto intro!: truncate_down_mono intro: order_trans[where y=0] - simp: abs_le_square_iff[symmetric] abs_real_def - div2_less_self) - then show ?thesis - unfolding j - by (simp add: power_down_simp) - qed - qed simp -qed - -lemma truncate_up_nonneg: "0 \ truncate_up p x" if "0 \ x" - by (simp add: that truncate_up_le) - -lemma truncate_up_pos: "0 < truncate_up p x" if "0 < x" - by (meson less_le_trans that truncate_up) - -lemma truncate_up_less_zero_iff[simp]: "truncate_up p x < 0 \ x < 0" -proof - - have f1: "\n r. truncate_up n r + truncate_down n (- 1 * r) = 0" - by (simp add: truncate_down_uminus_eq) - have f2: "(\v0 v1. truncate_up v0 v1 + truncate_down v0 (- 1 * v1) = 0) = (\v0 v1. truncate_up v0 v1 = - 1 * truncate_down v0 (- 1 * v1))" - by (auto simp: truncate_up_eq_truncate_down) - have f3: "\x1. ((0::real) < x1) = (\ x1 \ 0)" - by fastforce - have "(- 1 * x \ 0) = (0 \ x)" - by force - then have "0 \ x \ \ truncate_down p (- 1 * x) \ 0" - using f3 by (meson truncate_down_pos) - then have "(0 \ truncate_up p x) \ (\ 0 \ x)" - using f2 f1 truncate_up_nonneg by force - then show ?thesis - by linarith -qed - -lemma truncate_up_nonneg_iff[simp]: "truncate_up p x \ 0 \ x \ 0" - using truncate_up_less_zero_iff[of p x] truncate_up_nonneg[of x] - by linarith - -lemma power_up_even_nonneg: "even n \ 0 \ power_up p x n" - by (induct p x n rule: power_up.induct) - (auto simp: power_up.simps simp del: odd_Suc_div_two intro!: ) - -lemma truncate_up_eq_zero_iff[simp]: "truncate_up prec x = 0 \ x = 0" - by (metis not_less_iff_gr_or_eq truncate_up_less_zero_iff truncate_up_pos truncate_up_zero) - -lemma power_up_eq_zero_iff[simp]: "power_up prec b n = 0 \ b = 0 \ n \ 0" -proof (induction n arbitrary: b rule: less_induct) - case (less x) - then show ?case - using power_up_simp[of _ _ "x - 1"] - by (cases x) (auto simp: algebra_split_simps zero_le_mult_iff div2_less_self) -qed - -lemma power_up_nonneg_iff[simp]: - "power_up prec b n \ 0 \ even n \ b \ 0" -proof (induction n arbitrary: b rule: less_induct) - case (less x) - show ?case - using less(1)[of "x - 1" b] power_up_simp[of _ _ "x - 1"] - by (cases x) (auto simp: algebra_split_simps zero_le_mult_iff) -qed - -lemma power_up_neg_iff[simp]: - "power_up prec b n < 0 \ b < 0 \ odd n" - using power_up_nonneg_iff[of prec b n] by (auto simp del: power_up_nonneg_iff) - -lemma power_up_nonpos_iff[simp]: - notes [simp del] = power_up_neg_iff power_up_eq_zero_iff - shows "power_up prec b n \ 0 \ b < 0 \ odd n \ b = 0 \ n \ 0" - using power_up_neg_iff[of prec b n] power_up_eq_zero_iff[of prec b n] - by auto - -lemma power_up_mono: - "power_up prec a n \ power_up prec b n" - if "((0 \ a \ a \ b)\(odd n \ a \ b) \ (even n \ a \ 0 \ b \ a))" - using that -proof (induction n arbitrary: a b rule: less_induct) - case (less i) - show ?case - proof (cases i) - case j: (Suc j) - note IH = less[unfolded j even_Suc not_not] - note [simp del] = power_up.simps - show ?thesis - proof cases - assume [simp]: "even j" - have "a * power_up prec a j \ b * power_up prec b j" - by (smt IH(1) IH(2) \even j\ lessI mult_mono' mult_mono_nonpos_nonneg power_up_even_nonneg) - then have "truncate_up prec (a * power_up prec a j) \ truncate_up prec (b * power_up prec b j)" - by (auto intro!: truncate_up_mono simp: abs_le_square_iff[symmetric] abs_real_def) - then show ?thesis - unfolding j - by (simp add: power_up_simp) - next - assume [simp]: "odd j" - have "power_up prec 0 (Suc (j div 2)) \ - power_up prec b (Suc (j div 2))" - if "b < 0" "even (j div 2)" - apply (rule order_trans[where y=0]) - using IH that by (auto simp: div2_less_self) - then have "truncate_up prec ((power_up prec a (Suc (j div 2)))\<^sup>2) - \ truncate_up prec ((power_up prec b (Suc (j div 2)))\<^sup>2)" - using IH - by (auto intro!: truncate_up_mono intro: order_trans[where y=0] - simp: abs_le_square_iff[symmetric] abs_real_def - div2_less_self) - then show ?thesis - unfolding j - by (simp add: power_up_simp) - qed - qed simp -qed - -lemma set_of_subset_iff: "set_of X \ set_of Y \ lower Y \ lower X \ upper X \ upper Y" - for X Y::"'a::linorder interval" - by (auto simp: set_of_eq subset_iff) - -lemma power_float_interval_mono: - "set_of (power_float_interval prec n A) - \ set_of (power_float_interval prec n B)" - if "set_of A \ set_of B" -proof - - define la where "la = real_of_float (lower A)" - define ua where "ua = real_of_float (upper A)" - define lb where "lb = real_of_float (lower B)" - define ub where "ub = real_of_float (upper B)" - have ineqs: "lb \ la" "la \ ua" "ua \ ub" "lb \ ub" - using that lower_le_upper[of A] lower_le_upper[of B] - by (auto simp: la_def ua_def lb_def ub_def set_of_eq) - show ?thesis - using ineqs - by (simp add: set_of_subset_iff float_power_bnds_def max_def - power_down_fl.rep_eq power_up_fl.rep_eq - la_def[symmetric] ua_def[symmetric] lb_def[symmetric] ub_def[symmetric]) - (auto intro!: power_down_mono power_up_mono intro: order_trans[where y=0]) -qed - -lemma bounds_of_interval_eq_lower_upper: - "bounds_of_interval ivl = (lower ivl, upper ivl)" if "lower ivl \ upper ivl" - using that - by (auto simp: lower.rep_eq upper.rep_eq) - -lemma real_interval_Ivl: "real_interval (Ivl a b) = Ivl a b" - by transfer (auto simp: min_def) - -lemma set_of_mul_contains_real_zero: - "0 \\<^sub>r (A * B)" if "0 \\<^sub>r A \ 0 \\<^sub>r B" - using that set_of_mul_contains_zero[of A B] - by (auto simp: set_of_eq) - -fun subdivide_interval :: "nat \ float interval \ float interval list" - where "subdivide_interval 0 I = [I]" - | "subdivide_interval (Suc n) I = ( - let m = mid I - in (subdivide_interval n (Ivl (lower I) m)) @ (subdivide_interval n (Ivl m (upper I))) - )" - -lemma subdivide_interval_length: - shows "length (subdivide_interval n I) = 2^n" - by(induction n arbitrary: I, simp_all add: Let_def) - -lemma lower_le_mid: "lower x \ mid x" "real_of_float (lower x) \ mid x" - and mid_le_upper: "mid x \ upper x" "real_of_float (mid x) \ upper x" - unfolding mid_def - subgoal by transfer auto - subgoal by transfer auto - subgoal by transfer auto - subgoal by transfer auto - done - -lemma subdivide_interval_correct: - "list_ex (\i. x \\<^sub>r i) (subdivide_interval n I)" if "x \\<^sub>r I" for x::real - using that -proof(induction n arbitrary: x I) - case 0 - then show ?case by simp -next - case (Suc n) - from \x \\<^sub>r I\ consider "x \\<^sub>r Ivl (lower I) (mid I)" | "x \\<^sub>r Ivl (mid I) (upper I)" - by (cases "x \ real_of_float (mid I)") - (auto simp: set_of_eq min_def lower_le_mid mid_le_upper) - from this[case_names lower upper] show ?case - by cases (use Suc.IH in \auto simp: Let_def$$ -qed - -fun interval_list_union :: "'a::lattice interval list \ 'a interval" - where "interval_list_union [] = undefined" - | "interval_list_union [I] = I" - | "interval_list_union (I#Is) = sup I (interval_list_union Is)" - -lemma interval_list_union_correct: - assumes "S \ []" - assumes "i < length S" - shows "set_of (S!i) \ set_of (interval_list_union S)" - using assms -proof(induction S arbitrary: i) - case (Cons a S i) - thus ?case - proof(cases S) - fix b S' - assume "S = b # S'" - hence "S \ []" - by simp - show ?thesis - proof(cases i) - case 0 - show ?thesis - apply(cases S) - using interval_union_mono1 - by (auto simp add: 0) - next - case (Suc i_prev) - hence "i_prev < length S" - using Cons(3) by simp - - from Cons(1)[OF \S \ []\ this] Cons(1) - have "set_of ((a # S) ! i) \ set_of (interval_list_union S)" - by (simp add: \i = Suc i_prev\) - also have "... \ set_of (interval_list_union (a # S))" - using \S \ []\ - apply(cases S) - using interval_union_mono2 - by auto - finally show ?thesis . - qed - qed simp -qed simp - -lemma split_domain_correct: - fixes x :: "real list" - assumes "x all_in I" - assumes split_correct: "\x a I. x \\<^sub>r I \ list_ex (\i::float interval. x \\<^sub>r i) (split I)" - shows "list_ex (\s. x all_in s) (split_domain split I)" - using assms(1) -proof(induction I arbitrary: x) - case (Cons I Is x) - have "x \ []" - using Cons(2) by auto - obtain x' xs where x_decomp: "x = x' # xs" - using \x \ []\ list.exhaust by auto - hence "x' \\<^sub>r I" "xs all_in Is" - using Cons(2) - by auto - show ?case - using Cons(1)[OF \xs all_in Is\] - split_correct[OF \x' \\<^sub>r I\] - apply (auto simp add: list_ex_iff set_of_eq) - by (smt length_Cons less_Suc_eq_0_disj nth_Cons_0 nth_Cons_Suc x_decomp) -qed simp - -end \ No newline at end of file diff --git a/thys/Taylor_Models/Polynomial_Expression_Additional.thy b/thys/Taylor_Models/Polynomial_Expression_Additional.thy --- a/thys/Taylor_Models/Polynomial_Expression_Additional.thy +++ b/thys/Taylor_Models/Polynomial_Expression_Additional.thy @@ -1,407 +1,407 @@ theory Polynomial_Expression_Additional - imports Interval_Approximation + imports "Polynomial_Expression" "HOL-Decision_Procs.Approximation" begin lemma real_of_float_eq_zero_iff[simp]: "real_of_float x = 0 \ x = 0" by (simp add: real_of_float_eq) text \Theory @{theory Taylor_Models.Polynomial_Expression} contains a, more or less, 1:1 generalization of theory \Multivariate_Polynomial\. Any additions belong here.\ declare [[coercion_map map_poly]] declare [[coercion "interval_of::float\float interval"]] text \Apply float interval arguments to a float poly.\ value "Ipoly [Ivl (Float 4 (-6)) (Float 10 6)] (poly.Add (poly.C (Float 3 5)) (poly.Bound 0))" text \@{term map_poly} for homomorphisms\ lemma map_poly_homo_polyadd_eq_zero_iff: "map_poly f (p +\<^sub>p q) = 0\<^sub>p \ p +\<^sub>p q = 0\<^sub>p" if [symmetric, simp]: "\x y. f (x + y) = f x + f y" "\x. f x = 0 \ x = 0" by (induction p q rule: polyadd.induct) auto lemma zero_iffD: "(\x. f x = 0 \ x = 0) \ f 0 = 0" by auto lemma map_poly_homo_polyadd: "map_poly f (p1 +\<^sub>p p2) = map_poly f p1 +\<^sub>p map_poly f p2" if [simp]: "\x y. f (x + y) = f x + f y" "\x. f x = 0 \ x = 0" by (induction p1 p2 rule: polyadd.induct) (auto simp: zero_iffD[OF that(2)] Let_def map_poly_homo_polyadd_eq_zero_iff) lemma map_poly_homo_polyneg: "map_poly f (~\<^sub>p p1) = ~\<^sub>p (map_poly f p1)" if [simp]: "\x y. f (- x) = - f x" by (induction p1) (auto simp: Let_def map_poly_homo_polyadd_eq_zero_iff) lemma map_poly_homo_polysub: "map_poly f (p1 -\<^sub>p p2) = map_poly f p1 -\<^sub>p map_poly f p2" if [simp]: "\x y. f (x + y) = f x + f y" "\x. f x = 0 \ x = 0" "\x y. f (- x) = - f x" by (auto simp: polysub_def map_poly_homo_polyadd map_poly_homo_polyneg) lemma map_poly_homo_polymul: "map_poly f (p1 *\<^sub>p p2) = map_poly f p1 *\<^sub>p map_poly f p2" if [simp]: "\x y. f (x + y) = f x + f y" "\x. f x = 0 \ x = 0" "\x y. f (x * y) = f x * f y" by (induction p1 p2 rule: polymul.induct) (auto simp: zero_iffD[OF that(2)] map_poly_homo_polyadd) lemma map_poly_homo_polypow: "map_poly f (p1 ^\<^sub>p n) = map_poly f p1 ^\<^sub>p n" if [simp]: "\x y. f (x + y) = f x + f y" "\x. f x = 0 \ x = 0" "\x y. f (x * y) = f x * f y" "f 1 = 1" proof(induction n rule: nat_less_induct) case (1 n) then show ?case apply (cases n) apply (auto simp: map_poly_homo_polyadd map_poly_homo_polymul) by (smt Suc_less_eq div2_less_self even_Suc odd_Suc_div_two map_poly_homo_polymul that) qed lemmas map_poly_homo_polyarith = map_poly_homo_polyadd map_poly_homo_polyneg map_poly_homo_polysub map_poly_homo_polymul map_poly_homo_polypow text \Count the number of parameters of a polynomial.\ fun num_params :: "'a poly \ nat" where "num_params (poly.C c) = 0" | "num_params (poly.Bound n) = Suc n" | "num_params (poly.Add a b) = max (num_params a) (num_params b)" | "num_params (poly.Sub a b) = max (num_params a) (num_params b)" | "num_params (poly.Mul a b) = max (num_params a) (num_params b)" | "num_params (poly.Neg a) = num_params a" | "num_params (poly.Pw a n) = num_params a" | "num_params (poly.CN a n b) = max (max (num_params a) (num_params b)) (Suc n)" lemma num_params_map_poly[simp]: shows "num_params (map_poly f p) = num_params p" by (induction p, simp_all) lemma num_params_polyadd: shows "num_params (p1 +\<^sub>p p2) \ max (num_params p1) (num_params p2)" proof (induction p1 p2 rule: polyadd.induct) case (4 c n p c' n' p') then show ?case by auto (auto simp: max_def Let_def split: if_splits) qed auto lemma num_params_polyneg: shows "num_params (~\<^sub>p p) = num_params p" by (induction p rule: polyneg.induct) simp_all lemma num_params_polymul: shows "num_params (p1 *\<^sub>p p2) \ max (num_params p1) (num_params p2)" proof (induction p1 p2 rule: polymul.induct) case (4 c n p c' n' p') then show ?case by auto (auto simp: max_def Let_def split: if_splits intro!: num_params_polyadd[THEN order_trans]) qed auto lemma num_params_polypow: shows "num_params (p ^\<^sub>p n) \ num_params p" apply (induction n rule: polypow.induct) unfolding polypow.simps by (auto intro!: order_trans[OF num_params_polymul] simp: Let_def simp del: polypow.simps) lemma num_params_polynate: shows "num_params (polynate p) \ num_params p" proof(induction p rule: polynate.induct) case (2 l r) thus ?case using num_params_polyadd[of "polynate l" "polynate r"] by simp next case (3 l r) thus ?case using num_params_polyadd[of "polynate l" "~\<^sub>p (polynate r)"] by (simp add: polysub_def num_params_polyneg) next case (4 l r) thus ?case using num_params_polymul[of "polynate l" "polynate r"] by simp next case (5 p) thus ?case by (simp add: num_params_polyneg) next case (6 p n) thus ?case using num_params_polypow[of n "polynate p"] by simp qed simp_all lemma polynate_map_poly_real[simp]: fixes p :: "float poly" shows "map_poly real_of_float (polynate p) = polynate (map_poly real_of_float p)" by (induction p) (simp_all add: map_poly_homo_polyarith) text \Evaluating a float poly is equivalent to evaluating the corresponding real poly with the float parameters converted to reals.\ lemma Ipoly_real_float_eqiv: fixes p::"float poly" and xs::"float list" assumes "num_params p \ length xs" shows "Ipoly xs (p::real poly) = Ipoly xs p" using assms by (induction p, simp_all) text \Evaluating an \'a poly\ with \'a interval\ arguments is monotone.\ lemma Ipoly_interval_args_mono: fixes p::"'a::linordered_idom poly" and x::"'a list" and xs::"'a interval list" assumes "x all_in\<^sub>i xs" assumes "num_params p \ length xs" shows "Ipoly x p \ set_of (Ipoly xs (map_poly interval_of p))" using assms by (induction p) (auto simp: all_in_i_def plus_in_intervalI minus_in_intervalI times_in_intervalI uminus_in_intervalI set_of_power_mono) lemma Ipoly_interval_args_inc_mono: fixes p::"'a::{real_normed_algebra, linear_continuum_topology, linordered_idom} poly" and I::"'a interval list" and J::"'a interval list" assumes "num_params p \ length I" assumes "I all_subset J" shows "set_of (Ipoly I (map_poly interval_of p)) \ set_of (Ipoly J (map_poly interval_of p))" using assms by (induction p) (simp_all add: set_of_add_inc set_of_sub_inc set_of_mul_inc set_of_neg_inc set_of_pow_inc) section \Splitting polynomials to reduce floating point precision\ text \TODO: Move this! Definitions regarding floating point numbers should not be in a theory about polynomials.\ fun float_prec :: "float \ int" where "float_prec f = (let p=exponent f in if p \ 0 then 0 else -p)" fun float_round :: "nat \ float \ float" where "float_round prec f = ( let d = float_down prec f; u = float_up prec f in if f - d < u - f then d else u)" text \Splits any polynomial \p\ into two polynomials \l\, \r\, such that \\x::real. p(x) = l(x) + r(x)\ and all floating point coefficients in \p\ are rounded to precision \prec\. Not all cases need to give good results. Polynomials normalized with polynate only contain \poly.C\ and \poly.CN\ constructors.\ fun split_by_prec :: "nat \ float poly \ float poly * float poly" where "split_by_prec prec (poly.C f) = (let r = float_round prec f in (poly.C r, poly.C (f - r)))" | "split_by_prec prec (poly.Bound n) = (poly.Bound n, poly.C 0)" | "split_by_prec prec (poly.Add l r) = (let (ll, lr) = split_by_prec prec l; (rl, rr) = split_by_prec prec r in (poly.Add ll rl, poly.Add lr rr))" | "split_by_prec prec (poly.Sub l r) = (let (ll, lr) = split_by_prec prec l; (rl, rr) = split_by_prec prec r in (poly.Sub ll rl, poly.Sub lr rr))" | "split_by_prec prec (poly.Mul l r) = (let (ll, lr) = split_by_prec prec l; (rl, rr) = split_by_prec prec r in (poly.Mul ll rl, poly.Add (poly.Add (poly.Mul lr rl) (poly.Mul ll rr)) (poly.Mul lr rr)))" | "split_by_prec prec (poly.Neg p) = (let (l, r) = split_by_prec prec p in (poly.Neg l, poly.Neg r))" | "split_by_prec prec (poly.Pw p 0) = (poly.C 1, poly.C 0)" | "split_by_prec prec (poly.Pw p (Suc n)) = (let (l, r) = split_by_prec prec p in (poly.Pw l n, poly.Sub (poly.Pw p (Suc n)) (poly.Pw l n)))" | "split_by_prec prec (poly.CN c n p) = (let (cl, cr) = split_by_prec prec c; (pl, pr) = split_by_prec prec p in (poly.CN cl n pl, poly.CN cr n pr))" text \TODO: Prove precision constraint on \l\.\ lemma split_by_prec_correct: fixes args :: "real list" assumes "(l, r) = split_by_prec prec p" shows "Ipoly args p = Ipoly args l + Ipoly args r" (is ?P1) and "num_params l \ num_params p" (is ?P2) and "num_params r \ num_params p" (is ?P3) unfolding atomize_conj using assms proof(induction p arbitrary: l r) case (Add p1 p2 l r) thus ?case apply(simp add: Add(1,2)[OF prod.collapse] split_beta) using max.coboundedI1 max.coboundedI2 prod.collapse by metis next case (Sub p1 p2 l r) thus ?case apply(simp add: Sub(1,2)[OF prod.collapse] split_beta) using max.coboundedI1 max.coboundedI2 prod.collapse by metis next case (Mul p1 p2 l r) thus ?case apply(simp add: Mul(1,2)[OF prod.collapse] split_beta algebra_simps) using max.coboundedI1 max.coboundedI2 prod.collapse by metis next case (Neg p l r) thus ?case by (simp add: Neg(1)[OF prod.collapse] split_beta) next case (Pw p n l r) thus ?case by (cases n) (simp_all add: Pw(1)[OF prod.collapse] split_beta) next case (CN c n p2) thus ?case apply(simp add: CN(1,2)[OF prod.collapse] split_beta algebra_simps) by (meson le_max_iff_disj prod.collapse) qed (simp_all add: Let_def) section \Splitting polynomials by degree\ fun maxdegree :: "('a::zero) poly \ nat" where "maxdegree (poly.C c) = 0" | "maxdegree (poly.Bound n) = 1" | "maxdegree (poly.Add l r) = max (maxdegree l) (maxdegree r)" | "maxdegree (poly.Sub l r) = max (maxdegree l) (maxdegree r)" | "maxdegree (poly.Mul l r) = maxdegree l + maxdegree r" | "maxdegree (poly.Neg p) = maxdegree p" | "maxdegree (poly.Pw p n) = n * maxdegree p" | "maxdegree (poly.CN c n p) = max (maxdegree c) (1 + maxdegree p)" fun split_by_degree :: "nat \ 'a::zero poly \ 'a poly * 'a poly" where "split_by_degree n (poly.C c) = (poly.C c, poly.C 0)" | "split_by_degree 0 p = (poly.C 0, p)" | "split_by_degree (Suc n) (poly.CN c v p) = ( let (cl, cr) = split_by_degree (Suc n) c; (pl, pr) = split_by_degree n p in (poly.CN cl v pl, poly.CN cr v pr))" \ \This function is only intended for use on polynomials in normal form. Hence most cases never get executed.\ | "split_by_degree n p = (poly.C 0, p)" lemma split_by_degree_correct: fixes x :: "real list" and p :: "float poly" assumes "(l, r) = split_by_degree ord p" shows "maxdegree l \ ord" (is ?P1) and "Ipoly x p = Ipoly x l + Ipoly x r" (is ?P2) and "num_params l \ num_params p" (is ?P3) and "num_params r \ num_params p" (is ?P4) unfolding atomize_conj using assms proof(induction p arbitrary: l r ord) case (C c l r ord) thus ?case by simp next case (Bound v l r ord) thus ?case by (cases ord) simp_all next case (Add p1 p2 l r ord) thus ?case by (cases ord) simp_all next case (Sub p1 p2 l r ord) thus ?case by (cases ord) simp_all next case (Mul p1 p2 l r ord) thus ?case by (cases ord) simp_all next case (Neg p l r ord) thus ?case by (cases ord) simp_all next case (Pw p k l r ord) thus ?case by (cases ord) simp_all next case (CN c v p l r ord) then show ?case proof(cases ord) case (Suc m) obtain cl cr where cl_cr_def: "(cl, cr) = split_by_degree (Suc m) c" by (cases "split_by_degree (Suc m) c", simp) obtain pl pr where pl_pr_def: "(pl, pr) = split_by_degree m p" by (cases "split_by_degree m p", simp) have [simp]: "Ipoly x p = Ipoly x pl + Ipoly x pr" using CN(2)[OF pl_pr_def] by (cases ord) simp_all from CN(3) have l_decomp: "l = CN cl v pl" and r_decomp: "r = CN cr v pr" by (simp_all add: Suc cl_cr_def[symmetric] pl_pr_def[symmetric]) show ?thesis using CN(1)[OF cl_cr_def] CN(2)[OF pl_pr_def] unfolding l_decomp by (cases p) (auto simp add: l_decomp r_decomp algebra_simps Suc) qed simp qed text \Operations on lists.\ lemma length_map2[simp]: "length (map2 f a b) = min (length a) (length b)" proof(induction "map2 f a b" arbitrary: a b) case (Nil a b) hence "a = [] | b = []" by(cases a, simp, cases b, simp_all) then show ?case by auto next case (Cons x c a b) have "0 < length a \ 0 < length b" using Cons(2) by (cases a, simp, cases b, simp_all) then obtain xa ar xb br where a_decomp[simp]: "a = xa # ar" and b_decomp[simp]: "b = xb # br" by (cases a, simp_all, cases b, simp_all) show ?case using Cons by simp qed lemma map2_nth[simp]: assumes "n < length a" assumes "n < length b" shows "(map2 f a b)!n = f (a!n) (b!n)" using assms proof(induction n arbitrary: a b) case (0 a b) have "0 < length a" and "0 < length b" using 0 by simp_all thus ?case using 0 by simp next case (Suc n a b) from Suc.prems have "0 < length a" "0 < length b" "n < length (tl a)" "n < length (tl b)" using Suc.prems by auto have "map2 f a b = map2 f (hd a # tl a) (hd b # tl b)" using \0 < length a\ \0 < length b\ by simp also have "\ ! Suc n = map2 f (tl a) (tl b) ! n" by simp also have "\ = f (tl a ! n) (tl b ! n)" using \n < length (tl a)\ \n < length (tl b)\ by (rule Suc.IH) also have "tl a ! n = (hd a # tl a) ! Suc n" by simp also have "(hd a # tl a) = a" using \0 < length a\ by simp also have "tl b ! n = (hd b # tl b) ! Suc n" by simp also have "(hd b # tl b) = b" using \0 < length b\ by simp finally show ?case . qed text \Translating a polynomial by a vector.\ fun poly_translate :: "'a list \ 'a poly \ 'a poly" where "poly_translate vs (poly.C c) = poly.C c" | "poly_translate vs (poly.Bound n) = poly.Add (poly.Bound n) (poly.C (vs ! n))" | "poly_translate vs (poly.Add l r) = poly.Add (poly_translate vs l) (poly_translate vs r)" | "poly_translate vs (poly.Sub l r) = poly.Sub (poly_translate vs l) (poly_translate vs r)" | "poly_translate vs (poly.Mul l r) = poly.Mul (poly_translate vs l) (poly_translate vs r)" | "poly_translate vs (poly.Neg p) = poly.Neg (poly_translate vs p)" | "poly_translate vs (poly.Pw p n) = poly.Pw (poly_translate vs p) n" | "poly_translate vs (poly.CN c n p) = poly.Add (poly_translate vs c) (poly.Mul (poly.Add (poly.Bound n) (poly.C (vs ! n))) (poly_translate vs p))" text \Translating a polynomial is equivalent to translating its argument.\ lemma poly_translate_correct: assumes "num_params p \ length x" assumes "length x = length v" shows "Ipoly x (poly_translate v p) = Ipoly (map2 (+) x v) p" using assms by (induction p, simp_all) lemma real_poly_translate: assumes "num_params p \ length v" shows "Ipoly x (map_poly real_of_float (poly_translate v p)) = Ipoly x (poly_translate v (map_poly real_of_float p))" using assms by (induction p, simp_all) lemma num_params_poly_translate[simp]: shows "num_params (poly_translate v p) = num_params p" by (induction p, simp_all) 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,2092 +1,2086 @@ theory Taylor_Models - imports "Interval_Approximation" + 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 \TODO: get rid of float poly/float inteval and use real poly/real interval and data refinement?\ section \Multivariate Taylor Models\ subsection \Computing interval bounds on arithmetic expressions\ text \This is a wrapper around the "approx" function. It computes range bounds on floatarith expressions.\ fun compute_bound_fa :: "nat \ floatarith \ float interval list \ float interval option" - where "compute_bound_fa prec f I = - (case approx prec f (map (Some o (\x. (lower x, upper x))) I) of - Some (a, b) \ (if a \ b then Some (Ivl a b) else None) - | _ \ None)" + where "compute_bound_fa prec f I = approx prec f (map Some I)" lemma compute_bound_fa_correct: "interpret_floatarith f i \\<^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 \ (\x. (lower x, upper x))) I)" + 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 \ (\x. (lower x, upper x))) I) = Some (lower ivl, upper ivl)" + 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[symmetric]] + from approx[OF bounded Some] show ?thesis by (auto simp: set_of_eq) qed subsection \Definition of Taylor models and notion of rangeity\ text \Taylor models are a pair of a polynomial and an absolute error bound.\ datatype taylor_model = TaylorModel (tm_poly: "float poly") (tm_bound: "float interval") text \Taylor model for a real valuation of variables\ primrec insertion :: "(nat \ 'a) \ 'a poly \ '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 \ real) \ taylor_model \ 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 "\i. i < num_params p \ xs ! i = ys ! i" using that by (induction p; auto) lemma insertion_num_params_cong: "insertion e p = insertion f p" if "\i. i < num_params p \ e i = f i" using that by (induction p; auto) lemma insertion_eq_IpolyI: "insertion xs p = Ipoly ys p" if "\i. i < num_params p \ xs i = ys ! i" using that by (induction p; auto) lemma Ipoly_eq_insertionI: "Ipoly ys p = insertion xs p" if "\i. i < num_params p \ xs i = ys ! i" using that by (induction p; auto) lemma range_tmI: "x \\<^sub>i range_tm e tm" if x: "x \\<^sub>i interval_of (insertion e ((tm_poly tm))) + real_interval (tm_bound tm)" for e::"nat\real" by (auto simp: range_tm_def x) lemma range_tmD: "x \\<^sub>i interval_of (insertion e (tm_poly tm)) + real_interval (tm_bound tm)" if "x \\<^sub>i range_tm e tm" for e::"nat\real" using that by (auto simp: range_tm_def) subsection \Interval bounds for Taylor models\ text \Bound a polynomial by simply approximating it with interval arguments.\ fun compute_bound_poly :: "nat \ float interval poly \ (float interval list) \ (float interval list) \ 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 \Bounds on Taylor models are simply a bound on its polynomial, widened by the approximation error.\ fun compute_bound_tm :: "nat \ float interval list \ float interval list \ taylor_model \ 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 \\<^sub>r X" if "x \\<^sub>i X" using that by (auto simp: set_of_eq) lemma in_set_of_round_interval[intro, simp]: "x \\<^sub>r round_interval prec X" if "x \\<^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 \\<^sub>r X - Y" if "x \\<^sub>r X" "y \\<^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 transfer auto + by (simp add: interval_eqI) lemma real_interval_uminus: "real_interval (- b) = - real_interval b" - by transfer auto + by (simp add: interval_eqI) lemma real_interval_of: "real_interval (interval_of b) = interval_of b" - by transfer auto + 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 \\<^sub>r X + Y" if "x \\<^sub>r X" "y \\<^sub>r Y" using that by (auto simp: set_of_eq) lemma in_set_neg_plus_interval[intro, simp]: "- y \\<^sub>r - Y" if "y \\<^sub>r Y" using that by (auto simp: set_of_eq) -lemma real_interval_times: "real_interval (a * b) = real_interval a * real_interval b" - by transfer (auto simp: Let_def min_def max_def) - lemma in_set_real_times_interval[intro, simp]: "x * y \\<^sub>r X * Y" if "x \\<^sub>r X" "y \\<^sub>r Y" using that by (auto simp: real_interval_times intro!: times_in_intervalI) lemma real_interval_one: "real_interval 1 = 1" - by transfer simp + by (simp add: interval_eqI) lemma real_interval_zero: "real_interval 0 = 0" - by transfer simp + 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 \\<^sub>r X ^ n" if "x \\<^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 \\<^sub>r power_float_interval prec n X" if "x \\<^sub>r X" by (auto simp: real_interval_power that intro!: power_float_intervalI) lemma in_set_mult_float_interval[intro, simp]: "x * y \\<^sub>r mult_float_interval prec X Y" if "x \\<^sub>r X" "y \\<^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 \\<^sub>r I ! i - a ! i" if "x - e i \\<^sub>r a ! i" "x \\<^sub>r I ! i" using that by (auto simp: set_of_eq) definition develops_at_within::"(nat \ real) \ float interval list \ float interval list \ bool" where "develops_at_within e a I \ (a all_subset I) \ (\i < length I. e i \\<^sub>r I ! i - a ! i)" lemma develops_at_withinI: assumes all_in: "a all_subset I" assumes e: "\i. i < length I \ e i \\<^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" "\i. i < length I \ e i \\<^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 \ length I" assumes dev: "develops_at_within e a I" shows "insertion e (p::real poly) \\<^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 \ real" assumes n: "num_params (tm_poly t) \ length I" assumes dev: "develops_at_within e a I" assumes x0: "x0 \\<^sub>i range_tm e t" shows "x0 \\<^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 "\ \\<^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 \\<^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 \ real" assumes n: "num_params (tm_poly t) \ length I" assumes dev: "develops_at_within e a I" shows "set_of (range_tm e t) \ 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 \ length I" assumes mem: "I all_subset J" "a all_subset I" shows "set_of (compute_bound_poly prec p I a) \ 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 \ real" assumes "num_params (tm_poly t) \ length I" assumes "I all_subset J" assumes "a all_subset I" shows "set_of (compute_bound_tm prec I a t) \ 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 \Computing taylor models for basic, univariate functions\ definition tm_const :: "float \ taylor_model" where "tm_const c = TaylorModel (poly.C c) 0" context includes floatarith_notation begin definition tm_pi :: "nat \ 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 \\<^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 \\<^sub>i range_tm e (tm_pi prec)" proof- have "\prec. real_of_float (lb_pi prec) \ 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 \Derivations of floatarith expressions\ text \Compute the nth derivative of a floatarith expression\ fun deriv :: "nat \ floatarith \ nat \ 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 "((\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 \Faster derivation for univariate functions, producing smaller terms and thus less over-approximation.\ text \TODO: Extend to Arctan, Log!\ fun deriv_rec :: "floatarith \ nat \ floatarith" where "deriv_rec (Exp (Var 0)) _ = Exp (Var 0)" | "deriv_rec (Cos (Var 0)) n = (case n mod 4 of 0 \ Cos (Var 0) | Suc 0 \ Minus (Sin (Var 0)) | Suc (Suc 0) \ Minus (Cos (Var 0)) | Suc (Suc (Suc 0)) \ 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 "((\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: "(\xs. interpret_floatarith (Sin (Var 0)) xs) = (\xs. sin (xs!0))" by (simp add: ) show "((\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 \ 0" using assms by simp { fix n::nat and x::real assume "x \ 0" moreover have "(n mod 2 = 0 \ Suc n mod 2 = 1) \ (n mod 2 = 1 \ 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)