diff --git a/thys/ABY3_Protocols/Finite_Number_Type.thy b/thys/ABY3_Protocols/Finite_Number_Type.thy --- a/thys/ABY3_Protocols/Finite_Number_Type.thy +++ b/thys/ABY3_Protocols/Finite_Number_Type.thy @@ -1,102 +1,102 @@ theory Finite_Number_Type imports "HOL-Library.Cardinality" begin text \ To avoid carrying the modulo all the time, we introduce a new type for integers @{term "{0.. consts L :: nat specification (L) L_gt_1: "L > 1" by auto typedef natL = "{0.. natL" is "\x. (-x) mod int L" by simp lift_definition plus_natL :: "natL \ natL \ natL" is "\x y. (x + y) mod int L" by simp lift_definition minus_natL :: "natL \ natL \ natL" is "\x y. (x - y) mod int L" by simp lift_definition times_natL :: "natL \ natL \ natL" is "\x y. (x * y) mod int L" by simp instance by (standard; (transfer, simp add: algebra_simps mod_simps)) end typ int instantiation natL :: "{distrib_lattice, bounded_lattice, linorder}" begin lift_definition inf_natL :: "natL \ natL \ natL" is inf unfolding inf_int_def by auto lift_definition sup_natL :: "natL \ natL \ natL" is sup unfolding sup_int_def by auto lift_definition less_eq_natL :: "natL \ natL \ bool" is less_eq . lift_definition less_natL :: "natL \ natL \ bool" is less . lift_definition top_natL :: "natL" is "int L-1" using L_gt_1 by simp lift_definition bot_natL :: "natL" is 0 using L_gt_1 by simp instance by (standard; (transfer, simp add: inf_int_def sup_int_def))+ end instantiation natL :: semiring_modulo begin lift_definition divide_natL :: "natL \ natL \ natL" is divide apply (auto simp: div_int_pos_iff) - by (smt div_by_0 div_by_1 zdiv_mono2) + by (smt (verit) div_by_0 div_by_1 zdiv_mono2) lift_definition modulo_natL :: "natL \ natL \ natL" is modulo apply (auto simp: mod_int_pos_iff) - by (smt zmod_le_nonneg_dividend) + by (smt (verit) zmod_le_nonneg_dividend) instance by (standard; (transfer, simp add: mod_simps)) end instance natL :: finite apply standard unfolding type_definition.univ[OF type_definition_natL] by simp lemma natL_card[simp]: "CARD(natL) = L" unfolding type_definition.univ[OF type_definition_natL] apply (subst card_image) subgoal by (meson Abs_natL_inject inj_onI) subgoal by simp done end \ No newline at end of file diff --git a/thys/ABY3_Protocols/Shuffle.thy b/thys/ABY3_Protocols/Shuffle.thy --- a/thys/ABY3_Protocols/Shuffle.thy +++ b/thys/ABY3_Protocols/Shuffle.thy @@ -1,2343 +1,2343 @@ theory Shuffle imports CryptHOL.CryptHOL Additive_Sharing Spmf_Common Sharing_Lemmas begin text \ This is the formalization of the array shuffling protocol defined in \cite{laud2016secure} adapted for the ABY3 sharing scheme. For the moment, we assume an oracle that generates uniformly distributed permutations, instead of instantiating it with e.g. Fischer-Yates algorithm. \ no_notation (ASCII) comp (infixl "o" 55) no_notation m_inv ("inv\ _" [81] 80) no_adhoc_overloading Monad_Syntax.bind bind_pmf fun shuffleF :: "natL sharing list \ natL sharing list spmf" where "shuffleF xsl = spmf_of_set (permutations_of_multiset (mset xsl))" type_synonym zero_sharing = "natL sharing list" type_synonym party2_data = "natL list" type_synonym party01_permutation = "nat \ nat" type_synonym phase_msg = "zero_sharing \ party2_data \ party01_permutation" type_synonym role_msg = "(natL list \ natL list \ natL list) \ party2_data \ (party01_permutation \ party01_permutation)" (* (a, b, c) \ (a, b+c, 0) *) definition aby3_stack_sharing :: "Role \ natL sharing \ natL sharing" where "aby3_stack_sharing r s = make_sharing' r (next_role r) (prev_role r) (get_party r s) (get_party (next_role r) s + get_party (prev_role r) s) 0" (* one permutation step *) definition aby3_do_permute :: "Role \ natL sharing list \ (phase_msg \ natL sharing list) spmf" where "aby3_do_permute r x = (do { let n = length x; \ \ sequence_spmf (replicate n zero_sharing); \ \ spmf_of_set {\. \ permutes {.. y') \; let msg = (\, x2, \); return_spmf (msg, y) })" (* the shuffling protocol, consisting of three shuffling steps *) definition aby3_shuffleR :: "natL sharing list \ (role_msg sharing \ natL sharing list) spmf" where "aby3_shuffleR x = (do { ((\a,x',\a), a) \ aby3_do_permute Party1 x; \ \1st round\ ((\b,a',\b), b) \ aby3_do_permute Party2 a; \ \2nd round\ ((\c,b',\c), c) \ aby3_do_permute Party3 b; \ \3rd round\ let msg1 = ((map (get_party Party1) \a, map (get_party Party1) \b, map (get_party Party1) \c), b', \a, \c); let msg2 = ((map (get_party Party2) \a, map (get_party Party2) \b, map (get_party Party2) \c), x', \a, \b); let msg3 = ((map (get_party Party3) \a, map (get_party Party3) \b, map (get_party Party3) \c), a', \b, \c); let msg = make_sharing msg1 msg2 msg3; return_spmf (msg, c) })" (* the ideal functionality of shuffling *) definition aby3_shuffleF :: "natL sharing list \ natL sharing list spmf" where "aby3_shuffleF x = (do { \ \ spmf_of_set {\. \ permutes {.. = permute_list \ x1; y \ sequence_spmf (map share_nat x\); return_spmf y })" (* the simulator for party 1 *) definition S1 :: "natL list \ natL list \ role_msg spmf" where "S1 x1 yc1 = (do { let n = length x1; \a \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {.. sequence_spmf (replicate n (spmf_of_set UNIV)); yb1::natL list \ sequence_spmf (replicate n (spmf_of_set UNIV)); yb2::natL list \ sequence_spmf (replicate n (spmf_of_set UNIV)); \ \round 1\ let \a1 = map2 (-) ya1 (permute_list \a x1); \ \round 2\ let \b1 = yb1; \ \round 3\ let b' = yb2; let \c1 = map2 (-) (yc1) (permute_list \c (map2 (+) yb1 yb2)); \ \non-free message\ let msg1 = ((\a1, \b1, \c1), b', \a, \c); return_spmf msg1 })" (* the simulator for party 2 *) definition S2 :: "natL list \ natL list \ role_msg spmf" where "S2 x2 yc2 = (do { let n = length x2; x3 \ sequence_spmf (replicate n (spmf_of_set UNIV)); \a \ spmf_of_set {\. \ permutes {..b \ spmf_of_set {\. \ permutes {.. sequence_spmf (replicate n (spmf_of_set UNIV)); yb2::natL list \ sequence_spmf (replicate n (spmf_of_set UNIV)); \ \round 1\ let x' = x3; let \a2 = map2 (-) ya2 (permute_list \a (map2 (+) x2 x3)); \ \round 2\ let \b2 = map2 (-) yb2 (permute_list \b ya2); \ \round 3\ let \c2 = yc2; \ \non-free message\ let msg2 = ((\a2, \b2, \c2), x', \a, \b); return_spmf msg2 })" (* the simulator for party 3 *) definition S3 :: "natL list \ natL list \ role_msg spmf" where "S3 x3 yc3 = (do { let n = length x3; \b \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {.. sequence_spmf (replicate n (spmf_of_set UNIV)); ya1::natL list \ sequence_spmf (replicate n (spmf_of_set UNIV)); yb3::natL list \ sequence_spmf (replicate n (spmf_of_set UNIV)); \ \round 1\ let \a3 = ya3; \ \round 2\ let a' = ya1; let \b3 = map2 (-) yb3 (permute_list \b (map2 (+) ya3 ya1)); \ \round 3\ let \c3 = map2 (-) yc3 (permute_list \c yb3); \ \non-free message\ let msg3 = ((\a3, \b3, \c3), a', \b, \c); return_spmf msg3 })" definition S :: "Role \ natL list \ natL list \ role_msg spmf" where "S r = get_party r (make_sharing S1 S2 S3)" definition is_uniform_sharing_list :: "natL sharing list spmf \ bool" where "is_uniform_sharing_list xss \ (\xs. xss = bind_spmf xs (sequence_spmf \ map share_nat))" lemma case_prod_nesting_same: "case_prod (\a b. f (case_prod g x) a b ) x = case_prod (\a b. f (g a b) a b ) x" by (cases x) simp lemma zip_map_map_same: "map (\x. (f x, g x)) xs = zip (map f xs) (map g xs)" unfolding zip_map_map unfolding zip_same_conv_map by simp lemma dup_map_eq: "length xs = length ys \ (xs, map2 f ys xs) = (\xys. (map fst xys, map snd xys)) (map2 (\x y. (y, f x y)) ys xs)" by (auto simp: map_snd_zip[unfolded snd_def]) abbreviation "map2_spmf f xs ys \ map_spmf (case_prod f) (pair_spmf xs ys)" abbreviation "map3_spmf f xs ys zs \ map2_spmf (\a. case_prod (f a)) xs (pair_spmf ys zs)" lemma map_spmf_cong2: assumes "p = map_spmf m q" "\x. x\set_spmf q \ f (m x) = g x" shows "map_spmf f p = map_spmf g q" using assms by (simp add: spmf.map_comp cong: map_spmf_cong) lemma bind_spmf_cong2: assumes "p = map_spmf m q" "\x. x\set_spmf q \ f (m x) = g x" shows "bind_spmf p f = bind_spmf q g" using assms by (simp add: map_spmf_conv_bind_spmf cong: bind_spmf_cong) lemma map2_spmf_map2_sequence: "length xss = length yss \ map2_spmf (map2 f) (sequence_spmf xss) (sequence_spmf yss) = sequence_spmf (map2 (map2_spmf f) xss yss)" apply (induction xss yss rule: list_induct2) subgoal by simp subgoal premises IH for x xs y ys apply simp apply (fold IH) apply (unfold pair_map_spmf) apply (unfold spmf.map_comp) apply (rule map_spmf_cong2[where m="$$(x,y),(xs,ys)). ((x,xs),(y,ys))"]) subgoal unfolding pair_spmf_alt_def apply (simp add: map_spmf_conv_bind_spmf) apply (subst bind_commute_spmf[where q=y]) .. subgoal by auto done done abbreviation map3 :: "('a \ 'b \ 'c \ 'd) \ 'a list \ 'b list \ 'c list \ 'd list" where "map3 f a b c \ map2 (\a (b,c). f a b c) a (zip b c)" lemma map3_spmf_map3_sequence: "length xss = length yss \ length yss = length zss \ map3_spmf (map3 f) (sequence_spmf xss) (sequence_spmf yss) (sequence_spmf zss) = sequence_spmf (map3 (map3_spmf f) xss yss zss)" apply (induction xss yss zss rule: list_induct3) subgoal by simp subgoal premises IH for x xs y ys z zs apply simp apply (fold IH) apply (unfold pair_map_spmf) apply (unfold spmf.map_comp) apply (rule map_spmf_cong2[where m="\((x,y,z),(xs,ys,zs)). ((x,xs),(y,ys),(z,zs))"]) subgoal unfolding pair_spmf_alt_def apply (simp add: map_spmf_conv_bind_spmf) apply (subst bind_commute_spmf[where q=y]) apply (subst bind_commute_spmf[where q=z]) apply (subst bind_commute_spmf[where q=z]) .. subgoal by auto done done lemma in_pairD2: "x \ A \ B \ snd x \ B" by auto lemma list_map_cong2: "x = map m y \ (\z. z\set y =simp=> f (m z) = g z) \ map f x = map g y" unfolding simp_implies_def by simp lemma map_swap_zip: "map prod.swap (zip xs ys) = zip ys xs" apply (induction xs arbitrary: ys) subgoal by simp subgoal for x xs ys by (cases ys) auto done lemma inv_zero_sharing_sequence: "n = length x \ map_spmf (\\s. (\s, map2 (map_sharing2 (+)) x \s)) (sequence_spmf (replicate n zero_sharing)) = map_spmf (\ys. (map2 (map_sharing2 (-)) ys x, ys)) (sequence_spmf (map (share_nat \reconstruct) x))" proof - assume n: "n = length x" have "map_spmf (\\s. (\s, map2 (map_sharing2 (+)) x \s)) (sequence_spmf (replicate n zero_sharing)) = map2_spmf (\\s x. (\s, map2 (map_sharing2 (+)) x \s)) (sequence_spmf (replicate n zero_sharing)) (sequence_spmf (map return_spmf x))" unfolding sequence_map_return_spmf apply (rule map_spmf_cong2[where m="fst"]) subgoal by simp subgoal by (auto simp: case_prod_unfold dest: in_pairD2) done also have "... = map_spmf (\\xs. (map fst \xs, map snd \xs)) (map2_spmf (map2 (\\ x. (\, map_sharing2 (+) x$$)) (sequence_spmf (replicate n zero_sharing)) (sequence_spmf (map return_spmf x)))" apply (unfold spmf.map_comp) apply (rule map_spmf_cong[OF refl]) using n by (auto simp: case_prod_unfold comp_def set_sequence_spmf list_all2_iff map_swap_zip intro: list_map_cong2[where m=prod.swap]) also have "... = map_spmf (\\xs. (map fst \xs, map snd \xs)) (map2_spmf (map2 (\y x. (map_sharing2 (-) y x, y))) (sequence_spmf (map (share_nat \ reconstruct) x)) (sequence_spmf (map return_spmf x)))" apply (rule arg_cong[where f="map_spmf _"]) using n apply (simp add: map2_spmf_map2_sequence) apply (rule arg_cong[where f=sequence_spmf]) apply (unfold list_eq_iff_nth_eq) apply safe subgoal by simp apply (simp add: ) apply (subst map_spmf_cong2[where p="pair_spmf _ (return_spmf _)"]) apply (rule pair_spmf_return_spmf2) apply simp apply (subst map_spmf_cong2[where p="pair_spmf _ (return_spmf _)"]) apply (rule pair_spmf_return_spmf2) apply simp using inv_zero_sharing . also have "... = map2_spmf (\ys x. (map2 (map_sharing2 (-)) ys x, ys)) (sequence_spmf (map (share_nat \reconstruct) x)) (sequence_spmf (map return_spmf x))" apply (unfold spmf.map_comp) apply (rule map_spmf_cong[OF refl]) using n by (auto simp: case_prod_unfold comp_def set_sequence_spmf list_all2_iff map_swap_zip intro: list_map_cong2[where m=prod.swap]) also have "... = map_spmf (\ys. (map2 (map_sharing2 (-)) ys x, ys)) (sequence_spmf (map (share_nat \reconstruct) x))" unfolding sequence_map_return_spmf apply (rule map_spmf_cong2[where m="fst", symmetric]) subgoal by simp subgoal by (auto simp: case_prod_unfold dest: in_pairD2) done finally show ?thesis . qed lemma get_party_map_sharing2: "get_party p \ (case_prod (map_sharing2 f)) = case_prod f \ map_prod (get_party p) (get_party p)" by auto lemma map_map_prod_zip: "map (map_prod f g) (zip xs ys) = zip (map f xs) (map g ys)" by (simp add: map_prod_def zip_map_map) lemma map_map_prod_zip': "map (h \ map_prod f g) (zip xs ys) = map h (zip (map f xs) (map g ys))" by (simp add: map_prod_def zip_map_map) lemma eq_map_spmf_conv: assumes "\x. f (f' x) = x" "f' = inv f" "map_spmf f' x = y" shows "x = map_spmf f y" proof - have surj: "surj f" apply (rule surjI) using assms(1) . have "map_spmf f (map_spmf f' x) = map_spmf f y" unfolding assms(3) .. thus ?thesis using assms(1) by (simp add: spmf.map_comp surj_iff comp_def) qed lemma lift_map_spmf_pairs: "map2_spmf f = F \ map_spmf (case_prod f) (pair_spmf A B) = F A B" by auto lemma measure_pair_spmf_times': "C = A \ B \ measure (measure_spmf (pair_spmf p q)) C = measure (measure_spmf p) A * measure (measure_spmf q) B" by (simp add: measure_pair_spmf_times) lemma map_spmf_pairs_tmp: "map_spmf ($$a,b,c,d,e,f,g). (a,e,b,f,c,g,d)) (pair_spmf A (pair_spmf B (pair_spmf C (pair_spmf D (pair_spmf E (pair_spmf F G)))))) = (pair_spmf A (pair_spmf E (pair_spmf B (pair_spmf F (pair_spmf C (pair_spmf G D))))))" apply (rule spmf_eqI) apply (clarsimp simp add: spmf_map) subgoal for a e b f c g d apply (subst measure_pair_spmf_times'[where A="{a}"]) defer apply (subst measure_pair_spmf_times'[where A="{b}"]) defer apply (subst measure_pair_spmf_times'[where A="{c}"]) defer apply (subst measure_pair_spmf_times'[where A="{d}"]) defer apply (subst measure_pair_spmf_times'[where A="{e}"]) defer apply (subst measure_pair_spmf_times'[where A="{f}" and B="{g}"]) defer apply (auto simp: spmf_conv_measure_spmf) done done lemma case_case_prods_tmp: "(case case x of (a, b, c, d, e, f, g) \ (a, e, b, f, c, g, d) of (ya, yb, yc, yd, ye, yf, yg) \ F ya yb yc yd ye yf yg) = (case x of (a,b,c,d,e,f,g) \ F a e b f c g d)" by (cases x) simp lemma bind_spmf_permutes_cong: "(\\. \ permutes {..<(x::nat)} \ f \ = g$$ \ bind_spmf (spmf_of_set {\. \ permutes {... \ permutes {.. list_all2 (\x y. f x = g y) xs ys" apply (induction xs arbitrary: ys) subgoal by auto subgoal for x xs ys by (cases ys) (auto) done lemma bind_spmf_sequence_map_share_nat_cong: "(\l. map reconstruct l = x \ f l = g l) \ bind_spmf (sequence_spmf (map share_nat x)) f = bind_spmf (sequence_spmf (map share_nat x)) g" subgoal premises prems apply (rule bind_spmf_cong[OF refl]) apply (rule prems) unfolding set_sequence_spmf mem_Collect_eq apply (simp add: map_eq_iff_list_all2[where g=id, simplified]) apply (simp add: list_all2_map2) apply (erule list_all2_mono) unfolding share_nat_def by simp done lemma map_reconstruct_comp_eq_iff: "(\x. x\set xs \ reconstruct (f x) = reconstruct x) \ map (reconstruct \ f) xs = map reconstruct xs" by (induction xs) auto lemma permute_list_replicate: "p permutes {.. permute_list p (replicate n x) = replicate n x" apply (fold map_replicate_const[where lst="[0.. (\y::natL. y\set ys \ y = 0) \ map2 (-) xs ys = xs" by (induction xs ys rule: list_induct2) auto lemma permute_comp_left_inj: "p permutes {.. inj (\p'. p \ p')" by (rule fun.inj_map) (rule permutes_inj_on) lemma permute_comp_left_inj_on: "p permutes {.. inj_on (\p'. p \ p') A" using permute_comp_left_inj inj_on_subset by blast lemma permute_comp_right_inj: "p permutes {.. inj (\p'. p' \ p)" using inj_onI comp_id o_assoc permutes_surj surj_iff - by (smt) + by (smt (verit)) lemma permute_comp_right_inj_on: "p permutes {.. inj_on (\p'. p' \ p) A" using permute_comp_right_inj inj_on_subset by blast lemma permutes_inv_comp_left: "p permutes {.. inv (\p'. p \ p') = (\p'. inv p \ p')" by (rule inv_unique_comp; rule ext, simp add: permutes_inv_o comp_assoc[symmetric]) lemma permutes_inv_comp_right: "p permutes {.. inv (\p'. p' \ p) = (\p'. p' \ inv p)" by (rule inv_unique_comp; rule ext, simp add: permutes_inv_o comp_assoc) lemma permutes_inv_comp_left_right: "\a permutes {.. \b permutes {.. inv (\p'. \a \ p' \ \b) = (\p'. inv \a \ p' \ inv \b)" by (rule inv_unique_comp; rule ext, simp add: permutes_inv_o comp_assoc, simp add: permutes_inv_o comp_assoc[symmetric]) lemma permutes_inv_comp_left_left: "\a permutes {.. \b permutes {.. inv (\p'. \a \ \b \ p') = (\p'. inv \b \ inv \a \ p')" by (rule inv_unique_comp; rule ext, simp add: permutes_inv_o comp_assoc, simp add: permutes_inv_o comp_assoc[symmetric]) lemma permutes_inv_comp_right_right: "\a permutes {.. \b permutes {.. inv (\p'. p' \ \a \ \b) = (\p'. p' \ inv \b \ inv \a)" by (rule inv_unique_comp; rule ext, simp add: permutes_inv_o comp_assoc, simp add: permutes_inv_o comp_assoc[symmetric]) lemma image_compose_permutations_left_right: fixes S assumes "\a permutes S" "\b permutes S" shows "{\a \ \ \ \b |\. \ permutes S} = {\. \ permutes S}" proof - have *: "(\\. \a \ \ \ \b) = (\\'. \a \ \') \ (\\. \ \ \b)" by (simp add: comp_def) then show ?thesis apply (fold image_Collect) apply (unfold *) apply (fold image_comp) apply (subst image_Collect) apply (unfold image_compose_permutations_right[OF assms(2)]) apply (subst image_Collect) apply (unfold image_compose_permutations_left[OF assms(1)]) .. qed lemma image_compose_permutations_left_left: fixes S assumes "\a permutes S" "\b permutes S" shows "{\a \ \b \ \ |\. \ permutes S} = {\. \ permutes S}" using image_compose_permutations_left image_compose_permutations_right proof - have *: "(\\. \a \ \b \ \) = (\\'. \a \ \') \ (\\. \b \ \)" by (simp add: comp_def) show ?thesis apply (fold image_Collect) apply (unfold *) apply (fold image_comp) apply (subst image_Collect) apply (unfold image_compose_permutations_left[OF assms(2)]) apply (subst image_Collect) apply (unfold image_compose_permutations_left[OF assms(1)]) .. qed lemma image_compose_permutations_right_right: fixes S assumes "\a permutes S" "\b permutes S" shows "{\ \ \a \ \b |\. \ permutes S} = {\. \ permutes S}" using image_compose_permutations_left image_compose_permutations_right proof - have *: "(\\. \ \ \a \ \b) = (\\. \ \ \b) \ (\\'. \' \ \a)" by (simp add: comp_def) show ?thesis apply (fold image_Collect) apply (unfold *) apply (fold image_comp) apply (subst image_Collect) apply (unfold image_compose_permutations_right[OF assms(1)]) apply (subst image_Collect) apply (unfold image_compose_permutations_right[OF assms(2)]) .. qed lemma random_perm_middle: defines "random_perm n \ spmf_of_set {\. \ permutes {..(\a,\b,\c). ((\a,\b,\c),\a \ \b \ \c)) (pair_spmf (random_perm n) (pair_spmf (random_perm n) (random_perm n))) = map_spmf ($$\,\a,\c). ((\a,inv \a \ \ \ inv \c,\c),$$) (pair_spmf (random_perm n) (pair_spmf (random_perm n) (random_perm n)))" (is "?lhs = ?rhs") proof - have "?lhs = (do {\a \ random_perm n; \c \ random_perm n; (\b,p) \ map_spmf (\\b. (\b,\a \ \b \ \c)) (random_perm n); return_spmf ((\a, \b, \c), p)})" unfolding map_spmf_conv_bind_spmf pair_spmf_alt_def apply simp apply (subst (4) bind_commute_spmf) .. also have "\ = (do {\a \ random_perm n; \c \ random_perm n; map_spmf (\p. ((\a, inv \a \ p \ inv \c,\c),p)) (random_perm n)})" unfolding random_perm_def supply [intro!] = bind_spmf_permutes_cong apply rule+ apply (subst inv_uniform) subgoal for \a \c apply (rule inj_compose[unfolded comp_def, where f="\p. p \ \c"]) subgoal by (rule permute_comp_right_inj_on) subgoal by (rule permute_comp_left_inj_on) done apply (simp add: permutes_inv_comp_left_right map_spmf_conv_bind_spmf image_Collect image_compose_permutations_left_right) done also have "\ = ?rhs" unfolding map_spmf_conv_bind_spmf pair_spmf_alt_def apply (subst (2) bind_commute_spmf) apply (subst (1) bind_commute_spmf) apply simp done finally show ?thesis . qed lemma random_perm_right: defines "random_perm n \ spmf_of_set {\. \ permutes {..(\a,\b,\c). ((\a,\b,\c),\a \ \b \ \c)) (pair_spmf (random_perm n) (pair_spmf (random_perm n) (random_perm n))) = map_spmf ($$\,\a,\b). ((\a,\b,inv \b \ inv \a \$$,\)) (pair_spmf (random_perm n) (pair_spmf (random_perm n) (random_perm n)))" (is "?lhs = ?rhs") proof - have "?lhs = (do {\a \ random_perm n; \b \ random_perm n; (\c,\) \ map_spmf (\\c. (\c,\a \ \b \ \c)) (random_perm n); return_spmf ((\a, \b, \c), \)})" unfolding map_spmf_conv_bind_spmf pair_spmf_alt_def by simp also have "\ = (do {\a \ random_perm n; \b \ random_perm n; map_spmf (\\. ((\a, \b, inv \b \ inv \a \ \),\)) (random_perm n)})" unfolding random_perm_def supply [intro!] = bind_spmf_permutes_cong apply rule+ apply (subst inv_uniform) subgoal apply (rule permute_comp_left_inj_on) using permutes_compose . apply (simp add: permutes_inv_comp_left_left map_spmf_conv_bind_spmf image_Collect image_compose_permutations_left_left) done also have "\ = ?rhs" unfolding map_spmf_conv_bind_spmf pair_spmf_alt_def apply (subst (2) bind_commute_spmf) apply (subst (1) bind_commute_spmf) apply simp done finally show ?thesis . qed lemma random_perm_left: defines "random_perm n \ spmf_of_set {\. \ permutes {..(\a,\b,\c). ((\a,\b,\c),\a \ \b \ \c)) (pair_spmf (random_perm n) (pair_spmf (random_perm n) (random_perm n))) = map_spmf ($$\,\b,\c). ((\ \ inv \c \ inv \b,\b,\c),$$) (pair_spmf (random_perm n) (pair_spmf (random_perm n) (random_perm n)))" (is "?lhs = ?rhs") proof - have "?lhs = (do {\b \ random_perm n; \c \ random_perm n; (\a,\) \ map_spmf (\\a. (\a,\a \ \b \ \c)) (random_perm n); return_spmf ((\a, \b, \c), \)})" unfolding map_spmf_conv_bind_spmf pair_spmf_alt_def apply simp apply (subst (4) bind_commute_spmf) apply (subst (3) bind_commute_spmf) .. also have "\ = (do {\b \ random_perm n; \c \ random_perm n; map_spmf (\\. ((\ \ inv \c \ inv \b, \b, \c),\)) (random_perm n)})" unfolding random_perm_def supply [intro!] = bind_spmf_permutes_cong apply rule+ apply (subst inv_uniform) subgoal apply (unfold comp_assoc) apply (rule permute_comp_right_inj_on) using permutes_compose . apply (simp add: permutes_inv_comp_right_right map_spmf_conv_bind_spmf image_Collect image_compose_permutations_right_right) done also have "\ = ?rhs" unfolding map_spmf_conv_bind_spmf pair_spmf_alt_def apply (subst (2) bind_commute_spmf) apply (subst (1) bind_commute_spmf) apply simp done finally show ?thesis . qed lemma case_prod_return_spmf: "case_prod (\a b. return_spmf (f a b)) = (\x. return_spmf (case_prod f x))" by auto lemma sequence_share_nat_calc': assumes "r1\r2" "r2\r3" "r3\r1" shows "sequence_spmf (map share_nat xs) = (do { let n = length xs; let random_seq = sequence_spmf (replicate n (spmf_of_set UNIV)); (dp, dpn) \ (pair_spmf random_seq random_seq); return_spmf (map3 (\x a b. make_sharing' r1 r2 r3 a b (x - (a + b))) xs dp dpn) })" (is "_ = ?rhs") proof - have "sequence_spmf (map share_nat xs) = (do { let n = length xs; let random_seq = sequence_spmf (replicate n (spmf_of_set UNIV)); (xs, dp, dpn) \ pair_spmf (sequence_spmf (map return_spmf xs)) (pair_spmf random_seq random_seq); return_spmf (map3 (\x a b. make_sharing' r1 r2 r3 a b (x - (a + b))) xs dp dpn) })" apply (unfold Let_def) apply (unfold case_prod_return_spmf) apply (fold map_spmf_conv_bind_spmf) apply (subst map3_spmf_map3_sequence) subgoal by simp subgoal by simp apply (rule arg_cong[where f=sequence_spmf]) apply (unfold map_eq_iff_list_all2) apply (rule list_all2_all_nthI) subgoal by simp unfolding share_nat_def_calc'[OF assms] apply (auto simp: map_spmf_conv_bind_spmf pair_spmf_alt_def) done also have "\ = ?rhs" by (auto simp: pair_spmf_alt_def sequence_map_return_spmf) finally show ?thesis . qed lemma reconstruct_stack_sharing_eq_reconstruct: "reconstruct \ aby3_stack_sharing r = reconstruct" unfolding aby3_stack_sharing_def reconstruct_def by (cases r) (auto simp: make_sharing'_sel) lemma map2_ignore1: "length xs = length ys \ map2 (\_. f) xs ys = map f ys" apply (unfold map_eq_iff_list_all2) apply (rule list_all2_all_nthI) by auto lemma map2_ignore2: "length xs = length ys \ map2 (\a b. f a) xs ys = map f xs" apply (unfold map_eq_iff_list_all2) apply (rule list_all2_all_nthI) by auto lemma map_sequence_share_nat_reconstruct: "map_spmf (\x. (x, map reconstruct x)) (sequence_spmf (map share_nat y)) = map_spmf (\x. (x, y)) (sequence_spmf (map share_nat y))" apply (unfold map_spmf_conv_bind_spmf) apply (rule bind_spmf_cong[OF refl]) apply (auto simp: set_sequence_spmf list_eq_iff_nth_eq list_all2_conv_all_nth share_nat_def) done (* the main theorem of security of the shuffling protocol *) theorem shuffle_secrecy: assumes "is_uniform_sharing_list x_dist" shows "(do { x \ x_dist; (msg, y) \ aby3_shuffleR x; return_spmf (map (get_party r) x, get_party r msg, y) }) = (do { x \ x_dist; y \ aby3_shuffleF x; let xr = map (get_party r) x; let yr = map (get_party r) y; msg \ S r xr yr; return_spmf (xr, msg, y) })" (is "?lhs = ?rhs") proof - obtain xs where xs: "x_dist = xs \ (sequence_spmf \ map share_nat)" using assms unfolding is_uniform_sharing_list_def by auto have left_unfolded: "(do { x \ x_dist; (msg, y) \ aby3_shuffleR x; return_spmf (map (get_party r) x, get_party r msg, y)}) = (do { xs \ xs; x \ sequence_spmf (map share_nat xs); \ \round 1\ let n = length x; \a \ sequence_spmf (replicate n zero_sharing); \a \ spmf_of_set {\. \ permutes {..a y') \a; \ \round 2\ let n = length a; \b \ sequence_spmf (replicate n zero_sharing); \b \ spmf_of_set {\. \ permutes {..b y') \b; \ \round 3\ let n = length b; \c \ sequence_spmf (replicate n zero_sharing); \c \ spmf_of_set {\. \ permutes {..c y') \c; let msg1 = ((map (get_party Party1) \a, map (get_party Party1) \b, map (get_party Party1) \c), b', \a, \c); let msg2 = ((map (get_party Party2) \a, map (get_party Party2) \b, map (get_party Party2) \c), x', \a, \b); let msg3 = ((map (get_party Party3) \a, map (get_party Party3) \b, map (get_party Party3) \c), a', \b, \c); let msg = make_sharing msg1 msg2 msg3; return_spmf (map (get_party r) x, get_party r msg, c) })" unfolding xs aby3_shuffleR_def aby3_do_permute_def by (auto simp: case_prod_unfold Let_def) also have clarify_length: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); \ \round 1\ \a \ sequence_spmf (replicate n zero_sharing); \a \ spmf_of_set {\. \ permutes {..a y') \a; \ \round 2\ \b \ sequence_spmf (replicate n zero_sharing); \b \ spmf_of_set {\. \ permutes {..b y') \b; \ \round 3\ \c \ sequence_spmf (replicate n zero_sharing); \c \ spmf_of_set {\. \ permutes {..c y') \c; let msg1 = ((map (get_party Party1) \a, map (get_party Party1) \b, map (get_party Party1) \c), b', \a, \c); let msg2 = ((map (get_party Party2) \a, map (get_party Party2) \b, map (get_party Party2) \c), x', \a, \b); let msg3 = ((map (get_party Party3) \a, map (get_party Party3) \b, map (get_party Party3) \c), a', \b, \c); let msg = make_sharing msg1 msg2 msg3; return_spmf (map (get_party r) x, get_party r msg, c) })" supply [intro!] = bind_spmf_cong[OF refl] let_cong[OF refl] bind_spmf_sequence_map_cong bind_spmf_sequence_replicate_cong bind_spmf_permutes_cong by (auto simp: Let_def) also have hoist_permutations: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); \a \ spmf_of_set {\. \ permutes {..b \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {.. \round 1\ let x' = map (get_party (prev_role Party1)) x; let y' = map (aby3_stack_sharing Party1) x; \a \ sequence_spmf (replicate n zero_sharing); let a = map2 (map_sharing2 (+)) (permute_list \a y') \a; \ \round 2\ let a' = map (get_party (prev_role Party2)) a; let y' = map (aby3_stack_sharing Party2) a; \b \ sequence_spmf (replicate n zero_sharing); let b = map2 (map_sharing2 (+)) (permute_list \b y') \b; \ \round 3\ let b' = map (get_party (prev_role Party3)) b; let y' = map (aby3_stack_sharing Party3) b; \c \ sequence_spmf (replicate n zero_sharing); let c = map2 (map_sharing2 (+)) (permute_list \c y') \c; let msg1 = ((map (get_party Party1) \a, map (get_party Party1) \b, map (get_party Party1) \c), b', \a, \c); let msg2 = ((map (get_party Party2) \a, map (get_party Party2) \b, map (get_party Party2) \c), x', \a, \b); let msg3 = ((map (get_party Party3) \a, map (get_party Party3) \b, map (get_party Party3) \c), a', \b, \c); let msg = make_sharing msg1 msg2 msg3; return_spmf (map (get_party r) x, get_party r msg, c) })" apply (simp add: Let_def) apply (subst (1) bind_commute_spmf[where q="spmf_of_set _"]) apply (subst (2) bind_commute_spmf[where q="spmf_of_set _"]) apply (subst (2) bind_commute_spmf[where q="spmf_of_set _"]) apply (subst (3) bind_commute_spmf[where q="spmf_of_set _"]) apply (subst (3) bind_commute_spmf[where q="spmf_of_set _"]) apply (subst (3) bind_commute_spmf[where q="spmf_of_set _"]) by simp also have hoist_permutations: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); \a \ spmf_of_set {\. \ permutes {..b \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {.. \round 1\ let x' = map (get_party (prev_role Party1)) x; let y' = map (aby3_stack_sharing Party1) x; a \ sequence_spmf (map (share_nat \ reconstruct) (permute_list \a y')); let \a = map2 (map_sharing2 (-)) a (permute_list \a y'); \ \round 2\ let a' = map (get_party (prev_role Party2)) a; let y' = map (aby3_stack_sharing Party2) a; b \ sequence_spmf (map (share_nat \ reconstruct) (permute_list \b y')); let \b = map2 (map_sharing2 (-)) b (permute_list \b y'); \ \round 3\ let b' = map (get_party (prev_role Party3)) b; let y' = map (aby3_stack_sharing Party3) b; c \ sequence_spmf (map (share_nat \ reconstruct) (permute_list \c y')); let \c = map2 (map_sharing2 (-)) c (permute_list \c y'); let msg1 = ((map (get_party Party1) \a, map (get_party Party1) \b, map (get_party Party1) \c), b', \a, \c); let msg2 = ((map (get_party Party2) \a, map (get_party Party2) \b, map (get_party Party2) \c), x', \a, \b); let msg3 = ((map (get_party Party3) \a, map (get_party Party3) \b, map (get_party Party3) \c), a', \b, \c); let msg = make_sharing msg1 msg2 msg3; return_spmf (map (get_party r) x, get_party r msg, c) })" supply [intro!] = bind_spmf_cong[OF refl] let_cong[OF refl] prod.case_cong[OF refl] bind_spmf_sequence_map_cong bind_spmf_sequence_replicate_cong bind_spmf_permutes_cong apply rule+ apply (subst hoist_map_spmf[where s="sequence_spmf (replicate _ _)" and f = "map2 (map_sharing2 (+)) _"]) apply (subst hoist_map_spmf'[where s="sequence_spmf (map _ _)" and f = "\ys. map2 (map_sharing2 (-)) ys _"]) apply (subst inv_zero_sharing_sequence) subgoal by simp apply (unfold map_spmf_conv_bind_spmf) apply (unfold bind_spmf_assoc) apply (unfold return_bind_spmf) apply rule+ apply (subst (1 12) Let_def) apply rule+ apply (subst hoist_map_spmf[where s="sequence_spmf (replicate _ _)" and f = "map2 (map_sharing2 (+)) _"]) apply (subst hoist_map_spmf'[where s="sequence_spmf (map _ _)" and f = "\ys. map2 (map_sharing2 (-)) ys _"]) apply (subst inv_zero_sharing_sequence) subgoal by simp apply (unfold map_spmf_conv_bind_spmf) apply (unfold bind_spmf_assoc) apply (unfold return_bind_spmf) apply rule+ apply (subst (1 9) Let_def) apply rule+ apply (subst hoist_map_spmf[where s="sequence_spmf (replicate _ _)" and f = "map2 (map_sharing2 (+)) _"]) apply (subst hoist_map_spmf'[where s="sequence_spmf (map _ _)" and f = "\ys. map2 (map_sharing2 (-)) ys _"]) apply (subst inv_zero_sharing_sequence) subgoal by simp apply (unfold map_spmf_conv_bind_spmf) apply (unfold bind_spmf_assoc) apply (unfold return_bind_spmf) apply rule+ apply (subst (1 6) Let_def) apply rule+ done also have reconstruct: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); \a \ spmf_of_set {\. \ permutes {..b \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {.. \round 1\ let x' = map (get_party (prev_role Party1)) x; let y' = map (aby3_stack_sharing Party1) x; a \ sequence_spmf (map share_nat (permute_list \a xs)); let \a = map2 (map_sharing2 (-)) a (permute_list \a y'); \ \round 2\ let a' = map (get_party (prev_role Party2)) a; let y' = map (aby3_stack_sharing Party2) a; b \ sequence_spmf (map share_nat (permute_list (\a \ \b) xs)); let \b = map2 (map_sharing2 (-)) b (permute_list \b y'); \ \round 3\ let b' = map (get_party (prev_role Party3)) b; let y' = map (aby3_stack_sharing Party3) b; c \ sequence_spmf (map share_nat (permute_list (\a \ \b \ \c) xs)); let \c = map2 (map_sharing2 (-)) c (permute_list \c y'); let msg1 = ((map (get_party Party1) \a, map (get_party Party1) \b, map (get_party Party1) \c), b', \a, \c); let msg2 = ((map (get_party Party2) \a, map (get_party Party2) \b, map (get_party Party2) \c), x', \a, \b); let msg3 = ((map (get_party Party3) \a, map (get_party Party3) \b, map (get_party Party3) \c), a', \b, \c); let msg = make_sharing msg1 msg2 msg3; return_spmf (map (get_party r) x, get_party r msg, c) })" supply [intro!] = bind_spmf_cong[OF refl] let_cong[OF refl] prod.case_cong[OF refl] bind_spmf_sequence_map_cong bind_spmf_sequence_replicate_cong bind_spmf_permutes_cong bind_spmf_sequence_map_share_nat_cong apply rule+ apply (subst list.map_comp[symmetric]) apply (rule bind_spmf_cong) subgoal by (auto simp:permute_list_map[symmetric] map_reconstruct_comp_eq_iff reconstruct_def set_sequence_spmf[unfolded list_all2_iff] make_sharing'_sel reconstruct_stack_sharing_eq_reconstruct comp_assoc) apply rule+ apply (subst list.map_comp[symmetric]) apply (rule bind_spmf_cong) subgoal for x l xa \a \b \c xb xc xd xe xf xg apply (subst permute_list_map[symmetric] ) subgoal by (auto simp add: set_sequence_spmf[unfolded list_all2_iff]) apply simp apply (subst map_reconstruct_comp_eq_iff) subgoal by (simp add: reconstruct_def make_sharing'_sel aby3_stack_sharing_def) unfolding set_sequence_spmf mem_Collect_eq unfolding list_all2_map2 apply (subst map_eq_iff_list_all2[where f=reconstruct and g=id and xs=xd and ys="permute_list \a x", simplified, THEN iffD2]) subgoal by (erule list_all2_mono) (simp add: share_nat_def) apply (subst permute_list_compose) subgoal by auto .. apply rule+ apply (subst list.map_comp[symmetric]) apply (rule bind_spmf_cong) subgoal for x l xa \a \b \c xb xc xd xe xf xg xh xi xj xk apply (subst permute_list_map[symmetric] ) subgoal by (auto simp add: set_sequence_spmf[unfolded list_all2_iff]) apply simp apply (subst map_reconstruct_comp_eq_iff) subgoal by (simp add: reconstruct_def make_sharing'_sel aby3_stack_sharing_def) unfolding set_sequence_spmf mem_Collect_eq unfolding list_all2_map2 apply (subst map_eq_iff_list_all2[where f=reconstruct and g=id and xs=xh and ys="permute_list (\a \ \b) x", simplified, THEN iffD2]) subgoal by (erule list_all2_mono) (simp add: share_nat_def) apply (subst permute_list_compose[symmetric]) subgoal by auto .. .. also have hoist: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); \a \ spmf_of_set {\. \ permutes {..b \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {.. sequence_spmf (map share_nat (permute_list \a xs)); b \ sequence_spmf (map share_nat (permute_list (\a \ \b) xs)); c \ sequence_spmf (map share_nat (permute_list (\a \ \b \ \c) xs)); \ \round 1\ let x' = map (get_party (prev_role Party1)) x; let y' = map (aby3_stack_sharing Party1) x; let \a = map2 (map_sharing2 (-)) a (permute_list \a y'); \ \round 2\ let a' = map (get_party (prev_role Party2)) a; let y' = map (aby3_stack_sharing Party2) a; let \b = map2 (map_sharing2 (-)) b (permute_list \b y'); \ \round 3\ let b' = map (get_party (prev_role Party3)) b; let y' = map (aby3_stack_sharing Party3) b; let \c = map2 (map_sharing2 (-)) c (permute_list \c y'); let msg1 = ((map (get_party Party1) \a, map (get_party Party1) \b, map (get_party Party1) \c), b', \a, \c); let msg2 = ((map (get_party Party2) \a, map (get_party Party2) \b, map (get_party Party2) \c), x', \a, \b); let msg3 = ((map (get_party Party3) \a, map (get_party Party3) \b, map (get_party Party3) \c), a', \b, \c); let msg = make_sharing msg1 msg2 msg3; return_spmf (map (get_party r) x, get_party r msg, c) })" unfolding Let_def .. finally have hoisted_save: "?lhs = \" . let ?hoisted = \ { assume r: "r = Party1" have project_to_Party1: "?hoisted = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); \a \ spmf_of_set {\. \ permutes {..b \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {.. sequence_spmf (map share_nat (permute_list \a xs)); b \ sequence_spmf (map share_nat (permute_list (\a \ \b) xs)); c \ sequence_spmf (map share_nat (permute_list (\a \ \b \ \c) xs)); \ \round 1\ let x' = map (get_party Party3) x; let y' = map (aby3_stack_sharing Party1) x; let \a1 = map (case_prod (-)) (zip (map (get_party Party1) a) (map (get_party Party1) (permute_list \a y'))); \ \round 2\ let a' = map (get_party Party1) a; let y' = map (aby3_stack_sharing Party2) a; let \b1 = map (case_prod (-)) (zip (map (get_party Party1) b) (map (get_party Party1) (permute_list \b y'))); \ \round 3\ let b' = map (get_party Party2) b; let y' = map (aby3_stack_sharing Party3) b; let \c1 = map (case_prod (-)) (zip (map (get_party Party1) c) (map (get_party Party1) (permute_list \c y'))); let msg1 = ((\a1, \b1, \c1), b', \a, \c); return_spmf (map (get_party Party1) x, msg1, c) })" by (simp add: r Let_def get_party_map_sharing2 map_map_prod_zip') also have project_to_Party1: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); \a \ spmf_of_set {\. \ permutes {..b \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {.. sequence_spmf (map share_nat (permute_list \a xs)); b \ sequence_spmf (map share_nat (permute_list (\a \ \b) xs)); c \ sequence_spmf (map share_nat (permute_list (\a \ \b \ \c) xs)); \ \round 1\ let x' = map (get_party Party3) x; let y' = map (aby3_stack_sharing Party1) x; let \a1 = map2 (-) (map (get_party Party1) a) (permute_list \a (map (get_party Party1) y')); \ \round 2\ let a' = map (get_party Party1) a; let y' = map (aby3_stack_sharing Party2) a; let \b1 = map2 (-) (map (get_party Party1) b) (permute_list \b (map (get_party Party1) y')); \ \round 3\ let b' = map (get_party Party2) b; let y' = map (aby3_stack_sharing Party3) b; let \c1 = map2 (-) (map (get_party Party1) c) (permute_list \c (map (get_party Party1) y')); let msg1 = ((\a1, \b1, \c1), b', \a, \c); return_spmf (map (get_party Party1) x, msg1, c) })" supply [intro!] = bind_spmf_cong[OF refl] let_cong[OF refl] prod.case_cong[OF refl] bind_spmf_sequence_map_cong bind_spmf_sequence_replicate_cong bind_spmf_permutes_cong apply rule+ apply (subst permute_list_map[symmetric]) subgoal by simp apply rule+ apply (subst permute_list_map[symmetric]) subgoal by simp apply rule+ apply (subst permute_list_map[symmetric]) subgoal by simp .. also have reduce_Lets: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); \a \ spmf_of_set {\. \ permutes {..b \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {.. sequence_spmf (map share_nat (permute_list \a xs)); b \ sequence_spmf (map share_nat (permute_list (\a \ \b) xs)); c \ sequence_spmf (map share_nat (permute_list (\a \ \b \ \c) xs)); \ \round 1\ let \a1 = map2 (-) (map (get_party Party1) a) (permute_list \a (map (get_party Party1) x)); \ \round 2\ let \b1 = map2 (-) (map (get_party Party1) b) (permute_list \b (replicate (length a) 0)); \ \round 3\ let b' = map (get_party Party2) b; let \c1 = map2 (-) (map (get_party Party1) c) (permute_list \c (map2 (+) (map (get_party Party1) b) (map (get_party Party2) b))); let msg1 = ((\a1, \b1, \c1), b', \a, \c); return_spmf (map (get_party Party1) x, msg1, c) })" unfolding Let_def unfolding aby3_stack_sharing_def by (simp add: comp_def make_sharing'_sel map_replicate_const zip_map_map_same[symmetric]) also have simplify_minus_zero: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); \a \ spmf_of_set {\. \ permutes {..b \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {.. sequence_spmf (map share_nat (permute_list \a xs)); b \ sequence_spmf (map share_nat (permute_list (\a \ \b) xs)); c \ sequence_spmf (map share_nat (permute_list (\a \ \b \ \c) xs)); \ \round 1\ let \a1 = map2 (-) (map (get_party Party1) a) (permute_list \a (map (get_party Party1) x)); \ \round 2\ let \b1 = (map (get_party Party1) b); \ \round 3\ let b' = map (get_party Party2) b; let \c1 = map2 (-) (map (get_party Party1) c) (permute_list \c (map2 (+) (map (get_party Party1) b) (map (get_party Party2) b))); let msg1 = ((\a1, \b1, \c1), b', \a, \c); return_spmf (map (get_party Party1) x, msg1, c) })" supply [intro!] = bind_spmf_cong[OF refl] let_cong[OF refl] prod.case_cong[OF refl] bind_spmf_sequence_map_cong bind_spmf_sequence_replicate_cong bind_spmf_permutes_cong apply rule+ apply (subst permute_list_replicate) subgoal by simp apply (subst map2_minus_zero) subgoal by simp subgoal by simp .. also have break_perms_1: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); (\a,\b,\c) \ pair_spmf (spmf_of_set {\. \ permutes {... \ permutes {... \ permutes {.. sequence_spmf (map share_nat (permute_list \a xs)); b \ sequence_spmf (map share_nat (permute_list (\a \ \b) xs)); c \ sequence_spmf (map share_nat (permute_list (\a \ \b \ \c) xs)); \ \round 1\ let \a1 = map2 (-) (map (get_party Party1) a) (permute_list \a (map (get_party Party1) x)); \ \round 2\ let \b1 = (map (get_party Party1) b); \ \round 3\ let b' = map (get_party Party2) b; let \c1 = map2 (-) (map (get_party Party1) c) (permute_list \c (map2 (+) (map (get_party Party1) b) (map (get_party Party2) b))); let msg1 = ((\a1, \b1, \c1), b', \a, \c); return_spmf (map (get_party Party1) x, msg1, c) })" unfolding pair_spmf_alt_def by simp also have break_perms_2: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); ((\a,\b,\c),\) \ map_spmf ($$\a,\b,\c). ((\a,\b,\c), \a \ \b \ \c)) (pair_spmf (spmf_of_set {\. \ permutes {... \ permutes {... \ permutes {.. sequence_spmf (map share_nat (permute_list \a xs)); b \ sequence_spmf (map share_nat (permute_list (\a \ \b) xs)); c \ sequence_spmf (map share_nat (permute_list \ xs)); \ \round 1\ let \a1 = map2 (-) (map (get_party Party1) a) (permute_list \a (map (get_party Party1) x)); \ \round 2\ let \b1 = (map (get_party Party1) b); \ \round 3\ let b' = map (get_party Party2) b; let \c1 = map2 (-) (map (get_party Party1) c) (permute_list \c (map2 (+) (map (get_party Party1) b) (map (get_party Party2) b))); let msg1 = ((\a1, \b1, \c1), b', \a, \c); return_spmf (map (get_party Party1) x, msg1, c) })" unfolding pair_spmf_alt_def map_spmf_conv_bind_spmf by simp also have break_perms_3: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); \ \ spmf_of_set {\. \ permutes {..a \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {..b = inv \a \ \ \ inv \c; a \ sequence_spmf (map share_nat (permute_list \a xs)); b \ sequence_spmf (map share_nat (permute_list (\a \ \b) xs)); c \ sequence_spmf (map share_nat (permute_list \ xs)); \ \round 1\ let \a1 = map2 (-) (map (get_party Party1) a) (permute_list \a (map (get_party Party1) x)); \ \round 2\ let \b1 = (map (get_party Party1) b); \ \round 3\ let b' = map (get_party Party2) b; let \c1 = map2 (-) (map (get_party Party1) c) (permute_list \c (map2 (+) (map (get_party Party1) b) (map (get_party Party2) b))); let msg1 = ((\a1, \b1, \c1), b', \a, \c); return_spmf (map (get_party Party1) x, msg1, c) })" apply (unfold random_perm_middle) apply (unfold map_spmf_conv_bind_spmf pair_spmf_alt_def) by simp also have break_seqs_3: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); \ \ spmf_of_set {\. \ permutes {..a \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {..b = inv \a \ \ \ inv \c; a1 \ sequence_spmf (replicate n (spmf_of_set UNIV)); a2 \ sequence_spmf (replicate n (spmf_of_set UNIV)); let a = map3 (\a b c. make_sharing b c (a - (b + c))) (permute_list \a xs) a1 a2; b1 \ sequence_spmf (replicate n (spmf_of_set UNIV)); b2 \ sequence_spmf (replicate n (spmf_of_set UNIV)); let b = map3 (\a b c. make_sharing b c (a - (b + c))) (permute_list (\a \ \b) xs) b1 b2; c \ sequence_spmf (map share_nat (permute_list \ xs)); \ \round 1\ let \a1 = map2 (-) (map (get_party Party1) a) (permute_list \a (map (get_party Party1) x)); \ \round 2\ let \b1 = (map (get_party Party1) b); \ \round 3\ let b' = map (get_party Party2) b; let \c1 = map2 (-) (map (get_party Party1) c) (permute_list \c (map2 (+) (map (get_party Party1) b) (map (get_party Party2) b))); let msg1 = ((\a1, \b1, \c1), b', \a, \c); return_spmf (map (get_party Party1) x, msg1, c) })" apply (unfold sequence_share_nat_calc'[of Party1 Party2 Party3, simplified]) apply (simp add: pair_spmf_alt_def Let_def) done also have break_seqs_3: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); \ \ spmf_of_set {\. \ permutes {..a \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {.. sequence_spmf (replicate n (spmf_of_set UNIV)); a2::natL list \ sequence_spmf (replicate n (spmf_of_set UNIV)); b1::natL list \ sequence_spmf (replicate n (spmf_of_set UNIV)); b2::natL list \ sequence_spmf (replicate n (spmf_of_set UNIV)); c \ sequence_spmf (map share_nat (permute_list \ xs)); \ \round 1\ let \a1 = map2 (-) a1 (permute_list \a (map (get_party Party1) x)); \ \round 2\ let \b1 = b1; \ \round 3\ let b' = b2; let \c1 = map2 (-) (map (get_party Party1) c) (permute_list \c (map2 (+) b1 b2)); let msg1 = ((\a1, \b1, \c1), b', \a, \c); return_spmf (map (get_party Party1) x, msg1, c) })" supply [intro!] = bind_spmf_cong[OF refl] let_cong[OF refl] prod.case_cong[OF refl] bind_spmf_sequence_map_cong bind_spmf_sequence_replicate_cong bind_spmf_permutes_cong unfolding Let_def apply rule+ apply (auto simp: map2_ignore1 map2_ignore2 comp_def prod.case_distrib bind_spmf_const) done also have "\ = (do {x \ x_dist; y \ aby3_shuffleF x; let xr = map (get_party r) x; let yr = map (get_party r) y; msg \ S r xr yr; return_spmf (xr, msg, y)})" unfolding xs unfolding aby3_shuffleF_def apply (simp add: bind_spmf_const map_spmf_conv_bind_spmf) apply (subst lossless_sequence_spmf[unfolded lossless_spmf_def]) subgoal by simp apply simp apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"]) apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"]) apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"]) apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"]) apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"]) apply (subst (3) hoist_map_spmf[where s="sequence_spmf (map share_nat _)" and f="map reconstruct"]) apply (subst map_sequence_share_nat_reconstruct) apply (simp add: map_spmf_conv_bind_spmf) apply (subst Let_def) supply [intro!] = bind_spmf_cong[OF refl] let_cong[OF refl] prod.case_cong[OF refl] bind_spmf_sequence_map_cong bind_spmf_sequence_replicate_cong bind_spmf_permutes_cong supply [simp] = finite_permutations apply rule apply rule apply simp apply rule apply rule unfolding S_def S1_def r apply (simp add: Let_def) done finally have "?hoisted = \" . } note simulate_party1 = this { assume r: "r = Party2" have project_to_Party2: "?hoisted = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); \a \ spmf_of_set {\. \ permutes {..b \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {.. sequence_spmf (map share_nat (permute_list \a xs)); b \ sequence_spmf (map share_nat (permute_list (\a \ \b) xs)); c \ sequence_spmf (map share_nat (permute_list (\a \ \b \ \c) xs)); \ \round 1\ let x' = map (get_party Party3) x; let y' = map (aby3_stack_sharing Party1) x; let \a2 = map (case_prod (-)) (zip (map (get_party Party2) a) (map (get_party Party2) (permute_list \a y'))); \ \round 2\ let a' = map (get_party Party1) a; let y' = map (aby3_stack_sharing Party2) a; let \b2 = map (case_prod (-)) (zip (map (get_party Party2) b) (map (get_party Party2) (permute_list \b y'))); \ \round 3\ let b' = map (get_party Party2) b; let y' = map (aby3_stack_sharing Party3) b; let \c2 = map (case_prod (-)) (zip (map (get_party Party2) c) (map (get_party Party2) (permute_list \c y'))); let msg2 = ((\a2, \b2, \c2), x', \a, \b); return_spmf (map (get_party Party2) x, msg2, c) })" by (simp add: r Let_def get_party_map_sharing2 map_map_prod_zip') also have project_to_Party2: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); \a \ spmf_of_set {\. \ permutes {..b \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {.. sequence_spmf (map share_nat (permute_list \a xs)); b \ sequence_spmf (map share_nat (permute_list (\a \ \b) xs)); c \ sequence_spmf (map share_nat (permute_list (\a \ \b \ \c) xs)); \ \round 1\ let x' = map (get_party Party3) x; let y' = map (aby3_stack_sharing Party1) x; let \a2 = map2 (-) (map (get_party Party2) a) (permute_list \a (map (get_party Party2) y')); \ \round 2\ let a' = map (get_party Party1) a; let y' = map (aby3_stack_sharing Party2) a; let \b2 = map2 (-) (map (get_party Party2) b) (permute_list \b (map (get_party Party2) y')); \ \round 3\ let b' = map (get_party Party2) b; let y' = map (aby3_stack_sharing Party3) b; let \c2 = map2 (-) (map (get_party Party2) c) (permute_list \c (map (get_party Party2) y')); let msg2 = ((\a2, \b2, \c2), x', \a, \b); return_spmf (map (get_party Party2) x, msg2, c) })" supply [intro!] = bind_spmf_cong[OF refl] let_cong[OF refl] prod.case_cong[OF refl] bind_spmf_sequence_map_cong bind_spmf_sequence_replicate_cong bind_spmf_permutes_cong apply rule+ apply (subst permute_list_map[symmetric]) subgoal by simp apply rule+ apply (subst permute_list_map[symmetric]) subgoal by simp apply rule+ apply (subst permute_list_map[symmetric]) subgoal by simp .. also have reduce_Lets: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); \a \ spmf_of_set {\. \ permutes {..b \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {.. sequence_spmf (map share_nat (permute_list \a xs)); b \ sequence_spmf (map share_nat (permute_list (\a \ \b) xs)); c \ sequence_spmf (map share_nat (permute_list (\a \ \b \ \c) xs)); \ \round 1\ let x' = map (get_party Party3) x; let \a2 = map2 (-) (map (get_party Party2) a) (permute_list \a (map2 (+) (map (get_party Party2) x) (map (get_party Party3) x))); \ \round 2\ let \b2 = map2 (-) (map (get_party Party2) b) (permute_list \b (map (get_party Party2) a)); \ \round 3\ let \c2 = map2 (-) (map (get_party Party2) c) (permute_list \c (replicate (length b) 0)); let msg2 = ((\a2, \b2, \c2), x', \a, \b); return_spmf (map (get_party Party2) x, msg2, c) })" unfolding Let_def unfolding aby3_stack_sharing_def by (simp add: comp_def make_sharing'_sel map_replicate_const zip_map_map_same[symmetric]) also have simplify_minus_zero: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); \a \ spmf_of_set {\. \ permutes {..b \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {.. sequence_spmf (map share_nat (permute_list \a xs)); b \ sequence_spmf (map share_nat (permute_list (\a \ \b) xs)); c \ sequence_spmf (map share_nat (permute_list (\a \ \b \ \c) xs)); \ \round 1\ let x' = map (get_party Party3) x; let \a2 = map2 (-) (map (get_party Party2) a) (permute_list \a (map2 (+) (map (get_party Party2) x) (map (get_party Party3) x))); \ \round 2\ let \b2 = map2 (-) (map (get_party Party2) b) (permute_list \b (map (get_party Party2) a)); \ \round 3\ let \c2 = (map (get_party Party2) c); let msg2 = ((\a2, \b2, \c2), x', \a, \b); return_spmf (map (get_party Party2) x, msg2, c) })" supply [intro!] = bind_spmf_cong[OF refl] let_cong[OF refl] prod.case_cong[OF refl] bind_spmf_sequence_map_cong bind_spmf_sequence_replicate_cong bind_spmf_permutes_cong apply rule+ apply (subst permute_list_replicate) subgoal by simp apply (subst map2_minus_zero) subgoal by simp subgoal by simp .. also have break_perms_1: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); (\a,\b,\c) \ pair_spmf (spmf_of_set {\. \ permutes {... \ permutes {... \ permutes {.. sequence_spmf (map share_nat (permute_list \a xs)); b \ sequence_spmf (map share_nat (permute_list (\a \ \b) xs)); c \ sequence_spmf (map share_nat (permute_list (\a \ \b \ \c) xs)); \ \round 1\ let x' = map (get_party Party3) x; let \a2 = map2 (-) (map (get_party Party2) a) (permute_list \a (map2 (+) (map (get_party Party2) x) (map (get_party Party3) x))); \ \round 2\ let \b2 = map2 (-) (map (get_party Party2) b) (permute_list \b (map (get_party Party2) a)); \ \round 3\ let \c2 = (map (get_party Party2) c); let msg2 = ((\a2, \b2, \c2), x', \a, \b); return_spmf (map (get_party Party2) x, msg2, c) })" unfolding pair_spmf_alt_def by simp also have break_perms_2: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); ((\a,\b,\c),$$ \ map_spmf ($$\a,\b,\c). ((\a,\b,\c), \a \ \b \ \c)) (pair_spmf (spmf_of_set {\. \ permutes {... \ permutes {... \ permutes {.. sequence_spmf (map share_nat (permute_list \a xs)); b \ sequence_spmf (map share_nat (permute_list (\a \ \b) xs)); c \ sequence_spmf (map share_nat (permute_list \ xs)); \ \round 1\ let x' = map (get_party Party3) x; let \a2 = map2 (-) (map (get_party Party2) a) (permute_list \a (map2 (+) (map (get_party Party2) x) (map (get_party Party3) x))); \ \round 2\ let \b2 = map2 (-) (map (get_party Party2) b) (permute_list \b (map (get_party Party2) a)); \ \round 3\ let \c2 = (map (get_party Party2) c); let msg2 = ((\a2, \b2, \c2), x', \a, \b); return_spmf (map (get_party Party2) x, msg2, c) })" unfolding pair_spmf_alt_def map_spmf_conv_bind_spmf by simp also have break_perms_3: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); \ \ spmf_of_set {\. \ permutes {..a \ spmf_of_set {\. \ permutes {..b \ spmf_of_set {\. \ permutes {..c = inv \b \ inv \a \ \; a \ sequence_spmf (map share_nat (permute_list \a xs)); b \ sequence_spmf (map share_nat (permute_list (\a \ \b) xs)); c \ sequence_spmf (map share_nat (permute_list \ xs)); \ \round 1\ let x' = map (get_party Party3) x; let \a2 = map2 (-) (map (get_party Party2) a) (permute_list \a (map2 (+) (map (get_party Party2) x) (map (get_party Party3) x))); \ \round 2\ let \b2 = map2 (-) (map (get_party Party2) b) (permute_list \b (map (get_party Party2) a)); \ \round 3\ let \c2 = (map (get_party Party2) c); let msg2 = ((\a2, \b2, \c2), x', \a, \b); return_spmf (map (get_party Party2) x, msg2, c) })" apply (unfold random_perm_right) apply (unfold map_spmf_conv_bind_spmf pair_spmf_alt_def) by simp also have break_seqs_3: "\ = (do { xs \ xs; let n = length xs; x2 \ sequence_spmf (replicate n (spmf_of_set UNIV)); x3 \ sequence_spmf (replicate n (spmf_of_set UNIV)); let x = map3 (\a b c. make_sharing' Party2 Party3 Party1 b c (a - (b + c))) xs x2 x3; \ \ spmf_of_set {\. \ permutes {..a \ spmf_of_set {\. \ permutes {..b \ spmf_of_set {\. \ permutes {.. sequence_spmf (replicate n (spmf_of_set UNIV)); a3 \ sequence_spmf (replicate n (spmf_of_set UNIV)); let a = map3 (\a b c. make_sharing' Party2 Party3 Party1 b c (a - (b + c))) (permute_list \a xs) a2 a3; b2 \ sequence_spmf (replicate n (spmf_of_set UNIV)); b3 \ sequence_spmf (replicate n (spmf_of_set UNIV)); let b = map3 (\a b c. make_sharing' Party2 Party3 Party1 b c (a - (b + c))) (permute_list (\a \ \b) xs) b2 b3; c \ sequence_spmf (map share_nat (permute_list \ xs)); \ \round 1\ let x' = map (get_party Party3) x; let \a2 = map2 (-) (map (get_party Party2) a) (permute_list \a (map2 (+) (map (get_party Party2) x) (map (get_party Party3) x))); \ \round 2\ let \b2 = map2 (-) (map (get_party Party2) b) (permute_list \b (map (get_party Party2) a)); \ \round 3\ let \c2 = (map (get_party Party2) c); let msg2 = ((\a2, \b2, \c2), x', \a, \b); return_spmf (map (get_party Party2) x, msg2, c) })" apply (unfold sequence_share_nat_calc'[of Party2 Party3 Party1, simplified]) apply (simp add: pair_spmf_alt_def Let_def) done also have break_seqs_3: "\ = (do { xs \ xs; let n = length xs; x2 \ sequence_spmf (replicate n (spmf_of_set UNIV)); x3 \ sequence_spmf (replicate n (spmf_of_set UNIV)); \ \ spmf_of_set {\. \ permutes {..a \ spmf_of_set {\. \ permutes {..b \ spmf_of_set {\. \ permutes {.. sequence_spmf (replicate n (spmf_of_set UNIV)); a3::natL list \ sequence_spmf (replicate n (spmf_of_set UNIV)); b2::natL list \ sequence_spmf (replicate n (spmf_of_set UNIV)); b3::natL list \ sequence_spmf (replicate n (spmf_of_set UNIV)); c \ sequence_spmf (map share_nat (permute_list \ xs)); \ \round 1\ let x' = x3; let \a2 = map2 (-) a2 (permute_list \a (map2 (+) x2 x3)); \ \round 2\ let \b2 = map2 (-) b2 (permute_list \b a2); \ \round 3\ let \c2 = (map (get_party Party2) c); let msg2 = ((\a2, \b2, \c2), x', \a, \b); return_spmf (x2, msg2, c) })" supply [intro!] = bind_spmf_cong[OF refl] let_cong[OF refl] prod.case_cong[OF refl] bind_spmf_sequence_map_cong bind_spmf_sequence_replicate_cong bind_spmf_permutes_cong unfolding Let_def apply rule+ apply (auto simp: map2_ignore1 map2_ignore2 comp_def prod.case_distrib bind_spmf_const make_sharing'_sel) done also have "\ = (do {x \ x_dist; y \ aby3_shuffleF x; let xr = map (get_party r) x; let yr = map (get_party r) y; msg \ S r xr yr; return_spmf (xr, msg, y)})" supply [intro!] = bind_spmf_cong[OF refl] let_cong[OF refl] prod.case_cong[OF refl] bind_spmf_sequence_map_cong bind_spmf_sequence_replicate_cong bind_spmf_permutes_cong unfolding xs unfolding aby3_shuffleF_def apply (simp add: bind_spmf_const map_spmf_conv_bind_spmf) apply (subst lossless_sequence_spmf[unfolded lossless_spmf_def]) subgoal by simp apply (subst lossless_sequence_spmf[unfolded lossless_spmf_def]) subgoal by simp apply simp apply rule apply (subst (2) sequence_share_nat_calc'[of Party2 Party3 Party1, simplified]) apply (subst (2) Let_def) apply (simp add: pair_spmf_alt_def) apply (subst Let_def) unfolding S_def r apply (simp add: pair_spmf_alt_def comp_def prod.case_distrib map2_ignore2 make_sharing'_sel) apply (rule trans[rotated]) apply (rule bind_spmf_sequence_replicate_cong) apply (rule bind_spmf_sequence_replicate_cong) apply (simp add: map2_ignore1 map2_ignore2) apply (subst bind_spmf_const) apply (subst lossless_sequence_spmf[unfolded lossless_spmf_def]) subgoal by simp apply simp apply (subst (2) bind_commute_spmf[where p="sequence_spmf (replicate _ _)"]) apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"]) apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"]) apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"]) apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"]) apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"]) apply rule apply rule apply rule unfolding S2_def Let_def apply simp done finally have "?hoisted = \" . } note simulate_party2 = this { assume r: "r = Party3" have project_to_Party3: "?hoisted = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); \a \ spmf_of_set {\. \ permutes {..b \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {.. sequence_spmf (map share_nat (permute_list \a xs)); b \ sequence_spmf (map share_nat (permute_list (\a \ \b) xs)); c \ sequence_spmf (map share_nat (permute_list (\a \ \b \ \c) xs)); \ \round 1\ let x' = map (get_party Party3) x; let y' = map (aby3_stack_sharing Party1) x; let \a3 = map (case_prod (-)) (zip (map (get_party Party3) a) (map (get_party Party3) (permute_list \a y'))); \ \round 2\ let a' = map (get_party Party1) a; let y' = map (aby3_stack_sharing Party2) a; let \b3 = map (case_prod (-)) (zip (map (get_party Party3) b) (map (get_party Party3) (permute_list \b y'))); \ \round 3\ let b' = map (get_party Party2) b; let y' = map (aby3_stack_sharing Party3) b; let \c3 = map (case_prod (-)) (zip (map (get_party Party3) c) (map (get_party Party3) (permute_list \c y'))); let msg3 = ((\a3, \b3, \c3), a', \b, \c); return_spmf (map (get_party Party3) x, msg3, c) })" by (simp add: r Let_def get_party_map_sharing2 map_map_prod_zip') also have project_to_Party1: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); \a \ spmf_of_set {\. \ permutes {..b \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {.. sequence_spmf (map share_nat (permute_list \a xs)); b \ sequence_spmf (map share_nat (permute_list (\a \ \b) xs)); c \ sequence_spmf (map share_nat (permute_list (\a \ \b \ \c) xs)); \ \round 1\ let x' = map (get_party Party3) x; let y' = map (aby3_stack_sharing Party1) x; let \a3 = map2 (-) (map (get_party Party3) a) (permute_list \a (map (get_party Party3) y')); \ \round 2\ let a' = map (get_party Party1) a; let y' = map (aby3_stack_sharing Party2) a; let \b3 = map2 (-) (map (get_party Party3) b) (permute_list \b (map (get_party Party3) y')); \ \round 3\ let b' = map (get_party Party2) b; let y' = map (aby3_stack_sharing Party3) b; let \c3 = map2 (-) (map (get_party Party3) c) (permute_list \c (map (get_party Party3) y')); let msg3 = ((\a3, \b3, \c3), a', \b, \c); return_spmf (map (get_party Party3) x, msg3, c) })" supply [intro!] = bind_spmf_cong[OF refl] let_cong[OF refl] prod.case_cong[OF refl] bind_spmf_sequence_map_cong bind_spmf_sequence_replicate_cong bind_spmf_permutes_cong apply rule+ apply (subst permute_list_map[symmetric]) subgoal by simp apply rule+ apply (subst permute_list_map[symmetric]) subgoal by simp apply rule+ apply (subst permute_list_map[symmetric]) subgoal by simp .. also have reduce_Lets: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); \a \ spmf_of_set {\. \ permutes {..b \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {.. sequence_spmf (map share_nat (permute_list \a xs)); b \ sequence_spmf (map share_nat (permute_list (\a \ \b) xs)); c \ sequence_spmf (map share_nat (permute_list (\a \ \b \ \c) xs)); \ \round 1\ let \a3 = map2 (-) (map (get_party Party3) a) (permute_list \a (replicate (length x) 0)); \ \round 2\ let a' = map (get_party Party1) a; let \b3 = map2 (-) (map (get_party Party3) b) (permute_list \b (map2 (+) (map (get_party Party3) a) (map (get_party Party1) a))); \ \round 3\ let \c3 = map2 (-) (map (get_party Party3) c) (permute_list \c (map (get_party Party3) b)); let msg3 = ((\a3, \b3, \c3), a', \b, \c); return_spmf (map (get_party Party3) x, msg3, c) })" unfolding Let_def unfolding aby3_stack_sharing_def by (simp add: comp_def make_sharing'_sel map_replicate_const zip_map_map_same[symmetric]) also have simplify_minus_zero: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); \a \ spmf_of_set {\. \ permutes {..b \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {.. sequence_spmf (map share_nat (permute_list \a xs)); b \ sequence_spmf (map share_nat (permute_list (\a \ \b) xs)); c \ sequence_spmf (map share_nat (permute_list (\a \ \b \ \c) xs)); \ \round 1\ let \a3 = (map (get_party Party3) a); \ \round 2\ let a' = map (get_party Party1) a; let \b3 = map2 (-) (map (get_party Party3) b) (permute_list \b (map2 (+) (map (get_party Party3) a) (map (get_party Party1) a))); \ \round 3\ let \c3 = map2 (-) (map (get_party Party3) c) (permute_list \c (map (get_party Party3) b)); let msg3 = ((\a3, \b3, \c3), a', \b, \c); return_spmf (map (get_party Party3) x, msg3, c) })" supply [intro!] = bind_spmf_cong[OF refl] let_cong[OF refl] prod.case_cong[OF refl] bind_spmf_sequence_map_cong bind_spmf_sequence_replicate_cong bind_spmf_permutes_cong apply rule+ apply (subst permute_list_replicate) subgoal by simp apply (subst map2_minus_zero) subgoal by simp subgoal by simp .. also have break_perms_1: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); (\a,\b,\c) \ pair_spmf (spmf_of_set {\. \ permutes {... \ permutes {... \ permutes {.. sequence_spmf (map share_nat (permute_list \a xs)); b \ sequence_spmf (map share_nat (permute_list (\a \ \b) xs)); c \ sequence_spmf (map share_nat (permute_list (\a \ \b \ \c) xs)); \ \round 1\ let \a3 = (map (get_party Party3) a); \ \round 2\ let a' = map (get_party Party1) a; let \b3 = map2 (-) (map (get_party Party3) b) (permute_list \b (map2 (+) (map (get_party Party3) a) (map (get_party Party1) a))); \ \round 3\ let \c3 = map2 (-) (map (get_party Party3) c) (permute_list \c (map (get_party Party3) b)); let msg3 = ((\a3, \b3, \c3), a', \b, \c); return_spmf (map (get_party Party3) x, msg3, c) })" unfolding pair_spmf_alt_def by simp also have break_perms_2: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); ((\a,\b,\c),$$ \ map_spmf ($$\a,\b,\c). ((\a,\b,\c), \a \ \b \ \c)) (pair_spmf (spmf_of_set {\. \ permutes {... \ permutes {... \ permutes {.. sequence_spmf (map share_nat (permute_list \a xs)); b \ sequence_spmf (map share_nat (permute_list (\a \ \b) xs)); c \ sequence_spmf (map share_nat (permute_list \ xs)); \ \round 1\ let \a3 = (map (get_party Party3) a); \ \round 2\ let a' = map (get_party Party1) a; let \b3 = map2 (-) (map (get_party Party3) b) (permute_list \b (map2 (+) (map (get_party Party3) a) (map (get_party Party1) a))); \ \round 3\ let \c3 = map2 (-) (map (get_party Party3) c) (permute_list \c (map (get_party Party3) b)); let msg3 = ((\a3, \b3, \c3), a', \b, \c); return_spmf (map (get_party Party3) x, msg3, c) })" unfolding pair_spmf_alt_def map_spmf_conv_bind_spmf by simp also have break_perms_3: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); \ \ spmf_of_set {\. \ permutes {..b \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {..a = \ \ inv \c \ inv \b; a \ sequence_spmf (map share_nat (permute_list \a xs)); b \ sequence_spmf (map share_nat (permute_list (\a \ \b) xs)); c \ sequence_spmf (map share_nat (permute_list \ xs)); \ \round 1\ let \a3 = (map (get_party Party3) a); \ \round 2\ let a' = map (get_party Party1) a; let \b3 = map2 (-) (map (get_party Party3) b) (permute_list \b (map2 (+) (map (get_party Party3) a) (map (get_party Party1) a))); \ \round 3\ let \c3 = map2 (-) (map (get_party Party3) c) (permute_list \c (map (get_party Party3) b)); let msg3 = ((\a3, \b3, \c3), a', \b, \c); return_spmf (map (get_party Party3) x, msg3, c) })" apply (unfold random_perm_left) apply (unfold map_spmf_conv_bind_spmf pair_spmf_alt_def) by (simp add: Let_def) also have break_seqs_3: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); \ \ spmf_of_set {\. \ permutes {..b \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {..a = \ \ inv \c \ inv \b; a3 \ sequence_spmf (replicate n (spmf_of_set UNIV)); a1 \ sequence_spmf (replicate n (spmf_of_set UNIV)); let a = map3 (\a b c. make_sharing' Party3 Party1 Party2 b c (a - (b + c))) (permute_list \a xs) a3 a1; b3 \ sequence_spmf (replicate n (spmf_of_set UNIV)); b1 \ sequence_spmf (replicate n (spmf_of_set UNIV)); let b = map3 (\a b c. make_sharing' Party3 Party1 Party2 b c (a - (b + c))) (permute_list (\a \ \b) xs) b3 b1; c \ sequence_spmf (map share_nat (permute_list \ xs)); \ \round 1\ let \a3 = (map (get_party Party3) a); \ \round 2\ let a' = map (get_party Party1) a; let \b3 = map2 (-) (map (get_party Party3) b) (permute_list \b (map2 (+) (map (get_party Party3) a) (map (get_party Party1) a))); \ \round 3\ let \c3 = map2 (-) (map (get_party Party3) c) (permute_list \c (map (get_party Party3) b)); let msg3 = ((\a3, \b3, \c3), a', \b, \c); return_spmf (map (get_party Party3) x, msg3, c) })" apply (unfold sequence_share_nat_calc'[of Party3 Party1 Party2, simplified]) apply (simp add: pair_spmf_alt_def Let_def) done also have break_seqs_3: "\ = (do { xs \ xs; let n = length xs; x \ sequence_spmf (map share_nat xs); \ \ spmf_of_set {\. \ permutes {..b \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {..a = \ \ inv \c \ inv \b; a3::natL list \ sequence_spmf (replicate n (spmf_of_set UNIV)); a1::natL list \ sequence_spmf (replicate n (spmf_of_set UNIV)); b3::natL list \ sequence_spmf (replicate n (spmf_of_set UNIV)); b1::natL list \ sequence_spmf (replicate n (spmf_of_set UNIV)); c \ sequence_spmf (map share_nat (permute_list \ xs)); \ \round 1\ let \a3 = a3; \ \round 2\ let a' = a1; let \b3 = map2 (-) b3 (permute_list \b (map2 (+) a3 a1)); \ \round 3\ let \c3 = map2 (-) (map (get_party Party3) c) (permute_list \c b3); let msg3 = ((\a3, \b3, \c3), a', \b, \c); return_spmf (map (get_party Party3) x, msg3, c) })" supply [intro!] = bind_spmf_cong[OF refl] let_cong[OF refl] prod.case_cong[OF refl] bind_spmf_sequence_map_cong bind_spmf_sequence_replicate_cong bind_spmf_permutes_cong unfolding Let_def apply rule+ apply (auto simp: map2_ignore1 map2_ignore2 comp_def prod.case_distrib bind_spmf_const make_sharing'_sel) done also have "\ = (do {x \ x_dist; y \ aby3_shuffleF x; let xr = map (get_party r) x; let yr = map (get_party r) y; msg \ S r xr yr; return_spmf (xr, msg, y)})" unfolding xs unfolding aby3_shuffleF_def apply (subst bind_spmf_const) apply (subst lossless_sequence_spmf[unfolded lossless_spmf_def]) subgoal by simp apply (simp add: map_spmf_conv_bind_spmf) apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"]) apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"]) apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"]) apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"]) apply (subst bind_commute_spmf[where q="sequence_spmf (map share_nat _)"]) apply (subst (3) hoist_map_spmf[where s="sequence_spmf (map share_nat _)" and f="map reconstruct"]) apply (subst map_sequence_share_nat_reconstruct) apply (simp add: map_spmf_conv_bind_spmf) apply (subst Let_def) supply [intro!] = bind_spmf_cong[OF refl] let_cong[OF refl] prod.case_cong[OF refl] bind_spmf_sequence_map_cong bind_spmf_sequence_replicate_cong bind_spmf_permutes_cong supply [simp] = finite_permutations apply rule apply rule apply simp apply rule apply rule unfolding S_def S3_def r apply (simp add: Let_def) done finally have "?hoisted = \" . } note simulate_party3 = this show ?thesis unfolding hoisted_save apply (cases r) subgoal using simulate_party1 . subgoal using simulate_party2 . subgoal using simulate_party3 . done qed lemma Collect_case_prod: "{f x y | x y. P x y} = (case_prod f)  (Collect (case_prod P))" by auto lemma inj_split_Cons': "inj_on (\(n, xs). n#xs) X" by (auto intro!: inj_onI) lemma finite_indicator_eq_sum: "finite A \ indicat_real A x = sum (indicat_real {x}) A" by (induction rule: finite_induct) (auto simp: indicator_def) lemma spmf_of_set_Cons: "spmf_of_set (set_Cons A B) = map2_spmf (#) (spmf_of_set A) (spmf_of_set B)" unfolding set_Cons_def pair_spmf_of_set apply (rule spmf_eq_iff_set) subgoal unfolding Collect_case_prod apply (auto simp: set_spmf_of_set ) apply (subst (asm) finite_image_iff) subgoal by (rule inj_split_Cons') subgoal by (auto simp: finite_cartesian_product_iff) done subgoal unfolding Collect_case_prod apply (auto simp: spmf_of_set map_spmf_conv_bind_spmf spmf_bind integral_spmf_of_set) apply (subst card_image) subgoal by (rule inj_split_Cons') apply (auto simp: card_eq_0_iff indicator_single_Some) apply (subst (asm) finite_indicator_eq_sum) subgoal by (simp add: finite_image_iff inj_split_Cons') apply (subst (asm) sum.reindex) subgoal by (simp add: finite_image_iff inj_split_Cons') apply (auto) done done lemma sequence_spmf_replicate: "sequence_spmf (replicate n (spmf_of_set A)) = spmf_of_set (listset (replicate n A))" apply (induction n) subgoal by (auto simp: spmf_of_set_singleton) subgoal by (auto simp: spmf_of_set_Cons) done lemma listset_replicate: "listset (replicate n A) = {l. length l = n \ set l \ A}" apply (induction n) apply (auto simp: set_Cons_def) subgoal for n x by (cases x; simp) done lemma map2_map2_map3: "map2 f (map2 g x y) z = map3 (\x y. f (g x y)) x y z" by (auto simp: zip_assoc map_zip_map) lemma inv_add_sequence: assumes "n = length x" shows " map_spmf (\\::natL list. (\, map2 (+) \ x)) (sequence_spmf (replicate n (spmf_of_set UNIV))) = map_spmf (\y. (map2 (-) y x, y)) (sequence_spmf (replicate n (spmf_of_set UNIV)))" unfolding sequence_spmf_replicate apply (subst map_spmf_of_set_inj_on) subgoal unfolding inj_on_def by simp apply (subst map_spmf_of_set_inj_on) subgoal unfolding inj_on_def by simp apply (rule arg_cong[where f="spmf_of_set"]) using assms apply (auto simp: image_def listset_replicate map2_map2_map3 zip_same_conv_map map_zip_map2 map2_ignore2) done lemma S1_def_simplified: "S1 x1 yc1 = (do { let n = length x1; \a \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {..a1::natL list \ sequence_spmf (replicate n (spmf_of_set UNIV)); yb1::natL list \ sequence_spmf (replicate n (spmf_of_set UNIV)); yb2::natL list \ sequence_spmf (replicate n (spmf_of_set UNIV)); let \c1 = map2 (-) (yc1) (permute_list \c (map2 (+) yb1 yb2)); return_spmf ((\a1, yb1, \c1), yb2, \a, \c) })" unfolding S1_def supply [intro!] = bind_spmf_cong[OF refl] let_cong[OF refl] prod.case_cong[OF refl] bind_spmf_sequence_map_cong bind_spmf_sequence_replicate_cong bind_spmf_permutes_cong bind_spmf_sequence_map_share_nat_cong apply rule apply rule apply rule apply (subst hoist_map_spmf'[where s="sequence_spmf _" and f="\x. map2 (-) x _"]) apply (subst inv_add_sequence[symmetric]) subgoal by simp unfolding map_spmf_conv_bind_spmf apply simp done lemma S2_def_simplified: "S2 x2 yc2 = (do { let n = length x2; x3 \ sequence_spmf (replicate n (spmf_of_set UNIV)); \a \ spmf_of_set {\. \ permutes {..b \ spmf_of_set {\. \ permutes {..a2::natL list \ sequence_spmf (replicate n (spmf_of_set UNIV)); \b2::natL list \ sequence_spmf (replicate n (spmf_of_set UNIV)); let msg2 = ((\a2, \b2, yc2), x3, \a, \b); return_spmf msg2 })" unfolding S2_def supply [intro!] = bind_spmf_cong[OF refl] let_cong[OF refl] prod.case_cong[OF refl] bind_spmf_sequence_map_cong bind_spmf_sequence_replicate_cong bind_spmf_permutes_cong bind_spmf_sequence_map_share_nat_cong apply rule apply rule apply rule apply rule apply (rule trans) apply (rule bind_spmf_sequence_replicate_cong) apply (subst hoist_map_spmf'[where s="sequence_spmf _" and f="\x. map2 (-) x _"]) apply (subst inv_add_sequence[symmetric]) subgoal by simp apply (rule refl) apply (unfold map_spmf_conv_bind_spmf) apply simp apply (subst hoist_map_spmf'[where s="sequence_spmf _" and f="\x. map2 (-) x _"]) apply (subst inv_add_sequence[symmetric]) subgoal by simp apply (unfold map_spmf_conv_bind_spmf) apply simp done lemma S3_def_simplified: "S3 x3 yc3 = (do { let n = length x3; \b \ spmf_of_set {\. \ permutes {..c \ spmf_of_set {\. \ permutes {.. sequence_spmf (replicate n (spmf_of_set UNIV)); ya1::natL list \ sequence_spmf (replicate n (spmf_of_set UNIV)); \b3::natL list \ sequence_spmf (replicate n (spmf_of_set UNIV)); let \c3 = map2 (-) yc3 (permute_list \c (map2 (+) \b3 (permute_list \b (map2 (+) ya3 ya1)))); return_spmf ((ya3, \b3, \c3), ya1, \b, \c) })" unfolding S3_def supply [intro!] = bind_spmf_cong[OF refl] let_cong[OF refl] prod.case_cong[OF refl] bind_spmf_sequence_map_cong bind_spmf_sequence_replicate_cong bind_spmf_permutes_cong bind_spmf_sequence_map_share_nat_cong apply rule apply rule apply rule apply rule apply rule apply (subst hoist_map_spmf'[where s="sequence_spmf _" and f="\x. map2 (-) x _"]) apply (subst inv_add_sequence[symmetric]) subgoal by simp apply (unfold map_spmf_conv_bind_spmf) apply simp done end diff --git a/thys/ABY3_Protocols/Spmf_Common.thy b/thys/ABY3_Protocols/Spmf_Common.thy --- a/thys/ABY3_Protocols/Spmf_Common.thy +++ b/thys/ABY3_Protocols/Spmf_Common.thy @@ -1,437 +1,437 @@ theory Spmf_Common imports CryptHOL.CryptHOL begin no_adhoc_overloading Monad_Syntax.bind bind_pmf lemma mk_lossless_back_eq: "scale_spmf (weight_spmf s) (mk_lossless s) = s" unfolding mk_lossless_def unfolding scale_scale_spmf by (auto simp: field_simps weight_spmf_eq_0) lemma cond_spmf_enforce: "cond_spmf sx (Collect A) = mk_lossless (enforce_spmf A sx)" unfolding enforce_spmf_def unfolding cond_spmf_alt unfolding restrict_spmf_def unfolding enforce_option_alt_def apply (rule arg_cong[where f="mk_lossless"]) apply (rule arg_cong[where f="\x. map_pmf x sx"]) apply (intro ext) apply (rule arg_cong[where f="Option.bind _"]) apply auto done definition "rel_scale_spmf s t \ (mk_lossless s = mk_lossless t)" lemma rel_scale_spmf_refl: "rel_scale_spmf s s" unfolding rel_scale_spmf_def .. lemma rel_scale_spmf_sym: "rel_scale_spmf s t \ rel_scale_spmf t s" unfolding rel_scale_spmf_def by simp lemma rel_scale_spmf_trans: "rel_scale_spmf s t \ rel_scale_spmf t u \ rel_scale_spmf s u" unfolding rel_scale_spmf_def by simp lemma rel_scale_spmf_equiv: "equivp rel_scale_spmf" using rel_scale_spmf_refl rel_scale_spmf_sym by (auto intro!: equivpI reflpI sympI transpI dest: rel_scale_spmf_trans) lemma spmf_eq_iff: "p = q \ (\i. spmf p i = spmf q i)" using spmf_eqI by auto lemma spmf_eq_iff_set: "set_spmf a = set_spmf b \ (\x. x \ set_spmf b \ spmf a x = spmf b x) \ a = b" using in_set_spmf_iff_spmf spmf_eq_iff by (metis) lemma rel_scale_spmf_None: "rel_scale_spmf s t \ s = return_pmf None \ t = return_pmf None" unfolding rel_scale_spmf_def by auto lemma rel_scale_spmf_def_alt: "rel_scale_spmf s t \ (\k>0. s = scale_spmf k t)" proof assume rel: "rel_scale_spmf s t" then consider (isNone) "s = return_pmf None \ t = return_pmf None" | (notNone) "weight_spmf s > 0 \ weight_spmf t > 0" using rel_scale_spmf_None weight_spmf_eq_0 zero_less_measure_iff by blast then show "\k>0. s = scale_spmf k t" proof cases case isNone show ?thesis apply (rule exI[of _ 1]) using isNone by simp next case notNone have "scale_spmf (weight_spmf s) (mk_lossless s) = scale_spmf (weight_spmf s / weight_spmf t) t" unfolding rel[unfolded rel_scale_spmf_def] unfolding mk_lossless_def unfolding scale_scale_spmf by (auto simp: field_simps) then show "\k>0. s = scale_spmf k t" apply (unfold mk_lossless_back_eq) using notNone divide_pos_pos by blast qed next assume "\k>0. s = scale_spmf k t" then obtain k where kpos: "k>0" and st: "s = scale_spmf k t" by blast then consider (isNone) "weight_spmf s = 0 \ weight_spmf t = 0" | (notNone) "weight_spmf s > 0 \ weight_spmf t > 0" using zero_less_measure_iff mult_pos_pos zero_less_measure_iff by (fastforce simp: weight_scale_spmf) then show "rel_scale_spmf s t" proof cases case isNone then show ?thesis unfolding rel_scale_spmf_def weight_spmf_eq_0 by simp next case notNone then show ?thesis unfolding rel_scale_spmf_def unfolding mk_lossless_def unfolding st by (cases "k < inverse (weight_spmf t)") (auto simp: weight_scale_spmf scale_scale_spmf field_simps) qed qed lemma rel_scale_spmf_def_alt2: "rel_scale_spmf s t \ (s = return_pmf None \ t = return_pmf None) | (weight_spmf s > 0 \ weight_spmf t > 0 \ s = scale_spmf (weight_spmf s / weight_spmf t) t)" (is "?lhs \ ?rhs") proof assume rel: ?lhs then consider (isNone) "s = return_pmf None \ t = return_pmf None" | (notNone) "weight_spmf s > 0 \ weight_spmf t > 0" using rel_scale_spmf_None weight_spmf_eq_0 zero_less_measure_iff by blast thus ?rhs proof cases case notNone have "scale_spmf (weight_spmf s) (mk_lossless s) = scale_spmf (weight_spmf s / weight_spmf t) t" unfolding rel[unfolded rel_scale_spmf_def] unfolding mk_lossless_def unfolding scale_scale_spmf by (auto simp: field_simps) thus ?thesis apply (unfold mk_lossless_back_eq) using notNone by simp qed simp next assume ?rhs then show ?lhs proof cases case right then have gt0: "weight_spmf s > 0" "weight_spmf t > 0" and st: "s = scale_spmf (weight_spmf s / weight_spmf t) t" by auto then have "(1 / weight_spmf t) \ (weight_spmf s / weight_spmf t)" using weight_spmf_le_1 divide_le_cancel by fastforce then show ?thesis unfolding rel_scale_spmf_def mk_lossless_def apply (subst (3) st) using gt0 by (auto simp: scale_scale_spmf field_simps) qed (simp add: rel_scale_spmf_refl) qed lemma rel_scale_spmf_scale: "r > 0 \ rel_scale_spmf s t \ rel_scale_spmf s (scale_spmf r t)" apply (unfold rel_scale_spmf_def_alt) by (metis rel_scale_spmf_def rel_scale_spmf_def_alt) lemma rel_scale_spmf_mk_lossless: "rel_scale_spmf s t \ rel_scale_spmf s (mk_lossless t)" unfolding rel_scale_spmf_def_alt unfolding mk_lossless_def apply (cases "weight_spmf t = 0") subgoal by(simp add: weight_spmf_eq_0) subgoal apply (auto simp: weight_spmf_eq_0 field_simps scale_scale_spmf) using rel_scale_spmf_def_alt rel_scale_spmf_def_alt2 by blast done lemma rel_scale_spmf_eq_iff: "rel_scale_spmf s t \ weight_spmf s = weight_spmf t \ s = t" unfolding rel_scale_spmf_def_alt2 by auto lemma rel_scale_spmf_set_restrict: "finite A \ rel_scale_spmf (restrict_spmf (spmf_of_set A) B) (spmf_of_set (A \ B))" apply (unfold rel_scale_spmf_def) apply (fold cond_spmf_alt) apply (subst cond_spmf_spmf_of_set) subgoal . apply (unfold mk_lossless_spmf_of_set) .. lemma spmf_of_set_restrict_empty: "A \ B = {} \ restrict_spmf (spmf_of_set A) B = return_pmf None" unfolding spmf_of_set_def by simp lemma spmf_of_set_restrict_scale: "finite A \ restrict_spmf (spmf_of_set A) B = scale_spmf (card (A\B) / card A) (spmf_of_set (A\B))" apply (rule rel_scale_spmf_eq_iff) subgoal apply (cases "A\B = {}") subgoal by (auto simp: spmf_of_set_restrict_empty intro: rel_scale_spmf_refl) subgoal apply (rule rel_scale_spmf_scale) subgoal by (metis card_gt_0_iff divide_pos_pos finite_Int inf_bot_left of_nat_0_less_iff) subgoal by (rule rel_scale_spmf_set_restrict) done done subgoal apply (auto simp add: weight_scale_spmf measure_spmf_of_set) by (smt (verit, best) card_gt_0_iff card_mono disjoint_notin1 divide_le_eq_1_pos finite_Int inf_le1 of_nat_0_less_iff of_nat_le_iff) done lemma min_em2: "min a b = c \ a\c \ b=c" unfolding min_def by auto lemma weight_0_spmf: "weight_spmf s = 0 \ spmf s i = 0" using order_trans[OF spmf_le_weight, of s 0 i] by simp lemma mk_lossless_scale_absorb: "r > 0 \ mk_lossless (scale_spmf r s) = mk_lossless s" apply (rule rel_scale_spmf_eq_iff) subgoal apply (rule rel_scale_spmf_trans[where t=s]) subgoal apply (rule rel_scale_spmf_sym) apply (rule rel_scale_spmf_mk_lossless) apply (rule rel_scale_spmf_scale) subgoal . subgoal by (rule rel_scale_spmf_refl) done subgoal apply (rule rel_scale_spmf_mk_lossless) apply (rule rel_scale_spmf_refl) done done subgoal unfolding weight_mk_lossless by (auto simp flip: weight_spmf_eq_0 simp: weight_scale_spmf dest: min_em2) done lemma scale_spmf_None_iff: "scale_spmf k s = return_pmf None \ k\0 \ s=return_pmf None" apply (auto simp: spmf_eq_iff spmf_scale_spmf) using inverse_nonpositive_iff_nonpositive weight_0_spmf measure_le_0_iff - by smt + by (smt (verit)) lemma spmf_of_pmf_the: "lossless_spmf s \ spmf_of_pmf (map_pmf the s) = s" unfolding lossless_spmf_conv_spmf_of_pmf by auto lemma lossless_mk_lossless: "s \ return_pmf None \ lossless_spmf (mk_lossless s)" unfolding lossless_spmf_def unfolding weight_mk_lossless by simp definition pmf_of_spmf where "pmf_of_spmf p = map_pmf the (mk_lossless p)" lemma scale_weight_spmf_of_pmf: "p = scale_spmf (weight_spmf p) (spmf_of_pmf (pmf_of_spmf p))" unfolding pmf_of_spmf_def apply (cases "p = return_pmf None") subgoal by simp subgoal apply (subst mk_lossless_back_eq[of p, symmetric]) apply (rule arg_cong[where f="scale_spmf _ "]) apply (rule spmf_of_pmf_the[symmetric]) by (fact lossless_mk_lossless) done lemma pmf_spmf: "pmf_of_spmf (spmf_of_pmf p) = p" unfolding pmf_of_spmf_def unfolding lossless_spmf_spmf_of_spmf[THEN mk_lossless_lossless] unfolding map_the_spmf_of_pmf .. lemma spmf_pmf: "lossless_spmf p \ spmf_of_pmf (pmf_of_spmf p) = p" unfolding pmf_of_spmf_def by (simp add: spmf_of_pmf_the) lemma pmf_of_spmf_scale_spmf: "r > 0 \ pmf_of_spmf (scale_spmf r p) = pmf_of_spmf p" unfolding pmf_of_spmf_def by (simp add: mk_lossless_scale_absorb) lemma nonempty_spmf_weight: "p \ return_pmf None \ weight_spmf p > 0" apply (fold weight_spmf_eq_0) using dual_order.not_eq_order_implies_strict[OF _ weight_spmf_nonneg[of p]] by auto lemma pmf_of_spmf_mk_lossless: "pmf_of_spmf (mk_lossless p) = pmf_of_spmf p" apply (cases "p = return_pmf None") subgoal by auto apply (unfold mk_lossless_def) apply (subst pmf_of_spmf_scale_spmf) subgoal by (simp add: nonempty_spmf_weight) .. lemma spmf_pmf': "p \ return_pmf None \ spmf_of_pmf (pmf_of_spmf p) = mk_lossless p" apply (subst spmf_pmf[of "mk_lossless p", symmetric]) apply (unfold pmf_of_spmf_mk_lossless) subgoal using lossless_mk_lossless . subgoal .. done lemma rel_scale_spmf_cond_UNIV: "rel_scale_spmf s (cond_spmf s UNIV)" unfolding cond_spmf_UNIV by (rule rel_scale_spmf_mk_lossless) (rule rel_scale_spmf_refl) lemma "set_pmf p \ g \ {} \ pmf_prob p (f \ g) = pmf_prob (cond_pmf p g) f * pmf_prob p g" using measure_cond_pmf unfolding pmf_prob_def by (metis Int_commute divide_eq_eq measure_measure_pmf_not_zero) lemma bayes: "set_pmf p \ A \ {} \ set_pmf p \ B \ {} \ measure_pmf.prob (cond_pmf p A) B = measure_pmf.prob (cond_pmf p B) A * measure_pmf.prob p B / measure_pmf.prob p A" unfolding measure_cond_pmf by (subst inf_commute) (simp add: measure_pmf_zero_iff) definition spmf_prob :: "'a spmf \ 'a set \ real" where "spmf_prob p = Sigma_Algebra.measure (measure_spmf p)" lemma "spmf_prob = measure_measure_spmf" unfolding spmf_prob_def measure_measure_spmf_def .. lemma spmf_prob_pmf: "spmf_prob p A = pmf_prob p (Some  A)" unfolding spmf_prob_def pmf_prob_def unfolding measure_measure_spmf_conv_measure_pmf .. lemma bayes_spmf: "spmf_prob (cond_spmf p A) B = spmf_prob (cond_spmf p B) A * spmf_prob p B / spmf_prob p A" unfolding spmf_prob_def unfolding measure_cond_spmf by (subst inf_commute) (auto simp: measure_spmf_zero_iff) lemma spmf_prob_pmf_of_spmf: "spmf_prob p A = weight_spmf p * pmf_prob (pmf_of_spmf p) A" apply (subst scale_weight_spmf_of_pmf) apply (unfold spmf_prob_def) apply (subst measure_spmf_scale_spmf') subgoal using weight_spmf_le_1 . by (simp add: pmf_prob_def) lemma cond_spmf_Int: "cond_spmf (cond_spmf p A) B = cond_spmf p (A \ B)" apply (rule spmf_eqI) apply (unfold spmf_cond_spmf) apply(auto simp add: measure_cond_spmf split: if_split_asm) using Int_lower1[THEN measure_spmf.finite_measure_mono[simplified]] measure_le_0_iff by metis lemma cond_spmf_prob: "spmf_prob p (A \ B) = spmf_prob (cond_spmf p A) B * spmf_prob p A" unfolding spmf_prob_def measure_cond_spmf using Int_lower1[THEN measure_spmf.finite_measure_mono[simplified]] measure_le_0_iff by (metis mult_eq_0_iff nonzero_eq_divide_eq) definition "empty_spmf = return_pmf None" lemma spmf_prob_empty: "spmf_prob empty_spmf A = 0" unfolding spmf_prob_def empty_spmf_def by simp definition le_spmf :: "'a spmf \ 'a spmf \ bool" where "le_spmf p q \ (\k\1. p = scale_spmf k q)" definition lt_spmf :: "'a spmf \ 'a spmf \ bool" where "lt_spmf p q \ (\k<1. p = scale_spmf k q)" lemma "class.order_bot empty_spmf le_spmf lt_spmf" oops lemma spmf_prob_cond_Int: "spmf_prob (cond_spmf p C) (A \ B) = spmf_prob (cond_spmf p (B \ C)) A * spmf_prob (cond_spmf p C) B" apply (subst Int_commute[of B C]) apply (subst Int_commute[of A B]) apply (fold cond_spmf_Int) using cond_spmf_prob . lemma cond_spmf_mk_lossless: "cond_spmf (mk_lossless p) A = cond_spmf p A" apply (fold cond_spmf_UNIV) apply (unfold cond_spmf_Int) by simp primrec sequence_spmf :: "'a spmf list \ 'a list spmf" where "sequence_spmf [] = return_spmf []" | "sequence_spmf (x#xs) = map_spmf (case_prod Cons) (pair_spmf x (sequence_spmf xs))" lemma set_sequence_spmf: "set_spmf (sequence_spmf xs) = {l. list_all2 (\x s. x \ set_spmf s) l xs}" by (induction xs) (auto simp: list_all2_Cons2) lemma map_spmf_map_sequence: "map_spmf (map f) (sequence_spmf xs) = sequence_spmf (map (map_spmf f) xs)" apply (induction xs) subgoal by simp subgoal premises IH unfolding list.map unfolding sequence_spmf.simps apply (fold IH) apply (unfold pair_map_spmf) apply (unfold spmf.map_comp) by (simp add: comp_def case_prod_map_prod prod.case_distrib) done lemma sequence_map_return_spmf: "sequence_spmf (map return_spmf xs) = return_spmf xs" by (induction xs) auto lemma sequence_bind_cong: "\xs=ys; \y. length y = length ys \ f y = g y\ \ bind_spmf (sequence_spmf xs) f = bind_spmf (sequence_spmf ys) g" apply (rule bind_spmf_cong) subgoal by simp subgoal unfolding set_sequence_spmf list_all2_iff by simp done lemma bind_spmf_sequence_replicate_cong: "(\l. length l = n \ f l = g l) \ bind_spmf (sequence_spmf (replicate n x)) f = bind_spmf (sequence_spmf (replicate n x)) g" by (rule bind_spmf_cong[OF refl]) (simp add: set_spmf_of_set finite_permutations set_sequence_spmf[unfolded list_all2_iff]) lemma bind_spmf_sequence_map_cong: "(\l. length l = length x \ f l = g l) \ bind_spmf (sequence_spmf (map m x)) f = bind_spmf (sequence_spmf (map m x)) g" by (rule bind_spmf_cong[OF refl]) (simp add: set_spmf_of_set finite_permutations set_sequence_spmf[unfolded list_all2_iff]) lemma lossless_pair_spmf_iff: "lossless_spmf (pair_spmf a b) \ lossless_spmf a \ lossless_spmf b" unfolding pair_spmf_alt_def by (auto simp: set_spmf_eq_empty) lemma lossless_sequence_spmf: "(\x. x\set xs \ lossless_spmf x) \ lossless_spmf (sequence_spmf xs)" by (induction xs) (auto simp: lossless_pair_spmf_iff) end \ No newline at end of file diff --git a/thys/Approximation_Algorithms/Approx_BP_Hoare.thy b/thys/Approximation_Algorithms/Approx_BP_Hoare.thy --- a/thys/Approximation_Algorithms/Approx_BP_Hoare.thy +++ b/thys/Approximation_Algorithms/Approx_BP_Hoare.thy @@ -1,1708 +1,1708 @@ section \Bin Packing\ theory Approx_BP_Hoare imports Complex_Main "HOL-Hoare.Hoare_Logic" "HOL-Library.Disjoint_Sets" begin text \The algorithm and proofs are based on the work by Berghammer and Reuter \<^cite>\BerghammerR03\.\ subsection \Formalization of a Correct Bin Packing\ text \Definition of the unary operator \\\\\ from the article. \B\ will only be wrapped into a set if it is non-empty.\ definition wrap :: "'a set \ 'a set set" where "wrap B = (if B = {} then {} else {B})" lemma wrap_card: "card (wrap B) \ 1" unfolding wrap_def by auto text \If \M\ and \N\ are pairwise disjoint with \V\ and not yet contained in V, then the union of \M\ and \N\ is also pairwise disjoint with \V\.\ lemma pairwise_disjnt_Un: assumes "pairwise disjnt ({M} \ {N} \ V)" "M \ V" "N \ V" shows "pairwise disjnt ({M \ N} \ V)" using assms unfolding pairwise_def by auto text \A Bin Packing Problem is defined like in the article:\ locale BinPacking = fixes U :: "'a set" \ \A finite, non-empty set of objects\ and w :: "'a \ real" \ \A mapping from objects to their respective weights (positive real numbers)\ and c :: nat \ \The maximum capacity of a bin (a natural number)\ and S :: "'a set" \ \The set of \small\ objects (weight no larger than \1/2\ of \c$$\ and L :: "'a set" \ \The set of \large\ objects (weight larger than \1/2\ of \c\)\ assumes weight: "\u \ U. 0 < w(u) \ w(u) \ c" and U_Finite: "finite U" and U_NE: "U \ {}" and S_def: "S = {u \ U. w(u) \ c / 2}" and L_def: "L = U - S" begin text \In the article, this is defined as \w\ as well. However, to avoid ambiguity, we will abbreviate the weight of a bin as \W\.\ abbreviation W :: "'a set \ real" where "W B \ (\u \ B. w(u))" text \\P\ constitutes as a correct bin packing if \P\ is a partition of \U\ (as defined in @{thm [source] partition_on_def}) and the weights of the bins do not exceed their maximum capacity \c\.\ definition bp :: "'a set set \ bool" where "bp P \ partition_on U P \ (\B \ P. W(B) \ c)" lemma bpE: assumes "bp P" shows "pairwise disjnt P" "{} \ P" "\P = U" "\B \ P. W(B) \ c" using assms unfolding bp_def partition_on_def by blast+ lemma bpI: assumes "pairwise disjnt P" "{} \ P" "\P = U" "\B \ P. W(B) \ c" shows "bp P" using assms unfolding bp_def partition_on_def by blast text \Although we assume the \S\ and \L\ sets as given, manually obtaining them from \U\ is trivial and can be achieved in linear time. Proposed by the article \<^cite>\"BerghammerR03"\.\ lemma S_L_set_generation: "VARS S L W u {True} S := {}; L := {}; W := U; WHILE W \ {} INV {W \ U \ S = {v \ U - W. w(v) \ c / 2} \ L = {v \ U - W. w(v) > c / 2}} DO u := (SOME u. u \ W); IF 2 * w(u) \ c THEN S := S \ {u} ELSE L := L \ {u} FI; W := W - {u} OD {S = {v \ U. w(v) \ c / 2} \ L = {v \ U. w(v) > c / 2}}" by vcg (auto simp: some_in_eq) subsection \The Proposed Approximation Algorithm\ subsubsection \Functional Correctness\ text \According to the article, \inv\<^sub>1\ holds if \P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V}\ is a correct solution for the bin packing problem \<^cite>\BerghammerR03\. However, various assumptions made in the article seem to suggest that more information is demanded from this invariant and, indeed, mere correctness (as defined in @{thm [source] bp_def}) does not appear to suffice. To amend this, four additional conjuncts have been added to this invariant, whose necessity will be explained in the following proofs. It should be noted that there may be other (shorter) ways to amend this invariant. This approach, however, makes for rather straight-forward proofs, as these conjuncts can be utilized and proved in relatively few steps.\ definition inv\<^sub>1 :: "'a set set \ 'a set set \ 'a set \ 'a set \ 'a set \ bool" where "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V \ bp (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V}) \ \A correct solution to the bin packing problem\ \ $$P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2) = U - V \ \The partial solution does not contain objects that have not yet been assigned\ \ B\<^sub>1 \ (P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2) \ \\B\<^sub>1\ is distinct from all the other bins\ \ B\<^sub>2 \ (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2) \ \\B\<^sub>2\ is distinct from all the other bins\ \ (P\<^sub>1 \ wrap B\<^sub>1) \ (P\<^sub>2 \ wrap B\<^sub>2) = {} \ \The first and second partial solutions are disjoint from each other.\" (* lemma "partition_on U (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V}) \ u \ V \ partition_on U (P\<^sub>1 \ wrap (insert u B\<^sub>1) \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ (V-{u})})" nitpick*) lemma inv\<^sub>1E: assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" shows "bp (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V})" and "\(P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2) = U - V" and "B\<^sub>1 \ (P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2)" and "B\<^sub>2 \ (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2)" and "(P\<^sub>1 \ wrap B\<^sub>1) \ (P\<^sub>2 \ wrap B\<^sub>2) = {}" using assms unfolding inv\<^sub>1_def by auto lemma inv\<^sub>1I: assumes "bp (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V})" and "\(P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2) = U - V" and "B\<^sub>1 \ (P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2)" and "B\<^sub>2 \ (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2)" and "(P\<^sub>1 \ wrap B\<^sub>1) \ (P\<^sub>2 \ wrap B\<^sub>2) = {}" shows "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" using assms unfolding inv\<^sub>1_def by blast lemma wrap_Un [simp]: "wrap (M \ {x}) = {M \ {x}}" unfolding wrap_def by simp lemma wrap_empty [simp]: "wrap {} = {}" unfolding wrap_def by simp lemma wrap_not_empty [simp]: "M \ {} \ wrap M = {M}" unfolding wrap_def by simp text \If \inv\<^sub>1\ holds for the current partial solution, and the weight of an object \u \ V\ added to \B\<^sub>1\ does not exceed its capacity, then \inv\<^sub>1\ also holds if \B\<^sub>1\ and \{u}\ are replaced by \B\<^sub>1 \ {u}\.\ lemma inv\<^sub>1_stepA: assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "u \ V" "W(B\<^sub>1) + w(u) \ c" shows "inv\<^sub>1 P\<^sub>1 P\<^sub>2 (B\<^sub>1 \ {u}) B\<^sub>2 (V - {u})" proof - note invrules = inv\<^sub>1E[OF assms(1)] and bprules = bpE[OF invrules(1)] text \In the proof for \Theorem 3.2\ of the article it is erroneously argued that if \P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V}\ is a partition of \U\, then the same holds if \B\<^sub>1\ is replaced by \B\<^sub>1 \ {u}\. This is, however, not necessarily the case if \B\<^sub>1\ or \{u}\ are already contained in the partial solution. Suppose \P\<^sub>1\ contains the non-empty bin \B\<^sub>1\, then \P\<^sub>1 \ wrap B\<^sub>1\ would still be pairwise disjoint, provided \P\<^sub>1\ was pairwise disjoint before, as the union simply ignores the duplicate \B\<^sub>1\. Now, if the algorithm modifies \B\<^sub>1\ by adding an element from \V\ such that \B\<^sub>1\ becomes some non-empty \B\<^sub>1'\ with \B\<^sub>1 \ B\<^sub>1' \ \\ and \B\<^sub>1' \ P\<^sub>1\, one can see that this property would no longer be preserved. To avoid such a situation, we will use the first additional conjunct in \inv\<^sub>1\ to ensure that \{u}\ is not yet contained in the partial solution, and the second additional conjunct to ensure that \B\<^sub>1\ is not yet contained in the partial solution.\ \ \Rule 1: Pairwise Disjoint\ have NOTIN: "\M \ P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}}. u \ M" using invrules(2) assms(2) by blast have "{{v} |v. v \ V} = {{u}} \ {{v} |v. v \ V - {u}}" using assms(2) by blast then have "pairwise disjnt (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ ({{u}} \ {{v} |v. v \ V - {u}}))" using bprules(1) assms(2) by simp then have "pairwise disjnt (wrap B\<^sub>1 \ {{u}} \ P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}})" by (simp add: Un_commute) then have assm: "pairwise disjnt (wrap B\<^sub>1 \ {{u}} \ (P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}}))" by (simp add: Un_assoc) have "pairwise disjnt ({B\<^sub>1 \ {u}} \ (P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}}))" proof (cases \B\<^sub>1 = {}$$ case True with assm show ?thesis by simp next case False with assm have assm: "pairwise disjnt ({B\<^sub>1} \ {{u}} \ (P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}}))" by simp from NOTIN have "{u} \ P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}}" by blast from pairwise_disjnt_Un[OF assm _ this] invrules(2,3) show ?thesis using False by auto qed then have 1: "pairwise disjnt (P\<^sub>1 \ wrap (B\<^sub>1 \ {u}) \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}})" unfolding wrap_Un by simp \ \Rule 2: No empty sets\ from bprules(2) have 2: "{} \ P\<^sub>1 \ wrap (B\<^sub>1 \ {u}) \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}}" unfolding wrap_def by simp \ \Rule 3: Union preserved\ from bprules(3) have "\ (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{u}} \ {{v} |v. v \ V - {u}}) = U" using assms(2) by blast then have 3: "\ (P\<^sub>1 \ wrap (B\<^sub>1 \ {u}) \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}}) = U" unfolding wrap_def by force \ \Rule 4: Weights below capacity\ have "0 < w u" using weight assms(2) bprules(3) by blast have "finite B\<^sub>1" using bprules(3) U_Finite by (cases \B\<^sub>1 = {}\) auto then have "W (B\<^sub>1 \ {u}) \ W B\<^sub>1 + w u" using \0 < w u\ by (cases \u \ B\<^sub>1\) (auto simp: insert_absorb) also have "... \ c" using assms(3) . finally have "W (B\<^sub>1 \ {u}) \ c" . then have "\B \ wrap (B\<^sub>1 \ {u}). W B \ c" unfolding wrap_Un by blast moreover have "\B\P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}}. W B \ c" using bprules(4) by blast ultimately have 4: "\B\P\<^sub>1 \ wrap (B\<^sub>1 \ {u}) \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}}. W B \ c" by blast from bpI[OF 1 2 3 4] have 1: "bp (P\<^sub>1 \ wrap (B\<^sub>1 \ {u}) \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}})" . \ \Auxiliary information is preserved\ have "u \ U" using assms(2) bprules(3) by blast then have R: "U - (V - {u}) = U - V \ {u}" by blast have L: "\ (P\<^sub>1 \ wrap (B\<^sub>1 \ {u}) \ P\<^sub>2 \ wrap B\<^sub>2) = \ (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2) \ {u}" unfolding wrap_def using NOTIN by auto have 2: "\ (P\<^sub>1 \ wrap (B\<^sub>1 \ {u}) \ P\<^sub>2 \ wrap B\<^sub>2) = U - (V - {u})" unfolding L R invrules(2) .. have 3: "B\<^sub>1 \ {u} \ P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2" using NOTIN by auto have 4: "B\<^sub>2 \ P\<^sub>1 \ wrap (B\<^sub>1 \ {u}) \ P\<^sub>2" using invrules(4) NOTIN unfolding wrap_def by fastforce have 5: "(P\<^sub>1 \ wrap (B\<^sub>1 \ {u})) \ (P\<^sub>2 \ wrap B\<^sub>2) = {}" using invrules(5) NOTIN unfolding wrap_Un by auto from inv\<^sub>1I[OF 1 2 3 4 5] show ?thesis . qed text \If \inv\<^sub>1\ holds for the current partial solution, and the weight of an object \u \ V\ added to \B\<^sub>2\ does not exceed its capacity, then \inv\<^sub>1\ also holds if \B\<^sub>2\ and \{u}\ are replaced by \B\<^sub>2 \ {u}\.\ lemma inv\<^sub>1_stepB: assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "u \ V" "W B\<^sub>2 + w u \ c" shows "inv\<^sub>1 (P\<^sub>1 \ wrap B\<^sub>1) P\<^sub>2 {} (B\<^sub>2 \ {u}) (V - {u})" proof - note invrules = inv\<^sub>1E[OF assms(1)] and bprules = bpE[OF invrules(1)] text \The argumentation here is similar to the one in @{thm [source] inv\<^sub>1_stepA} with \B\<^sub>1\ replaced with \B\<^sub>2\ and using the first and third additional conjuncts of \inv\<^sub>1\ to amend the issue, instead of the first and second.\ \ \Rule 1: Pairwise Disjoint\ have NOTIN: "\M \ P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}}. u \ M" using invrules(2) assms(2) by blast have "{{v} |v. v \ V} = {{u}} \ {{v} |v. v \ V - {u}}" using assms(2) by blast then have "pairwise disjnt (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{u}} \ {{v} |v. v \ V - {u}})" using bprules(1) assms(2) by simp then have assm: "pairwise disjnt (wrap B\<^sub>2 \ {{u}} \ (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ {{v} |v. v \ V - {u}}))" by (simp add: Un_assoc Un_commute) have "pairwise disjnt ({B\<^sub>2 \ {u}} \ (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ {{v} |v. v \ V - {u}}))" proof (cases \B\<^sub>2 = {}\) case True with assm show ?thesis by simp next case False with assm have assm: "pairwise disjnt ({B\<^sub>2} \ {{u}} \ (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ {{v} |v. v \ V - {u}}))" by simp from NOTIN have "{u} \ P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ {{v} |v. v \ V - {u}}" by blast from pairwise_disjnt_Un[OF assm _ this] invrules(2,4) show ?thesis using False by auto qed then have 1: "pairwise disjnt (P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ P\<^sub>2 \ wrap (B\<^sub>2 \ {u}) \ {{v} |v. v \ V - {u}})" unfolding wrap_Un by simp \ \Rule 2: No empty sets\ from bprules(2) have 2: "{} \ P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ P\<^sub>2 \ wrap (B\<^sub>2 \ {u}) \ {{v} |v. v \ V - {u}}" unfolding wrap_def by simp \ \Rule 3: Union preserved\ from bprules(3) have "\ (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{u}} \ {{v} |v. v \ V - {u}}) = U" using assms(2) by blast then have 3: "\ (P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ P\<^sub>2 \ wrap (B\<^sub>2 \ {u}) \ {{v} |v. v \ V - {u}}) = U" unfolding wrap_def by force \ \Rule 4: Weights below capacity\ have "0 < w u" using weight assms(2) bprules(3) by blast have "finite B\<^sub>2" using bprules(3) U_Finite by (cases \B\<^sub>2 = {}\) auto then have "W (B\<^sub>2 \ {u}) \ W B\<^sub>2 + w u" using \0 < w u\ by (cases \u \ B\<^sub>2\) (auto simp: insert_absorb) also have "... \ c" using assms(3) . finally have "W (B\<^sub>2 \ {u}) \ c" . then have "\B \ wrap (B\<^sub>2 \ {u}). W B \ c" unfolding wrap_Un by blast moreover have "\B\P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ {{v} |v. v \ V - {u}}. W B \ c" using bprules(4) by blast ultimately have 4: "\B\P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ P\<^sub>2 \ wrap (B\<^sub>2 \ {u}) \ {{v} |v. v \ V - {u}}. W B \ c" by auto from bpI[OF 1 2 3 4] have 1: "bp (P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ P\<^sub>2 \ wrap (B\<^sub>2 \ {u}) \ {{v} |v. v \ V - {u}})" . \ \Auxiliary information is preserved\ have "u \ U" using assms(2) bprules(3) by blast then have R: "U - (V - {u}) = U - V \ {u}" by blast have L: "\ (P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ P\<^sub>2 \ wrap (B\<^sub>2 \ {u})) = \ (P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ P\<^sub>2 \ wrap B\<^sub>2) \ {u}" unfolding wrap_def using NOTIN by auto have 2: "\ (P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ P\<^sub>2 \ wrap (B\<^sub>2 \ {u})) = U - (V - {u})" unfolding L R using invrules(2) by simp have 3: "{} \ P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap (B\<^sub>2 \ {u})" using bpE(2)[OF 1] by simp have 4: "B\<^sub>2 \ {u} \ P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ P\<^sub>2" using NOTIN by auto have 5: "(P\<^sub>1 \ wrap B\<^sub>1 \ wrap {}) \ (P\<^sub>2 \ wrap (B\<^sub>2 \ {u})) = {}" using invrules(5) NOTIN unfolding wrap_empty wrap_Un by auto from inv\<^sub>1I[OF 1 2 3 4 5] show ?thesis . qed text \If \inv\<^sub>1\ holds for the current partial solution, then \inv\<^sub>1\ also holds if \B\<^sub>1\ and \B\<^sub>2\ are added to \P\<^sub>1\ and \P\<^sub>2\ respectively, \B\<^sub>1\ is emptied and \B\<^sub>2\ initialized with \u \ V\.\ lemma inv\<^sub>1_stepC: assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "u \ V" shows "inv\<^sub>1 (P\<^sub>1 \ wrap B\<^sub>1) (P\<^sub>2 \ wrap B\<^sub>2) {} {u} (V - {u})" proof - note invrules = inv\<^sub>1E[OF assms(1)] \ \Rule 1-4: Correct Bin Packing\ have "P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ (P\<^sub>2 \ wrap B\<^sub>2) \ wrap {u} \ {{v} |v. v \ V - {u}} = P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{u}} \ {{v} |v. v \ V - {u}}" by (metis (no_types, lifting) Un_assoc Un_empty_right insert_not_empty wrap_empty wrap_not_empty) also have "... = P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V}" using assms(2) by auto finally have EQ: "P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ (P\<^sub>2 \ wrap B\<^sub>2) \ wrap {u} \ {{v} |v. v \ V - {u}} = P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V}" . from invrules(1) have 1: "bp (P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ (P\<^sub>2 \ wrap B\<^sub>2) \ wrap {u} \ {{v} |v. v \ V - {u}})" unfolding EQ . \ \Auxiliary information is preserved\ have NOTIN: "\M \ P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}}. u \ M" using invrules(2) assms(2) by blast have "u \ U" using assms(2) bpE(3)[OF invrules(1)] by blast then have R: "U - (V - {u}) = U - V \ {u}" by blast have L: "\ (P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ (P\<^sub>2 \ wrap B\<^sub>2) \ wrap {u}) = \ (P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ (P\<^sub>2 \ wrap B\<^sub>2)) \ {u}" unfolding wrap_def using NOTIN by auto have 2: "\ (P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ (P\<^sub>2 \ wrap B\<^sub>2) \ wrap {u}) = U - (V - {u})" unfolding L R using invrules(2) by auto have 3: "{} \ P\<^sub>1 \ wrap B\<^sub>1 \ (P\<^sub>2 \ wrap B\<^sub>2) \ wrap {u}" using bpE(2)[OF 1] by simp have 4: "{u} \ P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ (P\<^sub>2 \ wrap B\<^sub>2)" using NOTIN by auto have 5: "(P\<^sub>1 \ wrap B\<^sub>1 \ wrap {}) \ (P\<^sub>2 \ wrap B\<^sub>2 \ wrap {u}) = {}" using invrules(5) NOTIN unfolding wrap_def by force from inv\<^sub>1I[OF 1 2 3 4 5] show ?thesis . qed text \A simplified version of the bin packing algorithm proposed in the article. It serves as an introduction into the approach taken, and, while it does not provide the desired approximation factor, it does ensure that \P\ is a correct solution of the bin packing problem.\ lemma simple_bp_correct: "VARS P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V u {True} P\<^sub>1 := {}; P\<^sub>2 := {}; B\<^sub>1 := {}; B\<^sub>2 := {}; V := U; WHILE V \ S \ {} INV {inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V} DO u := (SOME u. u \ V); V := V - {u}; IF W(B\<^sub>1) + w(u) \ c THEN B\<^sub>1 := B\<^sub>1 \ {u} ELSE IF W(B\<^sub>2) + w(u) \ c THEN B\<^sub>2 := B\<^sub>2 \ {u} ELSE P\<^sub>2 := P\<^sub>2 \ wrap B\<^sub>2; B\<^sub>2 := {u} FI; P\<^sub>1 := P\<^sub>1 \ wrap B\<^sub>1; B\<^sub>1 := {} FI OD; P := P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} | v. v \ V} {bp P}" proof (vcg, goal_cases) case (1 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V u) show ?case unfolding bp_def partition_on_def pairwise_def wrap_def inv\<^sub>1_def using weight by auto next case (2 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V u) then have INV: "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" .. from 2 have "V \ {}" by blast then have IN: "(SOME u. u \ V) \ V" by (simp add: some_in_eq) from inv\<^sub>1_stepA[OF INV IN] inv\<^sub>1_stepB[OF INV IN] inv\<^sub>1_stepC[OF INV IN] show ?case by blast next case (3 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V u) then show ?case unfolding inv\<^sub>1_def by blast qed subsubsection \Lower Bounds for the Bin Packing Problem\ lemma bp_bins_finite [simp]: assumes "bp P" shows "\B \ P. finite B" using bpE(3)[OF assms] U_Finite by (meson Sup_upper finite_subset) lemma bp_sol_finite [simp]: assumes "bp P" shows "finite P" using bpE(3)[OF assms] U_Finite by (simp add: finite_UnionD) text \If \P\ is a solution of the bin packing problem, then no bin in \P\ may contain more than one large object.\ lemma only_one_L_per_bin: assumes "bp P" "B \ P" shows "\x \ B. \y \ B. x \ y \ x \ L \ y \ L" proof (rule ccontr, simp) assume "\x\B. \y\B. x \ y \ x \ L \ y \ L" then obtain x y where *: "x \ B" "y \ B" "x \ y" "x \ L" "y \ L" by blast then have "c < w x + w y" using L_def S_def by force have "finite B" using assms by simp have "y \ B - {x}" using *(2,3) by blast have "W B = W (B - {x}) + w x" using *(1) \finite B\ by (simp add: sum.remove) also have "... = W (B - {x} - {y}) + w x + w y" using \y \ B - {x}\ \finite B\ by (simp add: sum.remove) finally have *: "W B = W (B - {x} - {y}) + w x + w y" . have "\u \ B. 0 < w u" using bpE(3)[OF assms(1)] assms(2) weight by blast - then have "0 \ W (B - {x} - {y})" by (smt DiffD1 sum_nonneg) + then have "0 \ W (B - {x} - {y})" by (smt (verit) DiffD1 sum_nonneg) with * have "c < W B" using \c < w x + w y\ by simp then show False using bpE(4)[OF assms(1)] assms(2) by fastforce qed text \If \P\ is a solution of the bin packing problem, then the amount of large objects is a lower bound for the amount of bins in P.\ lemma L_lower_bound_card: assumes "bp P" shows "card L \ card P" proof - have "\x \ L. \B \ P. x \ B" using bpE(3)[OF assms] L_def by blast then obtain f where f_def: "\u \ L. u \ f u \ f u \ P" by metis then have "inj_on f L" unfolding inj_on_def using only_one_L_per_bin[OF assms] by blast then have card_eq: "card L = card (f  L)" by (simp add: card_image) have "f  L \ P" using f_def by blast moreover have "finite P" using assms by simp ultimately have "card (f  L) \ card P" by (simp add: card_mono) then show ?thesis unfolding card_eq . qed text \If \P\ is a solution of the bin packing problem, then the amount of bins of a subset of P in which every bin contains a large object is a lower bound on the amount of large objects.\ lemma subset_bp_card: assumes "bp P" "M \ P" "\B \ M. B \ L \ {}" shows "card M \ card L" proof - have "\B \ M. \u \ L. u \ B" using assms(3) by fast then have "\f. \B \ M. f B \ L \ f B \ B" by metis then obtain f where f_def: "\B \ M. f B \ L \ f B \ B" .. have "inj_on f M" proof (rule ccontr) assume "\ inj_on f M" then have "\x \ M. \y \ M. x \ y \ f x = f y" unfolding inj_on_def by blast then obtain x y where *: "x \ M" "y \ M" "x \ y" "f x = f y" by blast then have "\u. u \ x \ u \ y" using f_def by metis then have "x \ y \ {}" by blast moreover have "pairwise disjnt M" using pairwise_subset[OF bpE(1)[OF assms(1)] assms(2)] . ultimately show False using * unfolding pairwise_def disjnt_def by simp qed moreover have "finite L" using L_def U_Finite by blast moreover have "f  M \ L" using f_def by blast ultimately show ?thesis using card_inj_on_le by blast qed text \If \P\ is a correct solution of the bin packing problem, \inv\<^sub>1\ holds for the partial solution, and every bin in \P\<^sub>1 \ wrap B\<^sub>1\ contains a large object, then the amount of bins in \P\<^sub>1 \ wrap B\<^sub>1 \ {{v} |v. v \ V \ L}\ is a lower bound for the amount of bins in \P\.\ lemma L_bins_lower_bound_card: assumes "bp P" "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "\B \ P\<^sub>1 \ wrap B\<^sub>1. B \ L \ {}" shows "card (P\<^sub>1 \ wrap B\<^sub>1 \ {{v} |v. v \ V \ L}) \ card P" proof - note invrules = inv\<^sub>1E[OF assms(2)] have "\B \ {{v} |v. v \ V \ L}. B \ L \ {}" by blast with assms(3) have "P\<^sub>1 \ wrap B\<^sub>1 \ {{v} |v. v \ V \ L} \ P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V}" "\B \ P\<^sub>1 \ wrap B\<^sub>1 \ {{v} |v. v \ V \ L}. B \ L \ {}" by blast+ from subset_bp_card[OF invrules(1) this] show ?thesis using L_lower_bound_card[OF assms(1)] by linarith qed text \If \P\ is a correct solution of the bin packing problem, then the sum of the weights of the objects is equal to the sum of the weights of the bins in \P\.\ lemma sum_Un_eq_sum_sum: assumes "bp P" shows "(\u \ U. w u) = (\B \ P. W B)" proof - have FINITE: "\B \ P. finite B" using assms by simp have DISJNT: "\A \ P. \B \ P. A \ B \ A \ B = {}" using bpE(1)[OF assms] unfolding pairwise_def disjnt_def . have "(\u \ (\P). w u) = (\B \ P. W B)" using sum.Union_disjoint[OF FINITE DISJNT] by auto then show ?thesis unfolding bpE(3)[OF assms] . qed text \If \P\ is a correct solution of the bin packing problem, then the sum of the weights of the items is a lower bound of amount of bins in \P\ multiplied by their maximum capacity.\ lemma sum_lower_bound_card: assumes "bp P" shows "(\u \ U. w u) \ c * card P" proof - have *: "\B \ P. 0 < W B \ W B \ c" using bpE(2-4)[OF assms] weight by (metis UnionI assms bp_bins_finite sum_pos) have "(\u \ U. w u) = (\B \ P. W B)" using sum_Un_eq_sum_sum[OF assms] . also have "... \ (\B \ P. c)" using sum_mono * by fastforce also have "... = c * card P" by simp finally show ?thesis . qed lemma bp_NE: assumes "bp P" shows "P \ {}" using U_NE bpE(3)[OF assms] by blast lemma sum_Un_ge: fixes f :: "_ \ real" assumes "finite M" "finite N" "\B \ M \ N. 0 < f B" shows "sum f M \ sum f (M \ N)" proof - have "0 \ sum f N - sum f (M \ N)" - using assms by (smt DiffD1 inf.cobounded2 UnCI sum_mono2) + using assms by (smt (verit) DiffD1 inf.cobounded2 UnCI sum_mono2) then have "sum f M \ sum f M + sum f N - sum f (M \ N)" by simp also have "... = sum f (M \ N)" using sum_Un[OF assms(1,2), symmetric] . finally show ?thesis . qed text \If \bij_exists\ holds, one can obtain a function which is bijective between the bins in \P\ and the objects in \V\ such that an object returned by the function would cause the bin to exceed its capacity.\ definition bij_exists :: "'a set set \ 'a set \ bool" where "bij_exists P V = (\f. bij_betw f P V \ (\B \ P. W B + w (f B) > c))" text \If \P\ is a functionally correct solution of the bin packing problem, \inv\<^sub>1\ holds for the partial solution, and such a bijective function exists between the bins in \P\<^sub>1\ and the objects in @{term "P\<^sub>2 \ wrap B\<^sub>2"}, the following strict lower bound can be shown:\ lemma P\<^sub>1_lower_bound_card: assumes "bp P" "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "bij_exists P\<^sub>1 ($$P\<^sub>2 \ wrap B\<^sub>2))" shows "card P\<^sub>1 + 1 \ card P" proof (cases \P\<^sub>1 = {}$$ case True have "finite P" using assms(1) by simp then have "1 \ card P" using bp_NE[OF assms(1)] by (metis Nat.add_0_right Suc_diff_1 Suc_le_mono card_gt_0_iff le0 mult_Suc_right nat_mult_1) then show ?thesis unfolding True by simp next note invrules = inv\<^sub>1E[OF assms(2)] case False obtain f where f_def: "bij_betw f P\<^sub>1 ($$P\<^sub>2 \ wrap B\<^sub>2))" "\B \ P\<^sub>1. W B + w (f B) > c" using assms(3) unfolding bij_exists_def by blast have FINITE: "finite P\<^sub>1" "finite (P\<^sub>2 \ wrap B\<^sub>2)" "finite (P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2)" "finite (wrap B\<^sub>1 \ {{v} |v. v \ V})" using inv\<^sub>1E(1)[OF assms(2)] bp_sol_finite by blast+ have F: "\B \ P\<^sub>2 \ wrap B\<^sub>2. finite B" using invrules(1) by simp have D: "\A \ P\<^sub>2 \ wrap B\<^sub>2. \B \ P\<^sub>2 \ wrap B\<^sub>2. A \ B \ A \ B = {}" using bpE(1)[OF invrules(1)] unfolding pairwise_def disjnt_def by auto have sum_eq: "W (\ (P\<^sub>2 \ wrap B\<^sub>2)) = (\B \ P\<^sub>2 \ wrap B\<^sub>2. W B)" using sum.Union_disjoint[OF F D] by auto have "\B\P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V}. 0 < W B" using bpE(2,3)[OF invrules(1)] weight by (metis (no_types, lifting) UnionI bp_bins_finite invrules(1) sum_pos) then have "(\B \ P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2. W B) \ (\B \ P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ (wrap B\<^sub>1 \ {{v} |v. v \ V}). W B)" using sum_Un_ge[OF FINITE(3,4), of W] by blast - also have "... = (\B \ P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V}. W B)" by (smt Un_assoc Un_commute) + also have "... = (\B \ P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V}. W B)" by (smt (verit) Un_assoc Un_commute) also have "... = W U" using sum_Un_eq_sum_sum[OF invrules(1), symmetric] . finally have *: "(\B \ P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2. W B) \ W U" . \ \This follows from the fourth and final additional conjunct of \inv\<^sub>1\ and is necessary to combine the sums of the bins of the two partial solutions. This does not inherently follow from the union being a correct solution, as this need not be the case if \P\<^sub>1\ and \P\<^sub>2 \ wrap B\<^sub>2\ happened to be equal.\ have DISJNT: "P\<^sub>1 \ (P\<^sub>2 \ wrap B\<^sub>2) = {}" using invrules(5) by blast \ \This part of the proof is based on the proof on page 72 of the article \<^cite>\BerghammerR03\.\ have "c * card P\<^sub>1 = (\B \ P\<^sub>1. c)" by simp also have "... < (\B \ P\<^sub>1. W B + w (f B))" using f_def(2) sum_strict_mono[OF FINITE(1) False] by fastforce also have "... = (\B \ P\<^sub>1. W B) + (\B \ P\<^sub>1. w (f B))" by (simp add: Groups_Big.comm_monoid_add_class.sum.distrib) also have "... = (\B \ P\<^sub>1. W B) + W (\ (P\<^sub>2 \ wrap B\<^sub>2))" unfolding sum.reindex_bij_betw[OF f_def(1), of w] .. also have "... = (\B \ P\<^sub>1. W B) + (\B \ P\<^sub>2 \ wrap B\<^sub>2. W B)" unfolding sum_eq .. also have "... = (\B \ P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2. W B)" using sum.union_disjoint[OF FINITE(1,2) DISJNT, of W] by (simp add: Un_assoc) also have "... \ (\u \ U. w u)" using * . also have "... \ c * card P" using sum_lower_bound_card[OF assms(1)] . finally show ?thesis by (simp flip: of_nat_mult) qed text \As @{thm wrap_card} holds, it follows that the amount of bins in \P\<^sub>1 \ wrap B\<^sub>1\ are a lower bound for the amount of bins in \P\.\ lemma P\<^sub>1_B\<^sub>1_lower_bound_card: assumes "bp P" "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "bij_exists P\<^sub>1 (\(P\<^sub>2 \ wrap B\<^sub>2))" shows "card (P\<^sub>1 \ wrap B\<^sub>1) \ card P" proof - have "card (P\<^sub>1 \ wrap B\<^sub>1) \ card P\<^sub>1 + card (wrap B\<^sub>1)" using card_Un_le by blast also have "... \ card P\<^sub>1 + 1" using wrap_card by simp also have "... \ card P" using P\<^sub>1_lower_bound_card[OF assms] . finally show ?thesis . qed text \If \inv\<^sub>1\ holds, there are at most half as many bins in \P\<^sub>2\ as there are objects in \P\<^sub>2\, and we can again obtain a bijective function between the bins in \P\<^sub>1\ and the objects of the second partial solution, then the amount of bins in the second partial solution are a strict lower bound for half the bins of the first partial solution.\ lemma P\<^sub>2_B\<^sub>2_lower_bound_P\<^sub>1: assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "2 * card P\<^sub>2 \ card (\P\<^sub>2)" "bij_exists P\<^sub>1 (\(P\<^sub>2 \ wrap B\<^sub>2))" shows "2 * card (P\<^sub>2 \ wrap B\<^sub>2) \ card P\<^sub>1 + 1" proof - note invrules = inv\<^sub>1E[OF assms(1)] and bprules = bpE[OF invrules(1)] have "pairwise disjnt (P\<^sub>2 \ wrap B\<^sub>2)" using bprules(1) pairwise_subset by blast moreover have "B\<^sub>2 \ P\<^sub>2" using invrules(4) by simp ultimately have DISJNT: "\P\<^sub>2 \ B\<^sub>2 = {}" by (auto, metis (no_types, opaque_lifting) sup_bot.right_neutral Un_insert_right disjnt_iff mk_disjoint_insert pairwise_insert wrap_Un) have "finite (\P\<^sub>2)" using U_Finite bprules(3) by auto have "finite B\<^sub>2" using bp_bins_finite[OF invrules(1)] wrap_not_empty by blast have "finite P\<^sub>2" "finite (wrap B\<^sub>2)" using bp_sol_finite[OF invrules(1)] by blast+ have DISJNT2: "P\<^sub>2 \ wrap B\<^sub>2 = {}" unfolding wrap_def using \B\<^sub>2 \ P\<^sub>2\ by auto have "card (wrap B\<^sub>2) \ card B\<^sub>2" proof (cases \B\<^sub>2 = {}$$ case False then have "1 \ card B\<^sub>2" by (simp add: leI \finite B\<^sub>2\) then show ?thesis using wrap_card[of B\<^sub>2] by linarith qed simp \ \This part of the proof is based on the proof on page 73 of the article \<^cite>\BerghammerR03\.\ from assms(2) have "2 * card P\<^sub>2 + 2 * card (wrap B\<^sub>2) \ card (\P\<^sub>2) + card (wrap B\<^sub>2) + 1" using wrap_card[of B\<^sub>2] by linarith then have "2 * (card P\<^sub>2 + card (wrap B\<^sub>2)) \ card (\P\<^sub>2) + card B\<^sub>2 + 1" using \card (wrap B\<^sub>2) \ card B\<^sub>2\ by simp then have "2 * (card (P\<^sub>2 \ wrap B\<^sub>2)) \ card (\P\<^sub>2 \ B\<^sub>2) + 1" using card_Un_disjoint[OF \finite (\P\<^sub>2)\ \finite B\<^sub>2\ DISJNT] and card_Un_disjoint[OF \finite P\<^sub>2\ \finite (wrap B\<^sub>2)\ DISJNT2] by argo then have "2 * (card (P\<^sub>2 \ wrap B\<^sub>2)) \ card ($$P\<^sub>2 \ wrap B\<^sub>2)) + 1" by (cases \B\<^sub>2 = {}$$ (auto simp: Un_commute) then show "2 * (card (P\<^sub>2 \ wrap B\<^sub>2)) \ card P\<^sub>1 + 1" using assms(3) bij_betw_same_card unfolding bij_exists_def by metis qed subsubsection \Proving the Approximation Factor\ text \We define \inv\<^sub>2\ as it is defined in the article. These conjuncts allow us to prove the desired approximation factor.\ definition inv\<^sub>2 :: "'a set set \ 'a set set \ 'a set \ 'a set \ 'a set \ bool" where "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V \ inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V \ \\inv\<^sub>1\ holds for the partial solution\ \ (V \ L \ {} \ (\B \ P\<^sub>1 \ wrap B\<^sub>1. B \ L \ {})) \ \If there are still large objects left, then every bin of the first partial solution must contain a large object\ \ bij_exists P\<^sub>1 ($$P\<^sub>2 \ wrap B\<^sub>2)) \ \There exists a bijective function between the bins of the first partial solution and the objects of the second one\ \ (2 * card P\<^sub>2 \ card (\P\<^sub>2)) \ \There are at most twice as many bins in \P\<^sub>2\ as there are objects in \P\<^sub>2\\" lemma inv\<^sub>2E: assumes "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" shows "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" and "V \ L \ {} \ \B \ P\<^sub>1 \ wrap B\<^sub>1. B \ L \ {}" and "bij_exists P\<^sub>1 (\(P\<^sub>2 \ wrap B\<^sub>2))" and "2 * card P\<^sub>2 \ card (\P\<^sub>2)" using assms unfolding inv\<^sub>2_def by blast+ lemma inv\<^sub>2I: assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" and "V \ L \ {} \ \B \ P\<^sub>1 \ wrap B\<^sub>1. B \ L \ {}" and "bij_exists P\<^sub>1 (\(P\<^sub>2 \ wrap B\<^sub>2))" and "2 * card P\<^sub>2 \ card (\P\<^sub>2)" shows "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" using assms unfolding inv\<^sub>2_def by blast text \If \P\ is a correct solution of the bin packing problem, \inv\<^sub>2\ holds for the partial solution, and there are no more small objects left to be distributed, then the amount of bins of the partial solution is no larger than \3 / 2\ of the amount of bins in \P\. This proof strongly follows the proof in \Theorem 4.1\ of the article \<^cite>\BerghammerR03\.\ lemma bin_packing_lower_bound_card: assumes "V \ S = {}" "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "bp P" shows "card (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V}) \ 3 / 2 * card P" proof (cases \V = {}$$ note invrules = inv\<^sub>2E[OF assms(2)] case True then have "card (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V}) = card (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2)" by simp also have "... \ card (P\<^sub>1 \ wrap B\<^sub>1) + card (P\<^sub>2 \ wrap B\<^sub>2)" using card_Un_le[of \P\<^sub>1 \ wrap B\<^sub>1\] by (simp add: Un_assoc) also have "... \ card P + card (P\<^sub>2 \ wrap B\<^sub>2)" using P\<^sub>1_B\<^sub>1_lower_bound_card[OF assms(3) invrules(1,3)] by simp also have "... \ card P + card P / 2" using P\<^sub>2_B\<^sub>2_lower_bound_P\<^sub>1[OF invrules(1,4,3)] and P\<^sub>1_lower_bound_card[OF assms(3) invrules(1,3)] by linarith finally show ?thesis by linarith next note invrules = inv\<^sub>2E[OF assms(2)] case False have "U = S \ L" using S_def L_def by blast then have *: "V = V \ L" using bpE(3)[OF inv\<^sub>1E(1)[OF invrules(1)]] and assms(1) by blast with False have NE: "V \ L \ {}" by simp have "card (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V}) = card (P\<^sub>1 \ wrap B\<^sub>1 \ {{v} |v. v \ V \ L} \ P\<^sub>2 \ wrap B\<^sub>2)" using * by (simp add: Un_commute Un_assoc) also have "... \ card (P\<^sub>1 \ wrap B\<^sub>1 \ {{v} |v. v \ V \ L}) + card (P\<^sub>2 \ wrap B\<^sub>2)" using card_Un_le[of \P\<^sub>1 \ wrap B\<^sub>1 \ {{v} |v. v \ V \ L}\] by (simp add: Un_assoc) also have "... \ card P + card (P\<^sub>2 \ wrap B\<^sub>2)" using L_bins_lower_bound_card[OF assms(3) invrules(1) invrules(2)[OF NE]] by linarith also have "... \ card P + card P / 2" using P\<^sub>2_B\<^sub>2_lower_bound_P\<^sub>1[OF invrules(1,4,3)] and P\<^sub>1_lower_bound_card[OF assms(3) invrules(1,3)] by linarith finally show ?thesis by linarith qed text \We define \inv\<^sub>3\ as it is defined in the article. This final conjunct allows us to prove that the invariant will be maintained by the algorithm.\ definition inv\<^sub>3 :: "'a set set \ 'a set set \ 'a set \ 'a set \ 'a set \ bool" where "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V \ inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V \ B\<^sub>2 \ S" lemma inv\<^sub>3E: assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" shows "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" and "B\<^sub>2 \ S" using assms unfolding inv\<^sub>3_def by blast+ lemma inv\<^sub>3I: assumes "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" and "B\<^sub>2 \ S" shows "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" using assms unfolding inv\<^sub>3_def by blast lemma loop_init: "inv\<^sub>3 {} {} {} {} U" proof - have *: "inv\<^sub>1 {} {} {} {} U" unfolding bp_def partition_on_def pairwise_def wrap_def inv\<^sub>1_def using weight by auto have "bij_exists {} (\ ({} \ wrap {}))" using bij_betwI' unfolding bij_exists_def by fastforce from inv\<^sub>2I[OF * _ this] have "inv\<^sub>2 {} {} {} {} U" by auto from inv\<^sub>3I[OF this] show ?thesis by blast qed text \If \B\<^sub>1\ is empty and there are no large objects left, then \inv\<^sub>3\ will be maintained if \B\<^sub>1\ is initialized with \u \ V \ S\.\ lemma loop_stepA: assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "B\<^sub>1 = {}" "V \ L = {}" "u \ V \ S" shows "inv\<^sub>3 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (V - {u})" proof - note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]] have WEIGHT: "W B\<^sub>1 + w u \ c" using S_def assms(2,4) by simp from assms(4) have "u \ V" by blast from inv\<^sub>1_stepA[OF invrules(1) this WEIGHT] assms(2) have 1: "inv\<^sub>1 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (V - {u})" by simp have 2: "(V - {u}) \ L \ {} \ \B\P\<^sub>1 \ wrap {u}. B \ L \ {}" using assms(3) by blast from inv\<^sub>2I[OF 1 2] invrules have "inv\<^sub>2 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (V - {u})" by blast from inv\<^sub>3I[OF this] show ?thesis using inv\<^sub>3E(2)[OF assms(1)] . qed text \If \B\<^sub>1\ is empty and there are large objects left, then \inv\<^sub>3\ will be maintained if \B\<^sub>1\ is initialized with \u \ V \ L\.\ lemma loop_stepB: assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "B\<^sub>1 = {}" "u \ V \ L" shows "inv\<^sub>3 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (V - {u})" proof - note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]] have WEIGHT: "W B\<^sub>1 + w u \ c" using L_def weight assms(2,3) by simp from assms(3) have "u \ V" by blast from inv\<^sub>1_stepA[OF invrules(1) this WEIGHT] assms(2) have 1: "inv\<^sub>1 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (V - {u})" by simp have "\B\P\<^sub>1. B \ L \ {}" using assms(3) invrules(2) by blast then have 2: "(V - {u}) \ L \ {} \ \B\P\<^sub>1 \ wrap {u}. B \ L \ {}" using assms(3) by (metis Int_iff UnE empty_iff insertE singletonI wrap_not_empty) from inv\<^sub>2I[OF 1 2] invrules have "inv\<^sub>2 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (V - {u})" by blast from inv\<^sub>3I[OF this] show ?thesis using inv\<^sub>3E(2)[OF assms(1)] . qed text \If \B\<^sub>1\ is not empty and \u \ V \ S\ does not exceed its maximum capacity, then \inv\<^sub>3\ will be maintained if \B\<^sub>1\ and \{u}\ are replaced with \B\<^sub>1 \ {u}\.\ lemma loop_stepC: assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "B\<^sub>1 \ {}" "u \ V \ S" "W B\<^sub>1 + w(u) \ c" shows "inv\<^sub>3 P\<^sub>1 P\<^sub>2 (B\<^sub>1 \ {u}) B\<^sub>2 (V - {u})" proof - note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]] from assms(3) have "u \ V" by blast from inv\<^sub>1_stepA[OF invrules(1) this assms(4)] have 1: "inv\<^sub>1 P\<^sub>1 P\<^sub>2 (B\<^sub>1 \ {u}) B\<^sub>2 (V - {u})" . have "(V - {u}) \ L \ {} \ \B\P\<^sub>1 \ wrap B\<^sub>1. B \ L \ {}" using invrules(2) by blast then have 2: "(V - {u}) \ L \ {} \ \B\P\<^sub>1 \ wrap (B\<^sub>1 \ {u}). B \ L \ {}" by (metis Int_commute Un_empty_right Un_insert_right assms(2) disjoint_insert(2) insert_iff wrap_not_empty) from inv\<^sub>2I[OF 1 2] invrules have "inv\<^sub>2 P\<^sub>1 P\<^sub>2 (B\<^sub>1 \ {u}) B\<^sub>2 (V - {u})" by blast from inv\<^sub>3I[OF this] show ?thesis using inv\<^sub>3E(2)[OF assms(1)] . qed text \If \B\<^sub>1\ is not empty and \u \ V \ S\ does exceed its maximum capacity but not the capacity of \B\<^sub>2\, then \inv\<^sub>3\ will be maintained if \B\<^sub>1\ is added to \P\<^sub>1\ and emptied, and \B\<^sub>2\ and \{u}\ are replaced with \B\<^sub>2 \ {u}\.\ lemma loop_stepD: assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "B\<^sub>1 \ {}" "u \ V \ S" "W B\<^sub>1 + w(u) > c" "W B\<^sub>2 + w(u) \ c" shows "inv\<^sub>3 (P\<^sub>1 \ wrap B\<^sub>1) P\<^sub>2 {} (B\<^sub>2 \ {u}) (V - {u})" proof - note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]] from assms(3) have "u \ V" by blast from inv\<^sub>1_stepB[OF invrules(1) this assms(5)] have 1: "inv\<^sub>1 (P\<^sub>1 \ wrap B\<^sub>1) P\<^sub>2 {} (B\<^sub>2 \ {u}) (V - {u})" . have 2: "(V - {u}) \ L \ {} \ \B\P\<^sub>1 \ wrap B\<^sub>1 \ wrap {}. B \ L \ {}" using invrules(2) unfolding wrap_empty by blast from invrules(3) obtain f where f_def: "bij_betw f P\<^sub>1 (\ (P\<^sub>2 \ wrap B\<^sub>2))" "\B\P\<^sub>1. c < W B + w (f B)" unfolding bij_exists_def by blast have "B\<^sub>1 \ P\<^sub>1" using inv\<^sub>1E(3)[OF invrules(1)] by blast have "u \ (\ (P\<^sub>2 \ wrap B\<^sub>2))" using inv\<^sub>1E(2)[OF invrules(1)] assms(3) by blast then have "(\ (P\<^sub>2 \ wrap (B\<^sub>2 \ {u}))) = (\ (P\<^sub>2 \ wrap B\<^sub>2 \ {{u}}))" by (metis Sup_empty Un_assoc Union_Un_distrib ccpo_Sup_singleton wrap_empty wrap_not_empty) also have "... = (\ (P\<^sub>2 \ wrap B\<^sub>2)) \ {u}" by simp finally have UN: "(\ (P\<^sub>2 \ wrap (B\<^sub>2 \ {u}))) = (\ (P\<^sub>2 \ wrap B\<^sub>2)) \ {u}" . have "wrap B\<^sub>1 = {B\<^sub>1}" using wrap_not_empty[of B\<^sub>1] assms(2) by simp let ?f = "f (B\<^sub>1 := u)" have BIJ: "bij_betw ?f (P\<^sub>1 \ wrap B\<^sub>1) (\ (P\<^sub>2 \ wrap (B\<^sub>2 \ {u})))" unfolding wrap_empty \wrap B\<^sub>1 = {B\<^sub>1}\ UN using f_def(1) \B\<^sub>1 \ P\<^sub>1\ \u \ (\ (P\<^sub>2 \ wrap B\<^sub>2))\ by (metis (no_types, lifting) bij_betw_cong fun_upd_other fun_upd_same notIn_Un_bij_betw3) have "c < W B\<^sub>1 + w (?f B\<^sub>1)" using assms(4) by simp then have "(\B\P\<^sub>1 \ wrap B\<^sub>1. c < W B + w (?f B))" unfolding \wrap B\<^sub>1 = {B\<^sub>1}\ using f_def(2) by simp with BIJ have "bij_betw ?f (P\<^sub>1 \ wrap B\<^sub>1) (\ (P\<^sub>2 \ wrap (B\<^sub>2 \ {u}))) \ (\B\P\<^sub>1 \ wrap B\<^sub>1. c < W B + w (?f B))" by blast then have 3: "bij_exists (P\<^sub>1 \ wrap B\<^sub>1) (\ (P\<^sub>2 \ wrap (B\<^sub>2 \ {u})))" unfolding bij_exists_def by blast from inv\<^sub>2I[OF 1 2 3] have "inv\<^sub>2 (P\<^sub>1 \ wrap B\<^sub>1) P\<^sub>2 {} (B\<^sub>2 \ {u}) (V - {u})" using invrules(4) by blast from inv\<^sub>3I[OF this] show ?thesis using inv\<^sub>3E(2)[OF assms(1)] assms(3) by blast qed text \If the maximum capacity of \B\<^sub>2\ is exceeded by \u \ V \ S\, then \B\<^sub>2\ must contain at least two objects.\ lemma B\<^sub>2_at_least_two_objects: assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "u \ V \ S" "W B\<^sub>2 + w(u) > c" shows "2 \ card B\<^sub>2" proof (rule ccontr, simp add: not_le) have FINITE: "finite B\<^sub>2" using inv\<^sub>1E(1)[OF inv\<^sub>2E(1)[OF inv\<^sub>3E(1)[OF assms(1)]]] by (metis (no_types, lifting) Finite_Set.finite.simps U_Finite Union_Un_distrib bpE(3) ccpo_Sup_singleton finite_Un wrap_not_empty) assume "card B\<^sub>2 < 2" then consider (0) "card B\<^sub>2 = 0" | (1) "card B\<^sub>2 = 1" by linarith then show False proof cases case 0 then have "B\<^sub>2 = {}" using FINITE by simp then show ?thesis using assms(2,3) S_def by simp next case 1 then obtain v where "B\<^sub>2 = {v}" using card_1_singletonE by auto with inv\<^sub>3E(2)[OF assms(1)] have "2 * w v \ c" using S_def by simp moreover from \B\<^sub>2 = {v}\ have "W B\<^sub>2 = w v" by simp ultimately show ?thesis using assms(2,3) S_def by simp qed qed text \If \B\<^sub>1\ is not empty and \u \ V \ S\ exceeds the maximum capacity of both \B\<^sub>1\ and \B\<^sub>2\, then \inv\<^sub>3\ will be maintained if \B\<^sub>1\ and \B\<^sub>2\ are added to \P\<^sub>1\ and \P\<^sub>2\ respectively, emptied, and \B\<^sub>2\ initialized with \u\.\ lemma loop_stepE: assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "B\<^sub>1 \ {}" "u \ V \ S" "W B\<^sub>1 + w(u) > c" "W B\<^sub>2 + w(u) > c" shows "inv\<^sub>3 (P\<^sub>1 \ wrap B\<^sub>1) (P\<^sub>2 \ wrap B\<^sub>2) {} {u} (V - {u})" proof - note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]] from assms(3) have "u \ V" by blast from inv\<^sub>1_stepC[OF invrules(1) this] have 1: "inv\<^sub>1 (P\<^sub>1 \ wrap B\<^sub>1) (P\<^sub>2 \ wrap B\<^sub>2) {} {u} (V - {u})" . have 2: "(V - {u}) \ L \ {} \ \B\P\<^sub>1 \ wrap B\<^sub>1 \ wrap {}. B \ L \ {}" using invrules(2) unfolding wrap_empty by blast from invrules(3) obtain f where f_def: "bij_betw f P\<^sub>1 (\ (P\<^sub>2 \ wrap B\<^sub>2))" "\B\P\<^sub>1. c < W B + w (f B)" unfolding bij_exists_def by blast have "B\<^sub>1 \ P\<^sub>1" using inv\<^sub>1E(3)[OF invrules(1)] by blast have "u \ (\ (P\<^sub>2 \ wrap B\<^sub>2))" using inv\<^sub>1E(2)[OF invrules(1)] assms(3) by blast have "(\ (P\<^sub>2 \ wrap B\<^sub>2 \ wrap {u})) = (\ (P\<^sub>2 \ wrap B\<^sub>2 \ {{u}}))" unfolding wrap_def by simp also have "... = (\ (P\<^sub>2 \ wrap B\<^sub>2)) \ {u}" by simp finally have UN: "(\ (P\<^sub>2 \ wrap B\<^sub>2 \ wrap {u})) = (\ (P\<^sub>2 \ wrap B\<^sub>2)) \ {u}" . have "wrap B\<^sub>1 = {B\<^sub>1}" using wrap_not_empty[of B\<^sub>1] assms(2) by simp let ?f = "f (B\<^sub>1 := u)" have BIJ: "bij_betw ?f (P\<^sub>1 \ wrap B\<^sub>1) (\ (P\<^sub>2 \ wrap B\<^sub>2 \ wrap {u}))" unfolding wrap_empty \wrap B\<^sub>1 = {B\<^sub>1}\ UN using f_def(1) \B\<^sub>1 \ P\<^sub>1\ \u \ (\ (P\<^sub>2 \ wrap B\<^sub>2))\ by (metis (no_types, lifting) bij_betw_cong fun_upd_other fun_upd_same notIn_Un_bij_betw3) have "c < W B\<^sub>1 + w (?f B\<^sub>1)" using assms(4) by simp then have "(\B\P\<^sub>1 \ wrap B\<^sub>1. c < W B + w (?f B))" unfolding \wrap B\<^sub>1 = {B\<^sub>1}\ using f_def(2) by simp with BIJ have "bij_betw ?f (P\<^sub>1 \ wrap B\<^sub>1) (\ (P\<^sub>2 \ wrap B\<^sub>2 \ wrap {u})) \ (\B\P\<^sub>1 \ wrap B\<^sub>1. c < W B + w (?f B))" by blast then have 3: "bij_exists (P\<^sub>1 \ wrap B\<^sub>1) (\ (P\<^sub>2 \ wrap B\<^sub>2 \ wrap {u}))" unfolding bij_exists_def by blast have 4: "2 * card (P\<^sub>2 \ wrap B\<^sub>2) \ card (\ (P\<^sub>2 \ wrap B\<^sub>2))" proof - note bprules = bpE[OF inv\<^sub>1E(1)[OF invrules(1)]] have "pairwise disjnt (P\<^sub>2 \ wrap B\<^sub>2)" using bprules(1) pairwise_subset by blast moreover have "B\<^sub>2 \ P\<^sub>2" using inv\<^sub>1E(4)[OF invrules(1)] by simp ultimately have DISJNT: "\P\<^sub>2 \ B\<^sub>2 = {}" by (auto, metis (no_types, opaque_lifting) sup_bot.right_neutral Un_insert_right disjnt_iff mk_disjoint_insert pairwise_insert wrap_Un) have "finite (\P\<^sub>2)" using U_Finite bprules(3) by auto have "finite B\<^sub>2" using inv\<^sub>1E(1)[OF invrules(1)] bp_bins_finite wrap_not_empty by blast have "2 * card (P\<^sub>2 \ wrap B\<^sub>2) \ 2 * (card P\<^sub>2 + card (wrap B\<^sub>2))" using card_Un_le[of P\<^sub>2 \wrap B\<^sub>2\] by simp also have "... \ 2 * card P\<^sub>2 + 2" using wrap_card by auto also have "... \ card (\ P\<^sub>2) + 2" using invrules(4) by simp also have "... \ card (\ P\<^sub>2) + card B\<^sub>2" using B\<^sub>2_at_least_two_objects[OF assms(1,3,5)] by simp also have "... = card (\ (P\<^sub>2 \ {B\<^sub>2}))" using DISJNT card_Un_disjoint[OF \finite (\P\<^sub>2)\ \finite B\<^sub>2\] by (simp add: Un_commute) also have "... = card (\ (P\<^sub>2 \ wrap B\<^sub>2))" by (cases \B\<^sub>2 = {}\) auto finally show ?thesis . qed from inv\<^sub>2I[OF 1 2 3 4] have "inv\<^sub>2 (P\<^sub>1 \ wrap B\<^sub>1) (P\<^sub>2 \ wrap B\<^sub>2) {} {u} (V - {u})" . from inv\<^sub>3I[OF this] show ?thesis using assms(3) by blast qed text \The bin packing algorithm as it is proposed in the article \<^cite>\BerghammerR03\. \P\ will not only be a correct solution of the bin packing problem, but the amount of bins will be a lower bound for \3 / 2\ of the amount of bins of any correct solution \Q\, and thus guarantee an approximation factor of \3 / 2\ for the optimum.\ lemma bp_approx: "VARS P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V u {True} P\<^sub>1 := {}; P\<^sub>2 := {}; B\<^sub>1 := {}; B\<^sub>2 := {}; V := U; WHILE V \ S \ {} INV {inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V} DO IF B\<^sub>1 \ {} THEN u := (SOME u. u \ V \ S) ELSE IF V \ L \ {} THEN u := (SOME u. u \ V \ L) ELSE u := (SOME u. u \ V \ S) FI FI; V := V - {u}; IF W(B\<^sub>1) + w(u) \ c THEN B\<^sub>1 := B\<^sub>1 \ {u} ELSE IF W(B\<^sub>2) + w(u) \ c THEN B\<^sub>2 := B\<^sub>2 \ {u} ELSE P\<^sub>2 := P\<^sub>2 \ wrap B\<^sub>2; B\<^sub>2 := {u} FI; P\<^sub>1 := P\<^sub>1 \ wrap B\<^sub>1; B\<^sub>1 := {} FI OD; P := P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} | v. v \ V} {bp P \ (\Q. bp Q \ card P \ 3 / 2 * card Q)}" proof (vcg, goal_cases) case (1 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V u) then show ?case by (simp add: loop_init) next case (2 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V u) then have INV: "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" .. let ?s = "SOME u. u \ V \ S" let ?l = "SOME u. u \ V \ L" have LIN: "V \ L \ {} \ ?l \ V \ L" using some_in_eq by metis then have LWEIGHT: "V \ L \ {} \ w ?l \ c" using L_def weight by blast from 2 have "V \ S \ {}" .. then have IN: "?s \ V \ S" using some_in_eq by metis then have "w ?s \ c" using S_def by simp then show ?case using LWEIGHT loop_stepA[OF INV _ _ IN] loop_stepB[OF INV _ LIN] loop_stepC[OF INV _ IN] and loop_stepD[OF INV _ IN] loop_stepE[OF INV _ IN] by (cases \B\<^sub>1 = {}\, cases \V \ L = {}\) auto next case (3 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V u) then have INV: "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" and EMPTY: "V \ S = {}" by blast+ from inv\<^sub>1E(1)[OF inv\<^sub>2E(1)[OF inv\<^sub>3E(1)[OF INV]]] and bin_packing_lower_bound_card[OF EMPTY inv\<^sub>3E(1)[OF INV]] show ?case by blast qed end (* BinPacking *) subsection \The Full Linear Time Version of the Proposed Algorithm\ text \Finally, we prove the Algorithm proposed on page 78 of the article \<^cite>\BerghammerR03\. This version generates the S and L sets beforehand and uses them directly to calculate the solution, thus removing the need for intersection operations, and ensuring linear time if we can perform \insertion, removal, and selection of an element, the union of two sets, and the emptiness test in constant time\ \<^cite>\BerghammerR03\.\ locale BinPacking_Complete = fixes U :: "'a set" \ \A finite, non-empty set of objects\ and w :: "'a \ real" \ \A mapping from objects to their respective weights (positive real numbers)\ and c :: nat \ \The maximum capacity of a bin (as a natural number)\ assumes weight: "\u \ U. 0 < w(u) \ w(u) \ c" and U_Finite: "finite U" and U_NE: "U \ {}" begin text \The correctness proofs will be identical to the ones of the simplified algorithm.\ abbreviation W :: "'a set \ real" where "W B \ (\u \ B. w(u))" definition bp :: "'a set set \ bool" where "bp P \ partition_on U P \ (\B \ P. W(B) \ c)" lemma bpE: assumes "bp P" shows "pairwise disjnt P" "{} \ P" "\P = U" "\B \ P. W(B) \ c" using assms unfolding bp_def partition_on_def by blast+ lemma bpI: assumes "pairwise disjnt P" "{} \ P" "\P = U" "\B \ P. W(B) \ c" shows "bp P" using assms unfolding bp_def partition_on_def by blast definition inv\<^sub>1 :: "'a set set \ 'a set set \ 'a set \ 'a set \ 'a set \ bool" where "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V \ bp (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V}) \ \A correct solution to the bin packing problem\ \ $$P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2) = U - V \ \The partial solution does not contain objects that have not yet been assigned\ \ B\<^sub>1 \ (P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2) \ \\B\<^sub>1\ is distinct from all the other bins\ \ B\<^sub>2 \ (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2) \ \\B\<^sub>2\ is distinct from all the other bins\ \ (P\<^sub>1 \ wrap B\<^sub>1) \ (P\<^sub>2 \ wrap B\<^sub>2) = {} \ \The first and second partial solutions are disjoint from each other.\" lemma inv\<^sub>1E: assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" shows "bp (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V})" and "\(P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2) = U - V" and "B\<^sub>1 \ (P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2)" and "B\<^sub>2 \ (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2)" and "(P\<^sub>1 \ wrap B\<^sub>1) \ (P\<^sub>2 \ wrap B\<^sub>2) = {}" using assms unfolding inv\<^sub>1_def by auto lemma inv\<^sub>1I: assumes "bp (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V})" and "\(P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2) = U - V" and "B\<^sub>1 \ (P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2)" and "B\<^sub>2 \ (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2)" and "(P\<^sub>1 \ wrap B\<^sub>1) \ (P\<^sub>2 \ wrap B\<^sub>2) = {}" shows "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" using assms unfolding inv\<^sub>1_def by blast lemma wrap_Un [simp]: "wrap (M \ {x}) = {M \ {x}}" unfolding wrap_def by simp lemma wrap_empty [simp]: "wrap {} = {}" unfolding wrap_def by simp lemma wrap_not_empty [simp]: "M \ {} \ wrap M = {M}" unfolding wrap_def by simp lemma inv\<^sub>1_stepA: assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "u \ V" "W(B\<^sub>1) + w(u) \ c" shows "inv\<^sub>1 P\<^sub>1 P\<^sub>2 (B\<^sub>1 \ {u}) B\<^sub>2 (V - {u})" proof - note invrules = inv\<^sub>1E[OF assms(1)] and bprules = bpE[OF invrules(1)] \ \Rule 1: Pairwise Disjoint\ have NOTIN: "\M \ P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}}. u \ M" using invrules(2) assms(2) by blast have "{{v} |v. v \ V} = {{u}} \ {{v} |v. v \ V - {u}}" using assms(2) by blast then have "pairwise disjnt (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ ({{u}} \ {{v} |v. v \ V - {u}}))" using bprules(1) assms(2) by simp then have "pairwise disjnt (wrap B\<^sub>1 \ {{u}} \ P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}})" by (simp add: Un_commute) then have assm: "pairwise disjnt (wrap B\<^sub>1 \ {{u}} \ (P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}}))" by (simp add: Un_assoc) have "pairwise disjnt ({B\<^sub>1 \ {u}} \ (P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}}))" proof (cases \B\<^sub>1 = {}$$ case True with assm show ?thesis by simp next case False with assm have assm: "pairwise disjnt ({B\<^sub>1} \ {{u}} \ (P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}}))" by simp from NOTIN have "{u} \ P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}}" by blast from pairwise_disjnt_Un[OF assm _ this] invrules(2,3) show ?thesis using False by auto qed then have 1: "pairwise disjnt (P\<^sub>1 \ wrap (B\<^sub>1 \ {u}) \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}})" unfolding wrap_Un by simp \ \Rule 2: No empty sets\ from bprules(2) have 2: "{} \ P\<^sub>1 \ wrap (B\<^sub>1 \ {u}) \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}}" unfolding wrap_def by simp \ \Rule 3: Union preserved\ from bprules(3) have "\ (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{u}} \ {{v} |v. v \ V - {u}}) = U" using assms(2) by blast then have 3: "\ (P\<^sub>1 \ wrap (B\<^sub>1 \ {u}) \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}}) = U" unfolding wrap_def by force \ \Rule 4: Weights below capacity\ have "0 < w u" using weight assms(2) bprules(3) by blast have "finite B\<^sub>1" using bprules(3) U_Finite by (cases \B\<^sub>1 = {}\) auto then have "W (B\<^sub>1 \ {u}) \ W B\<^sub>1 + w u" using \0 < w u\ by (cases \u \ B\<^sub>1\) (auto simp: insert_absorb) also have "... \ c" using assms(3) . finally have "W (B\<^sub>1 \ {u}) \ c" . then have "\B \ wrap (B\<^sub>1 \ {u}). W B \ c" unfolding wrap_Un by blast moreover have "\B\P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}}. W B \ c" using bprules(4) by blast ultimately have 4: "\B\P\<^sub>1 \ wrap (B\<^sub>1 \ {u}) \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}}. W B \ c" by blast from bpI[OF 1 2 3 4] have 1: "bp (P\<^sub>1 \ wrap (B\<^sub>1 \ {u}) \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}})" . \ \Auxiliary information is preserved\ have "u \ U" using assms(2) bprules(3) by blast then have R: "U - (V - {u}) = U - V \ {u}" by blast have L: "\ (P\<^sub>1 \ wrap (B\<^sub>1 \ {u}) \ P\<^sub>2 \ wrap B\<^sub>2) = \ (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2) \ {u}" unfolding wrap_def using NOTIN by auto have 2: "\ (P\<^sub>1 \ wrap (B\<^sub>1 \ {u}) \ P\<^sub>2 \ wrap B\<^sub>2) = U - (V - {u})" unfolding L R invrules(2) .. have 3: "B\<^sub>1 \ {u} \ P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2" using NOTIN by auto have 4: "B\<^sub>2 \ P\<^sub>1 \ wrap (B\<^sub>1 \ {u}) \ P\<^sub>2" using invrules(4) NOTIN unfolding wrap_def by fastforce have 5: "(P\<^sub>1 \ wrap (B\<^sub>1 \ {u})) \ (P\<^sub>2 \ wrap B\<^sub>2) = {}" using invrules(5) NOTIN unfolding wrap_Un by auto from inv\<^sub>1I[OF 1 2 3 4 5] show ?thesis . qed lemma inv\<^sub>1_stepB: assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "u \ V" "W B\<^sub>2 + w u \ c" shows "inv\<^sub>1 (P\<^sub>1 \ wrap B\<^sub>1) P\<^sub>2 {} (B\<^sub>2 \ {u}) (V - {u})" proof - note invrules = inv\<^sub>1E[OF assms(1)] and bprules = bpE[OF invrules(1)] have NOTIN: "\M \ P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}}. u \ M" using invrules(2) assms(2) by blast have "{{v} |v. v \ V} = {{u}} \ {{v} |v. v \ V - {u}}" using assms(2) by blast then have "pairwise disjnt (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{u}} \ {{v} |v. v \ V - {u}})" using bprules(1) assms(2) by simp then have assm: "pairwise disjnt (wrap B\<^sub>2 \ {{u}} \ (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ {{v} |v. v \ V - {u}}))" by (simp add: Un_assoc Un_commute) have "pairwise disjnt ({B\<^sub>2 \ {u}} \ (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ {{v} |v. v \ V - {u}}))" proof (cases \B\<^sub>2 = {}\) case True with assm show ?thesis by simp next case False with assm have assm: "pairwise disjnt ({B\<^sub>2} \ {{u}} \ (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ {{v} |v. v \ V - {u}}))" by simp from NOTIN have "{u} \ P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ {{v} |v. v \ V - {u}}" by blast from pairwise_disjnt_Un[OF assm _ this] invrules(2,4) show ?thesis using False by auto qed then have 1: "pairwise disjnt (P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ P\<^sub>2 \ wrap (B\<^sub>2 \ {u}) \ {{v} |v. v \ V - {u}})" unfolding wrap_Un by simp \ \Rule 2: No empty sets\ from bprules(2) have 2: "{} \ P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ P\<^sub>2 \ wrap (B\<^sub>2 \ {u}) \ {{v} |v. v \ V - {u}}" unfolding wrap_def by simp \ \Rule 3: Union preserved\ from bprules(3) have "\ (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{u}} \ {{v} |v. v \ V - {u}}) = U" using assms(2) by blast then have 3: "\ (P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ P\<^sub>2 \ wrap (B\<^sub>2 \ {u}) \ {{v} |v. v \ V - {u}}) = U" unfolding wrap_def by force \ \Rule 4: Weights below capacity\ have "0 < w u" using weight assms(2) bprules(3) by blast have "finite B\<^sub>2" using bprules(3) U_Finite by (cases \B\<^sub>2 = {}\) auto then have "W (B\<^sub>2 \ {u}) \ W B\<^sub>2 + w u" using \0 < w u\ by (cases \u \ B\<^sub>2\) (auto simp: insert_absorb) also have "... \ c" using assms(3) . finally have "W (B\<^sub>2 \ {u}) \ c" . then have "\B \ wrap (B\<^sub>2 \ {u}). W B \ c" unfolding wrap_Un by blast moreover have "\B\P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ {{v} |v. v \ V - {u}}. W B \ c" using bprules(4) by blast ultimately have 4: "\B\P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ P\<^sub>2 \ wrap (B\<^sub>2 \ {u}) \ {{v} |v. v \ V - {u}}. W B \ c" by auto from bpI[OF 1 2 3 4] have 1: "bp (P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ P\<^sub>2 \ wrap (B\<^sub>2 \ {u}) \ {{v} |v. v \ V - {u}})" . \ \Auxiliary information is preserved\ have "u \ U" using assms(2) bprules(3) by blast then have R: "U - (V - {u}) = U - V \ {u}" by blast have L: "\ (P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ P\<^sub>2 \ wrap (B\<^sub>2 \ {u})) = \ (P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ P\<^sub>2 \ wrap B\<^sub>2) \ {u}" unfolding wrap_def using NOTIN by auto have 2: "\ (P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ P\<^sub>2 \ wrap (B\<^sub>2 \ {u})) = U - (V - {u})" unfolding L R using invrules(2) by simp have 3: "{} \ P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap (B\<^sub>2 \ {u})" using bpE(2)[OF 1] by simp have 4: "B\<^sub>2 \ {u} \ P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ P\<^sub>2" using NOTIN by auto have 5: "(P\<^sub>1 \ wrap B\<^sub>1 \ wrap {}) \ (P\<^sub>2 \ wrap (B\<^sub>2 \ {u})) = {}" using invrules(5) NOTIN unfolding wrap_empty wrap_Un by auto from inv\<^sub>1I[OF 1 2 3 4 5] show ?thesis . qed lemma inv\<^sub>1_stepC: assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V" "u \ V" shows "inv\<^sub>1 (P\<^sub>1 \ wrap B\<^sub>1) (P\<^sub>2 \ wrap B\<^sub>2) {} {u} (V - {u})" proof - note invrules = inv\<^sub>1E[OF assms(1)] \ \Rule 1-4: Correct Bin Packing\ have "P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ (P\<^sub>2 \ wrap B\<^sub>2) \ wrap {u} \ {{v} |v. v \ V - {u}} = P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{u}} \ {{v} |v. v \ V - {u}}" by (metis (no_types, lifting) Un_assoc Un_empty_right insert_not_empty wrap_empty wrap_not_empty) also have "... = P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V}" using assms(2) by auto finally have EQ: "P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ (P\<^sub>2 \ wrap B\<^sub>2) \ wrap {u} \ {{v} |v. v \ V - {u}} = P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V}" . from invrules(1) have 1: "bp (P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ (P\<^sub>2 \ wrap B\<^sub>2) \ wrap {u} \ {{v} |v. v \ V - {u}})" unfolding EQ . \ \Auxiliary information is preserved\ have NOTIN: "\M \ P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ V - {u}}. u \ M" using invrules(2) assms(2) by blast have "u \ U" using assms(2) bpE(3)[OF invrules(1)] by blast then have R: "U - (V - {u}) = U - V \ {u}" by blast have L: "\ (P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ (P\<^sub>2 \ wrap B\<^sub>2) \ wrap {u}) = \ (P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ (P\<^sub>2 \ wrap B\<^sub>2)) \ {u}" unfolding wrap_def using NOTIN by auto have 2: "\ (P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ (P\<^sub>2 \ wrap B\<^sub>2) \ wrap {u}) = U - (V - {u})" unfolding L R using invrules(2) by auto have 3: "{} \ P\<^sub>1 \ wrap B\<^sub>1 \ (P\<^sub>2 \ wrap B\<^sub>2) \ wrap {u}" using bpE(2)[OF 1] by simp have 4: "{u} \ P\<^sub>1 \ wrap B\<^sub>1 \ wrap {} \ (P\<^sub>2 \ wrap B\<^sub>2)" using NOTIN by auto have 5: "(P\<^sub>1 \ wrap B\<^sub>1 \ wrap {}) \ (P\<^sub>2 \ wrap B\<^sub>2 \ wrap {u}) = {}" using invrules(5) NOTIN unfolding wrap_def by force from inv\<^sub>1I[OF 1 2 3 4 5] show ?thesis . qed text \From this point onward, we will require a different approach for proving lower bounds. Instead of fixing and assuming the definitions of the \S\ and \L\ sets, we will introduce the abbreviations \S\<^sub>U\ and \L\<^sub>U\ for any occurrences of the original \S\ and \L\ sets. The union of \S\ and \L\ can be interpreted as \V\. As a result, occurrences of \V \ S\ become $$S \ L) \ S = S\, and \V \ L\ become \(S \ L) \ L = L\. Occurrences of these sets will have to be replaced appropriately.\ abbreviation S\<^sub>U where "S\<^sub>U \ {u \ U. w u \ c / 2}" abbreviation L\<^sub>U where "L\<^sub>U \ {u \ U. c / 2 < w u}" text \As we will remove elements from \S\ and \L\, we will only be able to show that they remain subsets of \S\<^sub>U\ and \L\<^sub>U\ respectively.\ abbreviation SL where "SL S L \ S \ S\<^sub>U \ L \ L\<^sub>U" lemma bp_bins_finite [simp]: assumes "bp P" shows "\B \ P. finite B" using bpE(3)[OF assms] U_Finite by (meson Sup_upper finite_subset) lemma bp_sol_finite [simp]: assumes "bp P" shows "finite P" using bpE(3)[OF assms] U_Finite by (simp add: finite_UnionD) lemma only_one_L_per_bin: assumes "bp P" "B \ P" shows "\x \ B. \y \ B. x \ y \ x \ L\<^sub>U \ y \ L\<^sub>U" proof (rule ccontr, simp) assume "\x\B. \y\B. x \ y \ y \ U \ x \ U \ real c < w x * 2 \ real c < w y * 2" then obtain x y where *: "x \ B" "y \ B" "x \ y" "x \ L\<^sub>U" "y \ L\<^sub>U" by auto then have "c < w x + w y" by force have "finite B" using assms by simp have "y \ B - {x}" using *(2,3) by blast have "W B = W (B - {x}) + w x" using *(1) \finite B\ by (simp add: sum.remove) also have "... = W (B - {x} - {y}) + w x + w y" using \y \ B - {x}\ \finite B\ by (simp add: sum.remove) finally have *: "W B = W (B - {x} - {y}) + w x + w y" . have "\u \ B. 0 < w u" using bpE(3)[OF assms(1)] assms(2) weight by blast - then have "0 \ W (B - {x} - {y})" by (smt DiffD1 sum_nonneg) + then have "0 \ W (B - {x} - {y})" by (smt (verit) DiffD1 sum_nonneg) with * have "c < W B" using \c < w x + w y\ by simp then show False using bpE(4)[OF assms(1)] assms(2) by fastforce qed lemma L_lower_bound_card: assumes "bp P" shows "card L\<^sub>U \ card P" proof - have "\x \ L\<^sub>U. \B \ P. x \ B" using bpE(3)[OF assms] by blast then obtain f where f_def: "\u \ L\<^sub>U. u \ f u \ f u \ P" by metis then have "inj_on f L\<^sub>U" unfolding inj_on_def using only_one_L_per_bin[OF assms] by blast then have card_eq: "card L\<^sub>U = card (f  L\<^sub>U)" by (simp add: card_image) have "f  L\<^sub>U \ P" using f_def by blast moreover have "finite P" using assms by simp ultimately have "card (f  L\<^sub>U) \ card P" by (simp add: card_mono) then show ?thesis unfolding card_eq . qed lemma subset_bp_card: assumes "bp P" "M \ P" "\B \ M. B \ L\<^sub>U \ {}" shows "card M \ card L\<^sub>U" proof - have "\B \ M. \u \ L\<^sub>U. u \ B" using assms(3) by fast then have "\f. \B \ M. f B \ L\<^sub>U \ f B \ B" by metis then obtain f where f_def: "\B \ M. f B \ L\<^sub>U \ f B \ B" .. have "inj_on f M" proof (rule ccontr) assume "\ inj_on f M" then have "\x \ M. \y \ M. x \ y \ f x = f y" unfolding inj_on_def by blast then obtain x y where *: "x \ M" "y \ M" "x \ y" "f x = f y" by blast then have "\u. u \ x \ u \ y" using f_def by metis then have "x \ y \ {}" by blast moreover have "pairwise disjnt M" using pairwise_subset[OF bpE(1)[OF assms(1)] assms(2)] . ultimately show False using * unfolding pairwise_def disjnt_def by simp qed moreover have "finite L\<^sub>U" using U_Finite by auto moreover have "f  M \ L\<^sub>U" using f_def by blast ultimately show ?thesis using card_inj_on_le by blast qed lemma L_bins_lower_bound_card: assumes "bp P" "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 (S \ L)" "\B \ P\<^sub>1 \ wrap B\<^sub>1. B \ L\<^sub>U \ {}" and SL_def: "SL S L" shows "card (P\<^sub>1 \ wrap B\<^sub>1 \ {{v} |v. v \ L}) \ card P" proof - note invrules = inv\<^sub>1E[OF assms(2)] have "\B \ {{v} |v. v \ L}. B \ L\<^sub>U \ {}" using SL_def by blast with assms(3) have "P\<^sub>1 \ wrap B\<^sub>1 \ {{v} |v. v \ L} \ P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ S \ L}" "\B \ P\<^sub>1 \ wrap B\<^sub>1 \ {{v} |v. v \ L}. B \ L\<^sub>U \ {}" by blast+ from subset_bp_card[OF invrules(1) this] show ?thesis using L_lower_bound_card[OF assms(1)] by linarith qed lemma sum_Un_eq_sum_sum: assumes "bp P" shows "(\u \ U. w u) = (\B \ P. W B)" proof - have FINITE: "\B \ P. finite B" using assms by simp have DISJNT: "\A \ P. \B \ P. A \ B \ A \ B = {}" using bpE(1)[OF assms] unfolding pairwise_def disjnt_def . have "(\u \ (\P). w u) = (\B \ P. W B)" using sum.Union_disjoint[OF FINITE DISJNT] by auto then show ?thesis unfolding bpE(3)[OF assms] . qed lemma sum_lower_bound_card: assumes "bp P" shows "(\u \ U. w u) \ c * card P" proof - have *: "\B \ P. 0 < W B \ W B \ c" using bpE(2-4)[OF assms] weight by (metis UnionI assms bp_bins_finite sum_pos) have "(\u \ U. w u) = (\B \ P. W B)" using sum_Un_eq_sum_sum[OF assms] . also have "... \ (\B \ P. c)" using sum_mono * by fastforce also have "... = c * card P" by simp finally show ?thesis . qed lemma bp_NE: assumes "bp P" shows "P \ {}" using U_NE bpE(3)[OF assms] by blast lemma sum_Un_ge: fixes f :: "_ \ real" assumes "finite M" "finite N" "\B \ M \ N. 0 < f B" shows "sum f M \ sum f (M \ N)" proof - have "0 \ sum f N - sum f (M \ N)" - using assms by (smt DiffD1 inf.cobounded2 UnCI sum_mono2) + using assms by (smt (verit) DiffD1 inf.cobounded2 UnCI sum_mono2) then have "sum f M \ sum f M + sum f N - sum f (M \ N)" by simp also have "... = sum f (M \ N)" using sum_Un[OF assms(1,2), symmetric] . finally show ?thesis . qed definition bij_exists :: "'a set set \ 'a set \ bool" where "bij_exists P V = (\f. bij_betw f P V \ (\B \ P. W B + w (f B) > c))" lemma P\<^sub>1_lower_bound_card: assumes "bp P" "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 (S \ L)" "bij_exists P\<^sub>1 (\(P\<^sub>2 \ wrap B\<^sub>2))" shows "card P\<^sub>1 + 1 \ card P" proof (cases \P\<^sub>1 = {}$$ case True have "finite P" using assms(1) by simp then have "1 \ card P" using bp_NE[OF assms(1)] by (metis Nat.add_0_right Suc_diff_1 Suc_le_mono card_gt_0_iff le0 mult_Suc_right nat_mult_1) then show ?thesis unfolding True by simp next note invrules = inv\<^sub>1E[OF assms(2)] case False obtain f where f_def: "bij_betw f P\<^sub>1 ($$P\<^sub>2 \ wrap B\<^sub>2))" "\B \ P\<^sub>1. W B + w (f B) > c" using assms(3) unfolding bij_exists_def by blast have FINITE: "finite P\<^sub>1" "finite (P\<^sub>2 \ wrap B\<^sub>2)" "finite (P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2)" "finite (wrap B\<^sub>1 \ {{v} |v. v \ S \ L})" using inv\<^sub>1E(1)[OF assms(2)] bp_sol_finite by blast+ have F: "\B \ P\<^sub>2 \ wrap B\<^sub>2. finite B" using invrules(1) by simp have D: "\A \ P\<^sub>2 \ wrap B\<^sub>2. \B \ P\<^sub>2 \ wrap B\<^sub>2. A \ B \ A \ B = {}" using bpE(1)[OF invrules(1)] unfolding pairwise_def disjnt_def by auto have sum_eq: "W (\ (P\<^sub>2 \ wrap B\<^sub>2)) = (\B \ P\<^sub>2 \ wrap B\<^sub>2. W B)" using sum.Union_disjoint[OF F D] by auto have "\B\P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ S \ L}. 0 < W B" using bpE(2,3)[OF invrules(1)] weight by (metis (no_types, lifting) UnionI bp_bins_finite invrules(1) sum_pos) then have "(\B \ P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2. W B) \ (\B \ P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ (wrap B\<^sub>1 \ {{v} |v. v \ S \ L}). W B)" using sum_Un_ge[OF FINITE(3,4), of W] by blast - also have "... = (\B \ P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ S \ L}. W B)" by (smt Un_assoc Un_commute) + also have "... = (\B \ P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ S \ L}. W B)" by (smt (verit) Un_assoc Un_commute) also have "... = W U" using sum_Un_eq_sum_sum[OF invrules(1), symmetric] . finally have *: "(\B \ P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2. W B) \ W U" . have DISJNT: "P\<^sub>1 \ (P\<^sub>2 \ wrap B\<^sub>2) = {}" using invrules(5) by blast \ \This part of the proof is based on the proof on page 72 of the article \<^cite>\BerghammerR03\.\ have "c * card P\<^sub>1 = (\B \ P\<^sub>1. c)" by simp also have "... < (\B \ P\<^sub>1. W B + w (f B))" using f_def(2) sum_strict_mono[OF FINITE(1) False] by fastforce also have "... = (\B \ P\<^sub>1. W B) + (\B \ P\<^sub>1. w (f B))" by (simp add: Groups_Big.comm_monoid_add_class.sum.distrib) also have "... = (\B \ P\<^sub>1. W B) + W (\ (P\<^sub>2 \ wrap B\<^sub>2))" unfolding sum.reindex_bij_betw[OF f_def(1), of w] .. also have "... = (\B \ P\<^sub>1. W B) + (\B \ P\<^sub>2 \ wrap B\<^sub>2. W B)" unfolding sum_eq .. also have "... = (\B \ P\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2. W B)" using sum.union_disjoint[OF FINITE(1,2) DISJNT, of W] by (simp add: Un_assoc) also have "... \ (\u \ U. w u)" using * . also have "... \ c * card P" using sum_lower_bound_card[OF assms(1)] . finally show ?thesis by (simp flip: of_nat_mult) qed lemma P\<^sub>1_B\<^sub>1_lower_bound_card: assumes "bp P" "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 (S \ L)" "bij_exists P\<^sub>1 (\(P\<^sub>2 \ wrap B\<^sub>2))" shows "card (P\<^sub>1 \ wrap B\<^sub>1) \ card P" proof - have "card (P\<^sub>1 \ wrap B\<^sub>1) \ card P\<^sub>1 + card (wrap B\<^sub>1)" using card_Un_le by blast also have "... \ card P\<^sub>1 + 1" using wrap_card by simp also have "... \ card P" using P\<^sub>1_lower_bound_card[OF assms] . finally show ?thesis . qed lemma P\<^sub>2_B\<^sub>2_lower_bound_P\<^sub>1: assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 (S \ L)" "2 * card P\<^sub>2 \ card (\P\<^sub>2)" "bij_exists P\<^sub>1 (\(P\<^sub>2 \ wrap B\<^sub>2))" shows "2 * card (P\<^sub>2 \ wrap B\<^sub>2) \ card P\<^sub>1 + 1" proof - note invrules = inv\<^sub>1E[OF assms(1)] and bprules = bpE[OF invrules(1)] have "pairwise disjnt (P\<^sub>2 \ wrap B\<^sub>2)" using bprules(1) pairwise_subset by blast moreover have "B\<^sub>2 \ P\<^sub>2" using invrules(4) by simp ultimately have DISJNT: "\P\<^sub>2 \ B\<^sub>2 = {}" by (auto, metis (no_types, opaque_lifting) sup_bot.right_neutral Un_insert_right disjnt_iff mk_disjoint_insert pairwise_insert wrap_Un) have "finite (\P\<^sub>2)" using U_Finite bprules(3) by auto have "finite B\<^sub>2" using bp_bins_finite[OF invrules(1)] wrap_not_empty by blast have "finite P\<^sub>2" "finite (wrap B\<^sub>2)" using bp_sol_finite[OF invrules(1)] by blast+ have DISJNT2: "P\<^sub>2 \ wrap B\<^sub>2 = {}" unfolding wrap_def using \B\<^sub>2 \ P\<^sub>2\ by auto have "card (wrap B\<^sub>2) \ card B\<^sub>2" proof (cases \B\<^sub>2 = {}$$ case False then have "1 \ card B\<^sub>2" by (simp add: leI \finite B\<^sub>2\) then show ?thesis using wrap_card[of B\<^sub>2] by linarith qed simp \ \This part of the proof is based on the proof on page 73 of the article \<^cite>\BerghammerR03\.\ from assms(2) have "2 * card P\<^sub>2 + 2 * card (wrap B\<^sub>2) \ card (\P\<^sub>2) + card (wrap B\<^sub>2) + 1" using wrap_card[of B\<^sub>2] by linarith then have "2 * (card P\<^sub>2 + card (wrap B\<^sub>2)) \ card (\P\<^sub>2) + card B\<^sub>2 + 1" using \card (wrap B\<^sub>2) \ card B\<^sub>2\ by simp then have "2 * (card (P\<^sub>2 \ wrap B\<^sub>2)) \ card (\P\<^sub>2 \ B\<^sub>2) + 1" using card_Un_disjoint[OF \finite (\P\<^sub>2)\ \finite B\<^sub>2\ DISJNT] and card_Un_disjoint[OF \finite P\<^sub>2\ \finite (wrap B\<^sub>2)\ DISJNT2] by argo then have "2 * (card (P\<^sub>2 \ wrap B\<^sub>2)) \ card ($$P\<^sub>2 \ wrap B\<^sub>2)) + 1" by (cases \B\<^sub>2 = {}$$ (auto simp: Un_commute) then show "2 * (card (P\<^sub>2 \ wrap B\<^sub>2)) \ card P\<^sub>1 + 1" using assms(3) bij_betw_same_card unfolding bij_exists_def by metis qed text \We add \SL S L\ to \inv\<^sub>2\ to ensure that the \S\ and \L\ sets only contain objects with correct weights.\ definition inv\<^sub>2 :: "'a set set \ 'a set set \ 'a set \ 'a set \ 'a set \ 'a set \ bool" where "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L \ inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 (S \ L) \ \\inv\<^sub>1\ holds for the partial solution\ \ (L \ {} \ (\B \ P\<^sub>1 \ wrap B\<^sub>1. B \ L\<^sub>U \ {})) \ \If there are still large objects left, then every bin of the first partial solution must contain a large object\ \ bij_exists P\<^sub>1 ($$P\<^sub>2 \ wrap B\<^sub>2)) \ \There exists a bijective function between the bins of the first partial solution and the objects of the second one\ \ (2 * card P\<^sub>2 \ card (\P\<^sub>2)) \ \There are at most twice as many bins in \P\<^sub>2\ as there are objects in \P\<^sub>2\\ \ SL S L \ \\S\ and \L\ are subsets of \S\<^sub>U\ and \L\<^sub>U\\" lemma inv\<^sub>2E: assumes "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" shows "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 (S \ L)" and "L \ {} \ \B \ P\<^sub>1 \ wrap B\<^sub>1. B \ L\<^sub>U \ {}" and "bij_exists P\<^sub>1 (\(P\<^sub>2 \ wrap B\<^sub>2))" and "2 * card P\<^sub>2 \ card (\P\<^sub>2)" and "SL S L" using assms unfolding inv\<^sub>2_def by blast+ lemma inv\<^sub>2I: assumes "inv\<^sub>1 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 (S \ L)" and "L \ {} \ \B \ P\<^sub>1 \ wrap B\<^sub>1. B \ L\<^sub>U \ {}" and "bij_exists P\<^sub>1 (\(P\<^sub>2 \ wrap B\<^sub>2))" and "2 * card P\<^sub>2 \ card (\P\<^sub>2)" and "SL S L" shows "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" using assms unfolding inv\<^sub>2_def by blast lemma bin_packing_lower_bound_card: assumes "S = {}" "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" "bp P" shows "card (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ S \ L}) \ 3 / 2 * card P" proof (cases \L = {}$$ note invrules = inv\<^sub>2E[OF assms(2)] case True then have "card (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ S \ L}) = card (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2)" using assms(1) by simp also have "... \ card (P\<^sub>1 \ wrap B\<^sub>1) + card (P\<^sub>2 \ wrap B\<^sub>2)" using card_Un_le[of \P\<^sub>1 \ wrap B\<^sub>1\] by (simp add: Un_assoc) also have "... \ card P + card (P\<^sub>2 \ wrap B\<^sub>2)" using P\<^sub>1_B\<^sub>1_lower_bound_card[OF assms(3) invrules(1,3)] by simp also have "... \ card P + card P / 2" using P\<^sub>2_B\<^sub>2_lower_bound_P\<^sub>1[OF invrules(1,4,3)] and P\<^sub>1_lower_bound_card[OF assms(3) invrules(1,3)] by linarith finally show ?thesis by linarith next note invrules = inv\<^sub>2E[OF assms(2)] case False have "card (P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ S \ L}) = card (P\<^sub>1 \ wrap B\<^sub>1 \ {{v} |v. v \ L} \ P\<^sub>2 \ wrap B\<^sub>2)" using assms(1) by (simp add: Un_commute Un_assoc) also have "... \ card (P\<^sub>1 \ wrap B\<^sub>1 \ {{v} |v. v \ L}) + card (P\<^sub>2 \ wrap B\<^sub>2)" using card_Un_le[of \P\<^sub>1 \ wrap B\<^sub>1 \ {{v} |v. v \ L}\] by (simp add: Un_assoc) also have "... \ card P + card (P\<^sub>2 \ wrap B\<^sub>2)" using L_bins_lower_bound_card[OF assms(3) invrules(1) invrules(2)[OF False] invrules(5)] by linarith also have "... \ card P + card P / 2" using P\<^sub>2_B\<^sub>2_lower_bound_P\<^sub>1[OF invrules(1,4,3)] and P\<^sub>1_lower_bound_card[OF assms(3) invrules(1,3)] by linarith finally show ?thesis by linarith qed definition inv\<^sub>3 :: "'a set set \ 'a set set \ 'a set \ 'a set \ 'a set \ 'a set \ bool" where "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L \ inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L \ B\<^sub>2 \ S\<^sub>U" lemma inv\<^sub>3E: assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" shows "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" and "B\<^sub>2 \ S\<^sub>U" using assms unfolding inv\<^sub>3_def by blast+ lemma inv\<^sub>3I: assumes "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" and "B\<^sub>2 \ S\<^sub>U" shows "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" using assms unfolding inv\<^sub>3_def by blast lemma loop_init: "inv\<^sub>3 {} {} {} {} S\<^sub>U L\<^sub>U" proof - have "S\<^sub>U \ L\<^sub>U = U" by auto then have *: "inv\<^sub>1 {} {} {} {} (S\<^sub>U \ L\<^sub>U)" unfolding bp_def partition_on_def pairwise_def wrap_def inv\<^sub>1_def using weight by auto have "bij_exists {} (\ ({} \ wrap {}))" using bij_betwI' unfolding bij_exists_def by fastforce from inv\<^sub>2I[OF * _ this] have "inv\<^sub>2 {} {} {} {} S\<^sub>U L\<^sub>U" by auto from inv\<^sub>3I[OF this] show ?thesis by blast qed lemma loop_stepA: assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" "B\<^sub>1 = {}" "L = {}" "u \ S" shows "inv\<^sub>3 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (S - {u}) L" proof - note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]] have WEIGHT: "W B\<^sub>1 + w u \ c" using invrules(5) assms(2,4) by fastforce from assms(4) have "u \ S \ L" by blast from inv\<^sub>1_stepA[OF invrules(1) this WEIGHT] assms(2,3) have 1: "inv\<^sub>1 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (S - {u} \ L)" by simp have 2: "L \ {} \ \B\P\<^sub>1 \ wrap {u}. B \ L\<^sub>U \ {}" using assms(3) by blast from inv\<^sub>2I[OF 1 2] invrules have "inv\<^sub>2 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (S - {u}) L" by blast from inv\<^sub>3I[OF this] show ?thesis using inv\<^sub>3E(2)[OF assms(1)] . qed lemma loop_stepB: assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" "B\<^sub>1 = {}" "u \ L" shows "inv\<^sub>3 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 S (L - {u})" proof - note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]] have WEIGHT: "W B\<^sub>1 + w u \ c" using weight invrules(5) assms(2,3) by fastforce \ \This observation follows from the fact that the \S\ and \L\ sets have to be disjoint from each other, and allows us to reuse our proofs of the preservation of \inv\<^sub>1\ by simply replacing \V\ with \S \ L\\ have *: "S \ L - {u} = S \ (L - {u})" using invrules(5) assms(3) by force from assms(3) have "u \ S \ L" by blast from inv\<^sub>1_stepA[OF invrules(1) this WEIGHT] assms(2) * have 1: "inv\<^sub>1 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 (S \ (L - {u}))" by simp have "\B\P\<^sub>1. B \ L\<^sub>U \ {}" "{u} \ L\<^sub>U \ {}" using assms(3) invrules(2,5) by blast+ then have 2: "L \ {} \ \B\P\<^sub>1 \ wrap {u}. B \ L\<^sub>U \ {}" using assms(3) by (metis (full_types) Un_iff empty_iff insert_iff wrap_not_empty) from inv\<^sub>2I[OF 1 2] invrules have "inv\<^sub>2 P\<^sub>1 P\<^sub>2 {u} B\<^sub>2 S (L - {u})" by blast from inv\<^sub>3I[OF this] show ?thesis using inv\<^sub>3E(2)[OF assms(1)] . qed lemma loop_stepC: assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" "B\<^sub>1 \ {}" "u \ S" "W B\<^sub>1 + w(u) \ c" shows "inv\<^sub>3 P\<^sub>1 P\<^sub>2 (B\<^sub>1 \ {u}) B\<^sub>2 (S - {u}) L" proof - note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]] \ \Same approach, but removing \{u}\ from \S\ instead of \L\\ have *: "S \ L - {u} = (S - {u}) \ L" using invrules(5) assms(3) by force from assms(3) have "u \ S \ L" by blast from inv\<^sub>1_stepA[OF invrules(1) this assms(4)] * have 1: "inv\<^sub>1 P\<^sub>1 P\<^sub>2 (B\<^sub>1 \ {u}) B\<^sub>2 (S - {u} \ L)" by simp have "L \ {} \ \B\P\<^sub>1 \ wrap B\<^sub>1. B \ L\<^sub>U \ {}" using invrules(2) by blast then have 2: "L \ {} \ \B\P\<^sub>1 \ wrap (B\<^sub>1 \ {u}). B \ L\<^sub>U \ {}" - by (smt Int_insert_left Un_empty_right Un_iff Un_insert_right assms(2) insert_not_empty singletonD singletonI wrap_def) + by (smt (verit) Int_insert_left Un_empty_right Un_iff Un_insert_right assms(2) insert_not_empty singletonD singletonI wrap_def) from inv\<^sub>2I[OF 1 2] invrules have "inv\<^sub>2 P\<^sub>1 P\<^sub>2 (B\<^sub>1 \ {u}) B\<^sub>2 (S - {u}) L" by blast from inv\<^sub>3I[OF this] show ?thesis using inv\<^sub>3E(2)[OF assms(1)] . qed lemma loop_stepD: assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" "B\<^sub>1 \ {}" "u \ S" "W B\<^sub>1 + w(u) > c" "W B\<^sub>2 + w(u) \ c" shows "inv\<^sub>3 (P\<^sub>1 \ wrap B\<^sub>1) P\<^sub>2 {} (B\<^sub>2 \ {u}) (S - {u}) L" proof - note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]] have *: "S \ L - {u} = (S - {u}) \ L" using invrules(5) assms(3) by force from assms(3) have "u \ S \ L" by blast from inv\<^sub>1_stepB[OF invrules(1) this assms(5)] * have 1: "inv\<^sub>1 (P\<^sub>1 \ wrap B\<^sub>1) P\<^sub>2 {} (B\<^sub>2 \ {u}) (S - {u} \ L)" by simp have 2: "L \ {} \ \B\P\<^sub>1 \ wrap B\<^sub>1 \ wrap {}. B \ L\<^sub>U \ {}" using invrules(2) unfolding wrap_empty by blast from invrules(3) obtain f where f_def: "bij_betw f P\<^sub>1 (\ (P\<^sub>2 \ wrap B\<^sub>2))" "\B\P\<^sub>1. c < W B + w (f B)" unfolding bij_exists_def by blast have "B\<^sub>1 \ P\<^sub>1" using inv\<^sub>1E(3)[OF invrules(1)] by blast have "u \ (\ (P\<^sub>2 \ wrap B\<^sub>2))" using inv\<^sub>1E(2)[OF invrules(1)] assms(3) by blast then have "(\ (P\<^sub>2 \ wrap (B\<^sub>2 \ {u}))) = (\ (P\<^sub>2 \ wrap B\<^sub>2 \ {{u}}))" by (metis Sup_empty Un_assoc Union_Un_distrib ccpo_Sup_singleton wrap_empty wrap_not_empty) also have "... = (\ (P\<^sub>2 \ wrap B\<^sub>2)) \ {u}" by simp finally have UN: "(\ (P\<^sub>2 \ wrap (B\<^sub>2 \ {u}))) = (\ (P\<^sub>2 \ wrap B\<^sub>2)) \ {u}" . have "wrap B\<^sub>1 = {B\<^sub>1}" using wrap_not_empty[of B\<^sub>1] assms(2) by simp let ?f = "f (B\<^sub>1 := u)" have BIJ: "bij_betw ?f (P\<^sub>1 \ wrap B\<^sub>1) (\ (P\<^sub>2 \ wrap (B\<^sub>2 \ {u})))" unfolding wrap_empty \wrap B\<^sub>1 = {B\<^sub>1}\ UN using f_def(1) \B\<^sub>1 \ P\<^sub>1\ \u \ (\ (P\<^sub>2 \ wrap B\<^sub>2))\ by (metis (no_types, lifting) bij_betw_cong fun_upd_other fun_upd_same notIn_Un_bij_betw3) have "c < W B\<^sub>1 + w (?f B\<^sub>1)" using assms(4) by simp then have "(\B\P\<^sub>1 \ wrap B\<^sub>1. c < W B + w (?f B))" unfolding \wrap B\<^sub>1 = {B\<^sub>1}\ using f_def(2) by simp with BIJ have "bij_betw ?f (P\<^sub>1 \ wrap B\<^sub>1) (\ (P\<^sub>2 \ wrap (B\<^sub>2 \ {u}))) \ (\B\P\<^sub>1 \ wrap B\<^sub>1. c < W B + w (?f B))" by blast then have 3: "bij_exists (P\<^sub>1 \ wrap B\<^sub>1) (\ (P\<^sub>2 \ wrap (B\<^sub>2 \ {u})))" unfolding bij_exists_def by blast from inv\<^sub>2I[OF 1 2 3] have "inv\<^sub>2 (P\<^sub>1 \ wrap B\<^sub>1) P\<^sub>2 {} (B\<^sub>2 \ {u}) (S - {u}) L" using invrules(4,5) by blast from inv\<^sub>3I[OF this] show ?thesis using inv\<^sub>3E(2)[OF assms(1)] assms(3) invrules(5) by blast qed lemma B\<^sub>2_at_least_two_objects: assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" "u \ S" "W B\<^sub>2 + w(u) > c" shows "2 \ card B\<^sub>2" proof (rule ccontr, simp add: not_le) have FINITE: "finite B\<^sub>2" using inv\<^sub>1E(1)[OF inv\<^sub>2E(1)[OF inv\<^sub>3E(1)[OF assms(1)]]] by (metis (no_types, lifting) Finite_Set.finite.simps U_Finite Union_Un_distrib bpE(3) ccpo_Sup_singleton finite_Un wrap_not_empty) assume "card B\<^sub>2 < 2" then consider (0) "card B\<^sub>2 = 0" | (1) "card B\<^sub>2 = 1" by linarith then show False proof cases case 0 then have "B\<^sub>2 = {}" using FINITE by simp then show ?thesis using assms(2,3) inv\<^sub>2E(5)[OF inv\<^sub>3E(1)[OF assms(1)]] by force next case 1 then obtain v where "B\<^sub>2 = {v}" using card_1_singletonE by auto with inv\<^sub>3E(2)[OF assms(1)] have "2 * w v \ c" using inv\<^sub>2E(5)[OF inv\<^sub>3E(1)[OF assms(1)]] by simp moreover from \B\<^sub>2 = {v}\ have "W B\<^sub>2 = w v" by simp ultimately show ?thesis using assms(2,3) inv\<^sub>2E(5)[OF inv\<^sub>3E(1)[OF assms(1)]] by force qed qed lemma loop_stepE: assumes "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" "B\<^sub>1 \ {}" "u \ S" "W B\<^sub>1 + w(u) > c" "W B\<^sub>2 + w(u) > c" shows "inv\<^sub>3 (P\<^sub>1 \ wrap B\<^sub>1) (P\<^sub>2 \ wrap B\<^sub>2) {} {u} (S - {u}) L" proof - note invrules = inv\<^sub>2E[OF inv\<^sub>3E(1)[OF assms(1)]] have *: "S \ L - {u} = (S - {u}) \ L" using invrules(5) assms(3) by force from assms(3) have "u \ S \ L" by blast from inv\<^sub>1_stepC[OF invrules(1) this] * have 1: "inv\<^sub>1 (P\<^sub>1 \ wrap B\<^sub>1) (P\<^sub>2 \ wrap B\<^sub>2) {} {u} (S - {u} \ L)" by simp have 2: "L \ {} \ \B\P\<^sub>1 \ wrap B\<^sub>1 \ wrap {}. B \ L\<^sub>U \ {}" using invrules(2) unfolding wrap_empty by blast from invrules(3) obtain f where f_def: "bij_betw f P\<^sub>1 (\ (P\<^sub>2 \ wrap B\<^sub>2))" "\B\P\<^sub>1. c < W B + w (f B)" unfolding bij_exists_def by blast have "B\<^sub>1 \ P\<^sub>1" using inv\<^sub>1E(3)[OF invrules(1)] by blast have "u \ (\ (P\<^sub>2 \ wrap B\<^sub>2))" using inv\<^sub>1E(2)[OF invrules(1)] assms(3) by blast have "(\ (P\<^sub>2 \ wrap B\<^sub>2 \ wrap {u})) = (\ (P\<^sub>2 \ wrap B\<^sub>2 \ {{u}}))" unfolding wrap_def by simp also have "... = (\ (P\<^sub>2 \ wrap B\<^sub>2)) \ {u}" by simp finally have UN: "(\ (P\<^sub>2 \ wrap B\<^sub>2 \ wrap {u})) = (\ (P\<^sub>2 \ wrap B\<^sub>2)) \ {u}" . have "wrap B\<^sub>1 = {B\<^sub>1}" using wrap_not_empty[of B\<^sub>1] assms(2) by simp let ?f = "f (B\<^sub>1 := u)" have BIJ: "bij_betw ?f (P\<^sub>1 \ wrap B\<^sub>1) (\ (P\<^sub>2 \ wrap B\<^sub>2 \ wrap {u}))" unfolding wrap_empty \wrap B\<^sub>1 = {B\<^sub>1}\ UN using f_def(1) \B\<^sub>1 \ P\<^sub>1\ \u \ (\ (P\<^sub>2 \ wrap B\<^sub>2))\ by (metis (no_types, lifting) bij_betw_cong fun_upd_other fun_upd_same notIn_Un_bij_betw3) have "c < W B\<^sub>1 + w (?f B\<^sub>1)" using assms(4) by simp then have "(\B\P\<^sub>1 \ wrap B\<^sub>1. c < W B + w (?f B))" unfolding \wrap B\<^sub>1 = {B\<^sub>1}\ using f_def(2) by simp with BIJ have "bij_betw ?f (P\<^sub>1 \ wrap B\<^sub>1) (\ (P\<^sub>2 \ wrap B\<^sub>2 \ wrap {u})) \ (\B\P\<^sub>1 \ wrap B\<^sub>1. c < W B + w (?f B))" by blast then have 3: "bij_exists (P\<^sub>1 \ wrap B\<^sub>1) (\ (P\<^sub>2 \ wrap B\<^sub>2 \ wrap {u}))" unfolding bij_exists_def by blast have 4: "2 * card (P\<^sub>2 \ wrap B\<^sub>2) \ card (\ (P\<^sub>2 \ wrap B\<^sub>2))" proof - note bprules = bpE[OF inv\<^sub>1E(1)[OF invrules(1)]] have "pairwise disjnt (P\<^sub>2 \ wrap B\<^sub>2)" using bprules(1) pairwise_subset by blast moreover have "B\<^sub>2 \ P\<^sub>2" using inv\<^sub>1E(4)[OF invrules(1)] by simp ultimately have DISJNT: "\P\<^sub>2 \ B\<^sub>2 = {}" by (auto, metis (no_types, opaque_lifting) sup_bot.right_neutral Un_insert_right disjnt_iff mk_disjoint_insert pairwise_insert wrap_Un) have "finite (\P\<^sub>2)" using U_Finite bprules(3) by auto have "finite B\<^sub>2" using inv\<^sub>1E(1)[OF invrules(1)] bp_bins_finite wrap_not_empty by blast have "2 * card (P\<^sub>2 \ wrap B\<^sub>2) \ 2 * (card P\<^sub>2 + card (wrap B\<^sub>2))" using card_Un_le[of P\<^sub>2 \wrap B\<^sub>2\] by simp also have "... \ 2 * card P\<^sub>2 + 2" using wrap_card by auto also have "... \ card (\ P\<^sub>2) + 2" using invrules(4) by simp also have "... \ card (\ P\<^sub>2) + card B\<^sub>2" using B\<^sub>2_at_least_two_objects[OF assms(1,3,5)] by simp also have "... = card (\ (P\<^sub>2 \ {B\<^sub>2}))" using DISJNT card_Un_disjoint[OF \finite (\P\<^sub>2)\ \finite B\<^sub>2\] by (simp add: Un_commute) also have "... = card (\ (P\<^sub>2 \ wrap B\<^sub>2))" by (cases \B\<^sub>2 = {}\) auto finally show ?thesis . qed from inv\<^sub>2I[OF 1 2 3 4] have "inv\<^sub>2 (P\<^sub>1 \ wrap B\<^sub>1) (P\<^sub>2 \ wrap B\<^sub>2) {} {u} (S - {u}) L" using invrules(5) by blast from inv\<^sub>3I[OF this] show ?thesis using assms(3) invrules(5) by blast qed text \The bin packing algorithm as it is proposed on page 78 of the article \<^cite>\BerghammerR03\. \P\ will not only be a correct solution of the bin packing problem, but the amount of bins will be a lower bound for \3 / 2\ of the amount of bins of any correct solution \Q\, and thus guarantee an approximation factor of \3 / 2\ for the optimum.\ lemma bp_approx: "VARS P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V S L u {True} S := {}; L:= {}; V := U; WHILE V \ {} INV {V \ U \ S = {u \ U - V. w(u) \ c / 2} \ L = {u \ U - V. c / 2 < w(u)}} DO u := (SOME u. u \ V); IF w(u) \ c / 2 THEN S := S \ {u} ELSE L := L \ {u} FI; V := V - {u} OD; P\<^sub>1 := {}; P\<^sub>2 := {}; B\<^sub>1 := {}; B\<^sub>2 := {}; WHILE S \ {} INV {inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L} DO IF B\<^sub>1 \ {} THEN u := (SOME u. u \ S); S := S - {u} ELSE IF L \ {} THEN u := (SOME u. u \ L); L := L - {u} ELSE u := (SOME u. u \ S); S := S - {u} FI FI; IF W(B\<^sub>1) + w(u) \ c THEN B\<^sub>1 := B\<^sub>1 \ {u} ELSE IF W(B\<^sub>2) + w(u) \ c THEN B\<^sub>2 := B\<^sub>2 \ {u} ELSE P\<^sub>2 := P\<^sub>2 \ wrap B\<^sub>2; B\<^sub>2 := {u} FI; P\<^sub>1 := P\<^sub>1 \ wrap B\<^sub>1; B\<^sub>1 := {} FI OD; P := P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2; V := L; WHILE V \ {} INV {S = {} \ inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L \ V \ L \ P = P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v}|v. v \ L - V}} DO u := (SOME u. u \ V); P := P \ {{u}}; V := V - {u} OD {bp P \ (\Q. bp Q \ card P \ 3 / 2 * card Q)}" proof (vcg, goal_cases) case (1 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V S L u) then show ?case by blast next case (2 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V S L u) then show ?case by (auto simp: some_in_eq) next case (3 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V S L u) then show ?case using loop_init by force next case (4 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V S L u) then have INV: "inv\<^sub>3 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" .. let ?s = "SOME u. u \ S" let ?l = "SOME u. u \ L" note SL_def = inv\<^sub>2E(5)[OF inv\<^sub>3E(1)[OF INV]] have LIN: "L \ {} \ ?l \ L" using some_in_eq by metis then have LWEIGHT: "L \ {} \ w ?l \ c" using weight SL_def by blast from 4 have "S \ {}" .. then have IN: "?s \ S" using some_in_eq by metis then have "w ?s \ c" using SL_def by auto then show ?case using LWEIGHT loop_stepA[OF INV _ _ IN] loop_stepB[OF INV _ LIN] loop_stepC[OF INV _ IN] and loop_stepD[OF INV _ IN] loop_stepE[OF INV _ IN] by (cases \B\<^sub>1 = {}\, cases \L = {}\) auto next case (5 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V S L u) then show ?case by blast next case (6 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V S L u) then have *: "(SOME u. u \ V) \ V" "(SOME u. u \ V) \ L" by (auto simp add: some_in_eq) then have "P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ L - (V - {SOME u. u \ V})} = P\<^sub>1 \ wrap B\<^sub>1 \ P\<^sub>2 \ wrap B\<^sub>2 \ {{v} |v. v \ L - V \ {SOME u. u \ V}}" by blast with 6 * show ?case by blast next case (7 P P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 V S L u) then have *: "inv\<^sub>2 P\<^sub>1 P\<^sub>2 B\<^sub>1 B\<^sub>2 S L" using inv\<^sub>3E(1) by blast from inv\<^sub>1E(1)[OF inv\<^sub>2E(1)[OF *]] 7 have "bp P" by fastforce with bin_packing_lower_bound_card[OF _ *] 7 show ?case by fastforce qed end (* BinPacking_Complete *) end (* Theory *) \ No newline at end of file diff --git a/thys/Approximation_Algorithms/Center_Selection.thy b/thys/Approximation_Algorithms/Center_Selection.thy --- a/thys/Approximation_Algorithms/Center_Selection.thy +++ b/thys/Approximation_Algorithms/Center_Selection.thy @@ -1,457 +1,457 @@ (* Author: Ujkan Sulejmani *) section \Center Selection\ theory Center_Selection imports Complex_Main "HOL-Hoare.Hoare_Logic" begin text \The Center Selection (or metric k-center) problem. Given a set of \textit{sites} \S\ in a metric space, find a subset \C \ S\ that minimizes the maximal distance from any \s \ S\ to some \c \ C\. This theory presents a verified 2-approximation algorithm. It is based on Section 11.2 in the book by Kleinberg and Tardos \<^cite>\"KleinbergT06"\. In contrast to the proof in the book, our proof is a standard invariant proof.\ locale Center_Selection = fixes S :: "('a :: metric_space) set" and k :: nat assumes finite_sites: "finite S" and non_empty_sites: "S \ {}" and non_zero_k: "k > 0" begin definition distance :: "('a::metric_space) set \ ('a::metric_space) \ real" where "distance C s = Min (dist s  C)" definition radius :: "('a :: metric_space) set \ real" where "radius C = Max (distance C  S)" lemma distance_mono: assumes "C\<^sub>1 \ C\<^sub>2" and "C\<^sub>1 \ {}" and "finite C\<^sub>2" shows "distance C\<^sub>1 s \ distance C\<^sub>2 s" by (simp add: Min.subset_imp assms distance_def image_mono) lemma finite_distances: "finite (distance C  S)" using finite_sites by simp lemma non_empty_distances: "distance C  S \ {}" using non_empty_sites by simp lemma radius_contained: "radius C \ distance C  S" using finite_distances non_empty_distances Max_in radius_def by simp lemma radius_def2: "\s \ S. distance C s = radius C" using radius_contained image_iff by metis lemma dist_lemmas_aux: assumes "finite C" and "C \ {}" shows "finite (dist s  C)" and "finite (dist s  C) \ distance C s \ dist s  C" and "distance C s \ dist s  C \ \c \ C. dist s c = distance C s" and "\c \ C. dist s c = distance C s \ distance C s \ 0" proof show "finite C" using assms(1) by simp next assume "finite (dist s  C)" then show "distance C s \ dist s  C" using distance_def eq_Min_iff assms(2) by blast next assume "distance C s \ dist s  C" then show "\c \ C. dist s c = distance C s" by auto next assume "\c \ C. dist s c = distance C s" then show "distance C s \ 0" by (metis zero_le_dist) qed lemma dist_lemmas: assumes "finite C" and "C \ {}" shows "finite (dist s  C)" and "distance C s \ dist s  C" and "\c \ C. dist s c = distance C s" and "distance C s \ 0" using dist_lemmas_aux assms by auto lemma radius_max_prop: "(\s \ S. distance C s \ r) \ (radius C \ r)" by (metis image_iff radius_contained) lemma dist_ins: assumes "\c\<^sub>1 \ C. \c\<^sub>2 \ C. c\<^sub>1 \ c\<^sub>2 \ x < dist c\<^sub>1 c\<^sub>2" and "distance C s > x" and "finite C" and "C \ {}" shows "\c\<^sub>1 \ (C \ {s}). \c\<^sub>2 \ (C \ {s}). c\<^sub>1 \ c\<^sub>2 \ x < dist c\<^sub>1 c\<^sub>2" proof (rule+) fix c\<^sub>1 c\<^sub>2 assume local_assms: "c\<^sub>1\C \ {s}" "c\<^sub>2\C \ {s}" "c\<^sub>1 \ c\<^sub>2" then have "c\<^sub>1 \ C \ c\<^sub>2 \ C \ c\<^sub>1 \C \ c\<^sub>2\ {s} \ c\<^sub>2\C \ c\<^sub>1 \ {s} \ c\<^sub>1 \ {s} \ c\<^sub>2\ {s}" by auto then show "x < dist c\<^sub>1 c\<^sub>2" proof (elim disjE) assume "c\<^sub>1 \C \ c\<^sub>2\C" then show ?thesis using assms(1) local_assms(3) by simp next assume case_assm: "c\<^sub>1 \ C \ c\<^sub>2 \ {s}" have "x < distance C c\<^sub>2" using assms(2) case_assm by simp also have " ... \ dist c\<^sub>2 c\<^sub>1" using Min.coboundedI distance_def assms(3,4) dist_lemmas(1, 2) case_assm by simp also have " ... = dist c\<^sub>1 c\<^sub>2" using dist_commute by metis finally show ?thesis . next assume case_assm: "c\<^sub>2 \ C \ c\<^sub>1 \ {s}" have "x < distance C c\<^sub>1" using assms(2) case_assm by simp also have " ... \ dist c\<^sub>1 c\<^sub>2" using Min.coboundedI distance_def assms(3,4) dist_lemmas(1, 2) case_assm by simp finally show ?thesis . next assume "c\<^sub>1 \ {s} \ c\<^sub>2 \ {s}" then have False using local_assms by simp then show ?thesis by simp qed qed subsection \A Preliminary Algorithm and Proof\ text \This subsection verifies an auxiliary algorithm by Kleinberg and Tardos. Our proof of the main algorithm does not does not rely on this auxiliary algorithm at all but we do reuse part off its invariant proof later on.\ definition inv :: "('a :: metric_space) set \ ('a :: metric_space set) \ real \ bool" where "inv S' C r = ((\s \ (S - S'). distance C s \ 2*r) \ S' \ S \ C \ S \ (\c \ C. \s \ S'. S' \ {} \ dist c s > 2 * r) \ (S' = S \ C \ {}) \ (\c\<^sub>1 \ C. \c\<^sub>2 \ C. c\<^sub>1 \ c\<^sub>2 \ dist c\<^sub>1 c\<^sub>2 > 2 * r))" lemma inv_init: "inv S {} r" unfolding inv_def non_empty_sites by simp lemma inv_step: assumes "S' \ {}" and IH: "inv S' C r" defines[simp]: "s \ (SOME s. s \ S')" shows "inv (S' - {s' . s' \ S' \ dist s s' \ 2*r}) (C \ {s}) r" proof - have s_def: "s \ S'" using assms(1) some_in_eq by auto have "finite (C \ {s})" using IH finite_subset[OF _ finite_sites] by (simp add: inv_def) moreover have "(\s' \ (S - (S' - {s' . s' \ S' \ dist s s' \ 2*r})). distance (C \ {s}) s' \ 2*r)" proof fix s'' assume "s'' \ S - (S' - {s' . s' \ S' \ dist s s' \ 2*r})" then have "s'' \ S - S' \ s'' \ {s' . s' \ S' \ dist s s' \ 2*r}" by simp then show "distance (C \ {s}) s'' \ 2 * r" proof (elim disjE) assume local_assm: "s'' \ S - S'" have "S' = S \ C \ {}" using IH by (simp add: inv_def) then show ?thesis proof (elim disjE) assume "S' = S" then have "s'' \ {}" using local_assm by simp then show ?thesis by simp next assume C_not_empty: "C \ {}" have "finite C" using IH finite_subset[OF _ finite_sites] by (simp add: inv_def) then have "distance (C \ {s}) s'' \ distance C s''" using distance_mono C_not_empty by (meson Un_upper1 calculation) also have " ... \ 2 * r" using IH local_assm inv_def by simp finally show ?thesis . qed next assume local_assm: "s'' \ {s' . s' \ S' \ dist s s' \ 2*r}" then have "distance (C \ {s}) s'' \ dist s'' s" using Min.coboundedI distance_def dist_lemmas calculation by auto - also have " ... \ 2 * r" using local_assm by (smt dist_self dist_triangle2 mem_Collect_eq) + also have " ... \ 2 * r" using local_assm by (smt (verit) dist_self dist_triangle2 mem_Collect_eq) finally show ?thesis . qed qed moreover have "S' - {s' . s' \ S' \ dist s s' \ 2*r} \ S" using IH by (auto simp: inv_def) moreover { have "s \ S" using IH inv_def s_def by auto then have "C \ {s} \ S" using IH by (simp add: inv_def) } moreover have "(\c\C \ {s}. \c\<^sub>2\C \ {s}. c \ c\<^sub>2 \ 2 * r < dist c c\<^sub>2)" proof (rule+) fix c\<^sub>1 c\<^sub>2 assume local_assms: "c\<^sub>1 \ C \ {s}" "c\<^sub>2 \ C \ {s}" "c\<^sub>1 \ c\<^sub>2" then have "(c\<^sub>1 \ C \ c\<^sub>2 \ C) \ (c\<^sub>1 = s \ c\<^sub>2 \ C) \ (c\<^sub>1 \ C \ c\<^sub>2 = s) \ (c\<^sub>1 = s \ c\<^sub>2 = s)" using assms by auto then show "2 * r < dist c\<^sub>1 c\<^sub>2" proof (elim disjE) assume "c\<^sub>1 \ C \ c\<^sub>2 \ C" then show "2 * r < dist c\<^sub>1 c\<^sub>2" using IH inv_def local_assms by simp next assume case_assm: "c\<^sub>1 = s \ c\<^sub>2 \ C" have "(\c \ C. \s\S'. S' \ {} \ 2 * r < dist c s)" using IH inv_def by simp - then show ?thesis by (smt case_assm s_def assms(1) dist_self dist_triangle3 singletonD) + then show ?thesis by (smt (verit) case_assm s_def assms(1) dist_self dist_triangle3 singletonD) next assume case_assm: "c\<^sub>1 \ C \ c\<^sub>2 = s" have "(\c \ C. \s\S'. S' \ {} \ 2 * r < dist c s)" using IH inv_def by simp - then show ?thesis by (smt case_assm s_def assms(1) dist_self dist_triangle3 singletonD) + then show ?thesis by (smt (verit) case_assm s_def assms(1) dist_self dist_triangle3 singletonD) next assume "c\<^sub>1 = s \ c\<^sub>2 = s" then have False using local_assms(3) by simp then show ?thesis by simp qed qed moreover have "(\c\C \ {s}. \s'' \ S' - {s' \ S'. dist s s' \ 2 * r}. S' - {s' \ S'. dist s s' \ 2 * r} \ {} \ 2 * r < dist c s'')" using IH inv_def by fastforce moreover have "(S' - {s' \ S'. dist s s' \ 2 * r} = S \ C \ {s} \ {})" by simp ultimately show ?thesis unfolding inv_def by blast qed lemma inv_last_1: assumes "\s \ (S - S'). distance C s \ 2*r" and "S' = {}" shows "radius C \ 2*r" by (metis Diff_empty assms image_iff radius_contained) lemma inv_last_2: assumes "finite C" and "card C > n" and "C \ S" and "\c\<^sub>1 \ C. \c\<^sub>2 \ C. c\<^sub>1 \ c\<^sub>2 \ dist c\<^sub>1 c\<^sub>2 > 2*r" shows "\C'. card C' \ n \ card C' > 0 \ radius C' > r" (is ?P) proof (rule ccontr) assume "\ ?P" then obtain C' where card_C': "card C' \ n \ card C' > 0" and radius_C': "radius C' \ r" by auto have "\c \ C. (\c'. c' \ C' \ dist c c' \ r)" proof fix c assume "c \ C" then have "c \ S" using assms(3) by blast then have "distance C' c \ radius C'" using finite_distances by (simp add: radius_def) then have "distance C' c \ r" using radius_C' by simp then show "\c'. c' \ C' \ dist c c' \ r" using dist_lemmas by (metis card_C' card_gt_0_iff) qed then obtain f where f: "\c\C. f c \ C' \ dist c (f c) \ r" by metis have "\inj_on f C" proof assume "inj_on f C" then have "card C' \ card C" using \inj_on f C\ card_inj_on_le card_ge_0_finite card_C' f by blast then show False using card_C' \n < card C\ by linarith qed then obtain c1 c2 where defs: "c1 \ C \ c2 \ C \ c1 \ c2 \ f c1 = f c2" using inj_on_def by blast then have *: "dist c1 (f c1) \ r \ dist c2 (f c1) \ r" using f by auto have "2 * r < dist c1 c2" using assms defs by simp also have " ... \ dist c1 (f c1) + dist (f c1) c2" by(rule dist_triangle) also have " ... = dist c1 (f c1) + dist c2 (f c1)" using dist_commute by simp also have " ... \ 2 * r" using * by simp finally show False by simp qed lemma inv_last: assumes "inv {} C r" shows "(card C \ k \ radius C \ 2*r) \ (card C > k \ (\C'. card C' > 0 \ card C' \ k \ radius C' > r))" using assms inv_def inv_last_1 inv_last_2 finite_subset[OF _ finite_sites] by auto theorem Center_Selection_r: "VARS (S' :: ('a :: metric_space) set) (C :: ('a :: metric_space) set) (r :: real) (s :: 'a) {True} S' := S; C := {}; WHILE S' \ {} INV {inv S' C r} DO s := (SOME s. s \ S'); C := C \ {s}; S' := S' - {s' . s' \ S' \ dist s s' \ 2*r} OD {(card C \ k \ radius C \ 2*r) \ (card C > k \ (\C'. card C' > 0 \ card C' \ k \ radius C' > r))}" proof (vcg, goal_cases) case (1 S' C r) then show ?case using inv_init by simp next case (2 S' C r) then show ?case using inv_step by simp next case (3 S' C r) then show ?case using inv_last by blast qed subsection \The Main Algorithm\ definition invar :: "('a :: metric_space) set \ bool" where "invar C = (C \ {} \ card C \ k \ C \ S \ (\C'. (\c\<^sub>1 \ C. \c\<^sub>2 \ C. c\<^sub>1 \ c\<^sub>2 \ dist c\<^sub>1 c\<^sub>2 > 2 * radius C') \ (\s \ S. distance C s \ 2 * radius C')))" abbreviation some where "some A \ (SOME s. s \ A)" lemma invar_init: "invar {some S}" proof - let ?s = "some S" have s_in_S: "?s \ S" using some_in_eq non_empty_sites by blast have "{?s} \ {}" by simp moreover have "{SOME s. s \ S} \ S" using s_in_S by simp moreover have "card {SOME s. s \ S} \ k" using non_zero_k by simp ultimately show ?thesis by (auto simp: invar_def) qed abbreviation furthest_from where "furthest_from C \ (SOME s. s \ S \ distance C s = Max (distance C  S))" lemma invar_step: assumes "invar C" and "card C < k" shows "invar (C \ {furthest_from C})" proof - have furthest_from_C_props: "furthest_from C \ S \ distance C (furthest_from C) = radius C " using someI_ex[of "\x. x \ S \ distance C x = radius C"] radius_def2 radius_def by auto have C_props: "finite C \ C \ {}" using finite_subset[OF _ finite_sites] assms(1) unfolding invar_def by blast { have "card (C \ {furthest_from C}) \ card C + 1" using assms(1) C_props unfolding invar_def by (simp add: card_insert_if) then have "card (C \ {furthest_from C}) < k + 1" using assms(2) by simp then have "card (C \ {furthest_from C}) \ k" by simp } moreover have "C \ {furthest_from C} \ {}" by simp moreover have "(C \ {furthest_from C}) \ S" using assms(1) furthest_from_C_props unfolding invar_def by simp moreover have "\C'. (\s \ S. distance (C \ {furthest_from C}) s \ 2 * radius C') \ (\c\<^sub>1 \ C \ {furthest_from C}. \c\<^sub>2 \ C \ {furthest_from C}. c\<^sub>1 \ c\<^sub>2 \ 2 * radius C' < dist c\<^sub>1 c\<^sub>2)" proof fix C' have "distance C (furthest_from C) > 2 * radius C' \ distance C (furthest_from C) \ 2 * radius C'" by auto then show "(\s \ S. distance (C \ {furthest_from C}) s \ 2 * radius C') \ (\c\<^sub>1 \ C \ {furthest_from C}. \c\<^sub>2 \ C \ {furthest_from C}. c\<^sub>1 \ c\<^sub>2 \ 2 * radius C' < dist c\<^sub>1 c\<^sub>2)" proof (elim disjE) assume asm: "distance C (furthest_from C) > 2 * radius C'" then have "$$\s \ S. distance C s \ 2 * radius C')" using furthest_from_C_props by force then have IH: "\c\<^sub>1 \ C. \c\<^sub>2 \ C. c\<^sub>1 \ c\<^sub>2 \ 2 * radius C' < dist c\<^sub>1 c\<^sub>2" using assms(1) unfolding invar_def by blast have "(\c\<^sub>1 \ C \ {furthest_from C}. (\c\<^sub>2 \ C \ {furthest_from C}. c\<^sub>1 \ c\<^sub>2 \ 2 * radius C' < dist c\<^sub>1 c\<^sub>2))" using dist_ins[of "C" "2 * radius C'" "furthest_from C"] IH C_props asm by simp then show ?thesis by simp next assume main_assm: "2 * radius C' \ distance C (furthest_from C)" have "(\s \ S. distance (C \ {furthest_from C}) s \ 2 * radius C')" proof fix s assume local_assm: "s \ S" then show "distance (C \ {furthest_from C}) s \ 2 * radius C'" proof - have "distance (C \ {furthest_from C}) s \ distance C s" using distance_mono[of C "C \ {furthest_from C}"] C_props by auto also have " ... \ distance C (furthest_from C)" using Max.coboundedI local_assm finite_distances radius_def furthest_from_C_props by auto also have " ... \ 2 * radius C'" using main_assm by simp finally show ?thesis . qed qed then show ?thesis by blast qed qed ultimately show ?thesis unfolding invar_def by blast qed lemma invar_last: assumes "invar C" and "\card C < k" shows "card C = k" and "card C' > 0 \ card C' \ k \ radius C \ 2 * radius C'" proof - show "card C = k" using assms(1, 2) unfolding invar_def by simp next have C_props: "finite C \ C \ {}" using finite_sites assms(1) unfolding invar_def by (meson finite_subset) show "card C' > 0 \ card C' \ k \ radius C \ 2 * radius C'" proof (rule impI) assume C'_assms: "0 < card (C' :: 'a set) \ card C' \ k" let ?r = "radius C'" have "(\c\<^sub>1 \ C. \c\<^sub>2 \ C. c\<^sub>1 \ c\<^sub>2 \ 2 * ?r < dist c\<^sub>1 c\<^sub>2) \ (\s \ S. distance C s \ 2 * ?r)" using assms(1) unfolding invar_def by simp then show "radius C \ 2 * ?r" proof assume case_assm: "\c\<^sub>1\C. \c\<^sub>2\C. c\<^sub>1 \ c\<^sub>2 \ 2 * ?r < dist c\<^sub>1 c\<^sub>2" obtain s where s_def: "radius C = distance C s \ s \ S" using radius_def2 by metis show ?thesis proof (rule ccontr) assume contr_assm: "\ radius C \ 2 * ?r" then have s_prop: "distance C s > 2 * ?r" using s_def by simp then have \\c\<^sub>1 \ C \ {s}. \c\<^sub>2 \ C \ {s}. c\<^sub>1 \ c\<^sub>2 \ dist c\<^sub>1 c\<^sub>2 > 2 * ?r\ using C_props dist_ins[of "C" "2*?r" "s"] case_assm by blast moreover { have "s \ C" proof assume "s \ C" then have "distance C s \ dist s s" using Min.coboundedI[of "distance C  S" "dist s s"] by (simp add: distance_def C_props) also have " ... = 0" by simp - finally have "distance C s = 0" using dist_lemmas(4) by (smt C_props) + finally have "distance C s = 0" using dist_lemmas(4) by (smt (verit) C_props) then have radius_le_zero: "2 * ?r < 0" using contr_assm s_def by simp obtain x where x_def: "?r = distance C' x" using radius_def2 by metis obtain l where l_def: "distance C' x = dist x l" using dist_lemmas(3) by (metis C'_assms card_gt_0_iff) then have "dist x l = ?r" by (simp add: x_def) also have "... < 0" using C'_assms radius_le_zero by simp finally show False by simp qed then have "card (C \ {s}) > k" using assms(1,2) C_props unfolding invar_def by simp } moreover have "C \ {s} \ S" using assms(1) s_def unfolding invar_def by simp moreover have "finite (C \ {s})" using calculation(3) finite_subset finite_sites by auto ultimately have "\C. card C \ k \ card C > 0 \ radius C > ?r" using inv_last_2 by metis then have "?r > ?r" using C'_assms by blast then show False by simp qed next assume "\s\S. distance C s \ 2 * radius C'" then show ?thesis by (metis image_iff radius_contained) qed qed qed theorem Center_Selection: "VARS (C :: ('a :: metric_space) set) (s :: ('a :: metric_space)) {k \ card S} C := {some S}; WHILE card C < k INV {invar C} DO C := C \ {furthest_from C} OD {card C = k \ (\C'. card C' > 0 \ card C' \ k \ radius C \ 2 * radius C')}" proof (vcg, goal_cases) case (1 C s) show ?case using invar_init by simp next case (2 C s) then show ?case using invar_step by blast next case (3 C s) then show ?case using invar_last by blast qed end end \ No newline at end of file diff --git a/thys/Arith_Prog_Rel_Primes/Arith_Prog_Rel_Primes.thy b/thys/Arith_Prog_Rel_Primes/Arith_Prog_Rel_Primes.thy --- a/thys/Arith_Prog_Rel_Primes/Arith_Prog_Rel_Primes.thy +++ b/thys/Arith_Prog_Rel_Primes/Arith_Prog_Rel_Primes.thy @@ -1,955 +1,955 @@ (* File: Arith_Prog_Rel_Primes.thy Author: Jose Manuel Rodriguez Caballero, University of Tartu *) section \Problem ARITHMETIC PROGRESSIONS (Putnam exam problems 2002)\ theory Arith_Prog_Rel_Primes imports Complex_Main "HOL-Number_Theory.Number_Theory" begin text \ Statement of the problem (from ~\<^cite>\"putnam"$$: For which integers $n>1$ does the set of positive integers less than and relatively prime to $n$ constitute an arithmetic progression? The solution of the above problem is theorem @{text arith_prog_rel_primes_solution}. First, we will require some auxiliary material before we get started with the actual solution. \ subsection \Auxiliary results\ lemma even_and_odd_parts: fixes n::nat assumes \n \ 0\ shows \\ k q::nat. n = (2::nat)^k*q \ odd q\ proof- have \prime (2::nat)\ by simp thus ?thesis using prime_power_canonical[where p = "2" and m = "n"] assms semiring_normalization_rules(7) by auto qed lemma only_one_odd_div_power2: fixes n::nat assumes \n \ 0\ and \\ x. x dvd n \ odd x \ x = 1\ shows \\ k. n = (2::nat)^k\ by (metis even_and_odd_parts assms(1) assms(2) dvd_triv_left semiring_normalization_rules(11) semiring_normalization_rules(7)) lemma coprime_power2: fixes n::nat assumes \n \ 0\ and \\ x. x < n \ (coprime x n \ odd x)\ shows \\ k. n = (2::nat)^k\ proof- have \x dvd n \ odd x \ x = 1\ for x by (metis neq0_conv One_nat_def Suc_1 Suc_lessI assms(1) assms(2) coprime_left_2_iff_odd dvd_refl linorder_neqE_nat nat_dvd_1_iff_1 nat_dvd_not_less not_coprimeI) thus ?thesis using assms(1) only_one_odd_div_power2 by auto qed subsection \Main result\ text \ The solution to the problem ARITHMETIC PROGRESSIONS (Putnam exam problems 2002) \ theorem arith_prog_rel_primes_solution: fixes n :: nat assumes \n > 1\ shows $$prime n \ (\ k. n = 2^k) \ n = 6) \ (\ a b m. m \ 0 \ {x | x. x < n \ coprime x n} = {a+j*b| j::nat. j < m})\ proof- have \ (prime n \ (\ k. n = 2^k) \ n = 6) \ (\ b m. m \ 0 \ {x | x :: nat. x < n \ coprime x n} = {1+j*b| j::nat. j < m})\ proof show "\b m. m \ 0 \ {x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}" if "prime n \ (\k. n = 2 ^ k) \ n = 6" proof- have "\b m. m \ 0 \ {x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}" if "prime n" proof- have \\m. m \ 0 \ {x | x :: nat. x < n \ coprime x n} = {1+j| j::nat. j < m}\ proof- have \{x | x :: nat. x < n \ coprime x n} = {x | x :: nat. x \ 0 \ x < n}\ proof show "{x |x. x < n \ coprime x n} \ {x |x. x \ 0 \ x < n}" - by (smt Collect_mono not_le ord_0_nat ord_eq_0 order_refl prime_gt_1_nat that zero_neq_one) + using prime_nat_iff'' that by fastforce show "{x |x. x \ 0 \ x < n} \ {x |x. x < n \ coprime x n}" using coprime_commute prime_nat_iff'' that by fastforce qed obtain m where \m+1 = n\ using add.commute assms less_imp_add_positive by blast have \{1+j| j::nat. j < (m::nat)} = {x | x :: nat. x \ 0 \ x < m+1}\ by (metis Suc_eq_plus1 \m + 1 = n\ gr0_implies_Suc le_simps(3) less_nat_zero_code linorder_not_less nat.simps(3) nat_neq_iff plus_1_eq_Suc ) hence \{x | x :: nat. x < n \ coprime x n} = {1+j| j::nat. j < (m::nat)}\ using \{x | x :: nat. x < n \ coprime x n} = {x | x :: nat. x \ 0 \ x < n}\ \m+1 = n\ by auto from \n > 1\ have \m \ 0\ using \m + 1 = n\ by linarith have \{x | x :: nat. x < n \ coprime x n} = {1+j| j::nat. j < m}\ using Suc_eq_plus1 \1 < n\ \{x |x. x < n \ coprime x n} = {1 + j |j. j < m}\ by auto hence \(\ m. m \ 0 \ {x | x :: nat. x < n \ coprime x n} = {1+j| j::nat. j < m})\ using \m \ 0\ by blast thus ?thesis by blast qed hence \\m. m \ 0 \ {x | x :: nat. x < n \ coprime x n} = {1+j*1| j::nat. j < m}\ by auto thus ?thesis by blast qed moreover have "\b m. m \ 0 \ {x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}" if "\k. n = 2 ^ k" proof- obtain k where \n = 2 ^ k\ using \\k. n = 2 ^ k\ by auto have \k \ 0\ by (metis \1 < n\ \n = 2 ^ k\ nat_less_le power.simps(1)) obtain t where \Suc t = k\ by (metis \k \ 0\ fib.cases) have \n = 2^(Suc t)\ by (simp add: \Suc t = k\ \n = 2 ^ k$$ have \{x | x :: nat. x < n \ coprime x n} = {1+j*2| j::nat. j < 2^t}\ proof show "{x |x. x < n \ coprime x n} \ {1 + j * 2 |j. j < 2^t}" proof fix x assume \x \ {x |x. x < n \ coprime x n}\ hence \x < n\ by blast have \coprime x n\ using \x \ {x |x. x < n \ coprime x n}\ by blast hence \coprime x (2^(Suc k))\ by (simp add: \k \ 0\ \n = 2 ^ k\) have \odd x\ using \coprime x n\ \k \ 0\ \n = 2 ^ k\ by auto then obtain j where \x = 1+j*2\ by (metis add.commute add.left_commute left_add_twice mult_2_right oddE) have \x < 2^k\ using \n = 2 ^ k\ \x < n\ \x = 1+j*2\ by linarith hence \1+j*2 < 2^k\ using \x = 1+j*2\ by blast hence \j < 2^t\ using \Suc t = k\ by auto thus \x \ {1 + j * 2 |j. j < 2^t}\ using \x = 1+j*2\ by blast qed show "{1 + j * 2 |j. j < 2 ^ t} \ {x |x. x < n \ coprime x n}" proof fix x::nat assume \x \ {1 + j * 2 |j. j < 2 ^ t}\ then obtain j where \x = 1 + j * 2\ and \j < 2 ^ t\ by blast have \x < 2*(2^t)\ using \x = 1 + j * 2\ \j < 2 ^ t\ by linarith hence \x < n\ by (simp add: \n = 2 ^ Suc t\) moreover have \coprime x n\ by (metis (no_types) \\thesis. (\j. \x = 1 + j * 2; j < 2 ^ t\ \ thesis) \ thesis\ \n = 2 ^ k\ coprime_Suc_left_nat coprime_mult_right_iff coprime_power_right_iff plus_1_eq_Suc) ultimately show \x \ {x |x. x < n \ coprime x n}\ by blast qed qed have $$2::nat)^(t::nat) \ 0\ by simp obtain m where \m = (2::nat)^t\ by blast have \m \ 0\ using \m = 2 ^ t\ by auto have \{x | x :: nat. x < n \ coprime x n} = {1+j*2| j::nat. j < m}\ using \m = 2 ^ t\ \{x |x. x < n \ coprime x n} = {1 + j * 2 |j. j < 2 ^ t}\ by auto from \m \ 0\ \{x | x :: nat. x < n \ coprime x n} = {1+j*2| j::nat. j < m}\ show ?thesis by blast qed moreover have "\b m. m \ 0 \ {x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}" if "n = 6" proof- have \{x | x. x < 6 \ coprime x 6} = {1+j*4| j::nat. j < 2}\ proof- have \{x | x::nat. x < 6 \ coprime x 6} = {1, 5}\ proof show "{u. \x. u = (x::nat) \ x < 6 \ coprime x 6} \ {1, 5}" proof fix u::nat assume \u \ {u. \x. u = x \ x < 6 \ coprime x 6}\ hence \coprime u 6\ by blast have \u < 6\ using \u \ {u. \x. u = x \ x < 6 \ coprime x 6}\ by blast moreover have \u \ 0\ using \coprime u 6\ ord_eq_0 by fastforce moreover have \u \ 2\ using \coprime u 6\ by auto moreover have \u \ 3\ proof- have \gcd (3::nat) 6 = 3\ by auto thus ?thesis by (metis (no_types) \coprime u 6\ \gcd 3 6 = 3\ coprime_iff_gcd_eq_1 numeral_eq_one_iff semiring_norm(86)) qed moreover have \u \ 4\ proof- have \gcd (4::nat) 6 = 2\ by (metis (no_types, lifting) add_numeral_left gcd_add1 gcd_add2 gcd_nat.idem numeral_Bit0 numeral_One one_plus_numeral semiring_norm(4) semiring_norm(5)) thus ?thesis using \coprime u 6\ coprime_iff_gcd_eq_1 by auto qed ultimately have \u = 1 \ u = 5\ by auto thus \u \ {1, 5}\ by blast qed show "{1::nat, 5} \ {x |x. x < 6 \ coprime x 6}" proof- have \(1::nat) \ {x |x. x < 6 \ coprime x 6}\ by simp moreover have \(5::nat) \ {x |x. x < 6 \ coprime x 6}\ by (metis Suc_numeral coprime_Suc_right_nat less_add_one mem_Collect_eq numeral_plus_one semiring_norm(5) semiring_norm(8)) ultimately show ?thesis by blast qed qed moreover have \{1+j*4| j::nat. j < 2} = {1, 5}\ by auto ultimately show ?thesis by auto qed moreover have \(2::nat) \ 0\ by simp ultimately have \\ m. m \ 0 \ {x | x :: nat. x < 6 \ coprime x 6} = {1+j*4| j::nat. j < m}\ by blast thus ?thesis using that by auto qed ultimately show ?thesis using that by blast qed show "prime n \ (\k. n = 2 ^ k) \ n = 6" if "\b m. m \ 0 \ {x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}" proof- obtain b m where \m \ 0\ and \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ using \\b m. m \ 0 \ {x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by auto show ?thesis proof(cases \n = 2$$ case True thus ?thesis by auto next case False have \b \ 4\ proof(cases \odd b\) case True show ?thesis proof(rule classical) assume \$$b \ 4)\ hence \b > 4\ using le_less_linear by blast obtain m where \m \ 0\ and \{x | x :: nat. x < n \ coprime x n} = {1+j*b| j::nat. j < m}\ using \m \ 0\ \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by blast have \b \ 0\ using \4 < b\ by linarith have \n = 2 + (m-1)*b\ proof- have \n-1 \ {x | x :: nat. x < n \ coprime x n}\ using \1 < n\ coprime_diff_one_left_nat by auto have \n-1 \ {1+j*b| j::nat. j < m}\ using \n - 1 \ {x |x. x < n \ coprime x n}\ \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by blast then obtain i::nat where \n-1 = 1+i*b\ and \i < m\ by blast have \i \ m-1\ using \i < m\ by linarith have \1 + (m-1)*b \ {1+j*b| j::nat. j < m}\ using \m \ 0\ by auto hence \1 + (m-1)*b \ {x | x::nat. x < n \ coprime x n}\ using \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by blast hence \1 + (m-1)*b < n\ by blast hence \1 + (m-1)*b \ n-1\ by linarith hence \1 + (m-1)*b \ 1+i*b\ using \n - 1 = 1 + i * b\ by linarith hence \(m-1)*b \ i*b\ by linarith hence \m-1 \ i\ using \b \ 0\ by auto hence \m-1 = i\ using \i \ m - 1\ le_antisym by blast thus ?thesis using \m \ 0\ \n - 1 = 1 + i * b\ by auto qed have \m \ 2\ using \n = 2 + (m - 1)*b\ \n \ 2\ by auto hence \1+b \ {1+j*b| j. j < m}\ by fastforce hence \1+b \ {x | x::nat. x < n \ coprime x n}\ using \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by blast hence \coprime (1+b) n\ by blast have \(2::nat) dvd (1+b)\ using \odd b\ by simp hence \coprime (2::nat) n\ using \coprime (1 + b) n\ coprime_common_divisor coprime_left_2_iff_odd odd_one by blast have \(2::nat) < n\ using \1 < n\ \n \ 2\ by linarith have \2 \ {x | x :: nat. x < n \ coprime x n}\ using \2 < n\ \coprime 2 n\ by blast hence \2 \ {1+j*b| j::nat. j < m}\ using \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by blast then obtain j::nat where \2 = 1+j*b\ by blast have \1 = j*b\ using \2 = 1+j*b\ by linarith thus ?thesis by simp qed next case False hence \even b\ by simp show ?thesis proof(rule classical) assume \\(b \ 4)\ hence \b > 4\ using le_less_linear by blast obtain m where \ m \ 0\ and \{x | x::nat. x < n \ coprime x n} = {1+j*b| j::nat. j < m}\ using \m \ 0\ \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by blast have \b \ 0\ using \4 < b\ by linarith have \n = 2 + (m-1)*b\ proof- have \n-1 \ {x | x::nat. x < n \ coprime x n}\ using \1 < n\ coprime_diff_one_left_nat by auto have \n-1 \ {1+j*b| j::nat. j < m}\ using \n - 1 \ {x |x. x < n \ coprime x n}\ \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by blast then obtain i::nat where \n-1 = 1+i*b\ and \i < m\ by blast have \i \ m-1\ using \i < m\ by linarith have \1 + (m-1)*b \ {1+j*b| j::nat. j < m}\ using \m \ 0\ by auto hence \1 + (m-1)*b \ {x | x :: nat. x < n \ coprime x n}\ using \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by blast hence \1 + (m-1)*b < n\ by blast hence \1 + (m-1)*b \ n-1\ by linarith hence \1 + (m-1)*b \ 1+i*b\ using \n - 1 = 1 + i * b\ by linarith hence \(m-1)*b \ i*b\ by linarith hence \m-1 \ i\ using \b \ 0\ by auto hence \m-1 = i\ using \i \ m - 1\ le_antisym by blast thus ?thesis using \m \ 0\ \n - 1 = 1 + i * b\ by auto qed obtain k :: nat where \b = 2*k\ using \even b\ by blast have \n = 2*(1 + (m-1)*k)\ using \n = 2 + (m-1)*b\ \b = 2*k\ by simp show ?thesis proof (cases \odd m$$ case True hence \odd m\ by blast then obtain t::nat where \m-1 = 2*t\ by (metis odd_two_times_div_two_nat) have \n = 2*(1 + b*t)\ using \m - 1 = 2 * t\ \n = 2 + (m - 1) * b\ by auto have \t < m\ using \m - 1 = 2 * t\ \m \ 0\ by linarith have \1 + b*t \ {1+j*b| j::nat. j < m}\ using \t < m\ by auto hence \1 + b*t \ {x | x::nat. x < n \ coprime x n}\ using \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by blast hence \coprime (1 + b*t) n\ by auto thus ?thesis by (metis (no_types, lifting) \b = 2 * k\ \n = 2 * (1 + (m - 1) * k)\ \n = 2 * (1 + b * t)\ \n = 2 + (m - 1) * b\ \n \ 2\ add_cancel_right_right coprime_mult_right_iff coprime_self mult_cancel_left mult_is_0 nat_dvd_1_iff_1) next case False thus ?thesis proof(cases \odd k\) case True hence \odd k\ by blast have \even (1 + (m - 1) * k)\ by (simp add: False True \m \ 0\) have \coprime (2 + (m - 1) * k) (1 + (m - 1) * k)\ by simp have \coprime (2 + (m - 1) * k) n\ using \coprime (2 + (m - 1) * k) (1 + (m - 1) * k)\ \even (1 + (m - 1) * k)\ \n = 2 * (1 + (m - 1) * k)\ coprime_common_divisor coprime_mult_right_iff coprime_right_2_iff_odd odd_one by blast have \2 + (m - 1) * k < n\ by (metis (no_types, lifting) \even (1 + (m - 1) * k)\ \n = 2 * (1 + (m - 1) * k)\ add_gr_0 add_mono_thms_linordered_semiring(1) dvd_add_left_iff dvd_add_triv_left_iff dvd_imp_le le_add2 le_neq_implies_less less_numeral_extra(1) mult_2 odd_one) have \2 + (m - 1) * k \ {x | x :: nat. x < n \ coprime x n}\ using \2 + (m - 1) * k < n\ \coprime (2 + (m - 1) * k) n\ by blast hence \2 + (m - 1) * k \ {1 + j * b |j. j < m}\ using \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by blast then obtain j::nat where \2 + (m - 1) * k = 1 + j * b\ and \j < m\ by blast have \1 + (m - 1) * k = j * b\ using \2 + (m - 1) * k = 1 + j * b\ by simp hence \1 + (m - 1) * k = j * (2*k)\ using \b = 2 * k\ by blast thus ?thesis by (metis \b = 2 * k\ \even b\ \n = 2 * (1 + (m - 1) * k)\ \n = 2 + (m - 1) * b\ dvd_add_times_triv_right_iff dvd_antisym dvd_imp_le dvd_triv_right even_numeral mult_2 zero_less_numeral) next case False hence \even k\ by auto have \odd (1 + (m - 1) * k)\ by (simp add: \even k\ ) hence \coprime (3 + (m - 1) * k) (1 + (m - 1) * k)\ - by (smt add_numeral_left coprime_common_divisor coprime_right_2_iff_odd dvd_add_left_iff not_coprimeE numeral_Bit1 numeral_One numeral_plus_one one_add_one) + by (smt (verit) add_numeral_left coprime_common_divisor coprime_right_2_iff_odd dvd_add_left_iff not_coprimeE numeral_Bit1 numeral_One numeral_plus_one one_add_one) hence \coprime (3 + (m - 1) * k) n\ by (metis \even k\ \n = 2 * (1 + (m - 1) * k)\ coprime_mult_right_iff coprime_right_2_iff_odd even_add even_mult_iff odd_numeral) have \3 + (m - 1) * k < n\ - by (smt Groups.add_ac(2) \even k\ \n = 2 * (1 + (m - 1) * k)\ \n = 2 + (m - 1) * b\ \n \ 2\ add_Suc_right add_cancel_right_right add_mono_thms_linordered_semiring(1) dvd_imp_le even_add even_mult_iff le_add2 le_neq_implies_less left_add_twice mult_2 neq0_conv numeral_Bit1 numeral_One odd_numeral one_add_one plus_1_eq_Suc) + by (smt (verit) Groups.add_ac(2) \even k\ \n = 2 * (1 + (m - 1) * k)\ \n = 2 + (m - 1) * b\ \n \ 2\ add_Suc_right add_cancel_right_right add_mono_thms_linordered_semiring(1) dvd_imp_le even_add even_mult_iff le_add2 le_neq_implies_less left_add_twice mult_2 neq0_conv numeral_Bit1 numeral_One odd_numeral one_add_one plus_1_eq_Suc) have \3 + (m - 1) * k \ {x |x. x < n \ coprime x n}\ using \3 + (m - 1) * k < n\ \coprime (3 + (m - 1) * k) n\ by blast hence \3 + (m - 1) * k \ {1 + j * b |j. j < m}\ using \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by blast then obtain j::nat where \3 + (m - 1) * k = 1 + j * b\ by blast have \2 + (m - 1) * k = j * b\ using \3 + (m - 1) * k = 1 + j * b\ by simp hence \2 + (m - 1) * k = j * 2*k\ by (simp add: \b = 2 * k\) thus ?thesis by (metis \4 < b\ \b = 2 * k\ \even k\ dvd_add_times_triv_right_iff dvd_antisym dvd_triv_right mult_2 nat_neq_iff numeral_Bit0) qed qed qed qed moreover have \b \ 3\ proof (rule classical) assume \\ (b \ 3)\ hence \b = 3\ by blast obtain m where \m \ 0\ and \{x | x::nat. x < n \ coprime x n} = {1+j*b| j::nat. j < m}\ using \m \ 0\ \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by blast have \b \ 0\ by (simp add: \b = 3\) have \n = 2 + (m-1)*b\ proof- have \n-1 \ {x | x::nat. x < n \ coprime x n}\ using \1 < n\ coprime_diff_one_left_nat by auto have \n-1 \ {1+j*b| j::nat. j < m}\ using \n - 1 \ {x |x. x < n \ coprime x n}\ \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by blast then obtain i::nat where \n-1 = 1+i*b\ and \i < m\ by blast have \i \ m-1\ using \i < m\ by linarith have \1 + (m-1)*b \ {1+j*b| j::nat. j < m}\ using \m \ 0\ by auto hence \1 + (m-1)*b \ {x | x :: nat. x < n \ coprime x n}\ using \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by blast hence \1 + (m-1)*b < n\ by blast hence \1 + (m-1)*b \ n-1\ by linarith hence \1 + (m-1)*b \ 1+i*b\ using \n - 1 = 1 + i * b\ by linarith hence $$m-1)*b \ i*b\ by linarith hence \m-1 \ i\ using \b \ 0\ by auto hence \m-1 = i\ using \i \ m - 1\ le_antisym by blast thus ?thesis using \m \ 0\ \n - 1 = 1 + i * b\ by auto qed have \n > 2\ using \1 < n\ \n \ 2\ by linarith hence \ m \ 2 \ using \n = 2 + (m-1)*b\ \b = 3\ by simp have \4 \ {1+j*(b::nat)| j::nat. j < m}\ using \2 \ m\ \b = 3\ by force hence \(4::nat) \ {x | x :: nat. x < n \ coprime x n}\ using \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by auto hence \coprime (4::nat) n\ by blast have \(2::nat) dvd 4\ by auto hence \coprime (2::nat) n\ using \coprime (4::nat) n\ coprime_divisors dvd_refl by blast have \4 < n\ using \4 \ {x |x. x < n \ coprime x n}\ by blast have \2 < (4::nat)\ by auto have \2 < n\ by (simp add: \2 < n$$ hence \2 \ {x | x :: nat. x < n \ coprime x n}\ using \coprime (2::nat) n\ by blast hence \2 \ {1+j*(b::nat)| j::nat. j < m}\ using \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by blast then obtain j::nat where \2 = 1+j*3\ using \b = 3\ by blast from \2 = 1+j*3\ have \1 = j*3\ by auto hence \3 dvd 1\ by auto thus ?thesis using nat_dvd_1_iff_1 numeral_eq_one_iff by blast qed ultimately have \b = 0 \ b = 1 \ b = 2 \ b = 4\ by auto moreover have \b = 0 \ \k. n = 2^k\ proof- assume \b = 0\ have \{1 + j * b |j. j < m} = {1}\ using \b = 0\ \m \ 0\ by auto hence \{x |x. x < n \ coprime x n} = {1}\ using \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by blast hence \n = 2\ proof- have \n-1 \ {x | x :: nat. x < n \ coprime x n}\ using \1 < n\ coprime_diff_one_left_nat by auto have \n-1 \ {1}\ using \n - 1 \ {x |x. x < n \ coprime x n}\ \{x |x. x < n \ coprime x n} = {1}\ by blast hence \n-1 = 1\ by blast hence \n = 2\ by simp thus ?thesis by blast qed hence \n = 2^1\ by auto thus ?thesis by blast qed moreover have \b = 1 \ prime n\ proof- assume \b = 1\ have \x < n \ x \ 0 \ coprime x n\ for x proof- assume \x < n\ and \x \ 0\ have \{1+j| j::nat. j < m} = {x | x::nat. x < m+1 \ x \ 0}\ by (metis (full_types) Suc_eq_plus1 add_mono1 less_Suc_eq_0_disj nat.simps(3) plus_1_eq_Suc ) hence \{x | x :: nat. x < n \ coprime x n} = {x | x :: nat. x < m+1 \ x \ 0}\ using \b = 1\ \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by auto have \coprime (n-1) n\ using \1 < n\ coprime_diff_one_left_nat by auto have \n-1 < n\ using \1 < n\ by auto have \n-1 \ {x |x. x < n \ coprime x n}\ using \coprime (n - 1) n\ \n - 1 < n\ by blast have \n-1 \ m\ by (metis (no_types, lifting) CollectD Suc_eq_plus1 Suc_less_eq2 \n - 1 \ {x |x. x < n \ coprime x n}\ \{x |x. x < n \ coprime x n} = {x |x. x < m + 1 \ x \ 0}\ leD le_less_linear not_less_eq_eq ) have \m \ {x | x :: nat. x < m+1 \ x \ 0}\ using \m \ 0\ by auto have \m \ {x |x. x < n \ coprime x n} \ using \m \ {x |x. x < m + 1 \ x \ 0}\ \{x |x. x < n \ coprime x n} = {x |x. x < m + 1 \ x \ 0}\ by blast have \m < n\ using \m \ {x |x. x < n \ coprime x n}\ by blast have \m+1 = n\ using \m < n\ \n - 1 \ m\ by linarith have \x \ {x | x :: nat. x < m+1 \ x \ 0}\ using \m + 1 = n\ \x < n\ \x \ 0\ by blast hence \x \ {x |x. x < n \ coprime x n}\ using \{x |x. x < n \ coprime x n} = {x |x. x < m + 1 \ x \ 0}\ by blast thus ?thesis by blast qed thus ?thesis using assms coprime_commute nat_neq_iff prime_nat_iff'' by auto qed moreover have \b = 2 \ \ k. n = 2^k\ proof- assume \b = 2\ have \{x | x :: nat. x < n \ coprime x n} = {1+j*2| j::nat. j < m}\ using \b = 2\ \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by auto have \x < n \ coprime x n \ odd x\ for x::nat proof- assume \x < n\ have \coprime x n \ odd x\ proof- assume \coprime x n\ have \x \ {x | x :: nat. x < n \ coprime x n}\ by (simp add: \coprime x n\ \x < n\) hence \x \ {1+j*2| j::nat. j < m}\ using \{x |x. x < n \ coprime x n} = {1 + j * 2 |j. j < m}\ by blast then obtain j where \x = 1+j*2\ by blast thus ?thesis by simp qed moreover have \odd x \ coprime x n\ proof- assume \odd x\ obtain j::nat where \x = 1+j*2\ by (metis \odd x\ add.commute mult_2_right odd_two_times_div_two_succ one_add_one semiring_normalization_rules(16)) have \j < (n-1)/2\ using \x < n\ \x = 1 + j * 2\ by linarith have \n = 2*m\ proof- have $$2::nat) \ 0\ by auto have \n = 2+(m-1)*2\ proof- have \n-1 \ {x | x :: nat. x < n \ coprime x n}\ using \1 < n\ coprime_diff_one_left_nat by auto have \n-1 \ {1+j*b| j::nat. j < m}\ using \n - 1 \ {x |x. x < n \ coprime x n}\ \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by blast then obtain i::nat where \n-1 = 1+i*b\ and \i < m\ by blast have \i \ m-1\ using \i < m\ by linarith have \1 + (m-1)*b \ {1+j*b| j::nat. j < m}\ using \m \ 0\ by auto hence \1 + (m-1)*b \ {x | x :: nat. x < n \ coprime x n}\ using \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by blast hence \1 + (m-1)*b < n\ by blast hence \1 + (m-1)*b \ n-1\ by linarith hence \1 + (m-1)*b \ 1+i*b\ using \n - 1 = 1 + i * b\ by linarith hence \(m-1)*b \ i*b\ by linarith hence \m-1 \ i\ proof- have \b \ 0\ using \b = 2\ by simp thus ?thesis using \(m - 1) * b \ i * b\ mult_le_cancel2 by blast qed hence \m-1 = i\ using \i \ m - 1\ le_antisym by blast thus ?thesis using \m \ 0\ \n - 1 = 1 + i * b\ by (simp add: \b = 2$$ qed thus ?thesis by (simp add: \m \ 0\ \n = 2 + (m - 1) * 2\ mult.commute mult_eq_if) qed hence \j < m\ using \x < n\ \x = 1 + j * 2\ by linarith hence \x \ {1+j*2| j::nat. j < m}\ using \x = 1 + j * 2\ by blast hence \x \ {x | x :: nat. x < n \ coprime x n}\ using \{x |x. x < n \ coprime x n} = {1 + j * 2 |j. j < m}\ by blast thus ?thesis by blast qed ultimately show ?thesis by blast qed thus ?thesis using coprime_power2 assms by auto qed moreover have \b = 4 \ n = 6\ proof- assume \b = 4\ have \n = 2 \ n = 6\ proof(rule classical) assume \\ (n = 2 \ n = 6)\ have $$4::nat) \ 0\ by auto have \n = 2+(m-1)*4\ proof- have \n-1 \ {x | x :: nat. x < n \ coprime x n}\ using \1 < n\ coprime_diff_one_left_nat by auto have \n-1 \ {1+j*b| j::nat. j < m}\ using \n - 1 \ {x |x. x < n \ coprime x n}\ \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by blast then obtain i::nat where \n-1 = 1+i*b\ and \i < m\ by blast have \i \ m-1\ using \i < m\ by linarith have \1 + (m-1)*b \ {1+j*b| j::nat. j < m}\ using \m \ 0\ by auto hence \1 + (m-1)*b \ {x | x :: nat. x < n \ coprime x n}\ using \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by blast hence \1 + (m-1)*b < n\ by blast hence \1 + (m-1)*b \ n-1\ by linarith hence \1 + (m-1)*b \ 1+i*b\ using \n - 1 = 1 + i * b\ by linarith hence \(m-1)*b \ i*b\ by linarith hence \m-1 \ i\ proof- have \b \ 0\ using \b = 4\ by auto thus ?thesis using \(m - 1) * b \ i * b\ mult_le_cancel2 by blast qed hence \m-1 = i\ using \i \ m - 1\ le_antisym by blast thus ?thesis using \m \ 0\ \n - 1 = 1 + i * b\ by (simp add: \b = 4$$ qed hence \n = 4*m - 2\ by (simp add: \m \ 0\ mult.commute mult_eq_if) have \m \ 3\ using \\ (n = 2 \ n = 6)\ \n = 2 + (m - 1) * 4\ by auto hence \ {1+j*4| j::nat. j < 3} \ {1+j*4| j::nat. j < m}\ by force hence \9 \ {1+j*4| j::nat. j < 3}\ by force hence \9 \ {1+j*4| j::nat. j < m}\ using \ {1+j*4| j::nat. j < 3} \ {1+j*4| j::nat. j < m}\ by blast hence \9 \ {x | x :: nat. x < n \ coprime x n}\ using \b = 4\ \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by auto hence \coprime (9::nat) n\ by blast have $$3::nat) dvd 9\ by auto have \coprime (3::nat) n\ using \coprime (9::nat) n\ \(3::nat) dvd 9\ by (metis coprime_commute coprime_mult_right_iff dvd_def) have \(3::nat) < n\ by (metis One_nat_def Suc_lessI \1 < n\ \\ (n = 2 \ n = 6)\ \coprime 3 n\ coprime_self numeral_2_eq_2 numeral_3_eq_3 less_numeral_extra(1) nat_dvd_not_less) have \3 \ {x | x :: nat. x < n \ coprime x n}\ using \3 < n\ \coprime 3 n\ by blast hence \(3::nat) \ {1+j*4| j::nat. j < m}\ using \b = 4\ \{x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}\ by blast then obtain j::nat where \(3::nat) = 1 + j*4\ by blast have \2 = j*4\ using numeral_3_eq_3 \(3::nat) = 1 + j*4\ by linarith hence \1 = j*2\ by linarith hence \even 1\ by simp thus ?thesis using odd_one by blast qed thus ?thesis by (simp add: False) qed ultimately show ?thesis by blast qed qed qed moreover have \(\ b m. m \ 0 \ {x | x :: nat. x < n \ coprime x n} = {1+j*b| j::nat. j < m}) \ (\ a b m. m \ 0 \ {x | x :: nat. x < n \ coprime x n} = {a+j*b| j::nat. j < m})\ proof show "\a b m. m \ 0 \ {x |x. x < n \ coprime x n} = {a + j * b |j. j < m}" if "\b m. m \ 0 \ {x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}" using that by blast show "\b m. m \ 0 \ {x |x. x < n \ coprime x n} = {1 + j * b |j. j < m}" if "\a b m. m \ 0 \ {x |x. x < n \ coprime x n} = {a + j * b |j. j < m}" proof- obtain a b m::nat where \m \ 0\ and \{x | x :: nat. x < n \ coprime x n} = {a+j*b| j::nat. j < m}\ using \\a b m. m \ 0 \ {x |x. x < n \ coprime x n} = {a + j * b |j. j < m}\ by auto have \a = 1\ proof- have \{x | x :: nat. x < n \ coprime x n} = {(a::nat)+j*(b::nat)| j::nat. j < m} \ a = 1\ proof- have \Min {x | x :: nat. x < n \ coprime x n} = Min {a+j*b| j::nat. j < m}\ using \{x |x. x < n \ coprime x n} = {a + j * b |j. j < m}\ by auto have \Min {x | x :: nat. x < n \ coprime x n} = 1\ proof- have \finite {x | x :: nat. x < n \ coprime x n}\ by auto have \{x | x :: nat. x < n \ coprime x n} \ {}\ using \1 < n\ by auto have \1 \ {x | x :: nat. x < n \ coprime x n}\ using \1 < n\ by auto have \\ x. coprime x n \ x \ 1\ using \1 < n\ le_less_linear by fastforce hence \\ x. x < n \ coprime x n \ x \ 1\ by blast hence \\ x \ {x | x :: nat. x < n \ coprime x n}. x \ 1\ by blast hence \Min {x | x :: nat. x < n \ coprime x n} \ 1\ using \finite {x | x :: nat. x < n \ coprime x n}\ \{x |x. x < n \ coprime x n} \ {}\ by auto thus ?thesis using Min_le \1 \ {x |x. x < n \ coprime x n}\ \finite {x |x. x < n \ coprime x n}\ antisym by blast qed have \Min {a+j*b| j::nat. j < m} = a\ proof - have f1: "\n. a = a + n * b \ n < m" using \m \ 0\ by auto have f2: "\n. 1 = a + n * b \ n < m" using \{x |x. x < n \ coprime x n} = {a + j * b |j. j < m}\ assms coprime_1_left by blast have f3: "\na. a = na \ na < n \ coprime na n" using f1 \{x |x. x < n \ coprime x n} = {a + j * b |j. j < m}\ by blast have "n \ 1" by (metis (lifting) assms less_irrefl_nat) then have "\ coprime 0 n" by simp then show ?thesis using f3 f2 by (metis \Min {x |x. x < n \ coprime x n} = 1\ \{x |x. x < n \ coprime x n} = {a + j * b |j. j < m}\ less_one linorder_neqE_nat not_add_less1) qed hence \Min {a+j*b| j::nat. j < m} = a\ by blast thus ?thesis using \Min {x | x :: nat. x < n \ coprime x n} = 1\ \Min {x | x :: nat. x < n \ coprime x n} = Min {a+j*b| j::nat. j < m}\ by linarith qed thus ?thesis using \{x |x. x < n \ coprime x n} = {a + j * b |j. j < m}\ by blast qed thus ?thesis using \m \ 0\ \{x | x. x < n \ coprime x n} = {a+j*b| j::nat. j < m}\ by auto qed qed ultimately show ?thesis by simp qed end \ No newline at end of file diff --git a/thys/Arith_Prog_Rel_Primes/ROOT b/thys/Arith_Prog_Rel_Primes/ROOT --- a/thys/Arith_Prog_Rel_Primes/ROOT +++ b/thys/Arith_Prog_Rel_Primes/ROOT @@ -1,10 +1,9 @@ chapter AFP - session Arith_Prog_Rel_Primes = "HOL-Number_Theory" + options [timeout = 300] theories Arith_Prog_Rel_Primes document_files "root.tex" "root.bib" diff --git a/thys/Auto2_HOL/HOL/Arith_Thms.thy b/thys/Auto2_HOL/HOL/Arith_Thms.thy --- a/thys/Auto2_HOL/HOL/Arith_Thms.thy +++ b/thys/Auto2_HOL/HOL/Arith_Thms.thy @@ -1,252 +1,252 @@ (* File: Arith_Thms.thy Author: Bohua Zhan Setup for proof steps related to arithmetic, mostly on natural numbers. *) section \Setup for arithmetic\ theory Arith_Thms imports Order_Thms HOL.Binomial begin (* Reducing inequality on natural numbers. *) theorem reduce_le_plus_consts: "(x::nat) + n1 \ y + n2 \ x \ y + (n2-n1)" by simp theorem reduce_le_plus_consts': "n1 \ n2 \ (x::nat) + n1 \ y + n2 \ x + (n1-n2) \ y" by simp theorem reduce_less_plus_consts: "(x::nat) + n1 < y + n2 \ x < y + (n2-n1)" by simp theorem reduce_less_plus_consts': "n1 \ n2 \ (x::nat) + n1 < y + n2 \ x + (n1-n2) < y" by simp (* To normal form. *) theorem norm_less_lminus: "(x::nat) - n < y \ x \ y + (n-1)" by simp theorem norm_less_lplus: "(x::nat) + n < y \ x + (n+1) \ y" by simp theorem norm_less_rminus: "(x::nat) < y - n \ x + (n+1) \ y" by simp theorem norm_less_rplus: "(x::nat) < y + n \ x \ y + (n-1)" by simp theorem norm_less: "(x::nat) < y \ x + 1 \ y" by simp theorem norm_le_lminus: "(x::nat) - n \ y \ x \ y + n" by simp theorem norm_le_rminus: "(x::nat) \ y - n \ x \ y + 0" by simp theorem norm_le: "(x::nat) \ y \ x \ y + 0" by simp theorem norm_le_lplus0: "(x::nat) + 0 \ y \ x \ y + 0" by simp (* Transitive resolve. *) theorem trans_resolve1: "n1 > 0 \ (x::nat) + n1 \ y \ (y::nat) + n2 \ x \ False" by simp theorem trans_resolve2: "n1 > n2 \ (x::nat) + n1 \ y \ (y::nat) \ x + n2 \ False" by simp (* Transitive. *) theorem trans1: "(x::nat) + n1 \ y \ y + n2 \ z \ x + (n1+n2) \ z" by simp theorem trans2: "(x::nat) \ y + n1 \ y \ z + n2 \ x \ z + (n1+n2)" by simp theorem trans3: "(x::nat) + n1 \ y \ y \ z + n2 \ x \ z + (n2-n1)" by simp theorem trans4: "n1 > n2 \ (x::nat) + n1 \ y \ y \ z + n2 \ x + (n1-n2) \ z" by simp theorem trans5: "(x::nat) \ y + n1 \ y + n2 \ z \ x \ z + (n1-n2)" by simp theorem trans6: "n2 > n1 \ (x::nat) \ y + n1 \ y + n2 \ z \ x + (n2-n1) \ z" by simp (* Resolve. *) theorem single_resolve: "n > 0 \ (x::nat) + n \ x \ False" by simp theorem single_resolve_const: "n > 0 \ (x::nat) + n \ 0 \ False" by simp (* Comparison with constants. *) theorem cv_const1: "(x::nat) + n \ y \ 0 + (x+n) \ y" by simp (* x is const *) theorem cv_const2: "(x::nat) + n \ y \ x \ 0 + (y-n)" by simp (* y is const *) theorem cv_const3: "y < n \ (x::nat) + n \ y \ x + (n-y) \ 0" by simp (* y is const (contradiction with 0 \ x) *) theorem cv_const4: "(x::nat) \ y + n \ 0 + (x-n) \ y" by simp (* x is const *) theorem cv_const5: "(x::nat) \ y + n \ 0 \ y + (n-x)" by simp (* x is const (trivial) *) theorem cv_const6: "(x::nat) \ y + n \ x \ 0 + (y+n)" by simp (* y is const *) (* Misc *) theorem nat_eq_to_ineqs: "(x::nat) = y + n \ x \ y + n \ x \ y + n" by simp theorem nat_ineq_impl_not_eq: "(x::nat) + n \ y \ n > 0 \ x \ y" by simp theorem eq_to_ineqs: "(x::nat) \ y \ x \ y \ y \ x" by simp theorem ineq_to_eqs1: "(x::nat) \ y + 0 \ y \ x + 0 \ x = y" by simp ML_file \arith.ML\ ML_file \order.ML\ ML_file \order_test.ML\ setup \register_wellform_data ("(a::nat) - b", ["a \ b"])\ setup \add_prfstep_check_req ("(a::nat) - b", "(a::nat) \ b")\ (* Normalize any expression to "a - b" form. *) lemma nat_sub_norm: "(a::nat) = a - 0 \ a \ 0" by simp (* Adding and subtracting two normalized expressions. *) lemma nat_sub1: "(a::nat) \ b \ c \ d \ (a - b) + (c - d) = (a + c) - (b + d) \ a + c \ b + d" by simp lemma nat_sub2: "(a::nat) \ b \ c \ d \ a - b \ c - d \ (a - b) - (c - d) = (a + d) - (b + c) \ a + d \ b + c" by simp lemma nat_sub3: "(a::nat) \ b \ c \ d \ (a - b) * (c - d) = (a * c + b * d) - (a * d + b * c) \ a * c + b * d \ a * d + b * c" - by (smt diff_mult_distrib mult.commute mult_le_mono1 nat_sub2) + by (smt (verit) diff_mult_distrib mult.commute mult_le_mono1 nat_sub2) (* Cancel identical terms on two sides, yielding a normalized expression. *) lemma nat_sub_combine: "(a::nat) + b \ c + b \ (a + b) - (c + b) = a - c \ a \ c" by simp lemma nat_sub_combine2: "n \ m \ (a::nat) + b * n \ c + b * m \ (a + b * n) - (c + b * m) = (a + b * (n - m)) - c \ a + b * (n - m) \ c \ n \ m" by (simp add: add.commute right_diff_distrib') lemma nat_sub_combine3: "n \ m \ (a::nat) + b * n \ c + b * m \ (a + b * n) - (c + b * m) = a - (c + b * (m - n)) \ a \ c + b * (m - n) \ m \ n" - by (smt add.commute mult.commute nat_diff_add_eq2 nat_le_add_iff1) + by (smt (verit) add.commute mult.commute nat_diff_add_eq2 nat_le_add_iff1) ML_file \nat_sub.ML\ ML_file \nat_sub_test.ML\ (* Ordering on Nats. *) lemma le_neq_implies_less' [forward]: "(m::nat) \ n \ m \ n \ m < n" by simp lemma le_zero_to_equal_zero [forward]: "(n::nat) \ 0 \ n = 0" by simp lemma less_one_to_equal_zero [forward]: "(n::nat) < 1 \ n = 0" by simp setup \add_backward_prfstep_cond @{thm Nat.mult_le_mono1} [with_cond "?k \ 1"]\ setup \add_resolve_prfstep @{thm Nat.not_add_less1}\ lemma not_minus_less [resolve]: "\(i::nat) < (i - j)" by simp lemma nat_le_prod_with_same [backward]: "m \ 0 \ (n::nat) \ m * n" by simp lemma nat_le_prod_with_le [backward1]: "k \ 0 \ (n::nat) \ m \ (n::nat) \ k * m" using le_trans nat_le_prod_with_same by blast lemma nat_plus_le_to_less [backward1]: "b \ 0 \ (a::nat) + b \ c \ a < c" by simp lemma nat_plus_le_to_less2 [backward1]: "a \ 0 \ (a::nat) + b \ c \ b < c" by simp setup \add_forward_prfstep @{thm add_right_imp_eq}\ setup \add_forward_prfstep @{thm add_left_imp_eq}\ setup \add_rewrite_rule_cond @{thm Nat.le_diff_conv2} [with_term "?i + ?k"]\ lemma nat_less_diff_conv: "(i::nat) < j - k \ i + k < j" by simp setup \add_forward_prfstep_cond @{thm nat_less_diff_conv} [with_cond "?k \ ?NUMC", with_term "?i + ?k"]\ lemma Nat_le_diff_conv2_same [forward]: "i \ j \ (i::nat) \ i - j \ j = 0" by simp lemma nat_gt_zero [forward]: "b - a > 0 \ b > (a::nat)" by simp lemma n_minus_1_less_n: "(n::nat) \ 1 \ n - 1 < n" by simp setup \add_forward_prfstep_cond @{thm n_minus_1_less_n} [with_term "?n - 1"]\ (* Monotonicity of ordering *) setup \add_backward_prfstep @{thm Nat.diff_le_mono}\ setup \add_backward2_prfstep @{thm Nat.diff_less_mono}\ setup \add_backward_prfstep @{thm Nat.mult_le_mono2}\ setup \add_resolve_prfstep @{thm Nat.le_add1}\ setup \add_resolve_prfstep @{thm Nat.le_add2}\ setup \add_backward_prfstep @{thm add_left_mono}\ setup \add_backward_prfstep @{thm add_right_mono}\ lemma add_mono_neutr [backward]: "(0::'a::linordered_ring) \ b \ a \ a + b" by simp lemma add_mono_neutl [backward]: "(0::'a::linordered_ring) \ b \ a \ b + a" by simp setup \add_forward_prfstep @{thm add_less_imp_less_left}\ lemma sum_le_zero1 [forward]: "(a::'a::linordered_ring) + b < 0 \ a \ 0 \ b < 0" by (meson add_less_same_cancel1 less_le_trans) lemma less_sum1 [backward]: "b > 0 \ a < a + (b::nat)" by auto setup \add_backward_prfstep @{thm Nat.trans_less_add2}\ setup \add_backward_prfstep @{thm Nat.add_less_mono1}\ setup \add_backward1_prfstep @{thm Nat.add_less_mono}\ setup \add_backward1_prfstep @{thm Nat.add_le_mono}\ setup \add_backward1_prfstep @{thm add_increasing2}\ setup \add_backward1_prfstep @{thm add_mono}\ setup \add_backward_prfstep @{thm add_strict_left_mono}\ setup \add_backward1_prfstep @{thm Nat.mult_le_mono}\ (* Addition. *) theorem nat_add_eq_self_zero [forward]: "(m::nat) = m + n \ n = 0" by simp theorem nat_add_eq_self_zero' [forward]: "(m::nat) = n + m \ n = 0" by simp theorem nat_mult_2: "(a::nat) + a = 2 * a" by simp setup \add_rewrite_rule_cond @{thm nat_mult_2} [with_cond "?a \ 0"]\ theorem plus_one_non_zero [resolve]: "\(n::nat) + 1 = 0" by simp (* Diff. *) lemma nat_same_minus_ge [forward]: "(c::nat) - a \ c - b \ a \ c \ a \ b" by arith lemma diff_eq_zero [forward]: "(k::nat) \ j \ j - k = 0 \ j = k" by simp lemma diff_eq_zero' [forward]: "(k::nat) \ j \ j - k + i = j \ k = i" by simp (* Divides. *) theorem dvd_defD1 [resolve]: "(a::nat) dvd b \ \k. b = a * k" using dvdE by blast theorem dvd_defD2 [resolve]: "(a::nat) dvd b \ \k. b = k * a" by (metis dvd_mult_div_cancel mult.commute) setup \add_forward_prfstep @{thm Nat.dvd_imp_le}\ theorem dvd_ineq2 [forward]: "(k::nat) dvd n \ n > 0 \ k \ 1" by (simp add: Suc_leI dvd_pos_nat) setup \add_forward_prfstep_cond @{thm dvd_trans} (with_conds ["?a \ ?b", "?b \ ?c", "?a \ ?c"])\ setup \add_forward_prfstep_cond @{thm Nat.dvd_antisym} [with_cond "?m \ ?n"]\ theorem dvd_cancel [backward1]: "c > 0 \ (a::nat) * c dvd b * c \ a dvd b" by simp setup \add_forward_prfstep (equiv_forward_th @{thm dvd_add_right_iff})\ (* Divisibility: existence. *) setup \add_resolve_prfstep @{thm dvd_refl}\ theorem exists_n_dvd_n [backward]: "P (n::nat) \ \k. k dvd n \ P k" using dvd_refl by blast setup \add_resolve_prfstep @{thm one_dvd}\ theorem any_n_dvd_0 [forward]: "\ (\ k. k dvd (0::nat) \ P k) \ \ (\ k. P k)" by simp theorem n_dvd_one: "(n::nat) dvd 1 \ n = 1" by simp setup \add_forward_prfstep_cond @{thm n_dvd_one} [with_cond "?n \ 1"]\ (* Products. *) setup \add_rewrite_rule @{thm mult_zero_left}\ lemma prod_ineqs1 [forward]: "(m::nat) * k > 0 \ m > 0 \ k > 0" by simp lemma prod_ineqs2 [backward]: "(k::nat) > 0 \ m \ m * k" by simp theorem prod_cancel: "(a::nat) * b = a * c \ a > 0 \ b = c" by auto setup \add_forward_prfstep_cond @{thm prod_cancel} [with_cond "?b \ ?c"]\ theorem mult_n1n: "(n::nat) = m * n \ n > 0 \ m = 1" by auto setup \add_forward_prfstep_cond @{thm mult_n1n} [with_cond "?m \ 1"]\ theorem prod_is_one [forward]: "(x::nat) * y = 1 \ x = 1" by simp theorem prod_dvd_intro [backward]: "(k::nat) dvd m \ k dvd n \ k dvd m * n" using dvd_mult dvd_mult2 by blast (* Definition of gcd. *) setup \add_forward_prfstep_cond @{thm gcd_dvd1} [with_term "gcd ?a ?b"]\ setup \add_forward_prfstep_cond @{thm gcd_dvd2} [with_term "gcd ?a ?b"]\ (* Coprimality. *) setup \add_rewrite_rule_bidir @{thm coprime_iff_gcd_eq_1}\ lemma coprime_exp [backward]: "coprime d a \ coprime (d::nat) (a ^ n)" by simp setup \add_backward_prfstep @{thm coprime_exp}\ setup \add_rewrite_rule @{thm gcd.commute}\ lemma coprime_dvd_mult [backward1]: "coprime (a::nat) b \ a dvd c * b \ a dvd c" by (metis coprime_dvd_mult_left_iff) lemma coprime_dvd_mult' [backward1]: "coprime (a::nat) b \ a dvd b * c \ a dvd c" by (metis coprime_dvd_mult_right_iff) theorem coprime_dvd [forward]: "coprime (a::nat) b \ p dvd a \ p > 1 \ \ p dvd b" using coprime_common_divisor_nat by blast (* Powers. *) setup \add_rewrite_rule @{thm power_0}\ theorem power_ge_0 [rewrite]: "m \ 0 \ p ^ m = p * (p ^ (m - 1))" by (simp add: power_eq_if) setup \add_rewrite_rule_cond @{thm power_one} [with_cond "?n \ 0"]\ setup \add_rewrite_rule_cond @{thm power_one_right} [with_cond "?a \ 1"]\ setup \add_gen_prfstep ("power_case_intro", [WithTerm @{term_pat "?p ^ (?FREE::nat)"}, CreateCase @{term_pat "(?FREE::nat) = 0"}])\ lemma one_is_power_of_any [resolve]: "\i. (1::nat) = a ^ i" by (metis power.simps(1)) setup \add_rewrite_rule @{thm power_Suc}\ theorem power_dvd [forward]: "(p::nat)^n dvd a \ n \ 0 \ p dvd a" using dvd_power dvd_trans by blast theorem power_eq_one: "(b::nat) ^ n = 1 \ b = 1 \ n = 0" by (metis One_nat_def Suc_lessI nat_zero_less_power_iff power_0 power_inject_exp) setup \add_forward_prfstep_cond @{thm power_eq_one} (with_conds ["?b \ 1", "?n \ 0"])\ (* Factorial. *) theorem fact_ge_1_nat: "fact (n::nat) \ (1::nat)" by simp setup \add_forward_prfstep_cond @{thm fact_ge_1_nat} [with_term "fact ?n"]\ setup \add_backward1_prfstep @{thm dvd_fact}\ (* Successor function. *) setup \add_rewrite_rule @{thm Nat.Suc_eq_plus1}\ setup \add_backward_prfstep @{thm Nat.gr0_implies_Suc}\ (* Cases *) setup \fold add_rewrite_rule @{thms Nat.nat.case}\ (* Induction. *) lemma nat_cases: "P 0 \ (\n. P (Suc n)) \ P n" using nat_induct by auto (* div *) declare times_div_less_eq_dividend [resolve] setup \ add_var_induct_rule @{thm nat_induct} #> add_strong_induct_rule @{thm nat_less_induct} #> add_cases_rule @{thm nat_cases} \ end diff --git a/thys/Banach_Steinhaus/Banach_Steinhaus.thy b/thys/Banach_Steinhaus/Banach_Steinhaus.thy --- a/thys/Banach_Steinhaus/Banach_Steinhaus.thy +++ b/thys/Banach_Steinhaus/Banach_Steinhaus.thy @@ -1,481 +1,482 @@ (* File: Banach_Steinhaus.thy Author: Dominique Unruh, University of Tartu Author: Jose Manuel Rodriguez Caballero, University of Tartu *) section \Banach-Steinhaus theorem\ theory Banach_Steinhaus imports Banach_Steinhaus_Missing begin text \ We formalize Banach-Steinhaus theorem as theorem @{text banach_steinhaus}. This theorem was originally proved in Banach-Steinhaus's paper~\<^cite>\"banach1927principe"\. For the proof, we follow Sokal's approach~\<^cite>\"sokal2011really"\. Furthermore, we prove as a corollary a result about pointwise convergent sequences of bounded operators whose domain is a Banach space. \ subsection \Preliminaries for Sokal's proof of Banach-Steinhaus theorem\ lemma linear_plus_norm: includes notation_norm assumes \linear f\ shows \\f \\ \ max \f (x +$$\ \f (x - \)\\ text \ Explanation: For arbitrary \<^term>\x\ and a linear operator \<^term>\f\, \<^term>\norm (f \)\ is upper bounded by the maximum of the norms of the shifts of \<^term>\f\ (i.e., \<^term>\f (x + \)\ and \<^term>\f (x - \)\). \ proof- have \norm (f \) = norm ( (inverse (of_nat 2)) *\<^sub>R (f (x + \) - f (x - \)) )\ - by (smt add_diff_cancel_left' assms diff_add_cancel diff_diff_add linear_diff midpoint_def - midpoint_plus_self of_nat_1 of_nat_add one_add_one scaleR_half_double) + by (metis (no_types, opaque_lifting) add.commute assms diff_diff_eq2 group_cancel.sub1 + linear_cmul linear_diff of_nat_numeral real_vector_affinity_eq scaleR_2 + scaleR_right_diff_distrib zero_neq_numeral) also have \\ = inverse (of_nat 2) * norm (f (x + \) - f (x - \))\ using Real_Vector_Spaces.real_normed_vector_class.norm_scaleR by simp also have \\ \ inverse (of_nat 2) * (norm (f (x + \)) + norm (f (x - \)))\ by (simp add: norm_triangle_ineq4) also have \\ \ max (norm (f (x + \))) (norm (f (x - \)))\ by auto finally show ?thesis by blast qed lemma onorm_Sup_on_ball: includes notation_norm assumes \r > 0\ shows "\f\ \ Sup ( (\x. \f *\<^sub>v x\)  (ball x r) ) / r" text \ Explanation: Let \<^term>\f\ be a bounded operator and let \<^term>\x\ be a point. For any \<^term>\r > 0\, the operator norm of \<^term>\f\ is bounded above by the supremum of $f$ applied to the open ball of radius \<^term>\r\ around \<^term>\x\, divided by \<^term>\r\. \ proof- have bdd_above_3: \bdd_above ((\x. \f *\<^sub>v x\)  (ball 0 r))\ proof - obtain M where \\ \. \f *\<^sub>v \\ \ M * norm \\ and \M \ 0\ using norm_blinfun norm_ge_zero by blast hence \\ \. \ \ ball 0 r \ \f *\<^sub>v \\ \ M * r\ - using \r > 0\ by (smt mem_ball_0 mult_left_mono) + using \r > 0\ by (smt (verit) mem_ball_0 mult_left_mono) thus ?thesis by (meson bdd_aboveI2) qed have bdd_above_2: \bdd_above ((\ \. \f *\<^sub>v (x + \)\)  (ball 0 r))\ proof- have \bdd_above ((\ \. \f *\<^sub>v x\)  (ball 0 r))\ by auto moreover have \bdd_above ((\ \. \f *\<^sub>v \\)  (ball 0 r))\ using bdd_above_3 by blast ultimately have \bdd_above ((\ \. \f *\<^sub>v x\ + \f *\<^sub>v \\)  (ball 0 r))\ by (rule bdd_above_plus) then obtain M where \\ \. \ \ ball 0 r \ \f *\<^sub>v x\ + \f *\<^sub>v \\ \ M\ unfolding bdd_above_def by (meson image_eqI) moreover have \\f *\<^sub>v (x + \)\ \ \f *\<^sub>v x\ + \f *\<^sub>v \\\ for \ by (simp add: blinfun.add_right norm_triangle_ineq) ultimately have \\ \. \ \ ball 0 r \ \f *\<^sub>v (x + \)\ \ M\ by (simp add: blinfun.add_right norm_triangle_le) thus ?thesis by (meson bdd_aboveI2) qed have bdd_above_4: \bdd_above ((\ \. \f *\<^sub>v (x - \)\)  (ball 0 r))\ proof- obtain K where K_def: \\ \. \ \ ball 0 r \ \f *\<^sub>v (x + \)\ \ K\ using \bdd_above ((\ \. norm (f (x + \)))  (ball 0 r))\ unfolding bdd_above_def by (meson image_eqI) have \\ \ ball (0::'a) r \ -\ \ ball 0 r\ for \ by auto thus ?thesis by (metis K_def ab_group_add_class.ab_diff_conv_add_uminus bdd_aboveI2) qed have bdd_above_1: \bdd_above ((\ \. max \f *\<^sub>v (x + \)\ \f *\<^sub>v (x - \)\)  (ball 0 r))\ proof- have \bdd_above ((\ \. \f *\<^sub>v (x + \)\)  (ball 0 r))\ using bdd_above_2 by blast moreover have \bdd_above ((\ \. \f *\<^sub>v (x - \)\)  (ball 0 r))\ using bdd_above_4 by blast ultimately show ?thesis unfolding max_def apply auto apply (meson bdd_above_Int1 bdd_above_mono image_Int_subset) by (meson bdd_above_Int1 bdd_above_mono image_Int_subset) qed have bdd_above_6: \bdd_above ((\t. \f *\<^sub>v t\)  ball x r)\ proof- have \bounded (ball x r)\ by simp hence \bounded ((\t. \f *\<^sub>v t\)  ball x r)\ by (metis (no_types) add.left_neutral bdd_above_2 bdd_above_norm bounded_norm_comp image_add_ball image_image) thus ?thesis by (simp add: bounded_imp_bdd_above) qed have norm_1: $$\\. \f *\<^sub>v (x +$$\)  ball 0 r = (\t. \f *\<^sub>v t\)  ball x r\ by (metis add.right_neutral ball_translation image_image) have bdd_above_5: \bdd_above ((\\. norm (f (x + \)))  ball 0 r)\ by (simp add: bdd_above_2) have norm_2: \\\\ < r \ \f *\<^sub>v (x - \)\ \ (\\. \f *\<^sub>v (x + \)\)  ball 0 r\ for \ proof- assume \\\\ < r\ hence \\ \ ball (0::'a) r\ by auto hence \-\ \ ball (0::'a) r\ by auto thus ?thesis by (metis (no_types, lifting) ab_group_add_class.ab_diff_conv_add_uminus image_iff) qed have norm_2': \\\\ < r \ \f *\<^sub>v (x + \)\ \ (\\. \f *\<^sub>v (x - \)\)  ball 0 r\ for \ proof- assume \norm \ < r\ hence \\ \ ball (0::'a) r\ by auto hence \-\ \ ball (0::'a) r\ by auto thus ?thesis by (metis (no_types, lifting) diff_minus_eq_add image_iff) qed have bdd_above_6: \bdd_above ((\\. \f *\<^sub>v (x - \)\)  ball 0 r)\ by (simp add: bdd_above_4) have Sup_2: $$SUP \\ball 0 r. max \f *\<^sub>v (x +$$\ \f *\<^sub>v (x - \)\) = max (SUP \\ball 0 r. \f *\<^sub>v (x + \)\) (SUP \\ball 0 r. \f *\<^sub>v (x - \)\)\ proof- have \ball (0::'a) r \ {}\ using \r > 0\ by auto moreover have \bdd_above ((\\. \f *\<^sub>v (x + \)\)  ball 0 r)\ using bdd_above_5 by blast moreover have \bdd_above ((\\. \f *\<^sub>v (x - \)\)  ball 0 r)\ using bdd_above_6 by blast ultimately show ?thesis using max_Sup by (metis (mono_tags, lifting) Banach_Steinhaus_Missing.pointwise_max_def image_cong) qed have Sup_3': \\\\ < r \ \f *\<^sub>v (x + \)\ \ (\\. \f *\<^sub>v (x - \)\)  ball 0 r\ for \::'a by (simp add: norm_2') have Sup_3'': \\\\ < r \ \f *\<^sub>v (x - \)\ \ (\\. \f *\<^sub>v (x + \)\)  ball 0 r\ for \::'a by (simp add: norm_2) have Sup_3: \max (SUP \\ball 0 r. \f *\<^sub>v (x + \)\) (SUP \\ball 0 r. \f *\<^sub>v (x - \)\) = (SUP \\ball 0 r. \f *\<^sub>v (x + \)\)\ proof- have $$\\. \f *\<^sub>v (x +$$\)  (ball 0 r) = (\\. \f *\<^sub>v (x - \)\)  (ball 0 r)\ apply auto using Sup_3' apply auto using Sup_3'' by blast hence \Sup ((\\. \f *\<^sub>v (x + \)\)  (ball 0 r))=Sup ((\\. \f *\<^sub>v (x - \)\)  (ball 0 r))\ by simp thus ?thesis by simp qed have Sup_1: \Sup ((\t. \f *\<^sub>v t\)  (ball 0 r)) \ Sup ( (\\. \f *\<^sub>v \\)  (ball x r) )\ proof- have $$\t. \f *\<^sub>v t$$ \ \ max \f *\<^sub>v (x + \)\ \f *\<^sub>v (x - \)\\ for \ apply(rule linear_plus_norm) apply (rule bounded_linear.linear) by (simp add: blinfun.bounded_linear_right) moreover have \bdd_above ((\ \. max \f *\<^sub>v (x + \)\ \f *\<^sub>v (x - \)\)  (ball 0 r))\ using bdd_above_1 by blast moreover have \ball (0::'a) r \ {}\ using \r > 0\ by auto ultimately have \Sup ((\t. \f *\<^sub>v t\)  (ball 0 r)) \ Sup ((\\. max \f *\<^sub>v (x + \)\ \f *\<^sub>v (x - \)\)  (ball 0 r))\ - using cSUP_mono by smt + using cSUP_mono by (smt (verit)) also have \\ = max (Sup ((\\. \f *\<^sub>v (x + \)\)  (ball 0 r))) (Sup ((\\. \f *\<^sub>v (x - \)\)  (ball 0 r)))\ using Sup_2 by blast also have \\ = Sup ((\\. \f *\<^sub>v (x + \)\)  (ball 0 r))\ using Sup_3 by blast also have \\ = Sup ((\\. \f *\<^sub>v \\)  (ball x r))\ by (metis add.right_neutral ball_translation image_image) finally show ?thesis by blast qed have \\f\ = (SUP x\ball 0 r. \f *\<^sub>v x\) / r\ using \0 < r\ onorm_r by blast moreover have \Sup ((\t. \f *\<^sub>v t\)  (ball 0 r)) / r \ Sup ((\\. \f *\<^sub>v \\)  (ball x r)) / r\ using Sup_1 \0 < r\ divide_right_mono by fastforce ultimately have \\f\ \ Sup ((\t. \f *\<^sub>v t\)  ball x r) / r\ by simp thus ?thesis by simp qed lemma onorm_Sup_on_ball': includes notation_norm assumes \r > 0\ and \\ < 1\ shows \\\\ball x r. \ * r * \f\ \ \f *\<^sub>v \\\ text \ In the proof of Banach-Steinhaus theorem, we will use this variation of the lemma @{text onorm_Sup_on_ball}. Explanation: Let \<^term>\f\ be a bounded operator, let \<^term>\x\ be a point and let \<^term>\r\ be a positive real number. For any real number \<^term>\\ < 1\, there is a point \<^term>\\\ in the open ball of radius \<^term>\r\ around \<^term>\x\ such that \<^term>\\ * r * \f\ \ \f *\<^sub>v \\\. \ proof(cases \f = 0\) case True thus ?thesis by (metis assms(1) centre_in_ball mult_zero_right norm_zero order_refl zero_blinfun.rep_eq) next case False have bdd_above_1: \bdd_above ((\t. $$*\<^sub>v) f t$$  ball x r)\ for f::\'a \\<^sub>L 'b\ using assms(1) bounded_linear_image by (simp add: bounded_linear_image blinfun.bounded_linear_right bounded_imp_bdd_above bounded_norm_comp) have \norm f > 0\ using \f \ 0\ by auto have \norm f \ Sup ( (\\. $$*\<^sub>v) f \$$  (ball x r) ) / r\ using \r > 0\ by (simp add: onorm_Sup_on_ball) hence \r * norm f \ Sup ( (\\. $$*\<^sub>v) f \$$  (ball x r) )\ - using \0 < r\ by (smt divide_strict_right_mono nonzero_mult_div_cancel_left) + using \0 < r\ by (smt (verit) divide_strict_right_mono nonzero_mult_div_cancel_left) moreover have \\ * r * norm f < r * norm f\ using \\ < 1\ using \0 < norm f\ \0 < r\ by auto ultimately have \\ * r * norm f < Sup ( (norm \ ((*\<^sub>v) f))  (ball x r) )\ by simp moreover have $$norm \ ( (*\<^sub>v) f))  (ball x r) \ {}\ using \0 < r\ by auto moreover have \bdd_above ((norm \ ( (*\<^sub>v) f))  (ball x r))\ using bdd_above_1 apply transfer by simp ultimately have \\t \ (norm \ ( (*\<^sub>v) f))  (ball x r). \ * r * norm f < t\ by (simp add: less_cSup_iff) - thus ?thesis by (smt comp_def image_iff) + thus ?thesis by (smt (verit) comp_def image_iff) qed subsection \Banach-Steinhaus theorem\ theorem banach_steinhaus: fixes f::\'c \ ('a::banach \\<^sub>L 'b::real_normed_vector)\ assumes \\x. bounded (range (\n. (f n) *\<^sub>v x))\ shows \bounded (range f)\ text\ This is Banach-Steinhaus Theorem. Explanation: If a family of bounded operators on a Banach space is pointwise bounded, then it is uniformly bounded. \ proof(rule classical) assume \\(bounded (range f))\ have sum_1: \\K. \n. sum (\k. inverse (real_of_nat 3^k)) {0..n} \ K\ proof- have \summable (\n. inverse ((3::real) ^ n))\ by (simp flip: power_inverse) hence \bounded (range (\n. sum (\ k. inverse (real 3 ^ k)) {0.. using summable_imp_sums_bounded[where f = "(\n. inverse (real_of_nat 3^n))"] lessThan_atLeast0 by auto hence \\M. \h\(range (\n. sum (\ k. inverse (real 3 ^ k)) {0.. M\ using bounded_iff by blast then obtain M where \h\range (\n. sum (\ k. inverse (real 3 ^ k)) {0.. norm h \ M\ for h by blast have sum_2: \sum (\k. inverse (real_of_nat 3^k)) {0..n} \ M\ for n proof- have \norm (sum (\ k. inverse (real 3 ^ k)) {0..< Suc n}) \ M\ using \\h. h\(range (\n. sum (\ k. inverse (real 3 ^ k)) {0.. norm h \ M\ by blast hence \norm (sum (\ k. inverse (real 3 ^ k)) {0..n}) \ M\ by (simp add: atLeastLessThanSuc_atLeastAtMost) hence \(sum (\ k. inverse (real 3 ^ k)) {0..n}) \ M\ by auto thus ?thesis by blast qed have \sum (\k. inverse (real_of_nat 3^k)) {0..n} \ M\ for n using sum_2 by blast thus ?thesis by blast qed have \of_rat 2/3 < (1::real)\ by auto hence \\g::'a \\<^sub>L 'b. \x. \r. \\. g \ 0 \ r > 0 \ (\\ball x r \ (of_rat 2/3) * r * norm g \ norm ((*\<^sub>v) g$$)\ using onorm_Sup_on_ball' by blast hence \\\. \g::'a \\<^sub>L 'b. \x. \r. g \ 0 \ r > 0 \ ((\ g x r)\ball x r \ (of_rat 2/3) * r * norm g \ norm ((*\<^sub>v) g (\ g x r)))\ by metis then obtain \ where f1: \\g \ 0; r > 0\ \ \ g x r \ ball x r \ (of_rat 2/3) * r * norm g \ norm ((*\<^sub>v) g (\ g x r))\ for g::\'a \\<^sub>L 'b\ and x and r by blast have \\n. \k. norm (f k) \ 4^n\ using \$$bounded (range f))\ by (metis (mono_tags, opaque_lifting) boundedI image_iff linear) hence \\k. \n. norm (f (k n)) \ 4^n\ by metis hence \\k. \n. norm ((f \ k) n) \ 4^n\ by simp then obtain k where \norm ((f \ k) n) \ 4^n\ for n by blast define T where \T = f \ k\ have \T n \ range f\ for n unfolding T_def by simp have \norm (T n) \ of_nat (4^n)\ for n unfolding T_def using \\ n. norm ((f \ k) n) \ 4^n\ by auto hence \T n \ 0\ for n - by (smt T_def \\n. 4 ^ n \ norm ((f \ k) n)\ norm_zero power_not_zero zero_le_power) + by (smt (verit) T_def \\n. 4 ^ n \ norm ((f \ k) n)\ norm_zero power_not_zero zero_le_power) have \inverse (of_nat 3^n) > (0::real)\ for n by auto define y::\nat \ 'a\ where \y = rec_nat 0 (\n x. \ (T n) x (inverse (of_nat 3^n)))\ have \y (Suc n) \ ball (y n) (inverse (of_nat 3^n))\ for n using f1 \\ n. T n \ 0\ \\ n. inverse (of_nat 3^n) > 0\ unfolding y_def by auto hence \norm (y (Suc n) - y n) \ inverse (of_nat 3^n)\ for n - unfolding ball_def apply auto using dist_norm by (smt norm_minus_commute) + unfolding ball_def apply auto using dist_norm by (smt (verit) norm_minus_commute) moreover have \\K. \n. sum (\k. inverse (real_of_nat 3^k)) {0..n} \ K\ using sum_1 by blast moreover have \Cauchy y\ using convergent_series_Cauchy[where a = "\n. inverse (of_nat 3^n)" and \ = y] dist_norm by (metis calculation(1) calculation(2)) hence \\ x. y \ x\ by (simp add: convergent_eq_Cauchy) then obtain x where \y \ x\ by blast have norm_2: \norm (x - y (Suc n)) \ (inverse (of_nat 2))*(inverse (of_nat 3^n))\ for n proof- have \inverse (real_of_nat 3) < 1\ by simp moreover have \y 0 = 0\ using y_def by auto ultimately have \norm (x - y (Suc n)) \ (inverse (of_nat 3)) * inverse (1 - (inverse (of_nat 3))) * ((inverse (of_nat 3)) ^ n)\ using bound_Cauchy_to_lim[where c = "inverse (of_nat 3)" and y = y and x = x] power_inverse semiring_norm(77) \y \ x\ \\ n. norm (y (Suc n) - y n) \ inverse (of_nat 3^n)\ by (metis divide_inverse) moreover have \inverse (real_of_nat 3) * inverse (1 - (inverse (of_nat 3))) = inverse (of_nat 2)\ by auto ultimately show ?thesis by (metis power_inverse) qed have \norm (x - y (Suc n)) \ (inverse (of_nat 2))*(inverse (of_nat 3^n))\ for n using norm_2 by blast have \\ M. \ n. norm ((*\<^sub>v) (T n) x) \ M\ unfolding T_def apply auto by (metis \\x. bounded (range (\n. (*\<^sub>v) (f n) x))\ bounded_iff rangeI) then obtain M where \norm ((*\<^sub>v) (T n) x) \ M\ for n by blast have norm_1: \norm (T n) * norm (y (Suc n) - x) + norm ((*\<^sub>v) (T n) x) \ inverse (real 2) * inverse (real 3 ^ n) * norm (T n) + norm ((*\<^sub>v) (T n) x)\ for n proof- have \norm (y (Suc n) - x) \ (inverse (of_nat 2))*(inverse (of_nat 3^n))\ using \norm (x - y (Suc n)) \ (inverse (of_nat 2))*(inverse (of_nat 3^n))\ by (simp add: norm_minus_commute) moreover have \norm (T n) \ 0\ by auto ultimately have \norm (T n) * norm (y (Suc n) - x) \ (inverse (of_nat 2))*(inverse (of_nat 3^n))*norm (T n)\ by (simp add: \\n. T n \ 0$$ thus ?thesis by simp qed have inverse_2: $$inverse (of_nat 6)) * inverse (real 3 ^ n) * norm (T n) \ norm ((*\<^sub>v) (T n) x)\ for n proof- have \(of_rat 2/3)*(inverse (of_nat 3^n))*norm (T n) \ norm ((*\<^sub>v) (T n) (y (Suc n)))\ using f1 \\ n. T n \ 0\ \\ n. inverse (of_nat 3^n) > 0\ unfolding y_def by auto also have \\ = norm ((*\<^sub>v) (T n) ((y (Suc n) - x) + x))\ by auto also have \\ = norm ((*\<^sub>v) (T n) (y (Suc n) - x) + (*\<^sub>v) (T n) x)\ apply transfer apply auto by (metis diff_add_cancel linear_simps(1)) also have \\ \ norm ((*\<^sub>v) (T n) (y (Suc n) - x)) + norm ((*\<^sub>v) (T n) x)\ by (simp add: norm_triangle_ineq) also have \\ \ norm (T n) * norm (y (Suc n) - x) + norm ((*\<^sub>v) (T n) x)\ apply transfer apply auto using onorm by auto also have \\ \ (inverse (of_nat 2))*(inverse (of_nat 3^n))*norm (T n) + norm ((*\<^sub>v) (T n) x)\ using norm_1 by blast finally have \(of_rat 2/3) * inverse (real 3 ^ n) * norm (T n) \ inverse (real 2) * inverse (real 3 ^ n) * norm (T n) + norm ((*\<^sub>v) (T n) x)\ by blast hence \(of_rat 2/3) * inverse (real 3 ^ n) * norm (T n) - inverse (real 2) * inverse (real 3 ^ n) * norm (T n) \ norm ((*\<^sub>v) (T n) x)\ by linarith moreover have \(of_rat 2/3) * inverse (real 3 ^ n) * norm (T n) - inverse (real 2) * inverse (real 3 ^ n) * norm (T n) = (inverse (of_nat 6)) * inverse (real 3 ^ n) * norm (T n)\ by fastforce ultimately show \(inverse (of_nat 6)) * inverse (real 3 ^ n) * norm (T n) \ norm ((*\<^sub>v) (T n) x)\ by linarith qed have inverse_3: \(inverse (of_nat 6)) * (of_rat (4/3)^n) \ (inverse (of_nat 6)) * inverse (real 3 ^ n) * norm (T n)\ for n proof- have \of_rat (4/3)^n = inverse (real 3 ^ n) * (of_nat 4^n)\ apply auto by (metis divide_inverse_commute of_rat_divide power_divide of_rat_numeral_eq) also have \\ \ inverse (real 3 ^ n) * norm (T n)\ using \\n. norm (T n) \ of_nat (4^n)\ by simp finally have \of_rat (4/3)^n \ inverse (real 3 ^ n) * norm (T n)\ by blast moreover have \inverse (of_nat 6) > (0::real)\ by auto ultimately show ?thesis by auto qed have inverse_1: \(inverse (of_nat 6)) * (of_rat (4/3)^n) \ M\ for n proof- have \(inverse (of_nat 6)) * (of_rat (4/3)^n) \ (inverse (of_nat 6)) * inverse (real 3 ^ n) * norm (T n)\ using inverse_3 by blast also have \\ \ norm ((*\<^sub>v) (T n) x)\ using inverse_2 by blast finally have \(inverse (of_nat 6)) * (of_rat (4/3)^n) \ norm ((*\<^sub>v) (T n) x)\ by auto - thus ?thesis using \\ n. norm ((*\<^sub>v) (T n) x) \ M\ by smt + thus ?thesis using \\ n. norm ((*\<^sub>v) (T n) x) \ M\ by (smt (verit)) qed have \\n. M < (inverse (of_nat 6)) * (of_rat (4/3)^n)\ using Real.real_arch_pow by auto moreover have \(inverse (of_nat 6)) * (of_rat (4/3)^n) \ M\ for n using inverse_1 by blast - ultimately show ?thesis by smt + ultimately show ?thesis by (smt (verit)) qed subsection \A consequence of Banach-Steinhaus theorem\ corollary bounded_linear_limit_bounded_linear: fixes f::\nat \ ('a::banach \\<^sub>L 'b::real_normed_vector)\ assumes \\x. convergent (\n. (f n) *\<^sub>v x)\ shows \\g. (\n. (*\<^sub>v) (f n)) \pointwise\ (*\<^sub>v) g\ text\ Explanation: If a sequence of bounded operators on a Banach space converges pointwise, then the limit is also a bounded operator. \ proof- have \\l. (\n. (*\<^sub>v) (f n) x) \ l\ for x by (simp add: \\x. convergent (\n. (*\<^sub>v) (f n) x)\ convergentD) hence \\F. (\n. (*\<^sub>v) (f n)) \pointwise\ F\ unfolding pointwise_convergent_to_def by metis obtain F where \(\n. (*\<^sub>v) (f n)) \pointwise\ F\ using \\F. (\n. (*\<^sub>v) (f n)) \pointwise\ F\ by auto have \\x. (\ n. (*\<^sub>v) (f n) x) \ F x\ using \(\n. (*\<^sub>v) (f n)) \pointwise\ F\ apply transfer by (simp add: pointwise_convergent_to_def) have \bounded (range f)\ using \\x. convergent (\n. (*\<^sub>v) (f n) x)\ banach_steinhaus \\x. \l. (\n. (*\<^sub>v) (f n) x) \ l\ convergent_imp_bounded by blast have norm_f_n: \\ M. \ n. norm (f n) \ M\ unfolding bounded_def by (meson UNIV_I \bounded (range f)\ bounded_iff image_eqI) have \isCont (\ t::'b. norm t) y\ for y::'b using Limits.isCont_norm by simp hence \(\ n. norm ((*\<^sub>v) (f n) x)) \ (norm (F x))\ for x using \\ x::'a. (\ n. (*\<^sub>v) (f n) x) \ F x\ by (simp add: tendsto_norm) hence norm_f_n_x: \\ M. \ n. norm ((*\<^sub>v) (f n) x) \ M\ for x using Elementary_Metric_Spaces.convergent_imp_bounded by (metis UNIV_I \\ x::'a. (\ n. (*\<^sub>v) (f n) x) \ F x\ bounded_iff image_eqI) have norm_f: \\K. \n. \x. norm ((*\<^sub>v) (f n) x) \ norm x * K\ proof- have \\ M. \ n. norm ((*\<^sub>v) (f n) x) \ M\ for x using norm_f_n_x \\x. (\n. (*\<^sub>v) (f n) x) \ F x\ by blast hence \\ M. \ n. norm (f n) \ M\ using norm_f_n by simp then obtain M::real where \\ M. \ n. norm (f n) \ M\ by blast have \\ n. \x. norm ((*\<^sub>v) (f n) x) \ norm x * norm (f n)\ apply transfer apply auto by (metis mult.commute onorm) thus ?thesis using \\ M. \ n. norm (f n) \ M\ by (metis (no_types, opaque_lifting) dual_order.trans norm_eq_zero order_refl mult_le_cancel_left_pos vector_space_over_itself.scale_zero_left zero_less_norm_iff) qed have norm_F_x: \\K. \x. norm (F x) \ norm x * K\ proof- have "\K. \n. \x. norm ((*\<^sub>v) (f n) x) \ norm x * K" using norm_f \\x. (\n. (*\<^sub>v) (f n) x) \ F x\ by auto thus ?thesis using \\ x::'a. (\ n. (*\<^sub>v) (f n) x) \ F x\ apply transfer by (metis Lim_bounded tendsto_norm) qed have \linear F\ proof(rule linear_limit_linear) show \linear ((*\<^sub>v) (f n))\ for n apply transfer apply auto by (simp add: bounded_linear.linear) show \f \pointwise\ F\ using \(\n. (*\<^sub>v) (f n)) \pointwise\ F\ by auto qed moreover have \bounded_linear_axioms F\ using norm_F_x by (simp add: \\x. (\n. (*\<^sub>v) (f n) x) \ F x\ bounded_linear_axioms_def) ultimately have \bounded_linear F\ unfolding bounded_linear_def by blast hence \\g. (*\<^sub>v) g = F\ using bounded_linear_Blinfun_apply by auto thus ?thesis using \(\n. (*\<^sub>v) (f n)) \pointwise\ F\ apply transfer by auto qed end diff --git a/thys/Banach_Steinhaus/Banach_Steinhaus_Missing.thy b/thys/Banach_Steinhaus/Banach_Steinhaus_Missing.thy --- a/thys/Banach_Steinhaus/Banach_Steinhaus_Missing.thy +++ b/thys/Banach_Steinhaus/Banach_Steinhaus_Missing.thy @@ -1,898 +1,898 @@ (* File: Banach_Steinhaus_Missing.thy Author: Dominique Unruh, University of Tartu Author: Jose Manuel Rodriguez Caballero, University of Tartu *) section \Missing results for the proof of Banach-Steinhaus theorem\ theory Banach_Steinhaus_Missing imports "HOL-Analysis.Bounded_Linear_Function" "HOL-Analysis.Line_Segment" begin subsection \Results missing for the proof of Banach-Steinhaus theorem\ text \ The results proved here are preliminaries for the proof of Banach-Steinhaus theorem using Sokal's approach, but they do not explicitly appear in Sokal's paper \<^cite>\sokal2011really\. \ text\Notation for the norm\ bundle notation_norm begin notation norm ("\_\") end bundle no_notation_norm begin no_notation norm ("\_\") end unbundle notation_norm text\Notation for apply bilinear function\ bundle notation_blinfun_apply begin notation blinfun_apply (infixr "*\<^sub>v" 70) end bundle no_notation_blinfun_apply begin no_notation blinfun_apply (infixr "*\<^sub>v" 70) end unbundle notation_blinfun_apply lemma bdd_above_plus: fixes f::\'a \ real\ assumes \bdd_above (f  S)\ and \bdd_above (g  S)\ shows \bdd_above ((\ x. f x + g x)  S)\ text \ Explanation: If the images of two real-valued functions \<^term>\f\,\<^term>\g\ are bounded above on a set \<^term>\S\, then the image of their sum is bounded on \<^term>\S\. \ proof- obtain M where \\ x. x\S \ f x \ M\ using \bdd_above (f  S)\ unfolding bdd_above_def by blast obtain N where \\ x. x\S \ g x \ N\ using \bdd_above (g  S)\ unfolding bdd_above_def by blast have \\ x. x\S \ f x + g x \ M + N\ using \\x. x \ S \ f x \ M\ \\x. x \ S \ g x \ N\ by fastforce thus ?thesis unfolding bdd_above_def by blast qed text\The maximum of two functions\ definition pointwise_max:: "('a \ 'b::ord) \ ('a \ 'b) \ ('a \ 'b)" where \pointwise_max f g = (\x. max (f x) (g x))\ lemma max_Sup_absorb_left: fixes f g::\'a \ real\ assumes \X \ {}\ and \bdd_above (f  X)\ and \bdd_above (g  X)\ and \Sup (f  X) \ Sup (g  X)\ shows \Sup ((pointwise_max f g)  X) = Sup (f  X)\ text \Explanation: For real-valued functions \<^term>\f\ and \<^term>\g\, if the supremum of \<^term>\f\ is greater-equal the supremum of \<^term>\g\, then the supremum of \<^term>\max f g\ equals the supremum of \<^term>\f\. (Under some technical conditions.)\ proof- have y_Sup: \y \ ((\ x. max (f x) (g x))  X) \ y \ Sup (f  X)\ for y proof- assume \y \ ((\ x. max (f x) (g x))  X)\ then obtain x where \y = max (f x) (g x)\ and \x \ X\ by blast have \f x \ Sup (f  X)\ by (simp add: \x \ X\ \bdd_above (f  X)\ cSUP_upper) moreover have \g x \ Sup (g  X)\ by (simp add: \x \ X\ \bdd_above (g  X)\ cSUP_upper) ultimately have \max (f x) (g x) \ Sup (f  X)\ using \Sup (f  X) \ Sup (g  X)\ by auto thus ?thesis by (simp add: \y = max (f x) (g x)$$ qed have y_f_X: \y \ f  X \ y \ Sup ((\ x. max (f x) (g x))  X)\ for y proof- assume \y \ f  X\ then obtain x where \x \ X\ and \y = f x\ by blast have \bdd_above ((\ \. max (f \) (g \))  X)\ by (metis (no_types) \bdd_above (f  X)\ \bdd_above (g  X)\ bdd_above_image_sup sup_max) moreover have \e > 0 \ \ k \ (\ \. max (f \) (g \))  X. y \ k + e\ for e::real using \Sup (f  X) \ Sup (g  X)\ by (smt (verit, best) \x \ X\ \y = f x\ imageI) ultimately show ?thesis using \x \ X\ \y = f x\ cSUP_upper by fastforce qed have \Sup ((\ x. max (f x) (g x))  X) \ Sup (f  X)\ using y_Sup by (simp add: \X \ {}\ cSup_least) moreover have \Sup ((\ x. max (f x) (g x))  X) \ Sup (f  X)\ using y_f_X by (metis (mono_tags) cSup_least calculation empty_is_image) ultimately show ?thesis unfolding pointwise_max_def by simp qed lemma max_Sup_absorb_right: fixes f g::\'a \ real\ assumes \X \ {}\ and \bdd_above (f  X)\ and \bdd_above (g  X)\ and \Sup (f  X) \ Sup (g  X)\ shows \Sup ((pointwise_max f g)  X) = Sup (g  X)\ text \ Explanation: For real-valued functions \<^term>\f\ and \<^term>\g\ and a nonempty set \<^term>\X\, such that the \<^term>\f\ and \<^term>\g\ are bounded above on \<^term>\X\, if the supremum of \<^term>\f\ on \<^term>\X\ is lower-equal the supremum of \<^term>\g\ on \<^term>\X\, then the supremum of \<^term>\pointwise_max f g\ on \<^term>\X\ equals the supremum of \<^term>\g\. This is the right analog of @{text max_Sup_absorb_left}. \ proof- have \Sup ((pointwise_max g f)  X) = Sup (g  X)\ using assms by (simp add: max_Sup_absorb_left) moreover have \pointwise_max g f = pointwise_max f g\ unfolding pointwise_max_def by auto ultimately show ?thesis by simp qed lemma max_Sup: fixes f g::\'a \ real\ assumes \X \ {}\ and \bdd_above (f  X)\ and \bdd_above (g  X)\ shows \Sup ((pointwise_max f g)  X) = max (Sup (f  X)) (Sup (g  X))\ text \ Explanation: Let \<^term>\X\ be a nonempty set. Two supremum over \<^term>\X\ of the maximum of two real-value functions is equal to the maximum of their suprema over \<^term>\X\, provided that the functions are bounded above on \<^term>\X\. \ proof(cases \Sup (f  X) \ Sup (g  X)\) case True thus ?thesis by (simp add: assms(1) assms(2) assms(3) max_Sup_absorb_left) next case False have f1: "\ 0 \ Sup (f  X) + - 1 * Sup (g  X)" using False by linarith hence "Sup (Banach_Steinhaus_Missing.pointwise_max f g  X) = Sup (g  X)" by (simp add: assms(1) assms(2) assms(3) max_Sup_absorb_right) thus ?thesis using f1 by linarith qed lemma identity_telescopic: fixes x :: \_ \ 'a::real_normed_vector\ assumes \x \ l\ shows $$\ N. sum (\ k. x (Suc k) - x k) {n..N}) \ l - x n\ text\ Expression of a limit as a telescopic series. Explanation: If \<^term>\x\ converges to \<^term>\l\ then the sum \<^term>\sum (\ k. x (Suc k) - x k) {n..N}\ converges to \<^term>\l - x n\ as \<^term>\N\ goes to infinity. \ proof- have \(\ p. x (p + Suc n)) \ l\ using \x \ l\ by (rule LIMSEQ_ignore_initial_segment) hence \(\ p. x (Suc n + p)) \ l\ by (simp add: add.commute) hence \(\ p. x (Suc (n + p))) \ l\ by simp hence \(\ t. (- (x n)) + (\ p. x (Suc (n + p))) t ) \ (- (x n)) + l\ using tendsto_add_const_iff by metis hence f1: \(\ p. x (Suc (n + p)) - x n)\ l - x n\ by simp have \sum (\ k. x (Suc k) - x k) {n..n+p} = x (Suc (n+p)) - x n\ for p by (simp add: sum_Suc_diff) moreover have \(\ N. sum (\ k. x (Suc k) - x k) {n..N}) (n + t) = (\ p. sum (\ k. x (Suc k) - x k) {n..n+p}) t\ for t by blast ultimately have \(\ p. (\ N. sum (\ k. x (Suc k) - x k) {n..N}) (n + p)) \ l - x n\ using f1 by simp hence \(\ p. (\ N. sum (\ k. x (Suc k) - x k) {n..N}) (p + n)) \ l - x n\ by (simp add: add.commute) hence \(\ p. (\ N. sum (\ k. x (Suc k) - x k) {n..N}) p) \ l - x n\ using Topological_Spaces.LIMSEQ_offset[where f = "(\ N. sum (\ k. x (Suc k) - x k) {n..N})" and a = "l - x n" and k = n] by blast hence \(\ M. (\ N. sum (\ k. x (Suc k) - x k) {n..N}) M) \ l - x n\ by simp thus ?thesis by blast qed lemma bound_Cauchy_to_lim: assumes \y \ x\ and \\n. \y (Suc n) - y n\ \ c^n\ and \y 0 = 0\ and \c < 1\ shows \\x - y (Suc n)\ \ (c / (1 - c)) * c ^ n\ text\ Inequality about a sequence of approximations assuming that the sequence of differences is bounded by a geometric progression. Explanation: Let \<^term>\y\ be a sequence converging to \<^term>\x\. If \<^term>\y\ satisfies the inequality \\y (Suc n) - y n\ \ c ^ n\ for some \<^term>\c < 1\ and assuming \<^term>\y 0 = 0\ then the inequality \\x - y (Suc n)\ \ (c / (1 - c)) * c ^ n\ holds. \ proof- have \c \ 0\ using \\ n. \y (Suc n) - y n\ \ c^n\ by (metis dual_order.trans norm_ge_zero power_one_right) have norm_1: \norm (\k = Suc n..N. y (Suc k) - y k) \ (c ^ Suc n)/(1 - c)\ for N proof(cases \N < Suc n$$ case True hence \\sum (\k. y (Suc k) - y k) {Suc n .. N}\ = 0\ by auto thus ?thesis using \c \ 0\ \c < 1\ by auto next case False hence \N \ Suc n\ by auto have \c^(Suc N) \ 0\ using \c \ 0\ by auto have \1 - c > 0\ by (simp add: \c < 1\) hence $$1 - c)/(1 - c) = 1\ by auto have \\sum (\k. y (Suc k) - y k) {Suc n .. N}\ \ (sum (\k. \y (Suc k) - y k$$ {Suc n .. N})\ by (simp add: sum_norm_le) hence \\sum (\k. y (Suc k) - y k) {Suc n .. N}\ \ (sum (power c) {Suc n .. N})\ by (simp add: assms(2) sum_norm_le) hence $$1 - c) * \sum (\k. y (Suc k) - y k) {Suc n .. N}\ \ (1 - c) * (sum (power c) {Suc n .. N})\ using \0 < 1 - c\ mult_le_cancel_left_pos by blast also have \\ = c^(Suc n) - c^(Suc N)\ using Set_Interval.sum_gp_multiplied \Suc n \ N\ by blast also have \\ \ c^(Suc n)\ using \c^(Suc N) \ 0\ by auto finally have \(1 - c) * \\k = Suc n..N. y (Suc k) - y k\ \ c ^ Suc n\ by blast hence \((1 - c) * \\k = Suc n..N. y (Suc k) - y k$$/(1 - c) \ (c ^ Suc n)/(1 - c)\ using \0 < 1 - c\ divide_le_cancel by fastforce thus \\\k = Suc n..N. y (Suc k) - y k\ \ (c ^ Suc n)/(1 - c)\ using \0 < 1 - c\ by auto qed have $$\ N. (sum (\k. y (Suc k) - y k) {Suc n .. N})) \ x - y (Suc n)\ by (metis (no_types) \y \ x\ identity_telescopic) hence \(\ N. \sum (\k. y (Suc k) - y k) {Suc n .. N}$$ \ \x - y (Suc n)\\ using tendsto_norm by blast hence \\x - y (Suc n)\ \ (c ^ Suc n)/(1 - c)\ using norm_1 Lim_bounded by blast hence \\x - y (Suc n)\ \ (c ^ Suc n)/(1 - c)\ by auto moreover have $$c ^ Suc n)/(1 - c) = (c / (1 - c)) * (c ^ n)\ by (simp add: divide_inverse_commute) ultimately show \\x - y (Suc n)\ \ (c / (1 - c)) * (c ^ n)\ by linarith qed lemma onorm_open_ball: includes notation_norm shows \\f\ = Sup { \f *\<^sub>v x\ | x. \x\ < 1 }\ text \ Explanation: Let \<^term>\f\ be a bounded linear operator. The operator norm of \<^term>\f\ is the supremum of \<^term>\norm (f x)\ for \<^term>\x\ such that \<^term>\norm x < 1\. \ proof(cases \(UNIV::'a set) = 0$$ case True hence \x = 0\ for x::'a by auto hence \f *\<^sub>v x = 0\ for x by (metis (full_types) blinfun.zero_right) hence \\f\ = 0\ by (simp add: blinfun_eqI zero_blinfun.rep_eq) have \{ \f *\<^sub>v x\ | x. \x\ < 1} = {0}\ by (smt (verit, ccfv_SIG) Collect_cong \\x. f *\<^sub>v x = 0\ norm_zero singleton_conv) hence \Sup { \f *\<^sub>v x\ | x. \x\ < 1} = 0\ by simp thus ?thesis using \\f\ = 0\ by auto next case False hence $$UNIV::'a set) \ 0\ by simp have nonnegative: \\f *\<^sub>v x\ \ 0\ for x by simp have \\ x::'a. x \ 0\ using \UNIV \ 0\ by auto then obtain x::'a where \x \ 0\ by blast hence \\x\ \ 0\ by auto define y where \y = x /\<^sub>R \x\\ have \norm y = \ x /\<^sub>R \x\ \\ unfolding y_def by auto also have \\ = \x\ /\<^sub>R \x\\ by auto also have \\ = 1\ using \\x\ \ 0\ by auto finally have \\y\ = 1\ by blast hence norm_1_non_empty: \{ \f *\<^sub>v x\ | x. \x\ = 1} \ {}\ by blast have norm_1_bounded: \bdd_above { \f *\<^sub>v x\ | x. \x\ = 1}\ unfolding bdd_above_def apply auto by (metis norm_blinfun) have norm_less_1_non_empty: \{\f *\<^sub>v x\ | x. \x\ < 1} \ {}\ by (metis (mono_tags, lifting) Collect_empty_eq_bot bot_empty_eq empty_iff norm_zero zero_less_one) have norm_less_1_bounded: \bdd_above {\f *\<^sub>v x\ | x. \x\ < 1}\ proof- have \\r. \a r\ < 1 \ \f *\<^sub>v (a r)\ \ r\ for a :: "real \ 'a" proof- obtain r :: "('a \\<^sub>L 'b) \ real" where "\f x. 0 \ r f \ (bounded_linear f \ \f *\<^sub>v x\ \ \x\ * r f)" by (metis mult.commute norm_blinfun norm_ge_zero) have \\ \f\ < 0\ by simp hence "(\r. \f\ * \a r\ \ r) \ (\r. \a r\ < 1 \ \f *\<^sub>v a r\ \ r)" by (meson less_eq_real_def mult_le_cancel_left2) thus ?thesis using dual_order.trans norm_blinfun by blast qed hence \\ M. \ x. \x\ < 1 \ \f *\<^sub>v x\ \ M\ by metis thus ?thesis by auto qed have Sup_non_neg: \Sup {\f *\<^sub>v x\ |x. \x\ = 1} \ 0\ by (metis (mono_tags, lifting) \\y\ = 1\ cSup_upper2 mem_Collect_eq norm_1_bounded norm_ge_zero) have \{0::real} \ {}\ by simp have \bdd_above {0::real}\ by simp show \\f\ = Sup {\f *\<^sub>v x\ | x. \x\ < 1}\ proof(cases \\x. f *\<^sub>v x = 0$$ case True have \\f *\<^sub>v x\ = 0\ for x by (simp add: True) hence \{\f *\<^sub>v x\ | x. \x\ < 1 } \ {0}\ by blast moreover have \{\f *\<^sub>v x\ | x. \x\ < 1 } \ {0}\ using calculation norm_less_1_non_empty by fastforce ultimately have \{\f *\<^sub>v x\ | x. \x\ < 1 } = {0}\ by blast hence Sup1: \Sup {\f *\<^sub>v x\ | x. \x\ < 1 } = 0\ by simp have \\f\ = 0\ by (simp add: True blinfun_eqI) moreover have \Sup {\f *\<^sub>v x\ | x. \x\ < 1} = 0\ using Sup1 by blast ultimately show ?thesis by simp next case False have norm_f_eq_leq: \y \ {\f *\<^sub>v x\ | x. \x\ = 1} \ y \ Sup {\f *\<^sub>v x\ | x. \x\ < 1}\ for y proof- assume \y \ {\f *\<^sub>v x\ | x. \x\ = 1}\ hence \\ x. y = \f *\<^sub>v x\ \ \x\ = 1\ by blast then obtain x where \y = \f *\<^sub>v x\\ and \\x\ = 1\ by auto define y' where \y' n = (1 - (inverse (real (Suc n)))) *\<^sub>R y\ for n have \y' n \ {\f *\<^sub>v x\ | x. \x\ < 1}\ for n proof- have \y' n = (1 - (inverse (real (Suc n)))) *\<^sub>R \f *\<^sub>v x\\ using y'_def \y = \f *\<^sub>v x\\ by blast also have \... = $$1 - (inverse (real (Suc n))))\ *\<^sub>R \f *\<^sub>v x\\ by (metis (mono_tags, opaque_lifting) \y = \f *\<^sub>v x\\ abs_1 abs_le_self_iff abs_of_nat abs_of_nonneg add_diff_cancel_left' add_eq_if cancel_comm_monoid_add_class.diff_cancel diff_ge_0_iff_ge eq_iff_diff_eq_0 inverse_1 inverse_le_iff_le nat.distinct(1) of_nat_0 of_nat_Suc of_nat_le_0_iff zero_less_abs_iff zero_neq_one) also have \... = \f *\<^sub>v ((1 - (inverse (real (Suc n)))) *\<^sub>R x)\\ by (simp add: blinfun.scaleR_right) finally have y'_1: \y' n = \f *\<^sub>v ( (1 - (inverse (real (Suc n)))) *\<^sub>R x)\\ by blast have \\(1 - (inverse (Suc n))) *\<^sub>R x\ = (1 - (inverse (real (Suc n)))) * \x\\ by (simp add: linordered_field_class.inverse_le_1_iff) hence \\(1 - (inverse (Suc n))) *\<^sub>R x\ < 1\ by (simp add: \\x\ = 1$$ thus ?thesis using y'_1 by blast qed have $$\n. (1 - (inverse (real (Suc n)))) ) \ 1\ using Limits.LIMSEQ_inverse_real_of_nat_add_minus by simp hence \(\n. (1 - (inverse (real (Suc n)))) *\<^sub>R y) \ 1 *\<^sub>R y\ using Limits.tendsto_scaleR by blast hence \(\n. (1 - (inverse (real (Suc n)))) *\<^sub>R y) \ y\ by simp hence \(\n. y' n) \ y\ using y'_def by simp hence \y' \ y\ by simp have \y' n \ Sup {\f *\<^sub>v x\ | x. \x\ < 1}\ for n using cSup_upper \\n. y' n \ {\f *\<^sub>v x\ |x. \x\ < 1}\ norm_less_1_bounded by blast hence \y \ Sup {\f *\<^sub>v x\ | x. \x\ < 1}\ using \y' \ y\ Topological_Spaces.Sup_lim by (meson LIMSEQ_le_const2) thus ?thesis by blast qed hence \Sup {\f *\<^sub>v x\ | x. \x\ = 1} \ Sup {\f *\<^sub>v x\ | x. \x\ < 1}\ by (metis (lifting) cSup_least norm_1_non_empty) have \y \ {\f *\<^sub>v x\ | x. \x\ < 1} \ y \ Sup {\f *\<^sub>v x\ | x. \x\ = 1}\ for y proof(cases \y = 0$$ case True thus ?thesis by (simp add: Sup_non_neg) next case False hence \y \ 0\ by blast assume \y \ {\f *\<^sub>v x\ | x. \x\ < 1}\ hence \\ x. y = \f *\<^sub>v x\ \ \x\ < 1\ by blast then obtain x where \y = \f *\<^sub>v x\\ and \\x\ < 1\ by blast have $$1/\x$$ * y = (1/\x\) * \f x\\ by (simp add: \y = \f *\<^sub>v x\\) also have \... = \1/\x\\ * \f *\<^sub>v x\\ by simp also have \... = $$1/\x$$ *\<^sub>R (f *\<^sub>v x)\\ by simp also have \... = \f *\<^sub>v ((1/\x\) *\<^sub>R x)\\ by (simp add: blinfun.scaleR_right) finally have $$1/\x$$ * y = \f *\<^sub>v ((1/\x\) *\<^sub>R x)\\ by blast have \x \ 0\ using \y \ 0\ \y = \f *\<^sub>v x\\ blinfun.zero_right by auto have \\ (1/\x\) *\<^sub>R x \ = \ (1/\x\) \ * \x\\ by simp also have \... = (1/\x\) * \x\\ by simp finally have \$$1/\x$$ *\<^sub>R x\ = 1\ using \x \ 0\ by simp hence $$1/\x$$ * y \ { \f *\<^sub>v x\ | x. \x\ = 1}\ using \1 / \x\ * y = \f *\<^sub>v (1 / \x\) *\<^sub>R x\\ by blast hence $$1/\x$$ * y \ Sup { \f *\<^sub>v x\ | x. \x\ = 1}\ by (simp add: cSup_upper norm_1_bounded) moreover have \y \ (1/\x\) * y\ by (metis \\x\ < 1\ \y = \f *\<^sub>v x\\ mult_le_cancel_right1 norm_not_less_zero order.strict_implies_order \x \ 0\ less_divide_eq_1_pos zero_less_norm_iff) ultimately show ?thesis by linarith qed hence \Sup { \f *\<^sub>v x\ | x. \x\ < 1} \ Sup { \f *\<^sub>v x\ | x. \x\ = 1}\ by (smt (verit, del_insts) less_cSupD norm_less_1_non_empty) hence \Sup { \f *\<^sub>v x\ | x. \x\ = 1} = Sup { \f *\<^sub>v x\ | x. \x\ < 1}\ using \Sup {\f *\<^sub>v x\ |x. norm x = 1} \ Sup { \f *\<^sub>v x\ |x. \x\ < 1}\ by linarith have f1: $$SUP x. \f *\<^sub>v x\ / \x$$ = Sup { \f *\<^sub>v x\ / \x\ | x. True}\ by (simp add: full_SetCompr_eq) have \y \ { \f *\<^sub>v x\ / \x\ |x. True} \ y \ { \f *\<^sub>v x\ |x. \x\ = 1} \ {0}\ for y proof- assume \y \ { \f *\<^sub>v x\ / \x\ |x. True}\ show ?thesis proof(cases \y = 0\) case True thus ?thesis by simp next case False have \\ x. y = \f *\<^sub>v x\ / \x\\ using \y \ { \f *\<^sub>v x\ / \x\ |x. True}\ by auto then obtain x where \y = \f *\<^sub>v x\ / \x\\ by blast hence \y = $$1/\x$$\ * \ f *\<^sub>v x \\ by simp hence \y = $$1/\x$$ *\<^sub>R (f *\<^sub>v x)\\ by simp hence \y = \f ((1/\x\) *\<^sub>R x)\\ by (simp add: blinfun.scaleR_right) moreover have \\ (1/\x\) *\<^sub>R x \ = 1\ using False \y = \f *\<^sub>v x\ / \x\\ by auto ultimately have \y \ {\f *\<^sub>v x\ |x. \x\ = 1}\ by blast thus ?thesis by blast qed qed moreover have \y \ {\f x\ |x. \x\ = 1} \ {0} \ y \ {\f *\<^sub>v x\ / \x\ |x. True}\ for y proof(cases \y = 0\) case True thus ?thesis by auto next case False hence \y \ {0}\ by simp moreover assume \y \ {\f *\<^sub>v x\ |x. \x\ = 1} \ {0}\ ultimately have \y \ {\f *\<^sub>v x\ |x. \x\ = 1}\ by simp then obtain x where \\x\ = 1\ and \y = \f *\<^sub>v x\\ by auto have \y = \f *\<^sub>v x\ / \x\\ using \\x\ = 1\ \y = \f *\<^sub>v x\\ by simp thus ?thesis by auto qed ultimately have \{\f *\<^sub>v x\ / \x\ |x. True} = {\f *\<^sub>v x\ |x. \x\ = 1} \ {0}\ by blast hence \Sup {\f *\<^sub>v x\ / \x\ |x. True} = Sup ({\f *\<^sub>v x\ |x. \x\ = 1} \ {0})\ by simp have "\r s. \ (r::real) \ s \ sup r s = s" by (metis (lifting) sup.absorb_iff1 sup_commute) hence \Sup ({\f *\<^sub>v x\ |x. \x\ = 1} \ {(0::real)}) = max (Sup {\f *\<^sub>v x\ |x. \x\ = 1}) (Sup {0::real})\ using \0 \ Sup {\f *\<^sub>v x\ |x. \x\ = 1}\ \bdd_above {0}\ \{0} \ {}\ cSup_singleton cSup_union_distrib max.absorb_iff1 sup_commute norm_1_bounded norm_1_non_empty by (metis (no_types, lifting) ) moreover have \Sup {(0::real)} = (0::real)\ by simp ultimately have \Sup ({\f *\<^sub>v x\ |x. \x\ = 1} \ {0}) = Sup {\f *\<^sub>v x\ |x. \x\ = 1}\ using Sup_non_neg by linarith moreover have \Sup ( {\f *\<^sub>v x\ |x. \x\ = 1} \ {0}) = max (Sup {\f *\<^sub>v x\ |x. \x\ = 1}) (Sup {0}) \ using Sup_non_neg \Sup ({\f *\<^sub>v x\ |x. \x\ = 1} \ {0}) = max (Sup {\f *\<^sub>v x\ |x. \x\ = 1}) (Sup {0})\ by auto ultimately have f2: \Sup {\f *\<^sub>v x\ / \x\ | x. True} = Sup {\f *\<^sub>v x\ | x. \x\ = 1}\ using \Sup {\f *\<^sub>v x\ / \x\ |x. True} = Sup ({\f *\<^sub>v x\ |x. \x\ = 1} \ {0})\ by linarith have $$SUP x. \f *\<^sub>v x\ / \x$$ = Sup {\f *\<^sub>v x\ | x. \x\ = 1}\ using f1 f2 by linarith hence $$SUP x. \f *\<^sub>v x\ / \x$$ = Sup {\f *\<^sub>v x\ | x. \x\ < 1 }\ by (simp add: \Sup {\f *\<^sub>v x\ |x. \x\ = 1} = Sup {\f *\<^sub>v x\ |x. \x\ < 1}\) thus ?thesis apply transfer by (simp add: onorm_def) qed qed lemma onorm_r: includes notation_norm assumes \r > 0\ shows \\f\ = Sup ((\x. \f *\<^sub>v x\)  (ball 0 r)) / r\ text \ Explanation: The norm of \<^term>\f\ is \<^term>\1/r\ of the supremum of the norm of \<^term>\f *\<^sub>v x\ for \<^term>\x\ in the ball of radius \<^term>\r\ centered at the origin. \ proof- have \\f\ = Sup {\f *\<^sub>v x\ |x. \x\ < 1}\ using onorm_open_ball by blast moreover have *: \{\f *\<^sub>v x\ |x. \x\ < 1} = (\x. \f *\<^sub>v x\)  (ball 0 1)\ unfolding ball_def by auto ultimately have onorm_f: \\f\ = Sup ((\x. \f *\<^sub>v x\)  (ball 0 1))\ by simp have s2: \x \ (\t. r *\<^sub>R \f *\<^sub>v t\)  ball 0 1 \ x \ r * Sup ((\t. \f *\<^sub>v t\)  ball 0 1)\ for x proof- assume \x \ (\t. r *\<^sub>R \f *\<^sub>v t\)  ball 0 1\ hence \\ t. x = r *\<^sub>R \f *\<^sub>v t\ \ \t\ < 1\ by auto then obtain t where t: \x = r *\<^sub>R \f *\<^sub>v t\\ \\t\ < 1\ by blast define y where \y = x /\<^sub>R r\ have \x = r * (inverse r * x)\ using \x = r *\<^sub>R norm (f t)\ by auto hence \x - (r * (inverse r * x)) \ 0\ by linarith hence \x \ r * (x /\<^sub>R r)\ by auto have \y \ (\k. \f *\<^sub>v k\)  ball 0 1\ unfolding y_def using assms t * by fastforce moreover have \x \ r * y\ using \x \ r * (x /\<^sub>R r)\ y_def by blast ultimately have y_norm_f: \y \ (\t. \f *\<^sub>v t\)  ball 0 1 \ x \ r * y\ by blast have $$\t. \f *\<^sub>v t$$  ball 0 1 \ {}\ by simp moreover have \bdd_above ((\t. \f *\<^sub>v t\)  ball 0 1)\ by (simp add: bounded_linear_image blinfun.bounded_linear_right bounded_imp_bdd_above bounded_norm_comp) moreover have \\ y. y \ (\t. \f *\<^sub>v t\)  ball 0 1 \ x \ r * y\ using y_norm_f by blast ultimately show ?thesis by (meson assms cSup_upper dual_order.trans mult_le_cancel_left_pos) qed have s3: $$\x. x \ (\t. r * \f *\<^sub>v t$$  ball 0 1 \ x \ y) \ r * Sup ((\t. \f *\<^sub>v t\)  ball 0 1) \ y\ for y proof- assume \\x. x \ (\t. r * \f *\<^sub>v t\)  ball 0 1 \ x \ y\ have x_leq: \x \ (\t. \f *\<^sub>v t\)  ball 0 1 \ x \ y / r\ for x proof- assume \x \ (\t. \f *\<^sub>v t\)  ball 0 1\ then obtain t where \t \ ball (0::'a) 1\ and \x = \f *\<^sub>v t\\ by auto define x' where \x' = r *\<^sub>R x\ have \x' = r * \f *\<^sub>v t\\ by (simp add: \x = \f *\<^sub>v t\\ x'_def) hence \x' \ (\t. r * \f *\<^sub>v t\)  ball 0 1\ using \t \ ball (0::'a) 1\ by auto hence \x' \ y\ using \\x. x \ (\t. r * \f *\<^sub>v t\)  ball 0 1 \ x \ y\ by blast thus \x \ y / r\ unfolding x'_def using \r > 0\ by (simp add: mult.commute pos_le_divide_eq) qed have $$\t. \f *\<^sub>v t$$  ball 0 1 \ {}\ by simp moreover have \bdd_above ((\t. \f *\<^sub>v t\)  ball 0 1)\ by (simp add: bounded_linear_image blinfun.bounded_linear_right bounded_imp_bdd_above bounded_norm_comp) ultimately have \Sup ((\t. \f *\<^sub>v t\)  ball 0 1) \ y/r\ using x_leq by (simp add: \bdd_above ((\t. \f *\<^sub>v t\)  ball 0 1)\ cSup_least) thus ?thesis using \r > 0\ by (simp add: mult.commute pos_le_divide_eq) qed have norm_scaleR: \norm \ ((*\<^sub>R) r) = ((*\<^sub>R) \r\) \ (norm::'a \ real)\ by auto have f_x1: \f (r *\<^sub>R x) = r *\<^sub>R f x\ for x by (simp add: blinfun.scaleR_right) have \ball (0::'a) r = ((*\<^sub>R) r)  (ball 0 1)\ - by (smt assms ball_scale nonzero_mult_div_cancel_left right_inverse_eq scale_zero_right) + by (smt (verit) assms ball_scale nonzero_mult_div_cancel_left right_inverse_eq scale_zero_right) hence \Sup ((\t. \f *\<^sub>v t\)  (ball 0 r)) = Sup ((\t. \f *\<^sub>v t\)  (((*\<^sub>R) r)  (ball 0 1)))\ by simp also have \\ = Sup (((\t. \f *\<^sub>v t\) \ ((*\<^sub>R) r))  (ball 0 1))\ using Sup.SUP_image by auto also have \\ = Sup ((\t. \f *\<^sub>v (r *\<^sub>R t)\)  (ball 0 1))\ using f_x1 by (simp add: comp_assoc) also have \\ = Sup ((\t. \r\ *\<^sub>R \f *\<^sub>v t\)  (ball 0 1))\ using norm_scaleR f_x1 by auto also have \\ = Sup ((\t. r *\<^sub>R \f *\<^sub>v t\)  (ball 0 1))\ using \r > 0\ by auto also have \\ = r * Sup ((\t. \f *\<^sub>v t\)  (ball 0 1))\ apply (rule cSup_eq_non_empty) apply simp using s2 apply auto using s3 by auto also have \\ = r * \f\\ using onorm_f by auto finally have \Sup ((\t. \f *\<^sub>v t\)  ball 0 r) = r * \f\\ by blast thus \\f\ = Sup ((\x. \f *\<^sub>v x\)  (ball 0 r)) / r\ using \r > 0\ by simp qed text\Pointwise convergence\ definition pointwise_convergent_to :: $$nat \ ('a \ 'b::topological_space) ) \ ('a \ 'b) \ bool\ (\((_)/ \pointwise\ (_))\ [60, 60] 60) where \pointwise_convergent_to x l = (\ t::'a. (\ n. (x n) t) \ l t)\ lemma linear_limit_linear: fixes f :: \_ \ ('a::real_vector \ 'b::real_normed_vector)\ assumes \\n. linear (f n)\ and \f \pointwise\ F\ shows \linear F\ text\ Explanation: If a family of linear operators converges pointwise, then the limit is also a linear operator. \ proof show "F (x + y) = F x + F y" for x y proof- have "\a. F a = lim (\n. f n a)" using \f \pointwise\ F\ unfolding pointwise_convergent_to_def by (metis (full_types) limI) moreover have "\f b c g. (lim (\n. g n + f n) = (b::'b) + c \ \ f \ c) \ \ g \ b" by (metis (no_types) limI tendsto_add) moreover have "\a. (\n. f n a) \ F a" using assms(2) pointwise_convergent_to_def by force ultimately have lim_sum: \lim (\ n. (f n) x + (f n) y) = lim (\ n. (f n) x) + lim (\ n. (f n) y)\ by metis have \(f n) (x + y) = (f n) x + (f n) y\ for n using \\ n. linear (f n)\ unfolding linear_def using Real_Vector_Spaces.linear_iff assms(1) by auto hence \lim (\ n. (f n) (x + y)) = lim (\ n. (f n) x + (f n) y)\ by simp hence \lim (\ n. (f n) (x + y)) = lim (\ n. (f n) x) + lim (\ n. (f n) y)\ using lim_sum by simp moreover have \(\ n. (f n) (x + y)) \ F (x + y)\ using \f \pointwise\ F\ unfolding pointwise_convergent_to_def by blast moreover have \(\ n. (f n) x) \ F x\ using \f \pointwise\ F\ unfolding pointwise_convergent_to_def by blast moreover have \(\ n. (f n) y) \ F y\ using \f \pointwise\ F\ unfolding pointwise_convergent_to_def by blast ultimately show ?thesis by (metis limI) qed show "F (r *\<^sub>R x) = r *\<^sub>R F x" for r and x proof- have \(f n) (r *\<^sub>R x) = r *\<^sub>R (f n) x\ for n using \\ n. linear (f n)\ by (simp add: Real_Vector_Spaces.linear_def real_vector.linear_scale) hence \lim (\ n. (f n) (r *\<^sub>R x)) = lim (\ n. r *\<^sub>R (f n) x)\ by simp have \convergent (\ n. (f n) x)\ by (metis assms(2) convergentI pointwise_convergent_to_def) moreover have \isCont (\ t::'b. r *\<^sub>R t) tt\ for tt by (simp add: bounded_linear_scaleR_right) ultimately have \lim (\ n. r *\<^sub>R ((f n) x)) = r *\<^sub>R lim (\ n. (f n) x)\ using \f \pointwise\ F\ unfolding pointwise_convergent_to_def by (metis (mono_tags) isCont_tendsto_compose limI) hence \lim (\ n. (f n) (r *\<^sub>R x)) = r *\<^sub>R lim (\ n. (f n) x)\ using \lim (\ n. (f n) (r *\<^sub>R x)) = lim (\ n. r *\<^sub>R (f n) x)\ by simp moreover have \(\ n. (f n) x) \ F x\ using \f \pointwise\ F\ unfolding pointwise_convergent_to_def by blast moreover have \(\ n. (f n) (r *\<^sub>R x)) \ F (r *\<^sub>R x)\ using \f \pointwise\ F\ unfolding pointwise_convergent_to_def by blast ultimately show ?thesis by (metis limI) qed qed lemma non_Cauchy_unbounded: fixes a ::\_ \ real\ assumes \\n. a n \ 0\ and \e > 0\ and \\M. \m. \n. m \ M \ n \ M \ m > n \ sum a {Suc n..m} \ e\ shows \(\n. (sum a {0..n})) \ \\ text\ Explanation: If the sequence of partial sums of nonnegative terms is not Cauchy, then it converges to infinite. \ proof- define S::"ereal set" where \S = range (\n. sum a {0..n})\ have \\s\S. k*e \ s\ for k::nat proof(induction k) case 0 from \\M. \m. \n. m \ M \ n \ M \ m > n \ sum a {Suc n..m} \ e\ obtain m n where \m \ 0\ and \n \ 0\ and \m > n\ and \sum a {Suc n..m} \ e\ by blast have \n < Suc n\ by simp hence \{0..n} \ {Suc n..m} = {0..m}\ using Set_Interval.ivl_disj_un(7) \n < m\ by auto moreover have \finite {0..n}\ by simp moreover have \finite {Suc n..m}\ by simp moreover have \{0..n} \ {Suc n..m} = {}\ by simp ultimately have \sum a {0..n} + sum a {Suc n..m} = sum a {0..m}\ by (metis sum.union_disjoint) moreover have \sum a {Suc n..m} > 0\ using \e > 0\ \sum a {Suc n..m} \ e\ by linarith moreover have \sum a {0..n} \ 0\ by (simp add: assms(1) sum_nonneg) ultimately have \sum a {0..m} > 0\ by linarith moreover have \sum a {0..m} \ S\ unfolding S_def by blast ultimately have \\s\S. 0 \ s\ using ereal_less_eq(5) by fastforce thus ?case by (simp add: zero_ereal_def) next case (Suc k) assume \\s\S. k*e \ s\ then obtain s where \s\S\ and \ereal (k * e) \ s\ by blast have \\N. s = sum a {0..N}\ using \s\S\ unfolding S_def by blast then obtain N where \s = sum a {0..N}\ by blast from \\M. \m. \n. m \ M \ n \ M \ m > n \ sum a {Suc n..m} \ e\ obtain m n where \m \ Suc N\ and \n \ Suc N\ and \m > n\ and \sum a {Suc n..m} \ e\ by blast have \finite {Suc N..n}\ by simp moreover have \finite {Suc n..m}\ by simp moreover have \{Suc N..n} \ {Suc n..m} = {Suc N..m}\ using Set_Interval.ivl_disj_un by (metis \Suc N \ n\ \n < m\ atLeastSucAtMost_greaterThanAtMost order_less_imp_le) moreover have \{} = {Suc N..n} \ {Suc n..m}\ by simp ultimately have \sum a {Suc N..m} = sum a {Suc N..n} + sum a {Suc n..m}\ by (metis sum.union_disjoint) moreover have \sum a {Suc N..n} \ 0\ using \\n. a n \ 0\ by (simp add: sum_nonneg) ultimately have \sum a {Suc N..m} \ e\ using \e \ sum a {Suc n..m}\ by linarith have \finite {0..N}\ by simp have \finite {Suc N..m}\ by simp moreover have \{0..N} \ {Suc N..m} = {0..m}\ using Set_Interval.ivl_disj_un(7) \Suc N \ m\ by auto moreover have \{0..N} \ {Suc N..m} = {}\ by simp ultimately have \sum a {0..N} + sum a {Suc N..m} = sum a {0..m}\ by (metis \finite {0..N}\ sum.union_disjoint) hence \e + k * e \ sum a {0..m}\ using \ereal (real k * e) \ s\ \s = ereal (sum a {0..N})\ \e \ sum a {Suc N..m}\ by auto moreover have \e + k * e = (Suc k) * e\ by (simp add: semiring_normalization_rules(3)) ultimately have \(Suc k) * e \ sum a {0..m}\ by linarith hence \ereal ((Suc k) * e) \ sum a {0..m}\ by auto moreover have \sum a {0..m}\S\ unfolding S_def by blast ultimately show ?case by blast qed hence \\s\S. (real n) \ s\ for n by (meson assms(2) ereal_le_le ex_less_of_nat_mult less_le_not_le) hence \Sup S = \\ using Sup_le_iff Sup_subset_mono dual_order.strict_trans1 leD less_PInf_Ex_of_nat subsetI by metis hence Sup: \Sup ((range (\ n. (sum a {0..n})))::ereal set) = \\ using S_def by blast have \incseq (\n. (sum a {.. using \\n. a n \ 0\ using Extended_Real.incseq_sumI by auto hence \incseq (\n. (sum a {..< Suc n}))\ by (meson incseq_Suc_iff) hence \incseq (\n. (sum a {0..n})::ereal)\ using incseq_ereal by (simp add: atLeast0AtMost lessThan_Suc_atMost) hence \(\n. sum a {0..n}) \ Sup (range (\n. (sum a {0..n})::ereal))\ using LIMSEQ_SUP by auto thus ?thesis using Sup PInfty_neq_ereal by auto qed lemma sum_Cauchy_positive: fixes a ::\_ \ real\ assumes \\n. a n \ 0\ and \\K. \n. (sum a {0..n}) \ K\ shows \Cauchy (\n. sum a {0..n})\ text\ Explanation: If a series of nonnegative reals is bounded, then the series is Cauchy. \ proof (unfold Cauchy_altdef2, rule, rule) fix e::real assume \e>0\ have \\M. \m\M. \n\M. m > n \ sum a {Suc n..m} < e\ proof(rule classical) assume \\(\M. \m\M. \n\M. m > n \ sum a {Suc n..m} < e)\ hence \\M. \m. \n. m \ M \ n \ M \ m > n \ \(sum a {Suc n..m} < e)\ by blast hence \\M. \m. \n. m \ M \ n \ M \ m > n \ sum a {Suc n..m} \ e\ by fastforce hence \(\n. (sum a {0..n}) ) \ \\ using non_Cauchy_unbounded \0 < e\ assms(1) by blast from \\K. \n. sum a {0..n} \ K\ obtain K where \\n. sum a {0..n} \ K\ by blast from \(\n. sum a {0..n}) \ \\ have \\B. \N. \n\N. (\ n. (sum a {0..n}) ) n \ B\ using Lim_PInfty by simp hence \\n. (sum a {0..n}) \ K+1\ using ereal_less_eq(3) by blast thus ?thesis using \\n. (sum a {0..n}) \ K\ by (smt (verit, best)) qed have \sum a {Suc n..m} = sum a {0..m} - sum a {0..n}\ if "m > n" for m n by (metis add_diff_cancel_left' atLeast0AtMost less_imp_add_positive sum_up_index_split that) hence \\M. \m\M. \n\M. m > n \ sum a {0..m} - sum a {0..n} < e\ using \\M. \m\M. \n\M. m > n \ sum a {Suc n..m} < e\ by presburger then obtain M where \\m\M. \n\M. m > n \ sum a {0..m} - sum a {0..n} < e\ by blast moreover have \m > n \ sum a {0..m} \ sum a {0..n}\ for m n using \\ n. a n \ 0\ by (simp add: sum_mono2) ultimately have \\M. \m\M. \n\M. m > n \ \sum a {0..m} - sum a {0..n}\ < e\ by auto hence \\M. \m\M. \n\M. m \ n \ \sum a {0..m} - sum a {0..n}\ < e\ by (metis \0 < e\ abs_zero cancel_comm_monoid_add_class.diff_cancel diff_is_0_eq' less_irrefl_nat linorder_neqE_nat zero_less_diff) hence \\M. \m\M. \n\M. \sum a {0..m} - sum a {0..n}\ < e\ by (metis abs_minus_commute nat_le_linear) hence \\M. \m\M. \n\M. dist (sum a {0..m}) (sum a {0..n}) < e\ by (simp add: dist_real_def) hence \\M. \m\M. \n\M. dist (sum a {0..m}) (sum a {0..n}) < e\ by blast thus \\N. \n\N. dist (sum a {0..n}) (sum a {0..N}) < e\ by auto qed lemma convergent_series_Cauchy: fixes a::\nat \ real\ and \::\nat \ 'a::metric_space\ assumes \\M. \n. sum a {0..n} \ M\ and \\n. dist (\ (Suc n)) (\ n) \ a n\ shows \Cauchy \\ text\ Explanation: Let \<^term>\a\ be a real-valued sequence and let \<^term>\\\ be sequence in a metric space. If the partial sums of \<^term>\a\ are uniformly bounded and the distance between consecutive terms of \<^term>\\\ are bounded by the sequence \<^term>\a\, then \<^term>\\\ is Cauchy.\ proof (unfold Cauchy_altdef2, rule, rule) fix e::real assume \e > 0\ have \\k. a k \ 0\ using \\n. dist (\ (Suc n)) (\ n) \ a n\ dual_order.trans zero_le_dist by blast hence \Cauchy (\k. sum a {0..k})\ using \\M. \n. sum a {0..n} \ M\ sum_Cauchy_positive by blast hence \\M. \m\M. \n\M. dist (sum a {0..m}) (sum a {0..n}) < e\ unfolding Cauchy_def using \e > 0\ by blast hence \\M. \m\M. \n\M. m > n \ dist (sum a {0..m}) (sum a {0..n}) < e\ by blast have \dist (sum a {0..m}) (sum a {0..n}) = sum a {Suc n..m}\ if \n for m n proof - have \n < Suc n\ by simp have \finite {0..n}\ by simp moreover have \finite {Suc n..m}\ by simp moreover have \{0..n} \ {Suc n..m} = {0..m}\ using \n < Suc n\ \n < m\ by auto moreover have \{0..n} \ {Suc n..m} = {}\ by simp ultimately have sum_plus: \(sum a {0..n}) + sum a {Suc n..m} = (sum a {0..m})\ by (metis sum.union_disjoint) have \dist (sum a {0..m}) (sum a {0..n}) = \(sum a {0..m}) - (sum a {0..n})\\ using dist_real_def by blast moreover have \(sum a {0..m}) - (sum a {0..n}) = sum a {Suc n..m}\ using sum_plus by linarith ultimately show ?thesis by (simp add: \\k. 0 \ a k\ sum_nonneg) qed hence sum_a: \\M. \m\M. \n\M. m > n \ sum a {Suc n..m} < e\ by (metis \\M. \m\M. \n\M. dist (sum a {0..m}) (sum a {0..n}) < e$$ obtain M where \\m\M. \n\M. m > n \ sum a {Suc n..m} < e\ using sum_a \e > 0\ by blast hence \\m. \n. Suc m \ Suc M \ Suc n \ Suc M \ Suc m > Suc n \ sum a {Suc n..Suc m - 1} < e\ by simp hence \\m\1. \n\1. m \ Suc M \ n \ Suc M \ m > n \ sum a {n..m - 1} < e\ by (metis Suc_le_D) hence sum_a2: \\M. \m\M. \n\M. m > n \ sum a {n..m-1} < e\ by (meson add_leE) have \dist (\ (n+p+1)) (\ n) \ sum a {n..n+p}\ for p n :: nat proof(induction p) case 0 thus ?case by (simp add: assms(2)) next case (Suc p) thus ?case by (smt(verit, ccfv_SIG) Suc_eq_plus1 add_Suc_right add_less_same_cancel1 assms(2) dist_self dist_triangle2 gr_implies_not0 sum.cl_ivl_Suc) qed hence \m > n \ dist (\ m) (\ n) \ sum a {n..m-1}\ for m n :: nat by (metis Suc_eq_plus1 Suc_le_D diff_Suc_1 gr0_implies_Suc less_eq_Suc_le less_imp_Suc_add zero_less_Suc) hence \\M. \m\M. \n\M. m > n \ dist (\ m) (\ n) < e\ - using sum_a2 \e > 0\ by smt + using sum_a2 \e > 0\ by (smt (verit)) thus "\N. \n\N. dist (\ n) (\ N) < e" using \0 < e\ by fastforce qed unbundle notation_blinfun_apply unbundle no_notation_norm end diff --git a/thys/Boolos_Curious_Inference_Automated/ROOT b/thys/Boolos_Curious_Inference_Automated/ROOT --- a/thys/Boolos_Curious_Inference_Automated/ROOT +++ b/thys/Boolos_Curious_Inference_Automated/ROOT @@ -1,12 +1,9 @@ chapter AFP session "Boolos_Curious_Inference_Automated" = HOL + - options [timeout = 600] - theories - Boolos_Curious_Inference_Automated - + Boolos_Curious_Inference_Automated document_files "root.bib" "root.tex" diff --git a/thys/DigitsInBase/DigitsInBase.thy b/thys/DigitsInBase/DigitsInBase.thy --- a/thys/DigitsInBase/DigitsInBase.thy +++ b/thys/DigitsInBase/DigitsInBase.thy @@ -1,920 +1,918 @@ theory DigitsInBase imports "HOL-Computational_Algebra.Computational_Algebra" "HOL-Number_Theory.Number_Theory" begin section\Infinite sums\ text\In this section, it is shown that an infinite series \emph{of natural numbers} converges if and only if its terms are eventually zero. Additionally, the notion of a summation starting from an index other than zero is defined. A few obvious lemmas about these notions are established.\ definition eventually_zero :: "(nat \ _) \ bool" where "eventually_zero (D :: nat \ _) \ (\\<^sub>\ n. D n = 0)" lemma eventually_zero_char: shows "eventually_zero D \ (\s. \i\s. D i = 0)" unfolding eventually_zero_def using MOST_nat_le . text\There's a lot of commonality between this setup and univariate polynomials, but drawing out the similarities and proving them is beyond the scope of the current version of this theory except for the following lemma.\ lemma eventually_zero_poly: shows "eventually_zero D \ D = poly.coeff (Abs_poly D)" by (metis Abs_poly_inverse MOST_coeff_eq_0 eventually_zero_def mem_Collect_eq) lemma eventually_zero_imp_summable [simp]: assumes "eventually_zero D" shows "summable D" using summable_finite assms eventually_zero_char by (metis (mono_tags) atMost_iff finite_atMost nat_le_linear) lemma summable_bounded: fixes my_seq :: "nat \ nat" and n :: nat assumes "\ i . i \ n \ my_seq i = 0" shows "summable my_seq" using assms eventually_zero_char eventually_zero_imp_summable by blast lemma sum_bounded: fixes my_seq :: "nat \ nat" and n :: nat assumes "\ i . i \ n \ my_seq i = 0" shows "(\i. my_seq i) = (\i nat" assumes "eventually_zero seq1" shows "eventually_zero (\ i. seq1 i * seq2 i)" using mult_0 eventually_zero_char by (metis (no_types, lifting) assms) abbreviation upper_sum where "upper_sum seq n \ \i. seq (i + n)" syntax "_from_sum" :: "idt \ 'a \ 'b \ 'b" ("(3\_\_./ _)" [0,0,10] 10) translations "\i\n. t" == "CONST upper_sum (\i. t) n" text \The following two statements are proved as a sanity check. They are not intended to be used anywhere.\ corollary fixes seq :: "nat \ nat" and a :: nat assumes seq_def: "\ i. seq i = (if i = 0 then a else 0)" shows "(\i\0. seq i) = upper_sum (\ i. seq i) 0" by simp corollary fixes seq :: "nat \ nat" and a :: nat assumes seq_def: "\ i. seq i = (if i = 0 then a else 0)" shows "(\i\0. seq i) = a" by (smt (verit) group_cancel.rule0 lessI lessThan_0 linorder_not_less seq_def sum.empty sum.lessThan_Suc_shift sum_bounded) lemma bounded_sum_from: fixes seq :: "nat \ nat" and n s :: nat assumes "\i>s. seq i = 0" and "n \ s" shows "(\i\n. seq i) = (\i=n..s. seq i)" proof - have "\i. i > (s - n) \ seq (i + n) = 0" using assms by (meson less_diff_conv2) then have "(\i\n. seq i) = (\i\s-n. seq (i + n))" by (meson atMost_iff finite_atMost leI suminf_finite) also have "\ = (\i=n..s. seq i)" proof - have "\na. (\na\na. seq (na + n)) = sum seq {0 + n..na + n}" by (metis (no_types) atLeast0AtMost sum.shift_bounds_cl_nat_ivl) then show ?thesis by (simp add: assms(2)) qed finally show ?thesis . qed lemma split_suminf: fixes seq :: "nat \ nat" and n :: nat assumes "eventually_zero seq" shows "(\i. seq i) = (\ii\n. seq i)" proof - obtain s where s: "\i. i\s \ seq i = 0" using assms unfolding eventually_zero_char by presburger then have sum_s: "(\i. seq i) = (\ii. seq i) = (\ii$$n). seq i)" proof (cases "n \ s") case True then have "(\i\(n). seq i) = 0" using s by force moreover have "(\iii=n..s. seq i) = (\i\n. seq i)" by (metis False bounded_sum_from le_eq_less_or_eq nle_le s) from False have "n \ s" by simp then have "(\iii=n..s. seq i)" by (metis add_cancel_left_right nat_le_iff_add s sum.atLeastLessThan_concat add_0 lessThan_atLeast0 sum.last_plus) then show ?thesis using 0 sum_s by presburger qed qed lemma dvd_suminf: fixes seq :: "nat \ nat" and b :: nat assumes "eventually_zero seq" and "\i. b dvd seq i" shows "b dvd (\i. seq i)" proof - obtain s::nat where s: "i \ s \ seq i = 0" for i using assms(1) eventually_zero_char by blast then have "(\i. seq i) = (\ii i. seq (i + n))" by (meson assms eventually_zero_char trans_le_add1) section\Modular arithmetic\ text\This section establishes a number of lemmas about modular arithmetic, including that modular division distributes over an infinite'' sum whose terms are eventually zero.\ lemma pmod_int_char: fixes a b d :: int shows "[a = b] (mod d) \ (\(n::int). a = b + n*d)" by (metis cong_iff_lin cong_sym mult.commute) lemma equiv_conj_if: assumes "P \ Q" and "P \ R" and "Q \ R \ P" shows "P \ Q \ R" using assms by auto lemma mod_successor_char: fixes k k' i b :: nat assumes "(b::nat) \ 2" shows "[k = k'] (mod b^(Suc i)) \ [k div b^i = k' div b^i] (mod b) \ [k = k'] (mod b^i)" proof (rule equiv_conj_if) assume kk'_cong: "[k = k'] (mod b ^ Suc i)" then show "[k div b^i = k' div b^i] (mod b)" by (smt (verit, ccfv_SIG) Groups.mult_ac(2) add_diff_cancel_right' cong_def div_mult_mod_eq mod_mult2_eq mod_mult_self4 mult_cancel1 power_Suc2) from kk'_cong show "[k = k'] (mod b ^ i)" using Cong.cong_dvd_modulus_nat by (meson Suc_n_not_le_n le_imp_power_dvd nat_le_linear) next assume "[k div b^i = k' div b^i] (mod b)" moreover assume "[k = k'] (mod b^i)" ultimately show "[k = k'] (mod b ^ Suc i)" by (metis (mono_tags, lifting) cong_def mod_mult2_eq power_Suc2) qed lemma mod_1: fixes k k' b :: nat shows "[k = k'] (mod b^0)" by simp lemma mod_distributes: fixes seq :: "nat \ nat" and b :: nat assumes "\n. \i\n. seq i = 0" shows "[(\i. seq i) = (\i. seq i mod b)] (mod b)" proof - obtain n where n: "\i. i\n \ seq i = 0" using assms by presburger from n have "(\i. seq i) = (\ii. seq i mod b) = (\i 0" and "[m = a + b] (mod c * d)" and "a div d = 0" and "d dvd b" shows "[m div d = b div d] (mod c)" proof (subst pmod_int_char) obtain k::int where k: "m = a + b + k*c*d" using pmod_int_char assms(2) by (metis mult.assoc) have "d dvd (b + k*c*d)" using \d dvd b\ by simp from k have "m div d = (a + b + k*c*d) div d" by presburger also have "\ = (b + k*c*d) div d" using \a div d = 0\ \d dvd (b + k*c*d)\ by fastforce also have "\ = (b div d) + k*c" using \d dvd b\ \d > 0\ by auto finally show "\n. m div d = b div d + n * c" by blast qed lemma another_mod_cancellation: fixes a b c d m :: nat assumes "d > 0" and "[m = a + b] (mod c * d)" and "a div d = 0" and "d dvd b" shows "[m div d = b div d] (mod c)" by (smt (verit) another_mod_cancellation_int assms cong_int_iff of_nat_0 of_nat_0_less_iff of_nat_add of_nat_dvd_iff of_nat_mult zdiv_int) section\Digits as sequence\ text\Rules are introduced for computing the i^{\text{th}} digit of a base-b representation and the number of digits required to represent a given number. (The latter is essentially an integer version of the base-b logarithm.) It is shown that the sum of the terms d_i b^i converges to m if d_i is the i^{\text{th}} digit m. It is shown that the sequence of digits defined is the unique sequence of digits less than b with this property Additionally, the \texttt{digits\_in\_base} locale is introduced, which specifies a single symbol @{term b} referring to a natural number greater than one (the base of the digits). Consequently this symbol is omitted from many of the following lemmas and definitions. \ locale digits_in_base = fixes b :: nat assumes b_gte_2: "b \ 2" begin lemma b_facts [simp]: shows "b > 1" and "b > 0" and "b \ 1" and "b \ 0" and "1 mod b = 1" and "1 div b = 0" using b_gte_2 by force+ text\Definition based on @{cite ThreeDivides}.\ abbreviation ith_digit :: "nat \ nat \ nat" where "ith_digit m i \ (m div b^i) mod b" lemma ith_digit_lt_base: fixes m i :: nat shows "0 \ ith_digit m i" and "ith_digit m i < b" apply (rule Nat.le0) using b_facts(2) mod_less_divisor by presburger definition num_digits :: "nat \ nat" where "num_digits m = (LEAST i. m < b^i)" lemma num_digits_works: shows "m < b ^ (num_digits m)" by (metis LeastI One_nat_def b_facts(1) num_digits_def power_gt_expt) lemma num_digits_le: assumes "m < b^i" shows "num_digits m \ i" using assms num_digits_works[of m] Least_le num_digits_def by metis lemma num_digits_zero: fixes m :: nat assumes "num_digits m = 0" shows "m = 0" using num_digits_works[of m] unfolding assms by simp lemma num_digits_gt: assumes "m \ b^i" shows "num_digits m > i" by (meson assms b_facts(2) dual_order.strict_trans2 nat_power_less_imp_less num_digits_works) lemma num_digits_eqI [intro]: assumes "m \ b^i" and "m < b^(i+1)" shows "num_digits m = i + 1" proof - { fix j :: nat assume "j < i + 1" then have "m \ b^j" by (metis Suc_eq_plus1 assms(1) b_facts(1) less_Suc_eq_le order_trans power_increasing_iff) } then show ?thesis using num_digits_works unfolding num_digits_def by (meson assms(2) leD linorder_neqE_nat not_less_Least) qed lemma num_digits_char: assumes "m \ 1" shows "num_digits m = i + 1 \ m \ b^i \ m < b^(i+1)" by (metis add_diff_cancel_right' assms b_gte_2 ex_power_ivl1 num_digits_eqI) text\Statement based on @{cite ThreeDivides}.\ lemma num_digits_recurrence: fixes m :: nat assumes "m \ 1" shows "num_digits m = num_digits (m div b) + 1" proof - define nd where "nd = num_digits m" then have lb: "m \ b^(nd-1)" and ub: "m < b^nd" using num_digits_char[OF assms] apply (metis assms diff_is_0_eq le_add_diff_inverse2 nat_le_linear power_0) using nd_def num_digits_works by presburger from ub have ub2: "m div b < b^(nd-1)" by (metis Suc_eq_plus1 add.commute add_diff_inverse_nat assms less_mult_imp_div_less less_one linorder_not_less mult.commute power.simps(2) power_0) from lb have lb2: "m div b \ b^(nd - 1) div b" using div_le_mono by presburger show ?thesis proof (cases "m \ b") assume "m \ b" then have "nd \ 2" unfolding nd_def by (metis One_nat_def assms less_2_cases_iff linorder_not_le nd_def power_0 power_one_right ub) then have "m div b \ b^(nd-2)" using lb2 by (smt (verit) One_nat_def add_le_imp_le_diff b_facts(4) diff_diff_left le_add_diff_inverse2 nonzero_mult_div_cancel_left numeral_2_eq_2 plus_1_eq_Suc power_add power_commutes power_one_right) then show ?thesis using ub2 num_digits_char assms nd_def by (smt (verit) \2 \ nd\ add_diff_cancel_right' add_leD2 add_le_imp_le_diff diff_diff_left eq_diff_iff le_add2 nat_1_add_1 num_digits_eqI) next assume "\ b \ m" then have "m < b" by simp then have "num_digits m = 1" using assms by (metis One_nat_def Suc_eq_plus1 num_digits_char power_0 power_one_right) from \m < b\ have "m div b = 0" using div_less by presburger then have "num_digits (m div b) = 0" using Least_eq_0 num_digits_def by presburger show ?thesis using \num_digits (m div b) = 0\ \num_digits m = 1\ by presburger qed qed lemma num_digits_zero_2 [simp]: "num_digits 0 = 0" by (simp add: num_digits_def) end (* digits_in_base *) locale base_10 begin text\As a sanity check, the number of digits in base ten is computed for several natural numbers.\ sublocale digits_in_base 10 by (unfold_locales, simp) corollary shows "num_digits 0 = 0" and "num_digits 1 = 1" and "num_digits 9 = 1" and "num_digits 10 = 2" and "num_digits 99 = 2" and "num_digits 100 = 3" by (simp_all add: num_digits_recurrence) end (* base_10 *) context digits_in_base begin lemma high_digits_zero_helper: fixes m i :: nat shows "i < num_digits m \ ith_digit m i = 0" proof (cases "i < num_digits m") case True then show ?thesis by meson next case False then have "i \ num_digits m" by force then have "m < b^i" by (meson b_facts(1) num_digits_works order_less_le_trans power_increasing_iff) then show ?thesis by simp qed lemma high_digits_zero: fixes m i :: nat assumes "i \ num_digits m" shows "ith_digit m i = 0" using high_digits_zero_helper assms leD by blast lemma digit_expansion_bound: fixes i :: nat and A :: "nat \ nat" assumes "\j. A j < b" shows "(\j (b-1) * b^i" using assms by (metis One_nat_def Suc_pred b_facts(2) le_simps(2) mult_le_mono1) then have "(\j \ b ^ Suc i" using assms(1) mult_eq_if by auto finally show "(\jStatement and proof based on @{cite ThreeDivides}.\ lemma num_digits_suc: fixes n m :: nat assumes "Suc n = num_digits m" shows "n = num_digits (m div b)" using num_digits_recurrence assms by (metis One_nat_def Suc_eq_plus1 Suc_le_lessD le_add2 linorder_not_less num_digits_le old.nat.inject power_0) text\Proof (and to some extent statement) based on @{cite ThreeDivides}.\ lemma digit_expansion_bounded_seq: fixes m :: nat shows "m = (\jjjjj = (\j = (\j = (\j=Suc 0.. = (\jjA natural number can be obtained from knowing all its base-b digits by the formula \sum_j d_j b^j.\ theorem digit_expansion_seq: fixes m :: nat shows "m = (\j. ith_digit m j * b^j)" using digit_expansion_bounded_seq[of m] high_digits_zero[of m] sum_bounded mult_0 by (metis (no_types, lifting)) lemma lower_terms: fixes a c i :: nat assumes "c < b^i" and "a < b" shows "ith_digit (a * b^i + c) i = a" using assms by force lemma upper_terms: fixes A a i :: nat assumes "b*b^i dvd A" and "a < b" shows "ith_digit (A + a * b^i) i = a" using assms by force lemma current_term: fixes A a c i :: nat assumes "b*b^i dvd A" and "c < b^i" and "a < b" shows "ith_digit (A + a*b^i + c) i = a" proof - have "(A + a*b^i + c) div b^i mod b = (a*b^i + c) div b^i mod b" using assms(1) by (metis (no_types, lifting) div_eq_0_iff add_cancel_right_right assms(2) assms(3) div_plus_div_distrib_dvd_left dvd_add_times_triv_right_iff dvd_mult_right lower_terms upper_terms) also have "\ = a" using assms by force finally show "(A + a*b^i + c) div b^i mod b = a" . qed text\Given that \begin{equation*} m = \sum_i d_i b^i \end{equation*} where the d_i are all natural numbers less than b, it follows that d_j is the j^{\text{th}} digit of m.\ theorem seq_uniqueness: fixes m j :: nat and D :: "nat \ nat" assumes "eventually_zero D" and "m = (\i. D i * b^i)" and "\i. D i < b" shows "D j = ith_digit m j" proof - have "eventually_zero (ith_digit m)" using high_digits_zero by (meson eventually_zero_char) then have term_eventually_zero: "eventually_zero (\ i. D i * b^i)" using product_seq_eventually_zero assms(1) by auto then have shifted_term_eventually_zero: "eventually_zero (\ i. D (i + n) * b ^ (i + n))" for n using eventually_zero_shifted by blast note \m = (\i. D i * b^i)\ then have two_sums: "m = (\ii\Suc j. D i * b^i)" using split_suminf[OF term_eventually_zero] by presburger have "i\Suc j \ b*b^j dvd (D i * b^i)" for i by (metis dvd_mult2 le_imp_power_dvd mult.commute power_Suc) then have "b*b^j dvd (\i\Suc j. D i * b^i)" using dvd_suminf shifted_term_eventually_zero le_add2 by presburger with two_sums have "[m = (\iiiLittle Endian notation\ text\In this section we begin to define finite digit expansions. Ultimately we want to write digit expansions in big endian'' notation, by which we mean with the highest place digit on the left and the ones digit on the write, since this ordering is standard in informal mathematics. However, it is easier to first define little endian'' expansions with the ones digit on the left since that way the list indexing agrees with the sequence indexing used in the previous section (whenever both are defined). Notation, definitions, and lemmas in this section typically start with the prefix \texttt{LE} (for little endian'') to distinguish them from the big endian versions in the next section. \ fun LEeval_as_base ("_\<^bsub>LEbase _\<^esub>" [65, 65] 70) where "[] \<^bsub>LEbase b\<^esub> = 0" | "(d # d_list) \<^bsub>LEbase b\<^esub> = d + b * (d_list\<^bsub>LEbase b\<^esub>)" corollary shows "[2, 4] \<^bsub>LEbase 5\<^esub> = (22::nat)" by simp lemma LEbase_one_digit [simp]: shows "[a::nat] \<^bsub>LEbase b\<^esub> = a" by simp lemma LEbase_two_digits [simp]: shows "[a\<^sub>0::nat, a\<^sub>1] \<^bsub>LEbase b\<^esub> = a\<^sub>0 + a\<^sub>1 * b" by simp lemma LEbase_three_digits [simp]: shows "[a\<^sub>0::nat, a\<^sub>1, a\<^sub>2] \<^bsub>LEbase b\<^esub> = a\<^sub>0 + a\<^sub>1*b + a\<^sub>2*b^2" proof - have "[a\<^sub>0::nat, a\<^sub>1, a\<^sub>2] \<^bsub>LEbase b\<^esub> = a\<^sub>0 + ([a\<^sub>1, a\<^sub>2] \<^bsub>LEbase b\<^esub>) * b" by simp also have "\ = a\<^sub>0 + (a\<^sub>1 + a\<^sub>2*b) * b" by simp also have "\ = a\<^sub>0 + a\<^sub>1*b + a\<^sub>2*b^2" by (simp add: add_mult_distrib power2_eq_square) finally show ?thesis . qed lemma LEbase_closed_form: shows "(A :: nat list) \<^bsub>LEbase b\<^esub> = (\i < length A . A!i * b^i)" proof (induct A) case Nil show ?case by simp next case (Cons a A) show ?case proof - have "(a # A)\<^bsub>LEbase b\<^esub> = a + b * (A\<^bsub>LEbase b\<^esub>)" by simp also have "\ = a + b * (\i = a + (\i = a + (\i = a + (\i = (a#A)!0 * b^0 + (\i = (\iLEbase b\<^esub> = (A\<^bsub>LEbase b\<^esub>) + b^(length A) * (D\<^bsub>LEbase b\<^esub>)" proof (induct A) case Nil show ?case by simp next case (Cons a A) show ?case proof - have "((a # A) @ D)\<^bsub>LEbase b\<^esub> = ((a # (A @ D)) \<^bsub>LEbase b\<^esub>)" by simp also have "\ = a + b * ((A @ D) \<^bsub>LEbase b\<^esub>)" by simp also have "\ = a + b * (A\<^bsub>LEbase b\<^esub> + b ^ length A * (D\<^bsub>LEbase b\<^esub>))" unfolding Cons by rule also have "\ = (a + b * (A\<^bsub>LEbase b\<^esub>)) + b ^ (length (a#A)) * (D\<^bsub>LEbase b\<^esub>)" by (simp add: distrib_left) also have "\ = ((a # A)\<^bsub>LEbase b\<^esub>) + b ^ length (a # A) * (D\<^bsub>LEbase b\<^esub>)" by simp finally show ?thesis . qed qed context digits_in_base begin definition LEdigits :: "nat \ nat list" where "LEdigits m = [ith_digit m i. i \ [0..<(num_digits m)]]" lemma length_is_num_digits: fixes m :: nat shows "length (LEdigits m) = num_digits m" unfolding LEdigits_def by simp lemma ith_list_element [simp]: assumes "(i::nat) < length (LEdigits m)" shows "(LEdigits m) ! i = ith_digit m i" using assms by (simp add: length_is_num_digits LEdigits_def) lemma LEbase_infinite_sum: fixes m :: nat shows "(\i. ith_digit m i * b^i) = (LEdigits m)\<^bsub>LEbase b\<^esub>" proof (unfold LEdigits_def LEbase_closed_form) have "(\ii= (\i=(\i. ith_digit m i * b ^ i)" using sum_bounded high_digits_zero mult_0 by (metis (no_types, lifting)) finally show "(\i. ith_digit m i * b ^ i) = (\iLEbase b\<^esub> = m" using digit_expansion_seq LEbase_infinite_sum by presburger lemma LElist_uniqueness: fixes D :: "nat list" assumes "\ i < length D. D!i < b" and "D = [] \ last D \ 0" shows "LEdigits (D\<^bsub>LEbase b\<^esub>) = D" proof - define seq where "seq i = (if i < length D then D!i else 0)" for i then have seq_bound: "i \ length D \ seq i = 0" for i by simp then have seq_eventually_zero: "eventually_zero seq" using eventually_zero_char by blast have ith_digit_connection: "i < num_digits m \ (LEdigits m)!i = ith_digit m i" for m i unfolding LEdigits_def by simp let ?m = "D\<^bsub>LEbase b\<^esub>" have length_bounded_sum: "D\<^bsub>LEbase b\<^esub> = (\i = (\i. seq i * b^i)" using seq_bound sum_bounded by fastforce finally have seq_is_digits: "seq j = ith_digit ?m j" for j using seq_uniqueness[OF seq_eventually_zero] assms(1) by (metis b_facts(2) seq_def) then have "i < length D \ ith_digit ?m i = D!i" for i using seq_def by presburger then have "i < length D \ i < num_digits ?m \ (LEdigits ?m)!i = D!i" for i using ith_digit_connection[of i ?m] by presburger moreover have "length D = num_digits ?m" proof (rule le_antisym) show "length D \ num_digits ?m" proof (cases "D = []") assume "D \ []" then have "last D \ 0" using assms(2) by auto then have "last D \ 1" by simp have "?m \ seq (length D - 1) * b^(length D - 1)" using length_bounded_sum - by (smt (z3) One_nat_def Suc_pred diff_is_0_eq diff_le_self dual_order.strict_trans1 le_add2 - linorder_le_less_linear mult.right_neutral mult_cancel1 seq_def sum.lessThan_Suc - zero_less_diff) + by (metis b_facts(2) less_eq_div_iff_mult_less_eq mod_less_eq_dividend seq_is_digits zero_less_power) then have "?m \ (last D) * b^(length D - 1)" by (simp add: \D \ []\ last_conv_nth seq_def) with \last D \ 1\ have "?m \ b^(length D - 1)" by (metis le_trans mult_1 mult_le_mono1) then show "num_digits ?m \ length D" using num_digits_gt not_less_eq by (metis One_nat_def Suc_pred \D \ []\ bot_nat_0.extremum_uniqueI leI length_0_conv) qed simp show "num_digits ?m \ length D" by (metis length_bounded_sum seq_is_digits digit_expansion_bound ith_digit_lt_base(2) num_digits_le) qed ultimately show ?thesis by (simp add: length_is_num_digits list_eq_iff_nth_eq) qed lemma LE_digits_zero [simp]: "LEdigits 0 = []" using LEdigits_def by auto lemma LE_units_digit [simp]: assumes "(m::nat) \ {1..Big Endian notation\ text\In this section the desired representation of natural numbers, as finite lists of digits with the highest place on the left, is finally realized.\ definition BEeval_as_base ("_\<^bsub>base _\<^esub>" [65, 65] 70) where [simp]: "D\<^bsub>base b\<^esub> = (rev D)\<^bsub>LEbase b\<^esub>" corollary shows "[4, 2]\<^bsub>base 5\<^esub> = (22::nat)" by simp lemma BEbase_one_digit [simp]: shows "[a::nat] \<^bsub>base b\<^esub> = a" by simp lemma BEbase_two_digits [simp]: shows "[a\<^sub>1::nat, a\<^sub>0] \<^bsub>base b\<^esub> = a\<^sub>1*b + a\<^sub>0" by simp lemma BEbase_three_digits [simp]: shows "[a\<^sub>2::nat, a\<^sub>1, a\<^sub>0] \<^bsub>base b\<^esub> = a\<^sub>2*b^2 + a\<^sub>1*b + a\<^sub>0" proof - have "b * (a\<^sub>1 + b * a\<^sub>2) = a\<^sub>2 * b\<^sup>2 + a\<^sub>1 * b" apply (subst mult.commute) unfolding add_mult_distrib power2_eq_square by simp then show ?thesis by simp qed lemma BEbase_closed_form: fixes A :: "nat list" and b :: nat shows "A\<^bsub>base b\<^esub> = (\ibase b\<^esub> = (A\<^bsub>base b\<^esub>)*b^(length D) + (D\<^bsub>base b\<^esub>)" using LEbase_concatenate by simp context digits_in_base begin definition digits :: "nat \ nat list" where "digits m = rev (LEdigits m)" lemma length_is_num_digits_2: fixes m :: nat shows "length (digits m) = num_digits m" using length_is_num_digits digits_def by simp lemma LE_BE_equivalence: fixes m :: nat shows "(digits m) \<^bsub>base b\<^esub> = (LEdigits m) \<^bsub>LEbase b\<^esub>" by (simp add: digits_def) lemma BEbase_infinite_sum: fixes m :: nat shows "(\i. ith_digit m i * b^i) = (digits m)\<^bsub>base b\<^esub>" using LE_BE_equivalence LEbase_infinite_sum by presburger text\Every natural number can be represented in base b, specifically by the digits sequence defined earlier.\ theorem digit_expansion_list: fixes m :: nat shows "(digits m)\<^bsub>base b\<^esub> = m" using LE_BE_equivalence digit_expansion_LElist by auto text\If two natural numbers have the same base-b representation, then they are equal.\ lemma digits_cancellation: fixes k m :: nat assumes "digits k = digits m" shows "k = m" by (metis assms digit_expansion_list) text\Suppose we have a finite (possibly empty) sequence D_1, \dotsc, D_n of natural numbers such that 0 \le D_i < b for all i and such that D_1, if it exists, is nonzero. Then this sequence is the base-b representation for \sum_i D_i b^{n-i}.\ theorem list_uniqueness: fixes D :: "nat list" assumes "\ d \ set D. d < b" and "D = [] \ D!0 \ 0" shows "digits (D\<^bsub>base b\<^esub>) = D" unfolding digits_def BEeval_as_base_def using LElist_uniqueness by (metis Nil_is_rev_conv One_nat_def assms last_conv_nth length_greater_0_conv nth_mem rev_nth rev_swap set_rev) text\We now prove some simplification rules (including a reccurrence relation) to make it easier for Isabelle/HOL to compute the base-b representation of a natural number.\ text\The base-b representation of 0 is empty, at least following the conventions of this theory file.\ lemma digits_zero [simp]: shows "digits 0 = []" by (simp add: digits_def) text\If 0 < m < b, then the base-b representation of m consists of a single digit, namely m itself.\ lemma single_digit_number [simp]: assumes "m \ {0<..For all m \ge b, the base-b representation of m consists of the base-b representation of \lfloor m / b \rfloor followed by (as the last digit) the remainder of m when divided by b.\ lemma digits_recurrence [simp]: assumes "m \ b" shows "digits m = (digits (m div b)) @ [m mod b]" proof - have "num_digits m > 1" using assms by (simp add: num_digits_gt) then have "num_digits m > 0" by simp then have "num_digits (m div b) = num_digits m - 1" by (metis Suc_diff_1 num_digits_suc) have "k > 0 \ last (rev [0.. [0.. rev [0.. rev [Suc 0.. rev [0.. 0 \ [f i. i \ rev [1.. rev [0..<(k-1)]]" for f and k::nat by (metis One_nat_def Suc_diff_1) have digit_down: "ith_digit m (Suc i) = ith_digit (m div b) i" for i::nat by (simp add: div_mult2_eq) have "digits m = rev [ith_digit m i. i \ [0.. = [ith_digit m i. i \ rev [0.. = [ith_digit m i. i \ butlast (rev [0..1 < num_digits m\ bot_nat_0.extremum_strict dual_order.strict_trans1 last_map map_butlast snoc_eq_iff_butlast upt_eq_Nil_conv) also have "\ = [ith_digit m i. i \ rev [1..1 < num_digits m\ \\k. 0 < k \ last (rev [0.. by fastforce also have "\ = [ith_digit m (Suc i). i \ rev [0..<(num_digits m - 1)]] @ [ith_digit m 0]" using map_shift[OF \num_digits m > 0\] by blast also have "\ = [ith_digit (m div b) i. i \ rev [0..<(num_digits m - 1)]] @ [ith_digit m 0]" using digit_down by presburger also have "\ = (digits (m div b)) @ [ith_digit m 0]" by (simp add: LEdigits_def \num_digits (m div b) = num_digits m - 1\ digits_def rev_map) also have "\ = (digits (m div b)) @ [m mod b]" by simp finally show ?thesis . qed end (* digits_in_base *) section\Exercises\ text\This section contains demonstrations of how to denote certain facts with the notation of the previous sections, and how to quickly prove those facts using the lemmas and theorems above. \ text\The base-5 representation of 22 is 42_5.\ corollary "digits_in_base.digits 5 22 = [4, 2]" proof - interpret digits_in_base 5 by (simp add: digits_in_base.intro) show "digits 22 = [4, 2]" by simp qed text\A different proof of the same statement.\ corollary "digits_in_base.digits 5 22 = [4, 2]" proof - interpret digits_in_base 5 by (simp add: digits_in_base.intro) have "[4, 2]\<^bsub>base 5\<^esub> = (22::nat)" by simp have "d \ set [4, 2] \ d < 5" for d::nat by fastforce then show ?thesis using list_uniqueness by (metis $4, 2]\<^bsub>base 5\<^esub> = 22\ nth_Cons_0 numeral_2_eq_2 zero_neq_numeral) qed end diff --git a/thys/FOL_Seq_Calc1/Sequent2.thy b/thys/FOL_Seq_Calc1/Sequent2.thy --- a/thys/FOL_Seq_Calc1/Sequent2.thy +++ b/thys/FOL_Seq_Calc1/Sequent2.thy @@ -1,44 +1,44 @@ theory Sequent2 imports Sequent begin section \Completeness Revisited\ lemma \\p. q = compl p\ by (metis compl.simps(1)) definition compl' where \compl' = (\q. (SOME p. q = compl p))\ lemma comp'_sem: \eval e f g (compl' p) \ \ eval e f g p\ by (smt compl'_def compl.simps(1) compl eval.simps(7) someI_ex) lemma comp'_sem_list: \list_ex (\p. \ eval e f g p) (map compl' ps) \ list_ex (eval e f g) ps\ by (induct ps) (use comp'_sem in auto) theorem SC_completeness': fixes ps :: \(nat, nat) form list\ assumes \\(e :: nat \ nat hterm) f g. list_ex (eval e f g) (p # ps)\ shows \\ p # ps\ proof - define ps' where \ps' = map compl' ps\ then have \ps = map compl ps'\ - by (induct ps arbitrary: ps') (simp, smt compl'_def compl.simps(1) list.simps(9) someI_ex) + by (induct ps arbitrary: ps') (simp, smt (verit) compl'_def compl.simps(1) list.simps(9) someI_ex) from assms have \\(e :: nat \ nat hterm) f g. (list_ex (eval e f g) ps) \ eval e f g p\ by auto then have \\(e :: nat \ nat hterm) f g. (list_ex (\p. \ eval e f g p) ps') \ eval e f g p\ unfolding ps'_def using comp'_sem_list by blast then have \\(e :: nat \ nat hterm) f g. list_all (eval e f g) ps' \ eval e f g p\ by (metis Ball_set Bex_set) then have \\ p # map compl ps'\ using SC_completeness by blast then show ?thesis using \ps = map compl ps'\ by auto qed corollary fixes ps :: \(nat, nat) form list\ assumes \\(e :: nat \ nat hterm) f g. list_ex (eval e f g) ps\ shows \\ ps\ using assms SC_completeness' by (cases ps) auto end diff --git a/thys/GaleStewart_Games/AlternatingLists.thy b/thys/GaleStewart_Games/AlternatingLists.thy --- a/thys/GaleStewart_Games/AlternatingLists.thy +++ b/thys/GaleStewart_Games/AlternatingLists.thy @@ -1,144 +1,144 @@ section \ Alternating lists \ text \In lists where even and odd elements play different roles, it helps to define functions to take out the even elements. We defined the function (l)alternate on (coinductive) lists to do exactly this, and define certain properties.\ theory AlternatingLists imports MoreCoinductiveList2 (* for notation and lemmas like infinite_small_llength *) begin text \The functions alternate" and lalternate" are our main workhorses: they take every other item, so every item at even indices.\ fun alternate where "alternate Nil = Nil" | "alternate (Cons x xs) = Cons x (alternate (tl xs))" text \lalternate" takes every other item from a co-inductive list.\ primcorec lalternate :: "'a llist \ 'a llist" where "lalternate xs = (case xs of LNil \ LNil | (LCons x xs) \ LCons x (lalternate (ltl xs)))" lemma lalternate_ltake: "ltake (enat n) (lalternate xs) = lalternate (ltake (2*n) xs)" proof(induct n arbitrary:xs) case 0 then show ?case by (metis LNil_eq_ltake_iff enat_defs(1) lalternate.ctr(1) lnull_def mult_zero_right) next case (Suc n) hence lt:"ltake (enat n) (lalternate (ltl (ltl xs))) = lalternate (ltake (enat (2 * n)) (ltl (ltl xs)))". show ?case proof(cases "lalternate xs") case LNil then show ?thesis by(metis lalternate.disc(2) lnull_def ltake_LNil) next case (LCons x21 x22) thus ?thesis unfolding ltake_ltl mult_Suc_right add_2_eq_Suc using eSuc_enat lalternate.code lalternate.ctr(1) lhd_LCons_ltl llist.sel(1) - by (smt (z3) lt ltake_ltl llist.simps(3) llist.simps(5) ltake_eSuc_LCons) + by (smt (verit) lt ltake_ltl llist.simps(3) llist.simps(5) ltake_eSuc_LCons) qed qed lemma lalternate_llist_of[simp]: "lalternate (llist_of xs) = llist_of (alternate xs)" proof(induct "alternate xs" arbitrary:xs) case Nil then show ?case by (metis alternate.elims lalternate.ctr(1) list.simps(3) llist_of.simps(1) lnull_llist_of) next case (Cons a xs) then show ?case by(cases xs,auto simp: lalternate.ctr) qed lemma lalternate_finite_helper: (* The other direction is proved later, added as SIMP rule *) assumes "lfinite (lalternate xs)" shows "lfinite xs" using assms proof(induct "lalternate xs" arbitrary:xs rule:lfinite_induct) case LNil then show ?case unfolding lalternate.code[of xs] by(cases xs;auto) next case (LCons xs) then show ?case unfolding lalternate.code[of xs] by(cases "xs";cases "ltl xs";auto) qed lemma alternate_list_of: (* Note that this only holds for finite lists, as the other direction is left undefined with arguments (not just undefined) *) assumes "lfinite xs" shows "alternate (list_of xs) = list_of (lalternate xs)" using assms by (metis lalternate_llist_of list_of_llist_of llist_of_list_of) lemma alternate_length: "length (alternate xs) = (1+length xs) div 2" by (induct xs rule:induct_list012;simp) lemma lalternate_llength: "llength (lalternate xs) * 2 = (1+llength xs) \ llength (lalternate xs) * 2 = llength xs" proof(cases "lfinite xs") case True let ?xs = "list_of xs" have "length (alternate ?xs) = (1+length ?xs) div 2" using alternate_length by auto hence "length (alternate ?xs) * 2 = (1+length ?xs) \ length (alternate ?xs) * 2 = length ?xs" by auto then show ?thesis using alternate_list_of[OF True] lalternate_llist_of True length_list_of_conv_the_enat[OF True] llist_of_list_of[OF True] by (metis llength_llist_of numeral_One of_nat_eq_enat of_nat_mult of_nat_numeral plus_enat_simps(1)) next case False have "\ lfinite (lalternate xs)" using False lalternate_finite_helper by auto hence l1:"llength (lalternate xs) = \" by(rule not_lfinite_llength) from False have l2:"llength xs = \" using not_lfinite_llength by auto show ?thesis using l1 l2 by (simp add: mult_2_right) qed lemma lalternate_finite[simp]: shows "lfinite (lalternate xs) = lfinite xs" proof(cases "lfinite xs") case True then show ?thesis proof(cases "lfinite (lalternate xs)") case False hence False using not_lfinite_llength[OF False] True[unfolded lfinite_conv_llength_enat] lalternate_llength[of xs] by (auto simp:one_enat_def numeral_eq_enat) thus ?thesis by metis qed auto next case False then show ?thesis using lalternate_finite_helper by blast qed lemma nth_alternate: assumes "2*n < length xs" shows "alternate xs ! n = xs ! (2 * n)" using assms proof (induct xs arbitrary:n rule:induct_list012) case (3 x y zs) then show ?case proof(cases n) case (Suc nat) show ?thesis using "3.hyps"(1) "3.prems" Suc by force qed simp qed auto lemma lnth_lalternate: assumes "2*n < llength xs" shows "lalternate xs n = xs (2 * n)" proof - let ?xs = "ltake (2*Suc n) xs" have "lalternate ?xs n = ?xs (2 * n)" using assms alternate_list_of[of "ltake (2*Suc n) xs"] nth_alternate[of n "list_of ?xs"] - by (smt (z3) Suc_1 Suc_mult_less_cancel1 enat_ord_simps(2) infinite_small_llength lalternate_ltake length_list_of lessI llength_eq_enat_lfiniteD llength_ltake' ltake_all not_less nth_list_of numeral_eq_enat the_enat.simps times_enat_simps(1)) + by (smt (verit) Suc_1 Suc_mult_less_cancel1 enat_ord_simps(2) infinite_small_llength lalternate_ltake length_list_of lessI llength_eq_enat_lfiniteD llength_ltake' ltake_all not_less nth_list_of numeral_eq_enat the_enat.simps times_enat_simps(1)) thus ?thesis by (metis Suc_1 Suc_mult_less_cancel1 enat_ord_simps(2) lalternate_ltake lessI lnth_ltake) qed lemma lnth_lalternate2[simp]: assumes "n < llength (lalternate xs)" shows "lalternate xs n = xs (2 * n)" proof - from assms have "2*enat n < llength xs" by (metis enat_numeral lalternate_ltake leI linorder_neq_iff llength_ltake' ltake_all times_enat_simps(1)) from lnth_lalternate[OF this] show ?thesis. qed end \ No newline at end of file diff --git a/thys/GaleStewart_Games/FilteredList.thy b/thys/GaleStewart_Games/FilteredList.thy --- a/thys/GaleStewart_Games/FilteredList.thy +++ b/thys/GaleStewart_Games/FilteredList.thy @@ -1,310 +1,310 @@ theory FilteredList imports MoreCoinductiveList2 begin subsection \More on filtered lists\ text \We will reason about (co-inductive) lists with distinct elements. However, for our setting, this 'distinct' property only holds on the list after filtering. For this reason, we need some additional lemmas.\ text \Taking a sublist preserves distinctness after filtering.\ lemma ldistinct_lfilter_ltake[intro]: assumes "ldistinct (lfilter P xs)" shows "ldistinct (lfilter P (ltake x xs))" using assms by(induct xs,force,force ,(* sledgehammer found this gem to prove the inductive step via lfilter_lappend_lfinite! We will use this strategy ourselves later on *) metis lappend_ltake_ldrop ldistinct_lappend lfilter_lappend_lfinite lfinite_LConsI lfinite_ltake) text \The function lfind is used in multiple proofs, all are introduced to prove ltake_lfilter.\ definition lfind where "lfind P lst = (LEAST i. P (lst i))" lemma lfilter_lfind: assumes "lfilter P lst \ LNil" shows "P (lst lfind P lst)" (is ?g1) "P (lst y) \ lfind P lst \ y" (is "?a \ ?g2") "lfind P lst < llength lst" (is ?g3) proof - let ?I = "{n. enat n < llength lst \ P (lst n)}" let ?xs = lst from assms[unfolded lfilter_conv_lnths] lset_LNil have "lset (lnths lst {n. enat n < llength lst \ P (lst n)}) \ {}" by auto hence "{?xs i |i. enat i < llength ?xs \ i \ ?I} \ {}" using lset_lnths[of ?xs ?I] by metis then obtain i where p:"P (lst i)" "i < llength lst" by auto from p show ?g1 using LeastI lfind_def by metis from p show "?a \ ?g2" using Least_le lfind_def by metis from p show ?g3 using Least_le lfind_def by (metis enat_ord_simps(1) le_less_trans) qed lemma ltake_lfind_lset: assumes "x \ lset (ltake (enat (lfind P lst)) lst)" shows "\ P x" proof(cases "lfilter P (ltake (enat (lfind P lst)) lst) = LNil") case True then show ?thesis using assms unfolding lfilter_eq_LNil by auto next case False from assms[unfolded in_lset_conv_lnth] obtain n where n:"enat n < llength (ltake (enat (lfind P lst)) lst)" "ltake (enat (lfind P lst)) lst n = x" by blast { assume a:"P x" (* The idea of this {block} is that the element n must come after (lfind P lst) by lfilter_lfind(2) but this contradicts n(1). However, in the last step when writing this proof, sledgehammer found one that didn't use any of my previous steps, so here's a one-liner: *) from n Coinductive_List.lset_ltake False a enat_ord_simps(1) leD lfilter_empty_conv lfilter_lfind(2,3) llength_ltake' lnth_ltake subset_eq have False by metis } then show ?thesis by blast qed lemma ltake_lfind_conv: assumes "lfilter P lst \ LNil" shows "ltake (lfind P lst) lst = ltakeWhile (Not o P) lst" (is "?t1 = ?t2") "ldrop (lfind P lst) lst = ldropWhile (Not o P) lst" (is "?t3 = ?t4") proof - have lfin:"lfinite ?t1" by simp have [simp]:"min (enat (lfind P lst)) (llength lst) = (lfind P lst)" using lfilter_lfind(3)[OF assms] by (metis min.strict_order_iff) have l1:"llength ?t1 = lfind P lst" by simp from ltake_lfind_lset ltakeWhile_all have t:"ltakeWhile (Not o P) ?t1 = ?t1" unfolding o_def by metis have inset:"lset (ltake (enat (lfind P lst)) lst) \ {x. (Not \ P) x}" using ltake_lfind_lset[of _ P lst] by auto (* for use in ltakeWhile_lappend2 *) have isnull:"ltakeWhile (Not \ P) (ldrop (enat (lfind P lst)) lst) = LNil" apply(cases "ldrop (enat (lfind P lst)) lst") using lfilter_lfind(1)[OF assms] lhd_ldrop[OF lfilter_lfind(3)[OF assms]] by auto have "ltakeWhile (Not o P) ?t1 = ltakeWhile (Not o P) (lappend ?t1 ?t3)" unfolding ltakeWhile_lappend2[OF inset] isnull lappend_LNil2 t.. hence leneq:"llength ?t1 = llength ?t2" using t l1 lappend_ltake_ldrop by metis have "lappend ?t1 ?t3 = lappend ?t2 ?t4" unfolding lappend_ltakeWhile_ldropWhile[of "Not \ P" lst] lappend_ltake_ldrop[of "lfind P lst" lst] by simp from this[unfolded lappend_eq_lappend_conv[OF leneq]] lfin show "?t1 = ?t2" "?t3 = ?t4" by auto qed lemma lfilter_hdtl: assumes "lfilter P lst \ LNil" shows "\ n. LCons (lhd (lfilter P lst)) LNil = lfilter P (ltake (enat n) lst) \ ltl (lfilter P lst) = lfilter P (ldrop (enat n) lst)" proof(standard,standard) note * = lfilter_lfind[OF assms] let ?n = "Suc (lfind P lst)" let ?ltake = "ltake (enat ?n) lst" have ltake:"lappend (ltakeWhile (Not \ P) ?ltake) (ldropWhile (Not \ P) ?ltake) = ?ltake" (is "lappend ?ltw ?ldw = _") using lappend_ltakeWhile_ldropWhile by blast have "llength ?ldw \ 1" unfolding ldropWhile_lappend ltake_Suc_conv_snoc_lnth[OF *(3)] using ltake_lfind_lset[of _ P lst] by (auto intro:* simp:one_eSuc) hence null:"lnull (ltl (ldropWhile (Not \ P) ?ltake))" unfolding llength_eq_0[symmetric] llength_ltl by (metis dual_order.order_iff_strict enat_ile epred_0 epred_1 iless_Suc_eq le_zero_eq one_eSuc one_enat_def) have e:"enat (lfind P lst) < enat (Suc (lfind P lst))" by auto from * have "P (?ltake lfind P lst)" using lnth_ltake[OF e] by metis hence nonnull:"\ lnull (lfilter P ?ltake)" unfolding lnull_lfilter by (metis "*"(3) e in_lset_conv_lnth leI llength_ltake' ltake_all) show a:"LCons (lhd (lfilter P lst)) LNil = lfilter P ?ltake" (is "?lhs = ?rhs") proof - have "lhd (lfilter P ?ltake) = lhd (lfilter P lst)" by(rule lprefix_lhdD[OF lprefix_lfilterI[OF ltake_is_lprefix] nonnull]) hence h:"lhd ?lhs = lhd ?rhs" by simp have "ltl ?rhs = LNil" unfolding ltl_lfilter using null by (metis lfilter_LNil llist.collapse(1)) hence t:"ltl ?lhs = ltl ?rhs" by simp have flt:"?rhs \ LNil" using nonnull by fastforce show ?thesis by(rule llist_eq_lcons[of ?lhs ?rhs,OF _ flt h t],auto) qed from lappend_ltake_ldrop[of ?n lst] lappend_ltakeWhile_ldropWhile[of "Not \ P" lst] have "lappend (ltake ?n lst) (ldrop ?n lst) = lappend (ltakeWhile (Not \ P) lst) (ldropWhile (Not \ P) lst)" by auto from ltake_lfind_conv(2)[OF assms] have "ltl (ldropWhile (Not \ P) lst) = ldrop (enat (Suc (lfind P lst))) lst" unfolding ldrop_eSuc_conv_ltl eSuc_enat[symmetric] by simp thus "ltl (lfilter P lst) = lfilter P (ldrop (enat ?n) lst)" unfolding ltl_lfilter by metis qed lemma ltake_lfilter: shows "\ n. ltake (enat x) (lfilter P lst) = lfilter P (ltake (enat n) lst) \ ldrop (enat x) (lfilter P lst) = lfilter P (ldrop (enat n) lst)" proof(induct x) case 0 then show ?case by (metis LNil_eq_ltake_iff ldrop_enat ldropn_0 lfilter_code(1) zero_enat_def) next let ?fP = "lfilter P" case (Suc x) then obtain n where n:"ltake (enat x) (?fP lst) = ?fP (ltake (enat n) lst)" "ldrop (enat x) (lfilter P lst) = lfilter P (ldrop (enat n) lst)" by blast consider "lfilter P (ldrop (enat n) lst) \ LNil \ x < llength (?fP lst)" | "lfilter P (ldrop (enat n) lst) = LNil" | "x \ llength (?fP lst)" by force then show ?case proof(cases) case 1 hence *:"lfilter P (ldrop (enat n) lst) \ LNil" "enat x < llength (lfilter P lst)" by auto from lappend_ltake_ldrop have "lst = lappend (ltake (enat n) lst) (ldrop (enat n) lst)" by metis from lfilter_hdtl[OF *(1)] obtain delta where delta:"LCons (lhd (?fP (ldrop (enat n) lst))) LNil = ?fP (ltake (enat delta) (ldrop (enat n) lst))" "ltl (lfilter P (ldrop (enat n) lst)) = lfilter P (ldrop (enat delta) (ldrop (enat n) lst))" by blast have "ltake (enat (Suc x)) (?fP lst) = lappend (?fP (ltake (enat n) lst)) (LCons (?fP lst x) LNil)" using n ltake_Suc_conv_snoc_lnth * by metis also have "?fP lst x = ?fP lst (the_enat x)" by auto also have "\ = lhd (ldrop x (?fP lst))" using lhd_ldrop[symmetric] *(2) by metis also have "\ = lhd (?fP (ldrop (enat n) lst))" using n by metis also note delta(1) finally have take_part:"ltake (enat (Suc x)) (?fP lst) = ?fP (ltake (enat (n + delta)) lst)" using ltake_plus_conv_lappend by (metis infinite_small_llength lfilter_lappend_lfinite llength_ltake' ltake_all min.strict_order_iff not_less plus_enat_simps(1)) have "ldrop (enat (Suc x)) (?fP lst) = ltl (ldrop x (?fP lst))" by (simp add: ltl_ldropn ldrop_eSuc_ltl ldrop_enat) also have "ldrop x (?fP lst) = ?fP (ldrop (enat n) lst)" using n by metis also note delta(2) also have "lfilter P (ldrop (enat delta) (ldrop (enat n) lst)) = lfilter P (ldrop (enat delta + enat n) lst)" by simp also have "(enat delta + enat n) = enat (n + delta)" by simp finally have drop_part:"ldrop (enat (Suc x)) (?fP lst) = ?fP (ldrop (enat (n + delta)) lst)". from take_part drop_part show ?thesis by blast next case 2 note * = 2 lappend_ltake_ldrop[of "enat n" lst] Suc_llength infinite_small_llength lappend_LNil2 leI lfilter_lappend_lfinite llength_ltake' min.strict_order_iff n have take_part:"ltake (enat (Suc x)) (?fP lst) = ?fP (ltake (enat n) lst)" - using * by (smt (z3) ltake_all) + using * by (smt (verit) ltake_all) from 2 have drop_part:"ldrop (enat (Suc x)) (?fP lst) = ?fP (ldrop (enat n) lst)" - using * by (smt (z3) ldrop_all) + using * by (smt (verit) ldrop_all) from take_part drop_part show ?thesis by blast next case 3 then show ?thesis using n dual_order.order_iff_strict eSuc_enat iless_Suc_eq le_less_trans ltake_all ldrop_all by metis qed qed lemma filter_obtain_two: assumes "i < j" "j < length (filter P lst)" shows "\ i2 j2. i2 < j2 \ j2 < length lst \ lst ! i2 = filter P lst ! i \ lst ! j2 = filter P lst ! j" using assms proof(induct lst arbitrary: i j) case (Cons a lst) then obtain jprev where jprev:"j = Suc jprev" using lessE by metis show ?case proof(cases "P a") case True hence lnth[simp]:"length (filter P (a # lst)) = Suc (length (filter P lst))" by auto show ?thesis proof(cases i) case 0 from jprev True Cons(3) have "jprev < length (filter P lst) " by auto from nth_mem[OF this] have "filter P lst ! jprev \ set lst" by auto from this[unfolded in_set_conv_nth] obtain j2 where "j2 i j. i < llength lst \ j < llength lst \ lst i = lst j \ P (lst i) \ i = j" shows "ldistinct (lfilter P lst)" proof - { fix i j assume *: "enat i < llength (lfilter P lst)" "enat j < llength (lfilter P lst)" "lfilter P lst i = lfilter P lst j" "i < j" hence "lfilter P lst i \ lset (lfilter P lst)" unfolding in_lset_conv_lnth by auto with lset_lfilter have P:"P (lfilter P lst i)" by auto let ?maxij = "Suc (max i j)" from ltake_lfilter obtain maxij where maxij:"ltake ?maxij (lfilter P lst) = lfilter P (ltake (enat maxij) lst)" by blast let ?lst = "ltake (enat maxij) lst" have "lfinite ?lst" by auto define flst where "flst = list_of ?lst" hence flst:"llist_of flst = ?lst" by auto let ?flst = "llist_of flst" from * P have "enat i < llength (lfilter P ?flst)" "enat j < llength (lfilter P ?flst)" "lfilter P ?flst i = lfilter P ?flst j" and P2:"P (lfilter P ?lst i)" unfolding maxij[symmetric] flst by (auto simp add: lnth_ltake) hence "i < length (filter P flst)" "j < length (filter P flst)" and eq_ij: "filter P flst ! i = filter P flst ! j" unfolding llength_llist_of lfilter_llist_of lnth_llist_of by auto with filter_obtain_two[OF *(4) this(2)] obtain i2 j2 where "i2 < length flst" "j2 < length flst" "flst ! i2 = filter P flst ! i" "flst ! j2 = filter P flst ! j" and ineq:"i2 i j. i < llength lst \ j < llength lst \ P (lst i) \ lst i = lst j \ i = j)" proof show "ldistinct (lfilter P lst) \ \i j. enat i < llength lst \ enat j < llength lst \ P (lst i) \ lst i = lst j \ i = j" by (auto simp add: ldistinct_lfilterE) show "\i j. enat i < llength lst \ enat j < llength lst \ P (lst i) \ lst i = lst j \ i = j \ ldistinct (lfilter P lst) " using ldistinct_lfilterI by blast qed end \ No newline at end of file diff --git a/thys/IMO2019/IMO2019_Q1.thy b/thys/IMO2019/IMO2019_Q1.thy --- a/thys/IMO2019/IMO2019_Q1.thy +++ b/thys/IMO2019/IMO2019_Q1.thy @@ -1,66 +1,66 @@ (* File: IMO2019_Q1.thy Author: Manuel Eberl, TU MÃ¼nchen *) section \Q1\ theory IMO2019_Q1 imports Main begin text \ Consider a function \f : \ \ \\ that fulfils the functional equation \f(2a) + 2f(b) = f(f(a+b))\ for all \a, b \ \\. Then \f\ is either identically 0 or of the form \f(x) = 2x + c\ for some constant \c \ \\. \ context fixes f :: "int \ int" and m :: int assumes f_eq: "f (2 * a) + 2 * f b = f (f (a + b))" defines "m \ (f 0 - f (-2)) div 2" begin text \ We first show that \f\ is affine with slope \(f(0) - f(-2)) / 2\. This follows from plugging in \(0, b)\ and \(-1, b + 1)\ into the functional equation. \ lemma f_eq': "f x = m * x + f 0" proof - have rec: "f (b + 1) = f b + m" for b using f_eq[of 0 b] f_eq[of "-1" "b + 1"] by (simp add: m_def) moreover have "f (b - 1) = f b - m" for b using rec[of "b - 1"] by simp ultimately show ?thesis by (induction x rule: int_induct[of _ 0]) (auto simp: algebra_simps) qed text \ This version is better for the simplifier because it prevents it from looping. \ lemma f_eq'_aux [simp]: "NO_MATCH 0 x \ f x = m * x + f 0" by (rule f_eq') text \ Plugging in \(0, 0)\ and \(0, 1)\. \ lemma f_classification: "(\x. f x = 0) \ (\x. f x = 2 * x + f 0)" using f_eq[of 0 0] f_eq[of 0 1] by auto end text \ It is now easy to derive the full characterisation of the functions we considered: \ theorem fixes f :: "int \ int" shows "(\a b. f (2 * a) + 2 * f b = f (f (a + b))) \ (\x. f x = 0) \ (\x. f x = 2 * x + f 0)" (is "?lhs \ ?rhs") proof assume ?lhs thus ?rhs using f_classification[of f] by blast next assume ?rhs - thus ?lhs by smt + thus ?lhs by (smt (verit, ccfv_threshold) mult_2) qed end \ No newline at end of file diff --git a/thys/Isabelle_hoops/Ordinal_Sums.thy b/thys/Isabelle_hoops/Ordinal_Sums.thy --- a/thys/Isabelle_hoops/Ordinal_Sums.thy +++ b/thys/Isabelle_hoops/Ordinal_Sums.thy @@ -1,778 +1,778 @@ section\Ordinal sums\ text\We define @{text "tower of hoops"}, a family of almost disjoint hoops indexed by a total order. This is based on the definition of @{text "bounded tower of irreducible hoops"} in \<^cite>\"BUSANICHE2005"\ (see paragraph after Lemma 3.3). Parting from a tower of hoops we can define a hoop known as @{text "ordinal sum"}. Ordinal sums are a fundamental tool in the study of totally ordered hoops.\ theory Ordinal_Sums imports Hoops begin subsection\Tower of hoops\ locale tower_of_hoops = fixes index_set :: "'b set" ("I") fixes index_lesseq :: "'b \ 'b \ bool" (infix "\\<^sup>I" 60) fixes index_less :: "'b \ 'b \ bool" (infix "<\<^sup>I" 60) fixes universes :: "'b \ ('a set)" ("UNI") fixes multiplications :: "'b \ ('a \ 'a \ 'a)" ("MUL") fixes implications :: "'b \ ('a \ 'a \ 'a)" ("IMP") fixes sum_one :: 'a ("1\<^sup>S") assumes index_set_total_order: "total_poset_on I (\\<^sup>I) (<\<^sup>I)" and almost_disjoint: "i \ I \ j \ I \ i \ j \ UNI i \ UNI j = {1\<^sup>S}" and family_of_hoops: "i \ I \ hoop (UNI i) (MUL i) (IMP i) 1\<^sup>S" begin sublocale total_poset_on "I" "(\\<^sup>I)" "(<\<^sup>I)" using index_set_total_order by simp abbreviation (uni_i) uni_i :: "['b] \ ('a set)" ("(\(\<^sub>_))" [61] 60) where "\\<^sub>i \ UNI i" abbreviation (mult_i) mult_i :: "['b] \ ('a \ 'a \ 'a)" ("(*(\<^sup>_))" [61] 60) where "*\<^sup>i \ MUL i" abbreviation (imp_i) imp_i :: "['b] \ ('a \ 'a \ 'a)" ("(\(\<^sup>_))" [61] 60) where "\\<^sup>i \ IMP i" abbreviation (mult_i_xy) mult_i_xy :: "['a, 'b, 'a] \ 'a" ("((_)/ *(\<^sup>_) / (_))" [61, 50, 61] 60) where "x *\<^sup>i y \ MUL i x y" abbreviation (imp_i_xy) imp_i_xy :: "['a, 'b, 'a] \ 'a" ("((_)/ \(\<^sup>_) / (_))" [61, 50, 61] 60) where "x \\<^sup>i y \ IMP i x y" subsection\Ordinal sum universe\ definition sum_univ :: "'a set" ("S") where "S = {x. \ i \ I. x \ \\<^sub>i}" lemma sum_one_closed [simp]: "1\<^sup>S \ S" using family_of_hoops hoop.one_closed not_empty sum_univ_def by fastforce lemma sum_subsets: assumes "i \ I" shows "\\<^sub>i \ S" using sum_univ_def assms by blast subsection\Floor function: definition and properties\ lemma floor_unique: assumes "a \ S-{1\<^sup>S}" shows "\! i. i \ I \ a \ \\<^sub>i" using assms sum_univ_def almost_disjoint by blast function floor :: "'a \ 'b" where "floor x = (THE i. i \ I \ x \ \\<^sub>i)" if "x \ S-{1\<^sup>S}" | "floor x = undefined" if "x = 1\<^sup>S \ x \ S" by auto termination by lexicographic_order abbreviation (uni_floor) uni_floor :: "['a] \ ('a set)" ("(\\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r (\<^sub>_))" [61] 60) where "\\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>x \ UNI (floor x)" abbreviation (mult_floor) mult_floor :: "['a] \ ('a \ 'a \ 'a)" ("(*\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r (\<^sup>_))" [61] 60) where "*\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a \ MUL (floor a)" abbreviation (imp_floor) imp_floor :: "['a] \ ('a \ 'a \ 'a)" ("(\\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r (\<^sup>_))" [61] 60) where "\\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a \ IMP (floor a)" abbreviation (mult_floor_xy) mult_floor_xy :: "['a, 'a, 'a] \ 'a" ("((_)/ *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r (\<^sup>_) / (_))" [61, 50, 61] 60) where "x *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>y z \ MUL (floor y) x z" abbreviation (imp_floor_xy) imp_floor_xy :: "['a, 'a, 'a] \ 'a" ("((_)/ \\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r (\<^sup>_) / (_))" [61, 50, 61] 60) where "x \\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>y z \ IMP (floor y) x z" lemma floor_prop: assumes "a \ S-{1\<^sup>S}" shows "floor a \ I \ a \ \\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a" proof - have "floor a = (THE i. i \ I \ a \ \\<^sub>i)" using assms by auto then show ?thesis using assms theI_unique floor_unique by (metis (mono_tags, lifting)) qed lemma floor_one_closed: assumes "i \ I" shows "1\<^sup>S \ \\<^sub>i" using assms floor_prop family_of_hoops hoop.one_closed by metis lemma floor_mult_closed: assumes "i \ I" "a \ \\<^sub>i" "b \ \\<^sub>i" shows "a *\<^sup>i b \ \\<^sub>i" using assms family_of_hoops hoop.mult_closed by meson lemma floor_imp_closed: assumes "i \ I" "a \ \\<^sub>i" "b \ \\<^sub>i" shows "a \\<^sup>i b \ \\<^sub>i" using assms family_of_hoops hoop.imp_closed by meson subsection\Ordinal sum multiplication and implication\ function sum_mult :: "'a \ 'a \ 'a" (infix "*\<^sup>S" 60) where "x *\<^sup>S y = x *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>x y" if "x \ S-{1\<^sup>S}" "y \ S-{1\<^sup>S}" "floor x = floor y" | "x *\<^sup>S y = x" if "x \ S-{1\<^sup>S}" "y \ S-{1\<^sup>S}" "floor x <\<^sup>I floor y" | "x *\<^sup>S y = y" if "x \ S-{1\<^sup>S}" "y \ S-{1\<^sup>S}" "floor y <\<^sup>I floor x" | "x *\<^sup>S y = y" if "x = 1\<^sup>S" "y \ S-{1\<^sup>S}" | "x *\<^sup>S y = x" if "x \ S-{1\<^sup>S}" "y = 1\<^sup>S" | "x *\<^sup>S y = 1\<^sup>S" if "x = 1\<^sup>S" "y = 1\<^sup>S" | "x *\<^sup>S y = undefined" if "x \ S \ y \ S" apply auto - using floor.cases floor.simps(1) floor_prop trichotomy apply smt + using floor.cases floor.simps(1) floor_prop trichotomy apply (smt (verit)) using floor_prop strict_iff_order apply force using floor_prop strict_iff_order apply force using floor_prop trichotomy by auto termination by lexicographic_order function sum_imp :: "'a \ 'a \ 'a" (infix "\\<^sup>S" 60) where "x \\<^sup>S y = x \\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>x y" if "x \ S-{1\<^sup>S}" "y \ S-{1\<^sup>S}" "floor x = floor y" | "x \\<^sup>S y = 1\<^sup>S" if "x \ S-{1\<^sup>S}" "y \ S-{1\<^sup>S}" "floor x <\<^sup>I floor y" | "x \\<^sup>S y = y" if "x \ S-{1\<^sup>S}" "y \ S-{1\<^sup>S}" "floor y <\<^sup>I floor x" | "x \\<^sup>S y = y" if "x = 1\<^sup>S" "y \ S-{1\<^sup>S}" | "x \\<^sup>S y = 1\<^sup>S" if "x \ S-{1\<^sup>S}" "y = 1\<^sup>S" | "x \\<^sup>S y = 1\<^sup>S" if "x = 1\<^sup>S" "y = 1\<^sup>S" | "x \\<^sup>S y = undefined" if "x \ S \ y \ S" apply auto - using floor.cases floor.simps(1) floor_prop trichotomy apply smt + using floor.cases floor.simps(1) floor_prop trichotomy apply (smt (verit)) using floor_prop strict_iff_order apply force using floor_prop strict_iff_order apply force using floor_prop trichotomy by auto termination by lexicographic_order subsubsection\Some multiplication properties\ lemma sum_mult_not_one_aux: assumes "a \ S-{1\<^sup>S}" "b \ \\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a" shows "a *\<^sup>S b \ (\\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a)-{1\<^sup>S}" proof - consider (1) "b \ S-{1\<^sup>S}" | (2) "b = 1\<^sup>S" using sum_subsets assms floor_prop by blast then show ?thesis proof(cases) case 1 then have same_floor: "floor a = floor b" using assms floor_prop floor_unique by metis moreover have "a *\<^sup>S b = a *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a b" using "1" assms(1) same_floor by simp moreover have "a \ (\\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a)-{1\<^sup>S} \ b \ (\\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a)-{1\<^sup>S}" using "1" assms floor_prop by simp ultimately show ?thesis using assms(1) family_of_hoops floor_prop hoop.mult_C by metis next case 2 then show ?thesis using assms(1) floor_prop by auto qed qed corollary sum_mult_not_one: assumes "a \ S-{1\<^sup>S}" "b \ \\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a" shows "a *\<^sup>S b \ S-{1\<^sup>S} \ floor (a *\<^sup>S b) = floor a" proof - have "a *\<^sup>S b \ (\\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a)-{1\<^sup>S}" using sum_mult_not_one_aux assms by meson then have "a *\<^sup>S b \ S-{1\<^sup>S} \ a *\<^sup>S b \ \\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a" using sum_subsets assms(1) floor_prop by fastforce then show ?thesis using assms(1) floor_prop floor_unique by metis qed lemma sum_mult_A: assumes "a \ S-{1\<^sup>S}" "b \ \\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a" shows "a *\<^sup>S b = a *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a b \ b *\<^sup>S a = b *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a a" proof - consider (1) "b \ S-{1\<^sup>S}" | (2) "b = 1\<^sup>S" using sum_subsets assms floor_prop by blast then show ?thesis proof(cases) case 1 then have "floor a = floor b" using assms floor.cases floor_prop floor_unique by metis then show ?thesis using "1" assms by auto next case 2 then show ?thesis using assms(1) family_of_hoops floor_prop hoop.mult_neutr hoop.mult_neutr_2 by fastforce qed qed subsubsection\Some implication properties\ lemma sum_imp_floor: assumes "a \ S-{1\<^sup>S}" "b \ S-{1\<^sup>S}" "floor a = floor b" "a \\<^sup>S b \ S-{1\<^sup>S}" shows "floor (a \\<^sup>S b) = floor a" proof - have "a \\<^sup>S b \ \\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a" using sum_imp.simps(1) assms(1-3) floor_imp_closed floor_prop by metis then show ?thesis using assms(1,4) floor_prop floor_unique by blast qed lemma sum_imp_A: assumes "a \ S-{1\<^sup>S}" "b \ \\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a" shows "a \\<^sup>S b = a \\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a b" proof - consider (1) "b \ S-{1\<^sup>S}" | (2) "b = 1\<^sup>S" using sum_subsets assms floor_prop by blast then show ?thesis proof(cases) case 1 then show ?thesis using sum_imp.simps(1) assms floor_prop floor_unique by metis next case 2 then show ?thesis using sum_imp.simps(5) assms(1) family_of_hoops floor_prop hoop.imp_one_top by metis qed qed lemma sum_imp_B: assumes "a \ S-{1\<^sup>S}" "b \ \\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a" shows "b \\<^sup>S a = b \\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a a" proof - consider (1) "b \ S-{1\<^sup>S}" | (2) "b = 1\<^sup>S" using sum_subsets assms floor_prop by blast then show ?thesis proof(cases) case 1 then show ?thesis using sum_imp.simps(1) assms floor_prop floor_unique by metis next case 2 then show ?thesis using sum_imp.simps(4) assms(1) family_of_hoops floor_prop hoop.imp_one_C by metis qed qed lemma sum_imp_floor_antisymm: assumes "a \ S-{1\<^sup>S}" "b \ S-{1\<^sup>S}" "floor a = floor b" "a \\<^sup>S b = 1\<^sup>S" "b \\<^sup>S a = 1\<^sup>S" shows "a = b" proof - have "a \ \\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a \ b \ \\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a \ floor a \ I" using floor_prop assms by metis moreover have "a \\<^sup>S b = a \\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a b \ b \\<^sup>S a = b \\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a a" using assms by auto ultimately show ?thesis using assms(4,5) family_of_hoops hoop.ord_antisymm_equiv by metis qed corollary sum_imp_C: assumes "a \ S-{1\<^sup>S}" "b \ S-{1\<^sup>S}" "a \ b" "floor a = floor b" "a \\<^sup>S b = 1\<^sup>S" shows "b \\<^sup>S a \ 1\<^sup>S" using sum_imp_floor_antisymm assms by blast lemma sum_imp_D: assumes "a \ S" shows "1\<^sup>S \\<^sup>S a = a" using sum_imp.simps(4,6) assms by blast lemma sum_imp_E: assumes "a \ S" shows "a \\<^sup>S 1\<^sup>S = 1\<^sup>S" using sum_imp.simps(5,6) assms by blast subsection\The ordinal sum of a tower of hoops is a hoop\ subsubsection\@{term S} is not empty\ lemma sum_not_empty: "S \ \" using sum_one_closed by blast subsubsection\@{term sum_mult} and @{term sum_imp} are well defined\ lemma sum_mult_closed_one: assumes "a \ S" "b \ S" "a = 1\<^sup>S \ b = 1\<^sup>S" shows "a *\<^sup>S b \ S" using sum_mult.simps(4-6) assms floor.cases by metis lemma sum_mult_closed_not_one: assumes "a \ S-{1\<^sup>S}" "b \ S-{1\<^sup>S}" shows "a *\<^sup>S b \ S-{1\<^sup>S}" proof - from assms consider (1) "floor a = floor b" | (2) "floor a <\<^sup>I floor b \ floor b <\<^sup>I floor a" using trichotomy floor_prop by blast then show ?thesis proof(cases) case 1 then show ?thesis using sum_mult_not_one assms floor_prop by metis next case 2 then show ?thesis using assms by auto qed qed lemma sum_mult_closed: assumes "a \ S" "b \ S" shows "a *\<^sup>S b \ S" using sum_mult_closed_not_one sum_mult_closed_one assms by auto lemma sum_imp_closed_one: assumes "a \ S" "b \ S" "a = 1\<^sup>S \ b = 1\<^sup>S" shows "a \\<^sup>S b \ S" using sum_imp.simps(4-6) assms floor.cases by metis lemma sum_imp_closed_not_one: assumes "a \ S-{1\<^sup>S}" "b \ S-{1\<^sup>S}" shows "a \\<^sup>S b \ S" proof - from assms consider (1) "floor a = floor b" | (2) "floor a <\<^sup>I floor b \ floor b <\<^sup>I floor a" using trichotomy floor_prop by blast then show "a \\<^sup>S b \ S" proof(cases) case 1 then have "a \\<^sup>S b = a \\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a b" using assms by auto moreover have "a \\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a b \ \\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a" using "1" assms floor_imp_closed floor_prop by metis ultimately show ?thesis using sum_subsets assms(1) floor_prop by auto next case 2 then show ?thesis using assms by auto qed qed lemma sum_imp_closed: assumes "a \ S" "b \ S" shows "a \\<^sup>S b \ S" using sum_imp_closed_one sum_imp_closed_not_one assms by auto subsubsection\Neutrality of @{term sum_one}\ lemma sum_mult_neutr: assumes "a \ S" shows "a *\<^sup>S 1\<^sup>S = a \ 1\<^sup>S *\<^sup>S a = a" using assms sum_mult.simps(4-6) by blast subsubsection\Commutativity of @{term sum_mult}\ text\Now we prove @{term "x *\<^sup>S y = y *\<^sup>S x"} by showing that it holds when one of the variables is equal to @{term "1\<^sup>S"}. Then we consider when none of them is @{term "1\<^sup>S"}.\ lemma sum_mult_comm_one: assumes "a \ S" "b \ S" "a = 1\<^sup>S \ b = 1\<^sup>S" shows "a *\<^sup>S b = b *\<^sup>S a" using sum_mult_neutr assms by auto lemma sum_mult_comm_not_one: assumes "a \ S-{1\<^sup>S}" "b \ S-{1\<^sup>S}" shows "a *\<^sup>S b = b *\<^sup>S a" proof - from assms consider (1) "floor a = floor b" | (2) "floor a <\<^sup>I floor b \ floor b <\<^sup>I floor a" using trichotomy floor_prop by blast then show ?thesis proof(cases) case 1 then have same_floor: "b \ \\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a" using assms(2) floor_prop by simp then have "a *\<^sup>S b = a *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a b" using sum_mult_A assms(1) by blast also have "\ = b *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a a" using assms(1) family_of_hoops floor_prop hoop.mult_comm same_floor by meson also have "\ = b *\<^sup>S a" using sum_mult_A assms(1) same_floor by simp finally show ?thesis by auto next case 2 then show ?thesis using assms by auto qed qed lemma sum_mult_comm: assumes "a \ S" "b \ S" shows "a *\<^sup>S b = b *\<^sup>S a" using assms sum_mult_comm_one sum_mult_comm_not_one by auto subsubsection\Associativity of @{term sum_mult}\ text\Next we prove @{term "x *\<^sup>S (y *\<^sup>S z) = (x *\<^sup>S y) *\<^sup>S z"}.\ lemma sum_mult_assoc_one: assumes "a \ S" "b \ S" "c \ S" "a = 1\<^sup>S \ b = 1\<^sup>S \ c = 1\<^sup>S" shows "a *\<^sup>S (b *\<^sup>S c) = (a *\<^sup>S b) *\<^sup>S c" using sum_mult_neutr assms sum_mult_closed by metis lemma sum_mult_assoc_not_one: assumes "a \ S-{1\<^sup>S}" "b \ S-{1\<^sup>S}" "c \ S-{1\<^sup>S}" shows "a *\<^sup>S (b *\<^sup>S c) = (a *\<^sup>S b) *\<^sup>S c" proof - from assms consider (1) "floor a = floor b" "floor b = floor c" | (2) "floor a = floor b" "floor b <\<^sup>I floor c" | (3) "floor a = floor b" "floor c <\<^sup>I floor b" | (4) "floor a <\<^sup>I floor b" "floor b = floor c" | (5) "floor a <\<^sup>I floor b" "floor b <\<^sup>I floor c" | (6) "floor a <\<^sup>I floor b" "floor c <\<^sup>I floor b" | (7) "floor b <\<^sup>I floor a" "floor b = floor c" | (8) "floor b <\<^sup>I floor a" "floor b <\<^sup>I floor c" | (9) "floor b <\<^sup>I floor a" "floor c <\<^sup>I floor b" using trichotomy floor_prop by meson then show ?thesis proof(cases) case 1 then have "a *\<^sup>S (b *\<^sup>S c) = a *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a (b *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a c)" using sum_mult_A assms floor_mult_closed floor_prop by metis also have "\ = (a *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a b) *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a c" using "1" assms family_of_hoops floor_prop hoop.mult_assoc by metis also have "\ = (a *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>b b) *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>b c" using "1" by simp also have "\ = (a *\<^sup>S b) *\<^sup>S c" using "1" sum_mult_A assms floor_mult_closed floor_prop by metis finally show ?thesis by auto next case 2 then show ?thesis using sum_mult.simps(2,3) sum_mult_not_one assms floor_prop by metis next case 3 then show ?thesis using sum_mult.simps(3) sum_mult_not_one assms floor_prop by metis next case 4 then show ?thesis using sum_mult.simps(2) sum_mult_not_one assms floor_prop by metis next case 5 then show ?thesis using sum_mult.simps(2) assms floor_prop strict_trans by metis next case 6 then show ?thesis using sum_mult.simps(2,3) assms by metis next case 7 then show ?thesis using sum_mult.simps(3) sum_mult_not_one assms floor_prop by metis next case 8 then show ?thesis using sum_mult.simps(2,3) assms by metis next case 9 then show ?thesis using sum_mult.simps(3) assms floor_prop strict_trans by metis qed qed lemma sum_mult_assoc: assumes "a \ S" "b \ S" "c \ S" shows "a *\<^sup>S (b *\<^sup>S c) = (a *\<^sup>S b) *\<^sup>S c" using assms sum_mult_assoc_one sum_mult_assoc_not_one by blast subsubsection\Reflexivity of @{term sum_imp}\ lemma sum_imp_reflex: assumes "a \ S" shows "a \\<^sup>S a = 1\<^sup>S" proof - consider (1) "a \ S-{1\<^sup>S}" | (2) "a = 1\<^sup>S" using assms by blast then show ?thesis proof(cases) case 1 then have "a \\<^sup>S a = a \\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a a" by simp then show ?thesis using "1" family_of_hoops floor_prop hoop.imp_reflex by metis next case 2 then show ?thesis by simp qed qed subsubsection\Divisibility\ text\We prove @{term "x *\<^sup>S (x \\<^sup>S y) = y *\<^sup>S (y \\<^sup>S x)"} using the same methods as before.\ lemma sum_divisibility_one: assumes "a \ S" "b \ S" "a = 1\<^sup>S \ b = 1\<^sup>S" shows "a *\<^sup>S (a \\<^sup>S b) = b *\<^sup>S (b \\<^sup>S a)" proof - have "x \\<^sup>S y = y \ y \\<^sup>S x = 1\<^sup>S" if "x = 1\<^sup>S" "y \ S" for x y using sum_imp_D sum_imp_E that by simp then show ?thesis using assms sum_mult_neutr by metis qed lemma sum_divisibility_aux: assumes "a \ S-{1\<^sup>S}" "b \ \\<^sub>f\<^sub>l\<^sub>o\<^sub>o\<^sub>r \<^sub>a" shows "a *\<^sup>S (a \\<^sup>S b) = a *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a (a \\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a b)" using sum_imp_A sum_mult_A assms floor_imp_closed floor_prop by metis lemma sum_divisibility_not_one: assumes "a \ S-{1\<^sup>S}" "b \ S-{1\<^sup>S}" shows "a *\<^sup>S (a \\<^sup>S b) = b *\<^sup>S (b \\<^sup>S a)" proof - from assms consider (1) "floor a = floor b" | (2) "floor a <\<^sup>I floor b \ floor b <\<^sup>I floor a" using trichotomy floor_prop by blast then show ?thesis proof(cases) case 1 then have "a *\<^sup>S (a \\<^sup>S b) = a *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a (a \\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a b)" using "1" sum_divisibility_aux assms floor_prop by metis also have "\ = b *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a (b \\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a a)" using "1" assms family_of_hoops floor_prop hoop.divisibility by metis also have "\ = b *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>b (b \\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>b a)" using "1" by simp also have "\ = b *\<^sup>S (b \\<^sup>S a)" using "1" sum_divisibility_aux assms floor_prop by metis finally show ?thesis by auto next case 2 then show ?thesis using assms by auto qed qed lemma sum_divisibility: assumes "a \ S" "b \ S" shows "a *\<^sup>S (a \\<^sup>S b) = b *\<^sup>S (b \\<^sup>S a)" using assms sum_divisibility_one sum_divisibility_not_one by auto subsubsection\Residuation\ text\Finally we prove @{term "(x *\<^sup>S y) \\<^sup>S z = (x \\<^sup>S (y \\<^sup>S z))"}.\ lemma sum_residuation_one: assumes "a \ S" "b \ S" "c \ S" "a = 1\<^sup>S \ b = 1\<^sup>S \ c = 1\<^sup>S" shows "(a *\<^sup>S b) \\<^sup>S c = a \\<^sup>S (b \\<^sup>S c)" using sum_imp_D sum_imp_E sum_imp_closed sum_mult_closed sum_mult_neutr assms by metis lemma sum_residuation_not_one: assumes "a \ S-{1\<^sup>S}" "b \ S-{1\<^sup>S}" "c \ S-{1\<^sup>S}" shows "(a *\<^sup>S b) \\<^sup>S c = a \\<^sup>S (b \\<^sup>S c)" proof - from assms consider (1) "floor a = floor b" "floor b = floor c" | (2) "floor a = floor b" "floor b <\<^sup>I floor c" | (3) "floor a = floor b" "floor c <\<^sup>I floor b" | (4) "floor a <\<^sup>I floor b" "floor b = floor c" | (5) "floor a <\<^sup>I floor b" "floor b <\<^sup>I floor c" | (6) "floor a <\<^sup>I floor b" "floor c <\<^sup>I floor b" | (7) "floor b <\<^sup>I floor a" "floor b = floor c" | (8) "floor b <\<^sup>I floor a" "floor b <\<^sup>I floor c" | (9) "floor b <\<^sup>I floor a" "floor c <\<^sup>I floor b" using trichotomy floor_prop by meson then show ?thesis proof(cases) case 1 then have "(a *\<^sup>S b) \\<^sup>S c = (a *\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a b) \\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a c" using sum_imp_B sum_mult_A assms floor_mult_closed floor_prop by metis also have "\ = a \\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a (b \\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>a c)" using "1" assms family_of_hoops floor_prop hoop.residuation by metis also have "\ = a \\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>b (b \\<^sup>f\<^sup>l\<^sup>o\<^sup>o\<^sup>r \<^sup>b c)" using "1" by simp also have "\ = a \\<^sup>S (b \\<^sup>S c)" using "1" sum_imp_A assms floor_imp_closed floor_prop by metis finally show ?thesis by auto next case 2 then show ?thesis using sum_imp.simps(2,5) sum_mult_not_one assms floor_prop by metis next case 3 then show ?thesis using sum_imp.simps(3) sum_mult_not_one assms floor_prop by metis next case 4 then have "(a *\<^sup>S b) \\<^sup>S c = 1\<^sup>S" using "4" sum_imp.simps(2) sum_mult.simps(2) assms by metis moreover have "b \\<^sup>S c = 1\<^sup>S \ (b \\<^sup>S c \ S-{1\<^sup>S} \ floor (b \\<^sup>S c) = floor b)" using "4"(2) sum_imp_closed_not_one sum_imp_floor assms(2,3) by blast ultimately show ?thesis using "4"(1) sum_imp.simps(2,5) assms(1) by metis next case 5 then show ?thesis using sum_imp.simps(2,5) sum_mult.simps(2) assms floor_prop strict_trans by metis next case 6 then show ?thesis using assms by auto next case 7 then have "(a *\<^sup>S b) \\<^sup>S c = (b \\<^sup>S c)" using assms(1,2) by auto moreover have "b \\<^sup>S c = 1\<^sup>S \ (b \\<^sup>S c \ S-{1\<^sup>S} \ floor (b \\<^sup>S c) = floor b)" using "7"(2) sum_imp_closed_not_one sum_imp_floor assms(2,3) by blast ultimately show ?thesis using "7"(1) sum_imp.simps(3,5) assms(1) by metis next case 8 then show ?thesis using assms by auto next case 9 then show ?thesis using sum_imp.simps(3) sum_mult.simps(3) assms floor_prop strict_trans by metis qed qed lemma sum_residuation: assumes "a \ S" "b \ S" "c \ S" shows "(a *\<^sup>S b) \\<^sup>S c = a \\<^sup>S (b \\<^sup>S c)" using assms sum_residuation_one sum_residuation_not_one by blast subsubsection\Main result\ sublocale hoop "S" "(*\<^sup>S)" "(\\<^sup>S)" "1\<^sup>S" proof show "x *\<^sup>S y \ S" if "x \ S" "y \ S" for x y using that sum_mult_closed by simp next show "x \\<^sup>S y \ S" if "x \ S" "y \ S" for x y using that sum_imp_closed by simp next show "1\<^sup>S \ S" by simp next show "x *\<^sup>S y = y *\<^sup>S x" if "x \ S" "y \ S" for x y using that sum_mult_comm by simp next show "x *\<^sup>S (y *\<^sup>S z) = (x *\<^sup>S y) *\<^sup>S z" if "x \ S" "y \ S" "z \ S" for x y z using that sum_mult_assoc by simp next show "x *\<^sup>S 1\<^sup>S = x" if "x \ S" for x using that sum_mult_neutr by simp next show "x \\<^sup>S x = 1\<^sup>S" if "x \ S" for x using that sum_imp_reflex by simp next show "x *\<^sup>S (x \\<^sup>S y) = y *\<^sup>S (y \\<^sup>S x)" if "x \ S" "y \ S" for x y using that sum_divisibility by simp next show "x \\<^sup>S (y \\<^sup>S z) = (x *\<^sup>S y) \\<^sup>S z" if "x \ S" "y \ S" "z \ S" for x y z using that sum_residuation by simp qed end end \ No newline at end of file diff --git a/thys/Isabelle_hoops/Posets.thy b/thys/Isabelle_hoops/Posets.thy --- a/thys/Isabelle_hoops/Posets.thy +++ b/thys/Isabelle_hoops/Posets.thy @@ -1,57 +1,57 @@ section\Some order tools: posets with explicit universe\ theory Posets imports Main "HOL-Library.LaTeXsugar" begin locale poset_on = fixes P :: "'b set" fixes P_lesseq :: "'b \ 'b \ bool" (infix "\\<^sup>P" 60) fixes P_less :: "'b \ 'b \ bool" (infix "<\<^sup>P" 60) assumes not_empty [simp]: "P \ \" and reflex: "reflp_on P (\\<^sup>P)" and antisymm: "antisymp_on P (\\<^sup>P)" and trans: "transp_on P (\\<^sup>P)" and strict_iff_order: "x \ P \ y \ P \ x <\<^sup>P y = (x \\<^sup>P y \ x \ y)" begin lemma strict_trans: assumes "a \ P" "b \ P" "c \ P" "a <\<^sup>P b" "b <\<^sup>P c" shows "a <\<^sup>P c" using antisymm antisymp_onD assms trans strict_iff_order transp_onD - by smt + by (smt (verit, ccfv_SIG)) end locale bot_poset_on = poset_on + fixes bot :: "'b" ("0\<^sup>P") assumes bot_closed: "0\<^sup>P \ P" and bot_first: "x \ P \ 0\<^sup>P \\<^sup>P x" locale top_poset_on = poset_on + fixes top :: "'b" ("1\<^sup>P") assumes top_closed: "1\<^sup>P \ P" and top_last: "x \ P \ x \\<^sup>P 1\<^sup>P" locale bounded_poset_on = bot_poset_on + top_poset_on locale total_poset_on = poset_on + assumes total: "totalp_on P (\\<^sup>P)" begin lemma trichotomy: assumes "a \ P" "b \ P" shows "(a <\<^sup>P b \ \(a = b \ b <\<^sup>P a)) \ (a = b \ \(a <\<^sup>P b \ b <\<^sup>P a)) \ (b <\<^sup>P a \ \(a = b \ a <\<^sup>P b))" using antisymm antisymp_onD assms strict_iff_order total totalp_onD by metis lemma strict_order_equiv_not_converse: assumes "a \ P" "b \ P" shows "a <\<^sup>P b \ \(b \\<^sup>P a)" using assms strict_iff_order reflex reflp_onD strict_trans trichotomy by metis end end \ No newline at end of file diff --git a/thys/Jordan_Normal_Form/VS_Connect.thy b/thys/Jordan_Normal_Form/VS_Connect.thy --- a/thys/Jordan_Normal_Form/VS_Connect.thy +++ b/thys/Jordan_Normal_Form/VS_Connect.thy @@ -1,1327 +1,1323 @@ (* Author: RenÃ© Thiemann Akihisa Yamada License: BSD *) (* with contributions from Alexander Bentkamp, UniversitÃ¤t des Saarlandes *) section \Matrices as Vector Spaces\ text \This theory connects the Matrix theory with the VectorSpace theory of Holden Lee. As a consequence notions like span, basis, linear dependence, etc. are available for vectors and matrices of the Matrix-theory.\ theory VS_Connect imports Matrix Missing_VectorSpace Determinant begin hide_const (open) Multiset.mult hide_const (open) Polynomial.smult hide_const (open) Modules.module hide_const (open) subspace hide_fact (open) subspace_def named_theorems class_ring_simps abbreviation class_ring :: "'a :: {times,plus,one,zero} ring" where "class_ring \ \ carrier = UNIV, mult = (*), one = 1, zero = 0, add = (+) \" interpretation class_semiring: semiring "class_ring :: 'a :: semiring_1 ring" rewrites [class_ring_simps]: "carrier class_ring = UNIV" and [class_ring_simps]: "mult class_ring = (*)" and [class_ring_simps]: "add class_ring = (+)" and [class_ring_simps]: "one class_ring = 1" and [class_ring_simps]: "zero class_ring = 0" and [class_ring_simps]: "pow (class_ring :: 'a ring) = (^)" and [class_ring_simps]: "finsum (class_ring :: 'a ring) = sum" proof - let ?r = "class_ring :: 'a ring" show "semiring ?r" by (unfold_locales, auto simp: field_simps) then interpret semiring ?r . { fix x y have "x [^]\<^bsub>?r\<^esub> y = x ^ y" by (induct y, auto simp: power_commutes) } thus "([^]\<^bsub>?r\<^esub>) = (^)" by (intro ext) { fix f and A :: "'b set" have "finsum ?r f A = sum f A" by (induct A rule: infinite_finite_induct, auto) } thus "finsum ?r = sum" by (intro ext) qed auto interpretation class_ring: ring "class_ring :: 'a :: ring_1 ring" rewrites "carrier class_ring = UNIV" and "mult class_ring = (*)" and "add class_ring = (+)" and "one class_ring = 1" and "zero class_ring = 0" and [class_ring_simps]: "a_inv (class_ring :: 'a ring) = uminus" and [class_ring_simps]: "a_minus (class_ring :: 'a ring) = minus" and "pow (class_ring :: 'a ring) = (^)" and "finsum (class_ring :: 'a ring) = sum" proof - let ?r = "class_ring :: 'a ring" interpret semiring ?r .. show "finsum ?r = sum" "pow ?r = (^)" by (simp_all add: class_ring_simps) { fix x :: 'a have "\y. x + y = 0" by (rule exI[of _ "-x"], auto) } note [simp] = this show "ring ?r" by (unfold_locales, auto simp: field_simps Units_def) then interpret ring ?r . { fix x :: 'a have "\\<^bsub>?r\<^esub> x = - x" unfolding a_inv_def m_inv_def by (rule the1_equality, rule ex1I[of _ "- x"], auto simp: minus_unique) } note ainv = this thus inv: "a_inv ?r = uminus" by (intro ext) { fix x y :: 'a have "x \\<^bsub>?r\<^esub> y = x - y" apply (subst a_minus_def) using inv by auto } thus "(\x y. x \\<^bsub>?r\<^esub> y) = minus" by (intro ext) qed (auto simp: class_ring_simps) interpretation class_cring: cring "class_ring :: 'a :: comm_ring_1 ring" rewrites "carrier class_ring = UNIV" and "mult class_ring = (*)" and "add class_ring = (+)" and "one class_ring = 1" and "zero class_ring = 0" and "a_inv (class_ring :: 'a ring) = uminus" and "a_minus (class_ring :: 'a ring) = minus" and "pow (class_ring :: 'a ring) = (^)" and "finsum (class_ring :: 'a ring) = sum" and [class_ring_simps]: "finprod class_ring = prod" proof - let ?r = "class_ring :: 'a ring" interpret ring ?r .. show "cring ?r" by (unfold_locales, auto) then interpret cring ?r . show "a_inv (class_ring :: 'a ring) = uminus" and "a_minus (class_ring :: 'a ring) = minus" and "pow (class_ring :: 'a ring) = (^)" and "finsum (class_ring :: 'a ring) = sum" by (simp_all add: class_ring_simps) { fix f and A :: "'b set" have "finprod ?r f A = prod f A" by (induct A rule: infinite_finite_induct, auto) } thus "finprod ?r = prod" by (intro ext) qed (auto simp: class_ring_simps) definition div0 :: "'a :: {one,plus,times,zero}" where "div0 \ m_inv (class_ring :: 'a ring) 0" lemma class_field: "field (class_ring :: 'a :: field ring)" (is "field ?r") proof - interpret cring ?r .. { fix x :: 'a have "x \ 0 \ \xa. xa * x = 1 \ x * xa = 1" by (intro exI[of _ "inverse x"], auto) } note [simp] = this show "field ?r" by (unfold_locales, auto simp: Units_def) qed interpretation class_field: field "class_ring :: 'a :: field ring" rewrites "carrier class_ring = UNIV" and "mult class_ring = (*)" and "add class_ring = (+)" and "one class_ring = 1" and "zero class_ring = 0" and "a_inv class_ring = uminus" and "a_minus class_ring = minus" and "pow class_ring = (^)" and "finsum class_ring = sum" and "finprod class_ring = prod" and [class_ring_simps]: "m_inv (class_ring :: 'a ring) x = (if x = 0 then div0 else inverse x)" (* problem that m_inv ?r 0 = inverse 0 is not guaranteed *) proof - let ?r = "class_ring :: 'a ring" show "field ?r" using class_field. then interpret field ?r. show "a_inv ?r = uminus" and "a_minus ?r = minus" and "pow ?r = (^)" and "finsum ?r = sum" and "finprod ?r = prod" by (fact class_ring_simps)+ show "inv\<^bsub>?r\<^esub> x = (if x = 0 then div0 else inverse x)" proof (cases "x = 0") case True thus ?thesis unfolding div0_def by simp next case False thus ?thesis unfolding m_inv_def by (intro the1_equality ex1I[of _ "inverse x"], auto simp: inverse_unique) qed qed (auto simp: class_ring_simps) lemmas matrix_vs_simps = module_mat_simps class_ring_simps definition class_field :: "'a :: field ring" where [class_ring_simps]: "class_field \ class_ring" locale matrix_ring = fixes n :: nat and field_type :: "'a :: field itself" begin abbreviation R where "R \ ring_mat TYPE('a) n n" sublocale ring R rewrites "carrier R = carrier_mat n n" and "add R = (+)" and "mult R = (*)" and "one R = 1\<^sub>m n" and "zero R = 0\<^sub>m n n" using ring_mat by (auto simp: ring_mat_simps) end lemma matrix_vs: "vectorspace (class_ring :: 'a :: field ring) (module_mat TYPE('a) nr nc)" proof - interpret abelian_group "module_mat TYPE('a) nr nc" by (rule abelian_group_mat) show ?thesis unfolding class_field_def by (unfold_locales, unfold matrix_vs_simps, auto simp: add_smult_distrib_left_mat add_smult_distrib_right_mat) qed locale vec_module = fixes f_ty::"'a::comm_ring_1 itself" and n::"nat" begin abbreviation V where "V \ module_vec TYPE('a) n" sublocale Module.module "class_ring :: 'a ring" V rewrites "carrier V = carrier_vec n" and "add V = (+)" and "zero V = 0\<^sub>v n" and "module.smult V = (\\<^sub>v)" and "carrier class_ring = UNIV" and "monoid.mult class_ring = (*)" and "add class_ring = (+)" and "one class_ring = 1" and "zero class_ring = 0" and "a_inv (class_ring :: 'a ring) = uminus" and "a_minus (class_ring :: 'a ring) = (-)" and "pow (class_ring :: 'a ring) = (^)" and "finsum (class_ring :: 'a ring) = sum" and "finprod (class_ring :: 'a ring) = prod" and "\X. X \ UNIV = True" (* These rewrite rules will clean lemmas *) and "\x. x \ UNIV = True" and "\a A. a \ A \ UNIV \ True" and "\P. P \ True \ P" and "\P. (True \ P) \ Trueprop P" apply unfold_locales apply (auto simp: module_vec_simps class_ring_simps Units_def add_smult_distrib_vec smult_add_distrib_vec intro!:bexI[of _ "- _"]) done end locale matrix_vs = fixes nr :: nat and nc :: nat and field_type :: "'a :: field itself" begin abbreviation V where "V \ module_mat TYPE('a) nr nc" sublocale vectorspace class_ring V rewrites "carrier V = carrier_mat nr nc" and "add V = (+)" and "mult V = (*)" and "one V = 1\<^sub>m nr" and "zero V = 0\<^sub>m nr nc" and "smult V = (\\<^sub>m)" and "carrier class_ring = UNIV" and "mult class_ring = (*)" and "add class_ring = (+)" and "one class_ring = 1" and "zero class_ring = 0" and "a_inv (class_ring :: 'a ring) = uminus" and "a_minus (class_ring :: 'a ring) = minus" and "pow (class_ring :: 'a ring) = (^)" and "finsum (class_ring :: 'a ring) = sum" and "finprod (class_ring :: 'a ring) = prod" and "m_inv (class_ring :: 'a ring) x = (if x = 0 then div0 else inverse x)" by (rule matrix_vs, auto simp: matrix_vs_simps class_field_def) end lemma vec_module: "module (class_ring :: 'a :: field ring) (module_vec TYPE('a) n)" proof - interpret abelian_group "module_vec TYPE('a) n" apply (unfold_locales) unfolding module_vec_def Units_def using add_inv_exists_vec by auto show ?thesis unfolding class_field_def apply (unfold_locales) unfolding class_ring_simps unfolding module_vec_simps using add_smult_distrib_vec by (auto simp: smult_add_distrib_vec) qed lemma vec_vs: "vectorspace (class_ring :: 'a :: field ring) (module_vec TYPE('a) n)" unfolding vectorspace_def using vec_module class_field by (auto simp: class_field_def) locale vec_space = fixes f_ty::"'a::field itself" and n::"nat" begin sublocale vec_module f_ty n. sublocale vectorspace class_ring V rewrites cV[simp]: "carrier V = carrier_vec n" and [simp]: "add V = (+)" and [simp]: "zero V = 0\<^sub>v n" and [simp]: "smult V = (\\<^sub>v)" and "carrier class_ring = UNIV" and "mult class_ring = (*)" and "add class_ring = (+)" and "one class_ring = 1" and "zero class_ring = 0" and "a_inv (class_ring :: 'a ring) = uminus" and "a_minus (class_ring :: 'a ring) = minus" and "pow (class_ring :: 'a ring) = (^)" and "finsum (class_ring :: 'a ring) = sum" and "finprod (class_ring :: 'a ring) = prod" and "m_inv (class_ring :: 'a ring) x = (if x = 0 then div0 else inverse x)" using vec_vs unfolding class_field_def by (auto simp: module_vec_simps class_ring_simps) lemma finsum_vec[simp]: "finsum_vec TYPE('a) n = finsum V" by (force simp: finsum_vec_def monoid_vec_def finsum_def finprod_def) lemma finsum_scalar_prod_sum: assumes f: "f : U \ carrier_vec n" and w: "w: carrier_vec n" shows "finsum V f U \ w = sum (\u. f u \ w) U" using w f proof (induct U rule: infinite_finite_induct) case (insert u U) hence f: "f : U \ carrier_vec n" "f u : carrier_vec n" by auto show ?case unfolding finsum_insert[OF insert(1) insert(2) f] apply (subst add_scalar_prod_distrib) using insert by auto qed auto lemma vec_neg[simp]: assumes "x : carrier_vec n" shows "\\<^bsub>V\<^esub> x = - x" unfolding a_inv_def m_inv_def apply simp apply (rule the_equality, intro conjI) using assms apply auto using M.minus_unique uminus_carrier_vec uminus_r_inv_vec by blast lemma finsum_dim: "finite A \ f \ A \ carrier_vec n \ dim_vec (finsum V f A) = n" proof(induct set:finite) case (insert a A) hence dfa: "dim_vec (f a) = n" by auto have f: "f \ A \ carrier_vec n" using insert by auto hence fa: "f a \ carrier_vec n" using insert by auto show ?case unfolding finsum_insert[OF insert(1) insert(2) f fa] using insert by auto qed simp lemma lincomb_dim: assumes fin: "finite X" and X: "X \ carrier_vec n" shows "dim_vec (lincomb a X) = n" proof - let ?f = "\v. a v \\<^sub>v v" have f: "?f \ X \ carrier_vec n" apply rule using X by auto show ?thesis unfolding lincomb_def using finsum_dim[OF fin f]. qed lemma finsum_index: assumes i: "i < n" and f: "f \ X \ carrier_vec n" and X: "X \ carrier_vec n" shows "finsum V f X i = sum (\x. f x i) X" using X f proof (induct X rule: infinite_finite_induct) case empty then show ?case using i by simp next case (insert x X) then have Xf: "finite X" and xX: "x \ X" and x: "x \ carrier_vec n" and X: "X \ carrier_vec n" and fx: "f x \ carrier_vec n" and f: "f \ X \ carrier_vec n" by auto have i2: "i < dim_vec (finsum V f X)" using i finsum_closed[OF f] by auto have ix: "i < dim_vec x" using x i by auto show ?case unfolding finsum_insert[OF Xf xX f fx] unfolding sum.insert[OF Xf xX] unfolding index_add_vec(1)[OF i2] using insert lincomb_def by auto qed (insert i, auto) lemma lincomb_index: assumes i: "i < n" and X: "X \ carrier_vec n" shows "lincomb a X i = sum (\x. a x * x i) X" proof - let ?f = "\x. a x \\<^sub>v x" have f: "?f : X \ carrier_vec n" using X by auto have point: "\v. v \ X \ (a v \\<^sub>v v) i = a v * v i" using i X by auto show ?thesis unfolding lincomb_def unfolding finsum_index[OF i f X] using point X by simp qed lemma append_insert: "set (xs @ [x]) = insert x (set xs)" by simp lemma lincomb_units: assumes i: "i < n" shows "lincomb a (set (unit_vecs n)) i = a (unit_vec n i)" unfolding lincomb_index[OF i unit_vecs_carrier] unfolding unit_vecs_first proof - let ?f = "\m i. \x\set (unit_vecs_first n m). a x * x i" have zero:"\m j. m \ j \ j < n \ ?f m j = 0" proof - fix m show "\j. m \ j \ j < n \ ?f m j = 0" proof (induction m) case (Suc m) hence mj:"m\j" and mj':"m\j" and jn:"j set (unit_vecs_first n m)" apply(subst unit_vecs_first_distinct) by auto show ?case unfolding unit_vecs_first.simps unfolding append_insert unfolding sum.insert[OF finite_set mem] unfolding index_unit_vec(1)[OF mn jn] unfolding Suc(1)[OF mj jn] using mj' by simp qed simp qed { fix m have "i < m \ m \ n \ ?f m i = a (unit_vec n i)" proof (induction m arbitrary: i) case (Suc m) hence iSm: "i < Suc m" and i:"i set (unit_vecs_first n m)" apply(subst unit_vecs_first_distinct) by auto show ?case unfolding unit_vecs_first.simps unfolding append_insert unfolding sum.insert[OF finite_set mem] unfolding index_unit_vec(1)[OF mn i] using zero Suc by (cases "i = m",auto) qed auto } thus "?f n i = a (unit_vec n i)" using assms by auto qed lemma lincomb_coordinates: assumes v: "v : carrier_vec n" defines "a \ (\u. v (THE i. u = unit_vec n i))" shows "lincomb a (set (unit_vecs n)) = v" proof - have a: "a \ set (unit_vecs n) \ UNIV" by auto have fvu: "\i. i < n \ v i = a (unit_vec n i)" unfolding a_def using unit_vec_eq by auto show ?thesis apply rule unfolding lincomb_dim[OF finite_set unit_vecs_carrier] using v lincomb_units fvu by auto qed lemma span_unit_vecs_is_carrier: "span (set (unit_vecs n)) = carrier_vec n" (is "?L = ?R") proof (rule;rule) fix v assume vsU: "v \ ?L" show "v \ ?R" proof - obtain a where v: "v = lincomb a (set (unit_vecs n))" using vsU unfolding finite_span[OF finite_set unit_vecs_carrier] by auto thus ?thesis using lincomb_closed[OF unit_vecs_carrier] by auto qed next fix v::"'a vec" assume v: "v \ ?R" show "v \ ?L" unfolding span_def using lincomb_coordinates[OF v,symmetric] by auto qed lemma fin_dim[simp]: "fin_dim" unfolding fin_dim_def apply (intro eqTrueI exI conjI) using span_unit_vecs_is_carrier unit_vecs_carrier by auto lemma unit_vecs_basis: "basis (set (unit_vecs n))" unfolding basis_def span_unit_vecs_is_carrier proof (intro conjI) show "\ lin_dep (set (unit_vecs n))" proof assume "lin_dep (set (unit_vecs n))" from this[unfolded lin_dep_def] obtain A a v where fin: "finite A" and A: "A \ set (unit_vecs n)" and lc: "lincomb a A = 0\<^sub>v n" and v: "v \ A" and av: "a v \ 0" by auto from v A obtain i where i: "i < n" and vu: "v = unit_vec n i" unfolding unit_vecs_def by auto define b where "b = (\ x. if x \ A then a x else 0)" have id: "A \ (set (unit_vecs n) - A) = set (unit_vecs n)" using A by auto from lincomb_index[OF i unit_vecs_carrier] have "lincomb b (set (unit_vecs n)) i = (\x\ (A \ (set (unit_vecs n) - A)). b x * x i)" unfolding id . also have "\ = (\x\ A. b x * x i) + (\x\ set (unit_vecs n) - A. b x * x i)" by (rule sum.union_disjoint, insert fin, auto) also have "(\x\ A. b x * x i) = (\x\ A. a x * x i)" by (rule sum.cong, auto simp: b_def) also have "\ = lincomb a A i" by (subst lincomb_index[OF i], insert A unit_vecs_carrier, auto) also have "\ = 0" unfolding lc using i by simp also have "(\x\ set (unit_vecs n) - A. b x * x i) = 0" by (rule sum.neutral, auto simp: b_def) finally have "lincomb b (set (unit_vecs n)) i = 0" by simp from lincomb_units[OF i, of b, unfolded this] have "b v = 0" unfolding vu by simp with v av show False unfolding b_def by simp qed qed (insert unit_vecs_carrier, auto) lemma unit_vecs_length[simp]: "length (unit_vecs n) = n" unfolding unit_vecs_def by auto lemma unit_vecs_distinct: "distinct (unit_vecs n)" unfolding distinct_conv_nth unit_vecs_length proof (intro allI impI) fix i j assume *: "i < n" "j < n" "i \ j" show "unit_vecs n ! i \ unit_vecs n ! j" proof assume "unit_vecs n ! i = unit_vecs n ! j" from arg_cong[OF this, of "\ v. v i"] show False using * unfolding unit_vecs_def by auto qed qed lemma dim_is_n: "dim = n" unfolding dim_basis[OF finite_set unit_vecs_basis] unfolding distinct_card[OF unit_vecs_distinct] by simp end locale mat_space = vec_space f_ty nc for f_ty::"'a::field itself" and nc::"nat" + fixes nr :: "nat" begin abbreviation M where "M \ ring_mat TYPE('a) nc nr" end context vec_space begin lemma fin_dim_span: assumes "finite A" "A \ carrier V" shows "vectorspace.fin_dim class_ring (vs (span A))" proof - have "vectorspace class_ring (span_vs A)" using assms span_is_subspace subspace_def subspace_is_vs by simp have "A \ span A" using assms in_own_span by simp have "submodule class_ring (span A) V" using assms span_is_submodule by simp have "LinearCombinations.module.span class_ring (vs (span A)) A = carrier (vs (span A))" using span_li_not_depend(1)[OF \A \ span A\ \submodule class_ring (span A) V$ by auto then show ?thesis unfolding vectorspace.fin_dim_def[OF \vectorspace class_ring (span_vs A)\] using List.finite_set \A \ span A\ \vectorspace class_ring (vs (span A))\ vec_vs vectorspace.carrier_vs_is_self[OF \vectorspace class_ring (span_vs A)\] using assms(1) by auto qed lemma fin_dim_span_cols: assumes "A \ carrier_mat n nc" shows "vectorspace.fin_dim class_ring (vs (span (set (cols A))))" using fin_dim_span cols_dim List.finite_set assms carrier_matD(1) module_vec_simps(3) by force end context vec_module begin lemma lincomb_list_as_mat_mult: assumes "\w \ set ws. dim_vec w = n" shows "lincomb_list c ws = mat_of_cols n ws *\<^sub>v vec (length ws) c" (is "?l ws c = ?r ws c") proof (insert assms, induct ws arbitrary: c) case Nil then show ?case by (auto simp: mult_mat_vec_def scalar_prod_def) next case (Cons w ws) { fix i assume i: "i < n" have "?l (w#ws) c = c 0 \\<^sub>v w + mat_of_cols n ws *\<^sub>v vec (length ws) (c \ Suc)" by (simp add: Cons o_def) also have "\  i = ?r (w#ws) c  i" using Cons i index_smult_vec by (simp add: mat_of_cols_Cons_index_0 mat_of_cols_Cons_index_Suc o_def vec_Suc mult_mat_vec_def row_def length_Cons) finally have "?l (w#ws) c  i = \". } with Cons show ?case by (intro eq_vecI, auto) qed lemma lincomb_vec_diff_add: assumes A: "A \ carrier_vec n" and BA: "B \ A" and fin_A: "finite A" and f: "f \ A \ UNIV" shows "lincomb f A = lincomb f (A-B) + lincomb f B" proof - have "A - B \ B = A" using BA by auto hence "lincomb f A = lincomb f (A - B \ B)" by simp also have "... = lincomb f (A-B) + lincomb f B" by (rule lincomb_union, insert assms, auto intro: finite_subset) finally show ?thesis . qed lemma dim_sumlist: assumes "\x\set xs. dim_vec x = n" shows "dim_vec (M.sumlist xs) = n" using assms by (induct xs, auto) lemma sumlist_nth: assumes "\x\set xs. dim_vec x = n" and "ij. (xs ! j)  i) {0.. carrier_vec n" if x: "x\set xs" for x using snoc.prems x unfolding carrier_vec_def by auto have [simp]: "a \ carrier_vec n" using snoc.prems unfolding carrier_vec_def by auto have hyp: "M.sumlist xs  i = (\j = 0..j = 0..j = 0.. carrier_vec n" and d: "distinct ws" shows "lincomb f (set ws) = lincomb_list (\i. f (ws ! i)) ws" proof (insert assms, induct ws) case Nil then show ?case by auto next case (Cons a ws) have [simp]: "\v. v \ set ws \ v \ carrier_vec n" using Cons.prems(1) by auto then have ws: "set ws \ carrier_vec n" by auto have hyp: "lincomb f (set (ws)) = lincomb_list (\i. f (ws ! i)) ws" proof (intro Cons.hyps ws) show "distinct ws" using Cons.prems(2) by auto qed have "(map (\i. f (ws ! i) \\<^sub>v ws ! i) [0..v. f v \\<^sub>v v) ws)" by (intro nth_equalityI, auto) with ws have sumlist_rw: "sumlist (map (\i. f (ws ! i) \\<^sub>v ws ! i) [0..v. f v \\<^sub>v v) ws)" by (subst (1 2) sumlist_as_summset, auto) have "lincomb f (set (a # ws)) = (\\<^bsub>V\<^esub>v\set (a # ws). f v \\<^sub>v v)" unfolding lincomb_def .. also have "... = (\\<^bsub>V\<^esub>v\ insert a (set ws). f v \\<^sub>v v)" by simp also have "... = (f a \\<^sub>v a) + (\\<^bsub>V\<^esub>v\ (set ws). f v \\<^sub>v v)" by (rule finsum_insert, insert Cons.prems, auto) also have "... = f a \\<^sub>v a + lincomb_list (\i. f (ws ! i)) ws" using hyp lincomb_def by auto also have "... = f a \\<^sub>v a + sumlist (map (\v. f v \\<^sub>v v) ws)" unfolding lincomb_list_def sumlist_rw by auto also have "... = sumlist (map (\v. f v \\<^sub>v v) (a # ws))" proof - let ?a = "(map (\v. f v \\<^sub>v v) [a])" have a: "a \ carrier_vec n" using Cons.prems(1) by auto have "f a \\<^sub>v a = sumlist (map (\v. f v \\<^sub>v v) [a])" using Cons.prems(1) by auto hence "f a \\<^sub>v a + sumlist (map (\v. f v \\<^sub>v v) ws) = sumlist ?a + sumlist (map (\v. f v \\<^sub>v v) ws)" by simp also have "... = sumlist (?a @ (map (\v. f v \\<^sub>v v) ws))" by (rule sumlist_append[symmetric], auto simp add: a) finally show ?thesis by auto qed also have "... = sumlist (map (\i. f ((a # ws) ! i) \\<^sub>v (a # ws) ! i) [0..i. f ((a # ws) ! i) \\<^sub>v (a # ws) ! i) [0..v. f v \\<^sub>v v) (a # ws))" - proof (intro nth_equalityI, goal_cases) - case (2 i) thus ?case by (smt length_map map_nth nth_map) - qed auto + by (smt (verit, del_insts) length_map map_equality_iff map_nth nth_map) show ?thesis unfolding u .. qed also have "... = lincomb_list (\i. f ((a # ws) ! i)) (a # ws)" unfolding lincomb_list_def .. finally show ?case . qed end locale idom_vec = vec_module f_ty for f_ty :: "'a :: idom itself" begin lemma lin_dep_cols_imp_det_0': fixes ws defines "A \ mat_of_cols n ws" assumes dimv_ws: "\w\set ws. dim_vec w = n" assumes A: "A \ carrier_mat n n" and ld_cols: "lin_dep (set (cols A))" shows "det A = 0" proof (cases "distinct ws") case False obtain i j where ij: "i\j" and c: "col A i = col A j" and i: "ix. x \ set ws \ x \ carrier_vec n" using dimv_ws by auto obtain A' f' v where f'_in: "f' \ A' \ UNIV" and lc_f': "lincomb f' A' = 0\<^sub>v n" and f'_v: "f' v \ 0" and v_A': "v \ A'" and A'_in_rows: "A' \ set (cols A)" using ld_cols unfolding lin_dep_def by auto define f where "f \ \x. if x \ A' then 0 else f' x" have f_in: "f \ (set (cols A)) \ UNIV" using f'_in by auto have A'_in_carrier: "A' \ carrier_vec n" by (metis (no_types) A'_in_rows A_def cols_dim carrier_matD(1) mat_of_cols_carrier(1) subset_trans) have lc_f: "lincomb f (set (cols A)) = 0\<^sub>v n" proof - have l1: "lincomb f (set (cols A) - A') = 0\<^sub>v n" by (rule lincomb_zero, auto simp add: f_def, insert A cols_dim, blast) have l2: "lincomb f A' = 0\<^sub>v n " using lc_f' unfolding f_def using A'_in_carrier by auto have "lincomb f (set (cols A)) = lincomb f (set (cols A) - A') + lincomb f A'" proof (rule lincomb_vec_diff_add) show "set (cols A) \ carrier_vec n" using A cols_dim by blast show "A' \ set (cols A)" using A'_in_rows by blast qed auto also have "... = 0\<^sub>v n" using l1 l2 by auto finally show ?thesis . qed have v_in: "v \ (set (cols A))" using v_A' A'_in_rows by auto have fv: "f v \ 0" using f'_v v_A' unfolding f_def by auto let ?c = "(\i. f (ws ! i))" have "lincomb f (set ws) = lincomb_list ?c ws" by (rule lincomb_as_lincomb_list_distinct[OF _ True], auto) have "\v. v \ carrier_vec n \ v \ 0\<^sub>v n \ A *\<^sub>v v = 0\<^sub>v n" proof (rule exI[of _ " vec (length ws) ?c"], rule conjI) show "vec (length ws) ?c \ carrier_vec n" using A A_def by auto have vec_not0: "vec (length ws) ?c \ 0\<^sub>v n" proof - obtain i where ws_i: "(ws ! i) = v" and i: "i 0" using fv by simp finally show ?thesis using A A_def i by fastforce qed have "A *\<^sub>v vec (length ws) ?c = mat_of_cols n ws *\<^sub>v vec (length ws) ?c" unfolding A_def .. also have "... = lincomb_list ?c ws" by (rule lincomb_list_as_mat_mult[symmetric, OF dimv_ws]) also have "... = lincomb f (set ws)" by (rule lincomb_as_lincomb_list_distinct[symmetric, OF _ True], auto) also have "... = 0\<^sub>v n" using lc_f unfolding A_def using A by (simp add: subset_code(1)) finally show "vec (length ws) (\i. f (ws ! i)) \ 0\<^sub>v n \ A *\<^sub>v vec (length ws) (\i. f (ws ! i)) = 0\<^sub>v n" using vec_not0 by fast qed thus ?thesis unfolding det_0_iff_vec_prod_zero[OF A] . qed lemma lin_dep_cols_imp_det_0: assumes A: "A \ carrier_mat n n" and ld: "lin_dep (set (cols A))" shows "det A = 0" proof - have col_rw: "(cols (mat_of_cols n (cols A))) = cols A" using A by auto have m: "mat_of_cols n (cols A) = A" using A by auto show ?thesis by (rule A lin_dep_cols_imp_det_0'[of "cols A", unfolded col_rw, unfolded m, OF _ A ld]) (metis A cols_dim carrier_matD(1) subsetCE carrier_vecD) qed corollary lin_dep_rows_imp_det_0: assumes A: "A \ carrier_mat n n" and ld: "lin_dep (set (rows A))" shows "det A = 0" by (subst det_transpose[OF A, symmetric], rule lin_dep_cols_imp_det_0, auto simp add: ld A) lemma det_not_0_imp_lin_indpt_rows: assumes A: "A \ carrier_mat n n" and det: "det A \ 0" shows "lin_indpt (set (rows A))" using lin_dep_rows_imp_det_0[OF A] det by auto lemma upper_triangular_imp_lin_indpt_rows: assumes A: "A \ carrier_mat n n" and tri: "upper_triangular A" and diag: "0 \ set (diag_mat A)" shows "lin_indpt (set (rows A))" using det_not_0_imp_lin_indpt_rows upper_triangular_imp_det_eq_0_iff assms by auto (* Connection from set-based to list-based *) lemma lincomb_as_lincomb_list: fixes ws f assumes s: "set ws \ carrier_vec n" shows "lincomb f (set ws) = lincomb_list (\i. if \jv. v \ set ws \ v \ carrier_vec n" using snoc.prems(1) by auto then have ws: "set ws \ carrier_vec n" by auto have hyp: "lincomb f (set ws) = lincomb_list ?f ws" by (intro snoc.hyps ws) show ?case proof (cases "a\set ws") case True have g_length: "?g (length ws) = 0\<^sub>v n" using True by (auto, metis in_set_conv_nth nth_append) have "(map ?g [0..v n]" using g_length by simp finally have map_rw: "(map ?g [0..v n]" . have "M.sumlist (map ?g2 [0..v n " by (metis M.r_zero calculation hyp lincomb_closed lincomb_list_def ws) also have "... = M.sumlist (map ?g [0..v n])" by (rule M.sumlist_snoc[symmetric], auto simp add: nth_append) finally have summlist_rw: "M.sumlist (map ?g2 [0..v n])" . have "lincomb f (set (ws @ [a])) = lincomb f (set ws)" using True unfolding lincomb_def by (simp add: insert_absorb) thus ?thesis unfolding hyp lincomb_list_def map_rw summlist_rw by auto next case False have g_length: "?g (length ws) = f a \\<^sub>v a" using False by (auto simp add: nth_append) have "(map ?g [0..\<^sub>v a)]" using g_length by simp finally have map_rw: "(map ?g [0..\<^sub>v a)]" . have summlist_rw: "M.sumlist (map ?g2 [0..\<^bsub>V\<^esub>v\set (a # ws). f v \\<^sub>v v)" unfolding lincomb_def .. also have "... = (\\<^bsub>V\<^esub>v\ insert a (set ws). f v \\<^sub>v v)" by simp also have "... = (f a \\<^sub>v a) + (\\<^bsub>V\<^esub>v\ (set ws). f v \\<^sub>v v)" proof (rule finsum_insert) show "finite (set ws)" by auto show "a \ set ws" using False by auto show "(\v. f v \\<^sub>v v) \ set ws \ carrier_vec n" using snoc.prems(1) by auto show "f a \\<^sub>v a \ carrier_vec n" using snoc.prems by auto qed also have "... = (f a \\<^sub>v a) + lincomb f (set ws)" unfolding lincomb_def .. also have "... = (f a \\<^sub>v a) + lincomb_list ?f ws" using hyp by auto also have "... = lincomb_list ?f ws + (f a \\<^sub>v a)" using M.add.m_comm lincomb_list_carrier snoc.prems by auto also have "... = lincomb_list (\i. if \j carrier_vec n" using snoc.prems by (auto simp add: nth_append) show "f a \\<^sub>v a \ carrier_vec n" using snoc.prems by auto qed finally show ?thesis . qed qed auto lemma span_list_as_span: assumes "set vs \ carrier_vec n" shows "span_list vs = span (set vs)" using assms proof (auto simp: span_list_def span_def) fix f show "\a A. lincomb_list f vs = lincomb a A \ finite A \ A \ set vs" using assms lincomb_list_as_lincomb by auto next fix f::"'a vec \'a" and A assume fA: "finite A" and A: "A \ set vs" have [simp]: "x \ carrier_vec n" if x: "x \ A" for x using A x assms by auto have [simp]: "v \ carrier_vec n" if v: "v \ set vs" for v using assms v by auto have set_vs_Un: "((set vs) - A) \ A = set vs" using A by auto let ?f = "(\x. if x\(set vs) - A then 0 else f x)" have f0: "(\\<^bsub>V\<^esub>v\(set vs) - A. ?f v \\<^sub>v v) = 0\<^sub>v n" by (rule M.finsum_all0, auto) have "lincomb f A = lincomb ?f A" by (auto simp add: lincomb_def intro!: finsum_cong2) also have "... = (\\<^bsub>V\<^esub>v\(set vs) - A. ?f v \\<^sub>v v) + (\\<^bsub>V\<^esub>v\A. ?f v \\<^sub>v v)" unfolding f0 lincomb_def by auto also have "... = lincomb ?f (((set vs) - A) \ A)" unfolding lincomb_def by (rule M.finsum_Un_disjoint[symmetric], auto simp add: fA) also have "... = lincomb ?f (set vs)" using set_vs_Un by auto finally have "lincomb f A = lincomb ?f (set vs)" . with lincomb_as_lincomb_list[OF assms] show "\c. lincomb f A = lincomb_list c vs" by auto qed lemma in_spanI[intro]: assumes "v = lincomb a A" "finite A" "A \ W" shows "v \ span W" unfolding span_def using assms by auto lemma in_spanE: assumes "v \ span W" shows "\ a A. v = lincomb a A \ finite A \ A \ W" using assms unfolding span_def by auto declare in_own_span[intro] lemma smult_in_span: assumes "W \ carrier_vec n" and insp: "x \ span W" shows "c \\<^sub>v x \ span W" proof - from in_spanE[OF insp] obtain a A where a: "x = lincomb a A" "finite A" "A \ W" by blast have "c \\<^sub>v x = lincomb (\ x. c * a x) A" using a(1) unfolding lincomb_def a apply(subst finsum_smult) using assms a by (auto simp:smult_smult_assoc) thus "c \\<^sub>v x \ span W" using a(2,3) by auto qed lemma span_subsetI: assumes ws: "ws \ carrier_vec n" "us \ span ws" shows "span us \ span ws" by (simp add: assms(1) span_is_submodule span_is_subset subsetI ws) end context vec_space begin sublocale idom_vec. lemma sumlist_in_span: assumes W: "W \ carrier_vec n" shows "(\x. x \ set xs \ x \ span W) \ sumlist xs \ span W" proof (induct xs) case Nil thus ?case using W by force next case (Cons x xs) from span_is_subset2[OF W] Cons(2) have xs: "x \ carrier_vec n" "set xs \ carrier_vec n" by auto from span_add1[OF W Cons(2)[of x] Cons(1)[OF Cons(2)]] have "x + sumlist xs \ span W" by auto also have "x + sumlist xs = sumlist ([x] @ xs)" by (subst sumlist_append, insert xs, auto) finally show ?case by simp qed lemma span_span[simp]: assumes "W \ carrier_vec n" shows "span (span W) = span W" proof(standard,standard,goal_cases) case (1 x) with in_spanE obtain a A where a: "x = lincomb a A" "finite A" "A \ span W" by blast from a(3) assms have AC:"A \ carrier_vec n" by auto show ?case unfolding a(1)[unfolded lincomb_def] proof(insert a(3),atomize (full),rule finite_induct[OF a(2)],goal_cases) case 1 then show ?case using span_zero by auto next case (2 x F) { assume F:"insert x F \ span W" hence "a x \\<^sub>v x \ span W" by (intro smult_in_span[OF assms],auto) hence "a x \\<^sub>v x + (\\<^bsub>V\<^esub>v\F. a v \\<^sub>v v) \ span W" using span_add1 F 2 assms by auto hence "(\\<^bsub>V\<^esub>v\insert x F. a v \\<^sub>v v) \ span W" apply(subst M.finsum_insert[OF 2(1,2)]) using F assms by auto } then show ?case by auto qed next case 2 show ?case using assms by(intro in_own_span, auto) qed lemma upper_triangular_imp_basis: assumes A: "A \ carrier_mat n n" and tri: "upper_triangular A" and diag: "0 \ set (diag_mat A)" shows "basis (set (rows A))" using upper_triangular_imp_distinct[OF assms] using upper_triangular_imp_lin_indpt_rows[OF assms] A by (auto intro: dim_li_is_basis simp: distinct_card dim_is_n set_rows_carrier) lemma fin_dim_span_rows: assumes A: "A \ carrier_mat nr n" shows "vectorspace.fin_dim class_ring (vs (span (set (rows A))))" proof (rule fin_dim_span) show "set (rows A) \ carrier V" using A rows_carrier[of A] unfolding carrier_mat_def by auto show "finite (set (rows A))" by auto qed definition "row_space B = span (set (rows B))" definition "col_space B = span (set (cols B))" lemma row_space_eq_col_space_transpose: shows "row_space A = col_space A\<^sup>T" unfolding col_space_def row_space_def cols_transpose .. lemma col_space_eq_row_space_transpose: shows "col_space A = row_space A\<^sup>T" unfolding col_space_def row_space_def Matrix.rows_transpose .. lemma col_space_eq: assumes A: "A \ carrier_mat n nc" shows "col_space A = {y\carrier_vec (dim_row A). \x\carrier_vec (dim_col A). A *\<^sub>v x = y}" proof - let ?ws = "cols A" have set_cols_in: "set (cols A) \ carrier_vec n" using A unfolding cols_def by auto have "lincomb f S \ carrier_vec (dim_row A)" if "finite S" and S: "S \ set (cols A)" for f S using lincomb_closed A by (metis (full_types) S carrier_matD(1) cols_dim lincomb_closed subsetCE subsetI) moreover have "\x\carrier_vec (dim_col A). A *\<^sub>v x = lincomb f S" if fin_S: "finite S" and S: "S \ set (cols A)" for f S proof - let ?g = "(\v. if v \ S then f v else 0)" let ?g' = "(\i. if \j ?Z" using S by auto have inter: "S \ ?Z = {}" by auto have "lincomb f S = lincomb ?g S" by (rule lincomb_cong, insert set_cols_in A S, auto) also have "... = lincomb ?g (S \ ?Z)" by (rule lincomb_clean[symmetric],insert set_cols_in A S fin_S, auto) also have "... = lincomb ?g (set ?ws)" using union by auto also have "... = lincomb_list ?g' ?ws" by (rule lincomb_as_lincomb_list[OF set_cols_in]) also have "... = mat_of_cols n ?ws *\<^sub>v vec (length ?ws) ?g'" by (rule lincomb_list_as_mat_mult, insert set_cols_in A, auto) also have "... = A *\<^sub>v (vec (length ?ws) ?g')" using mat_of_cols_cols A by auto finally show ?thesis by auto qed moreover have "\f S. A *\<^sub>v x = lincomb f S \ finite S \ S \ set (cols A)" if Ax: "A *\<^sub>v x \ carrier_vec (dim_row A)" and x: "x \ carrier_vec (dim_col A)" for x proof - let ?c = "\i. x  i" have x_vec: "vec (length ?ws) ?c = x" using x by auto have "A *\<^sub>v x = mat_of_cols n ?ws *\<^sub>v vec (length ?ws) ?c" using mat_of_cols_cols A x_vec by auto also have "... = lincomb_list ?c ?ws" by (rule lincomb_list_as_mat_mult[symmetric], insert set_cols_in A, auto) also have "... = lincomb (mk_coeff ?ws ?c) (set ?ws)" by (rule lincomb_list_as_lincomb, insert set_cols_in A, auto) finally show ?thesis by auto qed ultimately show ?thesis unfolding col_space_def span_def by auto qed lemma vector_space_row_space: assumes A: "A \ carrier_mat nr n" shows "vectorspace class_ring (vs (row_space A))" proof - have fin: "finite (set (rows A))" by auto have s: "set (rows A) \ carrier V" using A unfolding rows_def by auto have "span_vs (set (rows A)) = vs (span (set (rows A)))" by auto moreover have "vectorspace class_ring (span_vs (set (rows A)))" using fin s span_is_subspace subspace_def subspace_is_vs by simp ultimately show ?thesis unfolding row_space_def by auto qed lemma row_space_eq: assumes A: "A \ carrier_mat nr n" shows "row_space A = {w\carrier_vec (dim_col A). \y\carrier_vec (dim_row A). A\<^sup>T *\<^sub>v y = w}" using A col_space_eq unfolding row_space_eq_col_space_transpose by auto lemma row_space_is_preserved: assumes inv_P: "invertible_mat P" and P: "P \ carrier_mat m m" and A: "A \ carrier_mat m n" shows "row_space (P*A) = row_space A" proof - have At: "A\<^sup>T \ carrier_mat n m" using A by auto have Pt: "P\<^sup>T \ carrier_mat m m" using P by auto have PA: "P*A \ carrier_mat m n" using P A by auto have "w \ row_space A" if w: "w \ row_space (P*A)" for w proof - have w_carrier: "w \ carrier_vec (dim_col (P*A))" using w mult_carrier_mat[OF P A] row_space_eq by auto from that and this obtain y where y: "y \ carrier_vec (dim_row (P * A))" and w_By: "w = (P*A)\<^sup>T *\<^sub>v y" unfolding row_space_eq[OF PA] by blast have ym: "y \ carrier_vec m" using y Pt by auto have "w=((P*A)\<^sup>T) *\<^sub>v y" using w_By . also have "... = (A\<^sup>T * P\<^sup>T) *\<^sub>v y" using transpose_mult[OF P A] by auto also have "... = A\<^sup>T *\<^sub>v (P\<^sup>T *\<^sub>v y)" by (rule assoc_mult_mat_vec[OF At Pt], insert Pt y, auto) finally show "w \ row_space A" unfolding row_space_eq[OF A] using At Pt ym by auto qed moreover have "w \ row_space (P*A)" if w: "w \ row_space A" for w proof - have w_carrier: "w \ carrier_vec (dim_col A)" using w A unfolding row_space_eq[OF A] by auto obtain P' where PP': "inverts_mat P P'" and P'P: "inverts_mat P' P" using inv_P P unfolding invertible_mat_def by blast have P': "P' \ carrier_mat m m" using PP' P'P P unfolding inverts_mat_def by (metis carrier_matD(1) carrier_matD(2) carrier_mat_triv index_mult_mat(3) index_one_mat(3)) from that obtain y where y: "y \ carrier_vec (dim_row A)" and w_Ay: "w = A\<^sup>T *\<^sub>v y" unfolding row_space_eq[OF A] by blast have Py: "(P'\<^sup>T *\<^sub>v y) \ carrier_vec m" using P' y A by auto have "w = A\<^sup>T *\<^sub>v y" using w_Ay . also have "... = ((P' * P)*A)\<^sup>T *\<^sub>v y" using P'P left_mult_one_mat A P' unfolding inverts_mat_def by auto also have "... = ((P' * (P*A))\<^sup>T) *\<^sub>v y" using assoc_mult_mat_vec P' P A by auto also have "... = ((P*A)\<^sup>T * P'\<^sup>T) *\<^sub>v y" using transpose_mult P A P' mult_carrier_mat by metis - also have "... = (P*A)\<^sup>T *\<^sub>v (P'\<^sup>T *\<^sub>v y)" - using assoc_mult_mat_vec A P P' y mult_carrier_mat - by (smt carrier_matD(1) transpose_carrier_mat) + also have "... = (P*A)\<^sup>T *\<^sub>v (P'\<^sup>T *\<^sub>v y)" using A P' PA y by auto finally show "w \ row_space (P*A)" unfolding row_space_eq[OF PA] using Py w_carrier A P by fastforce qed ultimately show ?thesis by auto qed end context vec_module begin lemma R_sumlist[simp]: "R.sumlist = sum_list" proof (intro ext) fix xs show "R.sumlist xs = sum_list xs" by (induct xs, auto) qed lemma sumlist_dim: assumes "\ x. x \ set xs \ x \ carrier_vec n" shows "dim_vec (sumlist xs) = n" using sumlist_carrier assms by fastforce lemma sumlist_vec_index: assumes "\ x. x \ set xs \ x \ carrier_vec n" and "i < n" shows "sumlist xs  i = sum_list (map (\ x. x  i) xs)" unfolding M.sumlist_def using assms(1) proof(induct xs) case (Cons a xs) hence cond:"\ x. x \ set xs \ x \ carrier_vec n" by auto from Cons(1)[OF cond] have IH:"foldr (+) xs (0\<^sub>v n)  i = (\x\xs. x  i)" by auto have "(a + foldr (+) xs (0\<^sub>v n))  i = a  i + (\x\xs. x  i)" apply(subst index_add_vec) unfolding IH using sumlist_dim[OF cond,unfolded M.sumlist_def] assms by auto then show ?case by auto next case Nil thus ?case using assms by auto qed lemma scalar_prod_left_sum_distrib: assumes vs: "\ v. v \ set vvs \ v \ carrier_vec n" and w: "w \ carrier_vec n" shows "sumlist vvs \ w = sum_list (map (\ v. v \ w) vvs)" using vs proof (induct vvs) case (Cons v vs) from Cons have v: "v \ carrier_vec n" and vs: "sumlist vs \ carrier_vec n" by (auto intro!: sumlist_carrier) have "sumlist (v # vs) \ w = sumlist ([v] @ vs) \ w " by auto also have "\ = (v + sumlist vs) \ w" by (subst sumlist_append, insert Cons v vs, auto) also have "\ = v \ w + (sumlist vs \ w)" by (rule add_scalar_prod_distrib[OF v vs w]) finally show ?case using Cons by auto qed (insert w, auto) lemma scalar_prod_right_sum_distrib: assumes vs: "\ v. v \ set vvs \ v \ carrier_vec n" and w: "w \ carrier_vec n" shows "w \ sumlist vvs = sum_list (map (\ v. w \ v) vvs)" by (subst comm_scalar_prod[OF w sumlist_carrier], insert vs w, force, subst scalar_prod_left_sum_distrib[OF vs w], force, rule arg_cong[of _ _ sum_list], rule nth_equalityI, auto simp: set_conv_nth intro!: comm_scalar_prod) lemma lincomb_list_add_vec_2: assumes us: "set us \ carrier_vec n" and x: "x = lincomb_list lc (us [i := us ! i + c \\<^sub>v us ! j])" and i: "j < length us" "i < length us" "i \ j" shows "x = lincomb_list (lc (j := lc j + lc i * c)) us" (is "_ = ?x") proof - let ?xx = "lc j + lc i * c" let ?i = "us ! i" let ?j = "us ! j" let ?v = "?i + c \\<^sub>v ?j" let ?ws = "us [i := us ! i + c \\<^sub>v us ! j]" from us have usk: "k < length us \ us ! k \ carrier_vec n" for k by auto from usk i have ij: "?i \ carrier_vec n" "?j \ carrier_vec n" by auto hence v: "c \\<^sub>v ?j \ carrier_vec n" "?v \ carrier_vec n" by auto with us have ws: "set ?ws \ carrier_vec n" unfolding set_conv_nth using i by (auto, rename_tac k, case_tac "k = i", auto) from us have us': "\w\set us. dim_vec w = n" by auto from ws have ws': "\w\set ?ws. dim_vec w = n" by auto have mset: "mset_set {0.. {0 ..< length us}", auto) define M2 where "M2 = M.summset {#lc ia \\<^sub>v ?ws ! ia. ia \# mset_set ({0..\<^sub>v us ! i. i \# mset_set ({0.. carrier_vec n" unfolding M1_def using usk by fastforce have M2: "M1 = M2" unfolding M2_def M1_def by (rule arg_cong[of _ _ M.summset], rule multiset.map_cong0, insert i usk, auto) have x1: "x = lc j \\<^sub>v ?j + (lc i \\<^sub>v ?i + lc i \\<^sub>v (c \\<^sub>v ?j) + M1)" unfolding x lincomb_list_def M2 M2_def apply (subst sumlist_as_summset, (insert us ws i v ij, auto simp: set_conv_nth)[1], insert i ij v us ws usk, simp add: mset smult_add_distrib_vec[OF ij(1) v(1)]) by (subst M.summset_add_mset, auto)+ have x2: "?x = ?xx \\<^sub>v ?j + (lc i \\<^sub>v ?i + M1)" unfolding x lincomb_list_def M1_def apply (subst sumlist_as_summset, (insert us ws i v ij, auto simp: set_conv_nth)[1], insert i ij v us ws usk, simp add: mset smult_add_distrib_vec[OF ij(1) v(1)]) by (subst M.summset_add_mset, auto)+ show ?thesis unfolding x1 x2 using M1 ij by (intro eq_vecI, auto simp: field_simps) qed lemma lincomb_list_add_vec_1: assumes us: "set us \ carrier_vec n" and x: "x = lincomb_list lc us" and i: "j < length us" "i < length us" "i \ j" shows "x = lincomb_list (lc (j := lc j - lc i * c)) (us [i := us ! i + c \\<^sub>v us ! j])" (is "_ = ?x") proof - let ?i = "us ! i" let ?j = "us ! j" let ?v = "?i + c \\<^sub>v ?j" let ?ws = "us [i := us ! i + c \\<^sub>v us ! j]" from us have usk: "k < length us \ us ! k \ carrier_vec n" for k by auto from usk i have ij: "?i \ carrier_vec n" "?j \ carrier_vec n" by auto hence v: "c \\<^sub>v ?j \ carrier_vec n" "?v \ carrier_vec n" by auto with us have ws: "set ?ws \ carrier_vec n" unfolding set_conv_nth using i by (auto, rename_tac k, case_tac "k = i", auto) from us have us': "\w\set us. dim_vec w = n" by auto from ws have ws': "\w\set ?ws. dim_vec w = n" by auto have mset: "mset_set {0.. {0 ..< length us}", auto) define M2 where "M2 = M.summset {#(if ia = j then lc j - lc i * c else lc ia) \\<^sub>v ?ws ! ia . ia \# mset_set ({0..\<^sub>v us ! i. i \# mset_set ({0.. carrier_vec n" unfolding M1_def using usk by fastforce have M2: "M1 = M2" unfolding M2_def M1_def by (rule arg_cong[of _ _ M.summset], rule multiset.map_cong0, insert i usk, auto) have x1: "x = lc j \\<^sub>v ?j + (lc i \\<^sub>v ?i + M1)" unfolding x lincomb_list_def M1_def apply (subst sumlist_as_summset, (insert us ws i v ij, auto simp: set_conv_nth)[1], insert i ij v us ws usk, simp add: mset smult_add_distrib_vec[OF ij(1) v(1)]) by (subst M.summset_add_mset, auto)+ have x2: "?x = (lc j - lc i * c) \\<^sub>v ?j + (lc i \\<^sub>v ?i + lc i \\<^sub>v (c \\<^sub>v ?j) + M1)" unfolding x lincomb_list_def M2 M2_def apply (subst sumlist_as_summset, (insert us ws i v ij, auto simp: set_conv_nth)[1], insert i ij v us ws usk, simp add: mset smult_add_distrib_vec[OF ij(1) v(1)]) by (subst M.summset_add_mset, auto)+ show ?thesis unfolding x1 x2 using M1 ij by (intro eq_vecI, auto simp: field_simps) qed end context vec_space begin lemma add_vec_span: assumes us: "set us \ carrier_vec n" and i: "j < length us" "i < length us" "i \ j" shows "span (set us) = span (set (us [i := us ! i + c \\<^sub>v us ! j]))" (is "_ = span (set ?ws)") proof - let ?i = "us ! i" let ?j = "us ! j" let ?v = "?i + c \\<^sub>v ?j" from us i have ij: "?i \ carrier_vec n" "?j \ carrier_vec n" by auto hence v: "?v \ carrier_vec n" by auto with us have ws: "set ?ws \ carrier_vec n" unfolding set_conv_nth using i by (auto, rename_tac k, case_tac "k = i", auto) have "span (set us) = span_list us" unfolding span_list_as_span[OF us] .. also have "\ = span_list ?ws" proof - { fix x assume "x \ span_list us" then obtain lc where "x = lincomb_list lc us" by (metis in_span_listE) from lincomb_list_add_vec_1[OF us this i, of c] have "x \ span_list ?ws" unfolding span_list_def by auto } moreover { fix x assume "x \ span_list ?ws" then obtain lc where "x = lincomb_list lc ?ws" by (metis in_span_listE) from lincomb_list_add_vec_2[OF us this i] have "x \ span_list us" unfolding span_list_def by auto } ultimately show ?thesis by blast qed also have "\ = span (set ?ws)" unfolding span_list_as_span[OF ws] .. finally show ?thesis . qed lemma prod_in_span[intro!]: assumes "b \ carrier_vec n" "S \ carrier_vec n" "a = 0 \ b \ span S" shows "a \\<^sub>v b \ span S" proof(cases "a = 0") case True then show ?thesis by (auto simp:lmult_0[OF assms(1)] span_zero) next case False with assms have "b \ span S" by auto from this[THEN in_spanE] obtain aa A where a[intro!]: "b = lincomb aa A" "finite A" "A \ S" by auto hence [intro!]:"(\v. aa v \\<^sub>v v) \ A \ carrier_vec n" using assms by auto show ?thesis proof show "a \\<^sub>v b = lincomb (\ v. a * aa v) A" using a(1) unfolding lincomb_def smult_smult_assoc[symmetric] by(subst finsum_smult[symmetric]) force+ qed auto qed lemma det_nonzero_congruence: assumes eq:"A * M = B * M" and det:"det (M::'a mat) \ 0" and M: "M \ carrier_mat n n" and carr:"A \ carrier_mat n n" "B \ carrier_mat n n" shows "A = B" proof - have "1\<^sub>m n \ carrier_mat n n" by auto from det_non_zero_imp_unit[OF M det] gauss_jordan_check_invertable[OF M this] have gj_fst:"(fst (gauss_jordan M (1\<^sub>m n)) = 1\<^sub>m n)" by metis define Mi where "Mi = snd (gauss_jordan M (1\<^sub>m n))" with gj_fst have gj:"gauss_jordan M (1\<^sub>m n) = (1\<^sub>m n, Mi)" unfolding fst_def snd_def by (auto split:prod.split) from gauss_jordan_compute_inverse(1,3)[OF M gj] have Mi: "Mi \ carrier_mat n n" and is1:"M * Mi = 1\<^sub>m n" by metis+ from arg_cong[OF eq, of "\ M. M * Mi"] show "A = B" unfolding carr[THEN assoc_mult_mat[OF _ M Mi]] is1 carr[THEN right_mult_one_mat]. qed lemma mat_of_rows_mult_as_finsum: assumes "v \ carrier_vec (length lst)" "\ i. i < length lst \ lst ! i \ carrier_vec n" defines "f l \ sum (\ i. if l = lst ! i then v  i else 0) {0..v v = lincomb f (set lst)" proof - from assms have "\ i < length lst. lst ! i \ carrier_vec n" by blast note an = all_nth_imp_all_set[OF this] hence slc:"set lst \ carrier_vec n" by auto hence dn [simp]:"\ x. x \ set lst \ dim_vec x = n" by auto have dl [simp]:"dim_vec (lincomb f (set lst)) = n" using an by (intro lincomb_dim,auto) show ?thesis proof show "dim_vec (mat_of_cols n lst *\<^sub>v v) = dim_vec (lincomb f (set lst))" using assms(1,2) by auto fix i assume i:"i < dim_vec (lincomb f (set lst))" hence i':"i < n" by auto with an have fcarr:"(\v. f v \\<^sub>v v) \ set lst \ carrier_vec n" by auto from i' have "(mat_of_cols n lst *\<^sub>v v)  i = row (mat_of_cols n lst) i \ v" by auto also have "\ = (\ia = 0.. = (\ia = 0.. = (\x\set lst. f x * x  i)" unfolding f_def sum_distrib_right apply (subst sum.swap) apply(rule sum.cong[OF refl]) unfolding if_distrib if_distribR mult_zero_left sum.delta[OF finite_set] by auto also have "\ = (\x\set lst. (f x \\<^sub>v x)  i)" apply(rule sum.cong[OF refl],subst index_smult_vec) using i slc by auto also have "\ = (\\<^bsub>V\<^esub>v\set lst. f v \\<^sub>v v)  i" unfolding finsum_index[OF i' fcarr slc] by auto finally show "(mat_of_cols n lst *\<^sub>v v)  i = lincomb f (set lst)  i" by (auto simp:lincomb_def) qed qed end end diff --git a/thys/KD_Tree/Range_Search.thy b/thys/KD_Tree/Range_Search.thy --- a/thys/KD_Tree/Range_Search.thy +++ b/thys/KD_Tree/Range_Search.thy @@ -1,87 +1,88 @@ (* File: Range_Search.thy Author: Martin Rau, TU MÃ¼nchen *) section \Range Searching\ theory Range_Search imports KD_Tree begin text\ Given two \k\-dimensional points \p\<^sub>0\ and \p\<^sub>1\ which bound the search space, the search should return only the points which satisfy the following criteria: For every point p in the resulting set: \newline \hspace{1cm} For every axis @{term "k"}: \newline \hspace{2cm} @{term "p\<^sub>0k \ pk \ pk \ p\<^sub>1k"} \newline For a \2\-d tree a query corresponds to selecting all the points in the rectangle that has \p\<^sub>0\ and \p\<^sub>1\ as its defining edges. \ subsection \Rectangle Definition\ lemma cbox_point_def: fixes p\<^sub>0 :: "('k::finite) point" shows "cbox p\<^sub>0 p\<^sub>1 = { p. \k. p\<^sub>0k \ pk \ pk \ p\<^sub>1k }" proof - have "cbox p\<^sub>0 p\<^sub>1 = { p. \k. p\<^sub>0 \ axis k 1 \ p \ axis k 1 \ p \ axis k 1 \ p\<^sub>1 \ axis k 1 }" unfolding cbox_def using axis_inverse by auto also have "... = { p. \k. p\<^sub>0k \ 1 \ pk \ 1 \ pk \ 1 \ p\<^sub>1k \ 1 }" - using inner_axis[of _ _ 1] by (smt Collect_cong) + using inner_axis[of _ _ 1] + by (metis (mono_tags, opaque_lifting)) also have "... = { p. \k. p\<^sub>0k \ pk \ pk \ p\<^sub>1k }" by simp finally show ?thesis . qed subsection \Search Function\ fun search :: "('k::finite) point \ 'k point \ 'k kdt \ 'k point set" where "search p\<^sub>0 p\<^sub>1 (Leaf p) = (if p \ cbox p\<^sub>0 p\<^sub>1 then { p } else {})" | "search p\<^sub>0 p\<^sub>1 (Node k v l r) = ( if v < p\<^sub>0k then search p\<^sub>0 p\<^sub>1 r else if p\<^sub>1k < v then search p\<^sub>0 p\<^sub>1 l else search p\<^sub>0 p\<^sub>1 l \ search p\<^sub>0 p\<^sub>1 r )" subsection \Auxiliary Lemmas\ lemma l_empty: assumes "invar (Node k v l r)" "v < p\<^sub>0k" shows "set_kdt l \ cbox p\<^sub>0 p\<^sub>1 = {}" proof - have "\p \ set_kdt l. pk < p\<^sub>0k" using assms by auto hence "\p \ set_kdt l. p \ cbox p\<^sub>0 p\<^sub>1" using cbox_point_def leD by blast thus ?thesis by blast qed lemma r_empty: assumes "invar (Node k v l r)" "p\<^sub>1k < v" shows "set_kdt r \ cbox p\<^sub>0 p\<^sub>1 = {}" proof - have "\p \ set_kdt r. p\<^sub>1k < pk" using assms by auto hence "\p \ set_kdt r. p \ cbox p\<^sub>0 p\<^sub>1" using cbox_point_def leD by blast thus ?thesis by blast qed subsection \Main Theorem\ theorem search_cbox: assumes "invar kdt" shows "search p\<^sub>0 p\<^sub>1 kdt = set_kdt kdt \ cbox p\<^sub>0 p\<^sub>1" using assms l_empty r_empty by (induction kdt) (auto, blast+) end diff --git a/thys/Lucas_Theorem/Lucas_Theorem.thy b/thys/Lucas_Theorem/Lucas_Theorem.thy --- a/thys/Lucas_Theorem/Lucas_Theorem.thy +++ b/thys/Lucas_Theorem/Lucas_Theorem.thy @@ -1,372 +1,373 @@ (* Title: Lucas_Theorem.thy Author: Chelsea Edmonds, University of Cambridge *) theory Lucas_Theorem imports Main "HOL-Computational_Algebra.Computational_Algebra" begin notation fps_nth (infixl "" 75) section \Extensions on Formal Power Series (FPS) Library\ text \This section presents a few extensions on the Formal Power Series (FPS) library, described in \<^cite>\"Chaieb2011"\ \ subsection \FPS Equivalence Relation \ text \ This proof requires reasoning around the equivalence of coefficients mod some prime number. This section defines an equivalence relation on FPS using the pattern described by Paulson in \<^cite>\"paulsonDefiningFunctionsEquivalence2006"\, as well as some basic lemmas for reasoning around how the equivalence holds after common operations are applied \ definition "fpsmodrel p \ { (f, g). \ n. (f  n) mod p = (g  n) mod p }" lemma fpsrel_iff [simp]: "(f, g) \ fpsmodrel p \ (\n. (f  n) mod p = (g  n) mod p)" by (simp add: fpsmodrel_def) lemma fps_equiv: "equiv UNIV (fpsmodrel p)" proof (rule equivI) show "refl (fpsmodrel p)" by (simp add: refl_on_def fpsmodrel_def) show "sym (fpsmodrel p)" by (simp add: sym_def fpsmodrel_def) show "trans (fpsmodrel p)" by (intro transI) (simp add: fpsmodrel_def) qed text \ Equivalence relation over multiplication \ lemma fps_mult_equiv_coeff: fixes f g :: "('a :: {euclidean_ring_cancel}) fps" assumes "(f, g) \ fpsmodrel p" shows "(f*h)n mod p = (g*h)n mod p" proof - have "((f*h)  n) mod p =(\i=0..n. (fi mod p * h(n - i) mod p) mod p) mod p" using mod_sum_eq mod_mult_left_eq by (simp add: fps_mult_nth mod_sum_eq mod_mult_left_eq) also have "... = (\i=0..n. (gi mod p * h(n - i) mod p) mod p) mod p" using assms by auto also have "... = ((g*h)  n) mod p" by (simp add: mod_mult_left_eq mod_sum_eq fps_mult_nth) thus ?thesis by (simp add: calculation) qed lemma fps_mult_equiv: fixes f g :: "('a :: {euclidean_ring_cancel}) fps" assumes "(f, g) \ fpsmodrel p" shows "(f*h, g*h) \ fpsmodrel p" using fpsmodrel_def fps_mult_equiv_coeff assms by blast text \ Equivalence relation over power operator \ lemma fps_power_equiv: fixes f g :: "('a :: {euclidean_ring_cancel}) fps" fixes x :: nat assumes "(f, g) \ fpsmodrel p" shows "(f^x, g^x) \ fpsmodrel p" using assms proof (induct x) case 0 thus ?case by (simp add: fpsmodrel_def) next case (Suc x) then have hyp: " \n. f^x  n mod p = g ^x  n mod p" using fpsrel_iff by blast thus ?case proof - have fact: "\n h. (g * h)  n mod p = (f * h)  n mod p" by (metis assms fps_mult_equiv_coeff) have "\n h. (g ^ x * h)  n mod p = (f ^ x * h)  n mod p" by (simp add: fps_mult_equiv_coeff hyp) then have "\n h. (h * g ^ x)  n mod p = (h * f ^ x)  n mod p" by (simp add: mult.commute) thus ?thesis using fact by force qed qed subsection \Binomial Coefficients \ text \The @{term "fps_binomial"} definition in the formal power series uses the @{term "n gchoose k"} operator. It's defined as being of type @{typ "'a :: field_char_0 fps"}, however the equivalence relation requires a type @{typ 'a} that supports the modulo operator. The proof of the binomial theorem based on FPS coefficients below uses the choose operator and does not put bounds on the type of @{term "fps_X"}.\ lemma binomial_coeffs_induct: fixes n k :: nat shows "(1 + fps_X)^n  k = of_nat(n choose k)" proof (induct n arbitrary: k) case 0 thus ?case by (metis binomial_eq_0_iff binomial_n_0 fps_nth_of_nat not_gr_zero of_nat_0 of_nat_1 power_0) next case h: (Suc n) - fix k have start: "(1 + fps_X)^(n + 1) = (1 + fps_X) * (1 + fps_X)^n" by auto show ?case using One_nat_def Suc_eq_plus1 Suc_pred add.commute binomial_Suc_Suc binomial_n_0 - fps_mult_fps_X_plus_1_nth h.hyps neq0_conv start by (smt of_nat_add) + fps_mult_fps_X_plus_1_nth h.hyps neq0_conv start + by (smt (verit, del_insts) of_nat_add) qed subsection \Freshman's Dream Lemma on FPS \ text \ The Freshman's dream lemma modulo a prime number p is a well known proof that (1 + x^p) \equiv (1 + x)^p \mod p\ text \ First prove that \binom{p^n}{k} \equiv 0 \mod p for k \ge 1 and k < p^n. The eventual proof only ended up requiring this with n = 1\ lemma pn_choose_k_modp_0: fixes n k::nat assumes "prime p" "k \ 1 \ k \ p^n - 1" "n > 0" shows "(p^n choose k) mod p = 0" proof - have inequality: "k \ p^n" using assms (2) by arith have choose_take_1: "((p^n - 1) choose ( k - 1))= fact (p^n - 1) div (fact (k - 1) * fact (p^n - k))" using binomial_altdef_nat diff_le_mono inequality assms(2) by auto have "k * (p^n choose k) = k * ((fact (p^n)) div (fact k * fact((p^n) - k)))" using assms binomial_fact'[OF inequality] by auto also have "... = k * fact (p^n) div (fact k * fact((p^n) - k))" using binomial_fact_lemma div_mult_self_is_m fact_gt_zero inequality mult.assoc mult.commute - nat_0_less_mult_iff by smt + nat_0_less_mult_iff + by (simp add: choose_dvd div_mult_swap) also have "... = k * fact (p^n) div (k * fact (k - 1) * fact((p^n) - k))" by (metis assms(2) fact_nonzero fact_num_eq_if le0 le_antisym of_nat_id) also have "... = fact (p^n) div (fact (k - 1) * fact((p^n) - k))" using assms by auto also have "... = ((p^n) * fact (p^n - 1)) div (fact (k - 1) * fact((p^n) - k))" by (metis assms(2) fact_nonzero fact_num_eq_if inequality le0 le_antisym of_nat_id) also have "... = (p^n) * (fact (p^n - 1) div (fact (k - 1) * fact((p^n) - k)))" by (metis assms(2) calculation choose_take_1 neq0_conv not_one_le_zero times_binomial_minus1_eq) finally have equality: "k * (p^n choose k) = p^n * ((p^n - 1) choose (k - 1))" using assms(2) times_binomial_minus1_eq by auto then have dvd_result: "p^n dvd (k * (p^n choose k))" by simp have "\ (p^n dvd k)" using assms (2) binomial_n_0 diff_diff_cancel nat_dvd_not_less neq0_conv by auto then have "p dvd (p^n choose k)" using mult.commute prime_imp_prime_elem prime_power_dvd_multD assms dvd_result by metis thus "?thesis" by simp qed text \ Applying the above lemma to the coefficients of (1 + X)^p, it is easy to show that all coefficients other than the 0th and pth will be 0 \ lemma fps_middle_coeffs: assumes "prime p" "n \ 0 \ n \ p" shows "((1 + fps_X :: int fps) ^p)  n mod p = 0 mod p" proof - let ?f = "(1 + fps_X :: int fps)^p" have "\ n. n > 0 \ n < p \ (p choose n) mod p = 0" using pn_choose_k_modp_0 [of p _ 1] \prime p\ by auto then have middle_0: "\ n. n > 0 \ n < p \ (?f  n) mod p = 0" using binomial_coeffs_induct by (metis of_nat_0 zmod_int) have "\ n. n > p \ ?f  n mod p = 0" using binomial_eq_0_iff binomial_coeffs_induct mod_0 by (metis of_nat_eq_0_iff) thus ?thesis using middle_0 assms(2) nat_neq_iff by auto qed text \It follows that (1+ X)^p is equivalent to (1 + X^p) under our equivalence relation, as required to prove the freshmans dream lemma. \ lemma fps_freshmans_dream: assumes "prime p" shows "(((1 + fps_X :: int fps ) ^p), (1 + (fps_X)^(p))) \ fpsmodrel p" proof - let ?f = "(1 + fps_X :: int fps)^p" let ?g = "(1 + (fps_X :: int fps)^p)" have all_f_coeffs: "\ n. n \ 0 \ n \ p \ ?f  n mod p = 0 mod p" using fps_middle_coeffs assms by blast have "?g  0 = 1" using assms by auto then have "?g  0 mod p = 1 mod p" using int_ops(2) zmod_int assms by presburger then have "?g  p mod p = 1 mod p" using assms by auto then have "\ n . ?f  n mod p = ?g  n mod p" using all_f_coeffs by (simp add: binomial_coeffs_induct) thus ?thesis using fpsrel_iff by blast qed section \Lucas's Theorem Proof\ text \A formalisation of Lucas's theorem based on a generating function proof using the existing formal power series (FPS) Isabelle library\ subsection \Reasoning about Coefficients Helpers\ text \A generating function proof of Lucas's theorem relies on direct comparison between coefficients of FPS which requires a number of helper lemmas to prove formally. In particular it compares the coefficients of (1 + X)^n \mod p to (1 + X^p)^N * (1 + X) ^rn \mod p, where N = n / p, and rn = n \mod p. This section proves that the kth coefficient of (1 + X^p)^N * (1 + X) ^rn = (N choose K) * (rn choose rk)\ text \Applying the @{term "fps_compose"} operator enables reasoning about the coefficients of (1 + X^p)^n using the existing binomial theorem proof with X^p instead of X.\ lemma fps_binomial_p_compose: assumes "p \ 0" shows "(1 + (fps_X:: ('a :: {idom} fps))^p)^n = ((1 + fps_X)^n) oo (fps_X^p)" proof - have "(1::'a fps) + fps_X ^ p = 1 + fps_X oo fps_X ^ p" by (simp add: assms fps_compose_add_distrib) then show ?thesis by (simp add: assms fps_compose_power) qed text \ Next the proof determines the value of the kth coefficient of (1 + X^p)^N. \ lemma fps_X_pow_binomial_coeffs: assumes "prime p" shows "(1 + (fps_X ::int fps)^p)^N k = (if p dvd k then (N choose (k div p)) else 0)" proof - let ?fx = "(fps_X :: int fps)" have "(1 + ?fx^p)^N  k = (((1 + ?fx)^N) oo (?fx^p)) k" by (metis assms fps_binomial_p_compose not_prime_0) also have "... = (\i=0..k.((1 + ?fx)^N)i * ((?fx^p)^ik))" by (simp add: fps_compose_nth) finally have coeffs: "(1 + ?fx^p)^N  k = (\i=0..k. (N choose i) * ((?fx^(p*i))k))" using binomial_coeffs_induct sum.cong by (metis (no_types, lifting) power_mult) thus ?thesis proof (cases "p dvd k") case False \ \p does not divide k implies the kth term has a coefficient of 0\ have "\ i. \(p dvd k) \ (?fx^(p*i))  k = 0" by auto thus ?thesis using coeffs by (simp add: False) next case True \ \p divides k implies the kth term has a non-zero coefficient\ have contained: "k div p \ {0.. k}" by simp have "\ i. i \ k div p \ (?fx^(p*i))  k = 0" using assms by auto then have notdivpis0: "\ i \ ({0 .. k} - {k div p}). (?fx^(p*i))  k = 0" by simp have "(1 + ?fx^p)^N  k = (N choose (k div p)) * (?fx^(p * (k div p)))  k + (\i\({0..k} -{k div p}). (N choose i) * ((?fx^(p*i))k))" using contained coeffs sum.remove by (metis (no_types, lifting) finite_atLeastAtMost) thus ?thesis using notdivpis0 True by simp qed qed text \ The final helper lemma proves the kth coefficient is equivalent to \binom{?N}{?K}*\binom{?rn}{?rk} as required.\ lemma fps_div_rep_coeffs: assumes "prime p" shows "((1 + (fps_X::int fps)^p)^(n div p) * (1 + fps_X)^(n mod p))  k = ((n div p) choose (k div p)) * ((n mod p) choose (k mod p))" (is "((1 + (fps_X::int fps)^p)^?N * (1 + fps_X)^?rn)  k = (?N choose ?K) * (?rn choose ?rk)") proof - \ \Initial facts with results around representation and 0 valued terms\ let ?fx = "fps_X :: int fps" have krep: "k - ?rk = ?K*p" by (simp add: minus_mod_eq_mult_div) have rk_in_range: "?rk \ {0..k}" by simp have "\ i \ p. (?rn choose i) = 0" using binomial_eq_0_iff by (metis assms(1) leD le_less_trans linorder_cases mod_le_divisor mod_less_divisor prime_gt_0_nat) then have ptok0: "\ i \ {p..k}. ((?rn choose i) * (1 + ?fx^p)^?N  (k - i)) = 0" by simp then have notrkis0: "\i \ {0.. k}. i \ ?rk \ (?rn choose i) * (1 + ?fx^p)^?N  (k - i) = 0" proof (cases "k < p") case True \ \When k < p, it presents a side case with regards to range of reasoning\ then have k_value: "k = ?rk" by simp then have "\ i < k. \ (p dvd (k - i))" using True by (metis diff_diff_cancel diff_is_0_eq dvd_imp_mod_0 less_imp_diff_less less_irrefl_nat mod_less) then show ?thesis using fps_X_pow_binomial_coeffs assms(1) k_value by simp next case False then have "\ i < p. i \ ?rk \ \(p dvd (k - i))" using mod_nat_eqI by auto then have "\ i \ {0.. ?rk \ (1 + ?fx^p)^?N  (k - i) = 0" using assms fps_X_pow_binomial_coeffs by simp then show ?thesis using ptok0 by auto qed \ \Main body of the proof, using helper facts above\ have "((1 + fps_X^p)^?N * (1 + fps_X)^?rn)  k = (((1 + fps_X)^?rn) * (1 + fps_X^p)^?N)  k" by (metis (no_types, opaque_lifting) distrib_left distrib_right fps_mult_fps_X_commute fps_one_mult(1) fps_one_mult(2) power_commuting_commutes) also have "... = (\i=0..k.(of_nat(?rn choose i)) * ((1 + (fps_X)^p)^?N  (k - i)))" by (simp add: fps_mult_nth binomial_coeffs_induct) also have "... = ((?rn choose ?rk) * (1 + ?fx^p)^?N  (k - ?rk)) + (\i\({0..k} - {?rk}). (?rn choose i) * (1 + ?fx^p)^?N  (k - i))" using rk_in_range sum.remove by (metis (no_types, lifting) finite_atLeastAtMost) finally have "((1 + ?fx^p)^?N * (1 + ?fx)^?rn)  k = ((?rn choose ?rk) * (1 + ?fx^p)^?N  (k - ?rk))" using notrkis0 by simp thus ?thesis using fps_X_pow_binomial_coeffs assms krep by auto qed (* Lucas theorem proof *) subsection \Lucas Theorem Proof\ text \ The proof of Lucas's theorem combines a generating function approach, based off \<^cite>\"Fine"\ with induction. For formalisation purposes, it was easier to first prove a well known corollary of the main theorem (also often presented as an alternative statement for Lucas's theorem), which can itself be used to backwards prove the the original statement by induction. This approach was adapted from P. Cameron's lecture notes on combinatorics \<^cite>\"petercameronNotesCombinatorics2007"\ \ subsubsection \ Proof of the Corollary \ text \ This step makes use of the coefficient equivalence arguments proved in the previous sections \ corollary lucas_corollary: fixes n k :: nat assumes "prime p" shows "(n choose k) mod p = (((n div p) choose (k div p)) * ((n mod p) choose (k mod p))) mod p" (is "(n choose k) mod p = ((?N choose ?K) * (?rn choose ?rk)) mod p") proof - let ?fx = "fps_X :: int fps" have n_rep: "n = ?N * p + ?rn" by simp have k_rep: "k =?K * p + ?rk" by simp have rhs_coeffs: "((1 + ?fx^p)^(?N) * (1 + ?fx)^(?rn))  k = (?N choose ?K) * (?rn choose ?rk)" using assms fps_div_rep_coeffs k_rep n_rep by blast \ \Application of coefficient reasoning\ have "((((1 + ?fx)^p)^(?N) * (1 + ?fx)^(?rn)), ((1 + ?fx^p)^(?N) * (1 + ?fx)^(?rn))) \ fpsmodrel p" using fps_freshmans_dream assms fps_mult_equiv fps_power_equiv by blast \ \Application of equivalence facts and freshmans dream lemma\ then have modrel2: "((1 + ?fx)^n, ((1 + ?fx^p)^(?N) * (1 + ?fx)^(?rn))) \ fpsmodrel p" by (metis (mono_tags, opaque_lifting) mult_div_mod_eq power_add power_mult) thus ?thesis using fpsrel_iff binomial_coeffs_induct rhs_coeffs by (metis of_nat_eq_iff zmod_int) qed subsubsection \ Proof of the Theorem \ text \The theorem statement requires a formalised way of referring to the base p representation of a number. We use a definition that specifies the ith digit of the base p representation. This definition is originally from the Hilbert's 10th Problem Formalisation project \<^cite>\"bayerDPRMTheoremIsabelle2019"\ which this work contributes to.\ definition nth_digit_general :: "nat \ nat \ nat \ nat" where "nth_digit_general num i base = (num div (base ^ i)) mod base" text \Applying induction on d, where d is the highest power required in either n or k's base p representation, @{thm lucas_corollary} can be used to prove the original theorem.\ theorem lucas_theorem: fixes n k d::nat assumes "n < p ^ (Suc d)" assumes "k < p ^ (Suc d)" assumes "prime p" shows "(n choose k) mod p = (\i\d. ((nth_digit_general n i p) choose (nth_digit_general k i p))) mod p" using assms proof (induct d arbitrary: n k) case 0 thus ?case using nth_digit_general_def assms by simp next case (Suc d) \ \Representation Variables\ let ?N = "n div p" let ?K = "k div p" let ?nr = "n mod p" let ?kr = "k mod p" \ \Required assumption facts\ have Mlessthan: "?N < p ^ (Suc d)" using less_mult_imp_div_less power_Suc2 assms(3) prime_ge_2_nat Suc.prems(1) by metis have Nlessthan: "?K < p ^ (Suc d)" using less_mult_imp_div_less power_Suc2 prime_ge_2_nat Suc.prems(2) assms(3) by metis have shift_bounds_fact: "(\i=(Suc 0)..(Suc (d )). ((nth_digit_general n i p) choose (nth_digit_general k i p))) = (\i=0..(d). (nth_digit_general n (Suc i) p) choose (nth_digit_general k (Suc i) p))" using prod.shift_bounds_cl_Suc_ivl by blast \ \Product manipulation helper fact\ have "(n choose k ) mod p = ((?N choose ?K) * (?nr choose ?kr)) mod p" using lucas_corollary assms(3) by blast \ \Application of corollary\ also have "...= ((\i\d. ((nth_digit_general ?N i p) choose (nth_digit_general ?K i p))) * (?nr choose ?kr)) mod p" using Mlessthan Nlessthan Suc.hyps mod_mult_cong assms(3) by blast \ \Using Inductive Hypothesis\ \ \Product manipulation steps\ also have "... = ((\i=0..(d). (nth_digit_general n (Suc i) p) choose (nth_digit_general k (Suc i) p)) * (?nr choose ?kr)) mod p" using atMost_atLeast0 nth_digit_general_def div_mult2_eq by auto also have "... = ((\i=1..(d+1). (nth_digit_general n i p) choose (nth_digit_general k i p)) * ((nth_digit_general n 0 p) choose (nth_digit_general k 0 p))) mod p" using nth_digit_general_def shift_bounds_fact by simp finally have "(n choose k ) mod p = ((\i=0..(d+1). (nth_digit_general n i p) choose (nth_digit_general k i p))) mod p" using One_nat_def atMost_atLeast0 mult.commute prod.atLeast1_atMost_eq prod.atMost_shift - by (smt Suc_eq_plus1 shift_bounds_fact) + by (smt (verit, ccfv_threshold)) thus ?case using Suc_eq_plus1 atMost_atLeast0 by presburger qed end \ No newline at end of file diff --git a/thys/Octonions/Octonions.thy b/thys/Octonions/Octonions.thy --- a/thys/Octonions/Octonions.thy +++ b/thys/Octonions/Octonions.thy @@ -1,1235 +1,1234 @@ (* Title: Octonions.thy Author: Angeliki Koutsoukou-Argyraki, University of Cambridge Date: September 2018 *) section\Theory of Octonions\ theory Octonions imports Cross_Product_7 begin subsection\Basic definitions\ text\As with the complex numbers, coinduction is convenient.\ codatatype octo = Octo (Ree: real) (Im1: real) (Im2: real) (Im3: real) (Im4: real) (Im5: real) (Im6: real) (Im7: real) lemma octo_eqI [intro?]: "\Ree x = Ree y; Im1 x = Im1 y; Im2 x = Im2 y; Im3 x = Im3 y; Im4 x = Im4 y;Im5 x = Im5 y; Im6 x = Im6 y; Im7 x = Im7 y\ \ x = y" by (rule octo.expand) simp lemma octo_eq_iff: "x = y \ Ree x = Ree y \ Im1 x = Im1 y \ Im2 x = Im2 y \ Im3 x = Im3 y \ Im4 x = Im4 y \ Im5 x = Im5 y \ Im6 x = Im6 y \ Im7 x = Im7 y" by (auto intro: octo.expand) context begin primcorec octo_e0 :: octo ("e0") where "Ree e0 = 1" | "Im1 e0 = 0" | "Im2 e0 = 0" | "Im3 e0 = 0" | "Im4 e0 = 0" | "Im5 e0 = 0" | "Im6 e0 = 0" | "Im7 e0 = 0" primcorec octo_e1 :: octo ("e1") where "Ree e1 = 0" | "Im1 e1 = 1" | "Im2 e1 = 0" | "Im3 e1 = 0" | "Im4 e1 = 0" | "Im5 e1 = 0" | "Im6 e1 = 0" | "Im7 e1 = 0" primcorec octo_e2 :: octo ("e2") where "Ree e2 = 0" | "Im1 e2 = 0" | "Im2 e2 = 1" | "Im3 e2 = 0" | "Im4 e2 = 0" | "Im5 e2 = 0" | "Im6 e2 = 0" | "Im7 e2 = 0" primcorec octo_e3 :: octo ("e3") where "Ree e3 = 0" | "Im1 e3 = 0" | "Im2 e3 = 0" | "Im3 e3 = 1" | "Im4 e3 = 0" | "Im5 e3 = 0" | "Im6 e3 = 0" | "Im7 e3 = 0" primcorec octo_e4 :: octo ("e4") where "Ree e4 = 0" | "Im1 e4 = 0" | "Im2 e4 = 0" | "Im3 e4 = 0" | "Im4 e4 = 1" | "Im5 e4 = 0" | "Im6 e4 = 0" | "Im7 e4 = 0" primcorec octo_e5 :: octo ("e5") where "Ree e5 = 0" | "Im1 e5 = 0" | "Im2 e5 = 0" | "Im3 e5 = 0" | "Im4 e5 = 0" | "Im5 e5 = 1" | "Im6 e5 = 0" | "Im7 e5 = 0" primcorec octo_e6 :: octo ("e6") where "Ree e6 = 0" | "Im1 e6 = 0" | "Im2 e6 = 0" | "Im3 e6 = 0" | "Im4 e6 = 0" | "Im5 e6 = 0" | "Im6 e6 = 1" | "Im7 e6 = 0" primcorec octo_e7 :: octo ("e7") where "Ree e7 = 0" | "Im1 e7 = 0" | "Im2 e7 = 0" | "Im3 e7 = 0" | "Im4 e7 = 0" | "Im5 e7 = 0" | "Im6 e7 = 0" | "Im7 e7 = 1" end subsection \Addition and Subtraction: An Abelian Group\ instantiation octo :: ab_group_add begin primcorec zero_octo where "Ree 0 = 0" |"Im1 0 = 0" | "Im2 0 = 0" | "Im3 0 = 0" |"Im4 0 = 0" | "Im5 0 = 0" | "Im6 0 = 0" | "Im7 0 = 0" primcorec plus_octo where "Ree (x + y) = Ree x + Ree y" | "Im1 (x + y) = Im1 x + Im1 y" | "Im2 (x + y) = Im2 x + Im2 y" | "Im3 (x + y) = Im3 x + Im3 y" | "Im4 (x + y) = Im4 x + Im4 y" | "Im5 (x + y) = Im5 x + Im5 y" | "Im6 (x + y) = Im6 x + Im6 y" | "Im7 (x + y) = Im7 x + Im7 y" primcorec uminus_octo where "Ree (- x) = - Ree x" | "Im1 (- x) = - Im1 x" | "Im2 (- x) = - Im2 x" | "Im3 (- x) = - Im3 x" | "Im4 (- x) = - Im4 x" | "Im5 (- x) = - Im5 x" | "Im6 (- x) = - Im6 x" | "Im7 (- x) = - Im7 x" primcorec minus_octo where "Ree (x - y) = Ree x - Ree y" | "Im1 (x - y) = Im1 x - Im1 y" | "Im2 (x - y) = Im2 x - Im2 y" | "Im3 (x - y) = Im3 x - Im3 y" | "Im4 (x - y) = Im4 x - Im4 y" | "Im5 (x - y) = Im5 x - Im5 y" | "Im6 (x - y) = Im6 x - Im6 y" | "Im7 (x - y) = Im7 x - Im7 y" instance by standard (simp_all add: octo_eq_iff) end lemma octo_eq_0_iff: "x = 0 \ Ree x ^ 2 + Im1 x ^ 2 + Im2 x ^ 2 + Im3 x ^ 2 + Im4 x ^ 2 + Im5 x ^ 2 + Im6 x ^ 2 + Im7 x ^ 2 = 0" proof assume "(octo.Ree x)\<^sup>2 + (Im1 x)\<^sup>2 + (Im2 x)\<^sup>2 + (Im3 x)\<^sup>2 + (Im4 x)\<^sup>2 + (Im5 x)\<^sup>2 + (Im6 x)\<^sup>2 + (Im7 x)\<^sup>2 = 0" then have "\qa. qa - x = qa" by (simp add: add_nonneg_eq_0_iff minus_octo.ctr) then show "x = 0" by simp qed auto subsection \A Normed Vector Space\ instantiation octo :: real_vector begin primcorec scaleR_octo where "Ree (scaleR r x) = r * Ree x" | "Im1 (scaleR r x) = r * Im1 x" | "Im2 (scaleR r x) = r * Im2 x" | "Im3 (scaleR r x) = r * Im3 x" | "Im4 (scaleR r x) = r * Im4 x" | "Im5 (scaleR r x) = r * Im5 x" | "Im6 (scaleR r x) = r * Im6 x" | "Im7 (scaleR r x) = r * Im7 x" instance by standard (auto simp: octo_eq_iff distrib_left distrib_right scaleR_add_right) end instantiation octo::one begin primcorec one_octo where "Ree 1 = 1" | "Im1 1 = 0" | "Im2 1 = 0" | "Im3 1 = 0" | "Im4 1 = 0" | "Im5 1 = 0" | "Im6 1 = 0" | "Im7 1 = 0" instance by standard end fun octo_proj where "octo_proj x 0 = ( Ree (x))" | "octo_proj x (Suc 0) = ( Im1(x))" | "octo_proj x (Suc (Suc 0)) = ( Im2 ( x))" | "octo_proj x (Suc (Suc (Suc 0))) = ( Im3( x))" | "octo_proj x (Suc (Suc (Suc (Suc 0)))) = ( Im4( x))" | "octo_proj x (Suc(Suc (Suc (Suc (Suc 0))))) = ( Im5( x))" | "octo_proj x (Suc(Suc (Suc (Suc (Suc (Suc 0)))))) = ( Im6( x))" | "octo_proj x (Suc( Suc(Suc (Suc (Suc (Suc (Suc 0))))))) = ( Im7( x))" lemma octo_proj_add: assumes "i \ 7" shows "octo_proj (x+y) i = octo_proj x i + octo_proj y i" proof - consider "i = 0" | "i = 1" | "i = 2" | "i = 3" | "i = 4" | "i = 5" | "i = 6" | "i = 7" using assms by force then show ?thesis by cases (auto simp: numeral_2_eq_2 numeral_3_eq_3 numeral_4_eq_4 numeral_5_eq_5 numeral_6_eq_6 numeral_7_eq_7 numeral_7_eq_7) qed instantiation octo ::real_normed_vector begin definition "norm x = sqrt ((Ree x)\<^sup>2 + (Im1 x)\<^sup>2 + (Im2 x)\<^sup>2 + (Im3 x)\<^sup>2 + (Im4 x)\<^sup>2 + (Im5 x)\<^sup>2 + (Im6 x)\<^sup>2+ (Im7 x)\<^sup>2 )" for x::octo definition "sgn x = x /\<^sub>R norm x" for x :: octo definition "dist x y = norm (x - y)" for x y :: octo definition [code del]: "(uniformity :: (octo \ octo) filter) = (INF e\{0 <..}. principal {(x, y). dist x y < e})" definition [code del]: "open (U :: octo set) \ (\x\U. eventually (\(x', y). x' = x \ y \ U) uniformity)" lemma norm_eq_L2: "norm x = L2_set (octo_proj x) {..7}" by (simp add: norm_octo_def L2_set_def eval_nat_numeral) instance proof fix r :: real and x y :: octo and S :: "octo set" show "(norm x = 0) \ (x = 0)" by (simp add: norm_octo_def octo_eq_iff add_nonneg_eq_0_iff) have eq: "L2_set (octo_proj (x + y)) {..7} = L2_set (\i. octo_proj x i + octo_proj y i) {..7}" by (rule L2_set_cong) (auto simp: octo_proj_add) show "norm (x + y) \ norm x + norm y" by (simp add: norm_eq_L2 eq L2_set_triangle_ineq) show "norm (scaleR r x) = \r\ * norm x" by (simp add: norm_octo_def octo_eq_iff power_mult_distrib distrib_left [symmetric] real_sqrt_mult) qed (rule sgn_octo_def dist_octo_def open_octo_def uniformity_octo_def)+ end lemma norm_octo_squared: "norm x ^ 2 = Ree x ^ 2 + Im1 x ^ 2 + Im2 x ^ 2 + Im3 x ^ 2 + Im4 x ^ 2 + Im5 x ^ 2 + Im6 x ^ 2 + Im7 x ^ 2" by (simp add: norm_octo_def) instantiation octo :: real_inner begin definition inner_octo where "inner_octo x y = Ree x * Ree y + Im1 x * Im1 y + Im2 x * Im2 y + Im3 x * Im3 y + Im4 x * Im4 y + Im5 x * Im5 y + Im6 x * Im6 y + Im7 x * Im7 y " for x y::octo instance by standard (auto simp: inner_octo_def algebra_simps norm_octo_def power2_eq_square octo_eq_iff add_nonneg_eq_0_iff) end lemma octo_inner_1 [simp]: "inner 1 x = Ree x" and octo_inner_1_right [simp]: "inner x 1 = Ree x" unfolding inner_octo_def by simp_all lemma octo_inner_e1_left [simp]: "inner e1 x = Im1 x" and octo_inner_e1_right [simp]: "inner x e1 = Im1 x" unfolding inner_octo_def by simp_all lemma octo_inner_e2_left [simp]: "inner e2 x = Im2 x" and octo_inner_e2_right [simp]: "inner x e2 = Im2 x" unfolding inner_octo_def by simp_all lemma octo_inner_e3_left [simp]: "inner e3 x = Im3 x" and octo_inner_e3_right [simp]: "inner x e3 = Im3 x" unfolding inner_octo_def by simp_all lemma octo_inner_e4_left [simp]: "inner e4 x = Im4 x" and octo_inner_e4_right [simp]: "inner x e4 = Im4 x" unfolding inner_octo_def by simp_all lemma octo_inner_e5_left [simp]: "inner e5 x = Im5 x" and octo_inner_e5_right [simp]: "inner x e5 = Im5 x" unfolding inner_octo_def by simp_all lemma octo_inner_e6_left [simp]: "inner e6 x = Im6 x" and octo_inner_e6_right [simp]: "inner x e6 = Im6 x" unfolding inner_octo_def by simp_all lemma octo_inner_e7_left [simp]: "inner e7 x = Im7 x" and octo_inner_e7_right [simp]: "inner x e7 = Im7 x" unfolding inner_octo_def by simp_all lemma octo_norm_pow_2_inner: "(norm x) ^ 2 = inner x x " for x::octo by (simp add: dot_square_norm) lemma octo_norm_property: "inner x y = (1/2)* ((norm(x+y))^2 - (norm(x))^2 - (norm(y))^2) " for x y ::octo by (simp add: dot_norm norm_octo_def) subsection \The Octonionic product and related properties and lemmas\ text\The multiplication is defined following one of the 480 equivalent multiplication tables in an analogy to the definition of the 7D cross product. \ instantiation octo :: times begin definition times_octo :: "[octo, octo] \ octo" where "(a * b) = (let t0 = Ree a * Ree b - Im1 a * Im1 b - Im2 a * Im2 b- Im3 a * Im3 b - Im4 a * Im4 b - Im5 a * Im5 b - Im6 a * Im6 b -Im7 a * Im7 b ; t1 = Ree a * Im1 b + Im1 a * Ree b + Im2 a * Im4 b +Im3 a * Im7 b - Im4 a * Im2 b +Im5 a * Im6 b - Im6 a * Im5 b - Im7 a * Im3 b ; t2 = Ree a * Im2 b - Im1 a * Im4 b+ Im2 a * Ree b + Im3 a * Im5 b + Im4 a * Im1 b - Im5 a * Im3 b + Im6 a * Im7 b - Im7 a *Im6 b ; t3 = Ree a * Im3 b -Im1 a * Im7 b -Im2 a *Im5 b +Im3 a * Ree b + Im4 a * Im6 b + Im5 a *Im2 b - Im6 a * Im4 b + Im7 a * Im1 b ; t4 = Ree a * Im4 b + Im1 a * Im2 b - Im2 a * Im1 b -Im3 a * Im6 b + Im4 a * Ree b +Im5 a * Im7 b +Im6 a * Im3 b -Im7 a * Im5 b ; t5 = Ree a * Im5 b - Im1 a * Im6 b +Im2 a * Im3 b -Im3 a * Im2 b -Im4 a * Im7 b +Im5 a * Ree b +Im6 a * Im1 b + Im7 a * Im4 b; t6 = Ree a * Im6 b + Im1 a * Im5 b - Im2 a * Im7 b +Im3 a * Im4 b - Im4 a * Im3 b -Im5 a * Im1 b + Im6 a * Ree b + Im7 a * Im2 b ; t7 = Ree a * Im7 b + Im1 a * Im3 b +Im2 a * Im6 b - Im3 a * Im1 b + Im4 a * Im5 b -Im5 a * Im4 b - Im6 a * Im2 b +Im7 a * Ree b in Octo t0 t1 t2 t3 t4 t5 t6 t7)" instance by standard end instantiation octo ::inverse begin primcorec inverse_octo where "Ree (inverse x) = Ree x / (Ree x ^ 2 + Im1 x ^ 2 + Im2 x ^ 2 + Im3 x ^ 2 +Im4 x ^ 2 + Im5 x ^ 2 + Im6 x ^ 2 + Im7 x ^2 )" | "Im1 (inverse x) = - (Im1 x) / (Ree x ^ 2 + Im1 x ^ 2 + Im2 x ^ 2 + Im3 x ^ 2 +Im4 x ^ 2 + Im5 x ^ 2 + Im6 x ^ 2 + Im7 x ^2)" | "Im2 (inverse x) = - (Im2 x) / (Ree x ^ 2 + Im1 x ^ 2 + Im2 x ^ 2 + Im3 x ^ 2 +Im4 x ^ 2 + Im5 x ^ 2 + Im6 x ^ 2 + Im7 x ^2 )" | "Im3 (inverse x) = - (Im3 x) / (Ree x ^ 2 + Im1 x ^ 2 + Im2 x ^ 2 + Im3 x ^ 2 +Im4 x ^ 2 + Im5 x ^ 2 + Im6 x ^ 2 + Im7 x ^2 )" | "Im4 (inverse x) = - (Im4 x) / (Ree x ^ 2 + Im1 x ^ 2 + Im2 x ^ 2 + Im3 x ^ 2 +Im4 x ^ 2 + Im5 x ^ 2 + Im6 x ^ 2 + Im7 x ^2 )" | "Im5 (inverse x) = - (Im5 x) / (Ree x ^ 2 + Im1 x ^ 2 + Im2 x ^ 2 + Im3 x ^ 2 +Im4 x ^ 2 + Im5 x ^ 2 + Im6 x ^ 2 + Im7 x ^2)" | "Im6 (inverse x) = - (Im6 x) / (Ree x ^ 2 + Im1 x ^ 2 + Im2 x ^ 2 + Im3 x ^ 2 +Im4 x ^ 2 + Im5 x ^ 2 + Im6 x ^ 2 + Im7 x ^2 )" | "Im7 (inverse x) = - (Im7 x) / (Ree x ^ 2 + Im1 x ^ 2 + Im2 x ^ 2 + Im3 x ^ 2 +Im4 x ^ 2 + Im5 x ^ 2 + Im6 x ^ 2 + Im7 x ^2 )" definition "x div y = x * ( inverse y)" for x y :: octo instance by standard end lemma octo_mult_components: "Ree (x * y ) = Ree x * Ree y - Im1 x * Im1 y - Im2 x * Im2 y - Im3 x * Im3 y - Im4 x * Im4 y - Im5 x * Im5 y - Im6 x * Im6 y- Im7 x * Im7 y" "Im1 (x * y ) = Ree x * Im1 y + Im1 x * Ree y + Im2 x * Im4 y +Im3 x * Im7 y - Im4 x * Im2 y +Im5 x * Im6 y - Im6 x * Im5 y - Im7 x * Im3 y " " Im2 (x * y ) = Ree x * Im2 y - Im1 x * Im4 y+ Im2 x * Ree y + Im3 x * Im5 y + Im4 x * Im1 y - Im5 x * Im3 y + Im6 x * Im7 y - Im7 x *Im6 y " " Im3 (x * y ) = Ree x * Im3 y -Im1 x * Im7 y -Im2 x *Im5 y +Im3 x * Ree y + Im4 x * Im6 y + Im5 x *Im2 y - Im6 x * Im4 y + Im7 x * Im1 y " "Im4 (x *y ) = Ree x * Im4 y + Im1 x * Im2 y - Im2 x * Im1 y -Im3 x * Im6 y + Im4 x * Ree y +Im5 x * Im7 y +Im6 x * Im3 y -Im7 x * Im5 y " "Im5 (x * y ) = Ree x * Im5 y - Im1 x * Im6 y +Im2 x * Im3 y -Im3 x * Im2 y -Im4 x * Im7 y +Im5 x * Ree y +Im6 x * Im1 y + Im7 x * Im4 y " " Im6 (x * y) = Ree x * Im6 y + Im1 x * Im5 y - Im2 x * Im7 y +Im3 x * Im4 y - Im4 x * Im3 y -Im5 x * Im1 y + Im6 x * Ree y + Im7 x * Im2 y " "Im7 (x * y) = Ree x * Im7 y + Im1 x * Im3 y +Im2 x * Im6 y - Im3 x * Im1 y + Im4 x * Im5 y -Im5 x * Im4 y - Im6 x * Im2 y +Im7 x * Ree y " unfolding times_octo_def by auto lemma octo_distrib_left : "a * (b + c) = a * b + a * c" for a b c ::octo unfolding times_octo_def plus_octo_def minus_octo_def uminus_octo_def scaleR_octo_def by (simp add: octo_eq_iff octo_mult_components algebra_simps) lemma octo_distrib_right : "(b + c) * a = b * a + c * a" for a b c ::octo unfolding times_octo_def plus_octo_def minus_octo_def uminus_octo_def scaleR_octo_def by (simp add: octo_eq_iff octo_mult_components algebra_simps) lemma multiplicative_norm_octo: "norm (x * y) = norm x * norm y" for x y ::octo proof - have "norm (x * y) ^ 2 = norm x ^ 2 * norm y ^ 2" unfolding norm_octo_squared octo_mult_components by algebra also have "... = (norm x * norm y) ^ 2" by (simp add: power_mult_distrib) finally show ?thesis by simp qed lemma mult_1_right_octo [simp]: "x * 1 = (x :: octo)" and mult_1_left_octo [simp]: "1 * x = (x :: octo)" by (simp_all add: times_octo_def) instance octo :: power .. lemma power2_eq_square_octo: "x ^ 2 = (x * x :: octo)" by (simp add: numeral_2_eq_2 times_octo_def) lemma octo_product_alternative_left: "x * (x * y) = (x * x :: octo) * y" unfolding octo_eq_iff octo_mult_components by algebra lemma octo_product_alternative_right: "x * (y * y) = (x * y :: octo) * y" unfolding octo_eq_iff octo_mult_components by algebra lemma octo_product_flexible: "(x * y) * x = x * (y * x :: octo)" unfolding octo_eq_iff octo_mult_components by algebra lemma octo_power_commutes: "x ^ y * x = x * (x ^ y :: octo)" by (induction y) (simp_all add: octo_product_flexible) lemma octo_product_noncommutative: "\(\x y::octo. (x * y = y * x))" - - using inverse_1 left_inverse mult_not_zero octo.sel(8) octo_e4.sel(2) - octo_e4.sel(3) octo_e4.sel(5) octo_e5.sel(1) octo_e5.sel(2) - octo_e5.sel(3) octo_e5.sel(5) octo_e5.sel(6) octo_e5.sel(8) times_octo_def - by smt + by (auto simp: times_octo_def) + (metis (no_types, lifting) Im1_def add_0 mult.commute mult_1 mult_zero_left octo.case + octo_e5.simps(2) octo_e5.simps(3) octo_e5.simps(4) octo_e5.simps(5) octo_e5.simps(6) + octo_e5.simps(8) zero_neq_numeral) lemma octo_product_nonassociative : "\(\ x y z::octo. x * (y * z) = (x * y) * z)" proof- define x where "x = Octo 1 0 0 0 1 0 0 0" define y where "y = Octo 1 3 0 0 0 1 0 0" define z where "z = Octo 0 1 0 1 1 1 0 0" have "x * (y * z) \ (x * y) * z" by (simp add: octo_eq_iff octo_mult_components x_def y_def z_def) thus ?thesis by blast qed subsection \Embedding of the Reals into the Octonions\ definition octo_of_real :: "real \ octo" where "octo_of_real r = scaleR r 1" definition octo_of_nat :: "nat \ octo" where "octo_of_nat r = scaleR r 1" definition octo_of_int :: "int \ octo" where "octo_of_int r = scaleR r 1" lemma octo_of_nat_sel [simp]: "Ree (octo_of_nat x) = of_nat x" "Im1 (octo_of_nat x) = 0" "Im2 (octo_of_nat x) = 0" "Im3 (octo_of_nat x) = 0" "Im4 (octo_of_nat x) = 0" "Im5 (octo_of_nat x) = 0" "Im6 (octo_of_nat x) = 0" "Im7 (octo_of_nat x) = 0" by (simp_all add: octo_of_nat_def) lemma octo_of_real_sel [simp]: "Ree (octo_of_real x) = x" "Im1 (octo_of_real x) = 0" "Im2 (octo_of_real x) = 0" "Im3 (octo_of_real x) = 0" "Im4 (octo_of_real x) = 0" "Im5 (octo_of_real x) = 0" "Im6 (octo_of_real x) = 0" "Im7 (octo_of_real x) = 0" by (simp_all add: octo_of_real_def) lemma octo_of_int_sel [simp]: "Ree (octo_of_int x) = of_int x" "Im1 (octo_of_int x) = 0" "Im2 (octo_of_int x) = 0" "Im3 (octo_of_int x) = 0" "Im4 (octo_of_int x) = 0" "Im5 (octo_of_int x) = 0" "Im6 (octo_of_int x) = 0" "Im7 (octo_of_int x) = 0" by (simp_all add: octo_of_int_def) lemma scaleR_conv_octo_of_real: "scaleR r x = octo_of_real r * x" by (simp add: octo_eq_iff octo_mult_components octo_of_real_def) lemma octo_of_real_0 [simp]: "octo_of_real 0 = 0" by (simp add: octo_of_real_def) lemma octo_of_real_1 [simp]: "octo_of_real 1 = 1" by (simp add: octo_of_real_def) lemma octo_of_real_add [simp]: "octo_of_real (x + y) = octo_of_real x + octo_of_real y" by (simp add: octo_of_real_def scaleR_left_distrib) lemma octo_of_real_minus [simp]: "octo_of_real (- x) = - octo_of_real x" by (simp add: octo_of_real_def) lemma octo_of_real_diff [simp]: "octo_of_real (x - y) = octo_of_real x - octo_of_real y" by (simp add: octo_of_real_def scaleR_left_diff_distrib) lemma octo_of_real_mult [simp]: "octo_of_real (x * y) = octo_of_real x * octo_of_real y" using octo_of_real_def by (metis scaleR_conv_octo_of_real scaleR_scaleR) lemma octo_of_real_sum[simp]: "octo_of_real (sum f s) = (\x\s. octo_of_real (f x))" by (induct s rule: infinite_finite_induct) auto lemma octo_of_real_power [simp]: "octo_of_real (x ^ y) = (octo_of_real x :: octo) ^ y" by (induct y)(simp_all) lemma octo_of_real_eq_iff [simp]: "octo_of_real x = octo_of_real y \ x = y" using octo_of_real_def by (simp add: octo_of_real_def one_octo.code zero_octo.code) lemmas octo_of_real_eq_0_iff [simp] = octo_of_real_eq_iff [of _ 0, simplified] lemmas octo_of_real_eq_1_iff [simp] = octo_of_real_eq_iff [of _ 1, simplified] lemma minus_octo_of_real_eq_octo_of_real_iff [simp]: "-octo_of_real x = octo_of_real y \ -x = y" using octo_of_real_eq_iff[of "-x" y] by (simp only: octo_of_real_minus) lemma octo_of_real_eq_minus_of_real_iff [simp]: "octo_of_real x = -octo_of_real y \ x = -y" using octo_of_real_eq_iff[of x "-y"] by (simp only: octo_of_real_minus) lemma octo_of_real_of_nat_eq [simp]: "octo_of_real (of_nat x) = octo_of_nat x" unfolding octo_of_real_def by (simp add: octo_of_nat_def) lemma octo_of_real_of_int_eq [simp]: "octo_of_real (of_int z) = octo_of_int z" unfolding octo_of_real_def by (simp add: octo_of_int_def) lemma octo_of_int_of_nat: "octo_of_int (of_nat n) = octo_of_nat n" by (simp add: octo_eq_iff) lemma octo_of_nat_add [simp]: "octo_of_nat (a + b) = octo_of_nat a + octo_of_nat b" and octo_of_nat_mult [simp]: "octo_of_nat (a * b) = octo_of_nat a * octo_of_nat b" and octo_of_nat_diff [simp]: "b \ a \ octo_of_nat (a - b) = octo_of_nat a - octo_of_nat b" and octo_of_nat_0 [simp]: "octo_of_nat 0 = 0" and octo_of_nat_1 [simp]: "octo_of_nat 1 = 1" and octo_of_nat_Suc_0 [simp]: "octo_of_nat (Suc 0) = 1" by (simp_all add: octo_eq_iff octo_mult_components) lemma octo_of_int_add [simp]: "octo_of_int (a + b) = octo_of_int a + octo_of_int b" and octo_of_int_mult [simp]: "octo_of_int (a * b) = octo_of_int a * octo_of_int b" and octo_of_int_diff [simp]: "b \ a \ octo_of_int (a - b) = octo_of_int a - octo_of_int b" and octo_of_int_0 [simp]: "octo_of_int 0 = 0" and octo_of_int_1 [simp]: "octo_of_int 1 = 1" by (simp_all add: octo_eq_iff octo_mult_components) instance octo :: numeral .. lemma numeral_octo_conv_of_nat: "numeral x = octo_of_nat (numeral x)" proof (induction x) case(Bit0 x) have "numeral x+ numeral x = octo_of_nat(numeral x+ numeral x)" unfolding Bit0.IH octo_of_nat_add .. thus ?case by (simp add: numeral_Bit0) next case(Bit1 x) have "numeral x+ numeral x + numeral num.One= octo_of_nat (numeral x + numeral x + numeral num.One)" unfolding Bit1.IH octo_of_nat_add by simp thus ?case by (simp add: numeral_Bit1) qed auto lemma numeral_octo_sel [simp]: "Ree (numeral n) = numeral n" "Im1 (numeral n) = 0" "Im2 (numeral n) = 0" "Im3 (numeral n) = 0" "Im4 (numeral n) = 0" "Im5 (numeral n) = 0" "Im6 (numeral n) = 0" "Im7 (numeral n) = 0" by (simp_all add: numeral_octo_conv_of_nat) lemma octo_of_real_numeral [simp]: "octo_of_real (numeral w) = numeral w" by (simp add: numeral_octo_conv_of_nat octo_of_real_def octo_of_nat_def) lemma octo_of_real_neg_numeral [simp]: "octo_of_real (- numeral w) = - numeral w" by simp lemma octo_of_real_times_commute: "octo_of_real r * q = q * octo_of_real r" using octo_of_real_def times_octo_def by simp lemma octo_of_real_times_conv_scaleR: "octo_of_real x * y = scaleR x y" by (simp add: octo_eq_iff octo_mult_components) lemma octo_mult_scaleR_left: "(r *\<^sub>R x) * y = r *\<^sub>R (x * y :: octo)" by (simp add: octo_eq_iff octo_mult_components algebra_simps) lemma octo_mult_scaleR_right: "x * (r *\<^sub>R y) = r *\<^sub>R (x * y :: octo)" by (simp add: octo_eq_iff octo_mult_components algebra_simps) lemma scaleR_octo_of_real [simp]: "scaleR r (octo_of_real s) = octo_of_real (r * s)" by (simp add: octo_of_real_def) lemma octo_of_real_times_left_commute: "octo_of_real r * (x * q) = x * (octo_of_real r * q)" unfolding octo_of_real_times_conv_scaleR by (simp add: octo_mult_scaleR_right) lemma nonzero_octo_of_real_inverse: "x \ 0 \ octo_of_real (inverse x) = inverse (octo_of_real x :: octo)" by (simp add: octo_eq_iff power2_eq_square divide_simps) lemma octo_of_real_inverse [simp]: "octo_of_real (inverse x) = inverse (octo_of_real x )" by (simp add: octo_eq_iff power2_eq_square divide_simps) lemma nonzero_octo_of_real_divide: "y \ 0 \ octo_of_real (x / y) = (octo_of_real x / octo_of_real y ::octo)" by (simp add: divide_inverse divide_octo_def) lemma octo_of_real_divide [simp]: "octo_of_real (x / y) = (octo_of_real x / octo_of_real y :: octo)" using divide_inverse divide_octo_def octo_of_real_def octo_of_real_inverse by (metis octo_of_real_mult) lemma octo_of_real_inverse_collapse [simp]: assumes "c \ 0" shows "octo_of_real c * octo_of_real (inverse c) = 1" "octo_of_real (inverse c) * octo_of_real c = 1" using assms by (simp_all add: octo_eq_iff octo_mult_components power2_eq_square) lemma octo_divide_numeral: fixes x::octo shows "x / numeral y = x /\<^sub>R numeral y" using octo_of_real_times_commute[of "inverse (numeral y)"] by (simp add: scaleR_conv_octo_of_real divide_octo_def flip: octo_of_real_numeral) lemma octo_divide_numeral_sel [simp]: "Ree (x / numeral w) = Ree x / numeral w" "Im1 (x / numeral w) = Im1 x / numeral w" "Im2 (x / numeral w) = Im2 x / numeral w" "Im3 (x / numeral w) = Im3 x / numeral w" "Im4 (x / numeral w) = Im4 x / numeral w" "Im5 (x / numeral w) = Im5 x / numeral w" "Im6 (x / numeral w) = Im6 x / numeral w" "Im7 (x / numeral w) = Im7 x / numeral w" unfolding octo_divide_numeral by simp_all lemma octo_norm_units [simp]: "norm octo_e1 = 1" "norm (e2::octo) = 1" "norm (e3::octo) = 1" "norm (e4::octo) = 1 " "norm (e5::octo) = 1" "norm (e6::octo) = 1" "norm (e7::octo) = 1" by (auto simp: norm_octo_def) lemma e1_nz [simp]: "e1 \ 0" and e2_nz [simp]: "e2 \ 0" and e3_nz [simp]: "e3 \ 0" and e4_nz [simp]: "e4 \ 0" and e5_nz [simp]: "e5 \ 0" and e6_nz [simp]: "e6 \ 0" and e7_nz [simp]: "e7 \ 0" by (simp_all add: octo_eq_iff) subsection \"Expansion" into the traditional notation\ lemma octo_unfold: "q = (Ree q) *\<^sub>R e0 + (Im1 q) *\<^sub>R e1 + (Im2 q) *\<^sub>R e2 + (Im3 q) *\<^sub>R e3 + (Im4 q) *\<^sub>R e4 + (Im5 q) *\<^sub>R e5 + (Im6 q) *\<^sub>R e6 + (Im7 q) *\<^sub>R e7" by (simp add: octo_eq_iff) lemma octo_trad: "Octo x y z w u v q g = x *\<^sub>R e0 + y *\<^sub>R e1 + z *\<^sub>R e2 + w *\<^sub>R e3 + u *\<^sub>R e4 + v *\<^sub>R e5 + q *\<^sub>R e6 + g*\<^sub>R e7 " by (simp add: octo_eq_iff) lemma octo_of_real_eq_Octo: "octo_of_real a = Octo a 0 0 0 0 0 0 0 " by (simp add: octo_eq_iff) lemma e1_squared [simp]: "e1 ^ 2 = -1" and e2_squared [simp]: "e2 ^ 2 = -1" and e3_squared [simp]: "e3 ^ 2 = -1" and e4_squared [simp]: "e4 ^ 2 = -1" and e5_squared [simp]: "e5 ^ 2 = -1" and e6_squared [simp]: "e6 ^ 2 = -1" and e7_squared [simp]: "e7 ^ 2 = -1" by (simp_all add: octo_eq_iff power2_eq_square_octo octo_mult_components) lemma inverse_e1 [simp]: "inverse e1 = -e1" and inverse_e2 [simp]: "inverse e2 = -e2" and inverse_e3 [simp]: "inverse e3 = -e3" and inverse_e4 [simp]: "inverse e4 = -e4" and inverse_e5 [simp]: "inverse e5 = -e5" and inverse_e6 [simp]: "inverse e6 = -e6" and inverse_e7 [simp]: "inverse e7 = -e7" by (simp_all add: octo_eq_iff) subsection \Conjugate of an octonion and related properties.\ primcorec cnj :: "octo \ octo" where "Ree (cnj z) = Ree z" | "Im1 (cnj z) = - Im1 z" | "Im2 (cnj z) = - Im2 z" | "Im3 (cnj z) = - Im3 z" | "Im4 (cnj z) = - Im4 z" | "Im5 (cnj z) = - Im5 z" | "Im6 (cnj z) = - Im6 z" | "Im7 (cnj z) = - Im7 z" lemma cnj_cancel_iff [simp]: "cnj x = cnj y \ x = y" proof show "cnj x = cnj y \ x = y" by (simp add: octo_eq_iff) qed auto lemma cnj_cnj [simp]: "cnj(cnj q) = q" by (simp add: octo_eq_iff) lemma cnj_of_real [simp]: "cnj(octo_of_real x) = octo_of_real x" using octo_eq_iff by (simp add: octo_of_real_eq_Octo) lemma cnj_zero [simp]: "cnj 0 = 0" by (simp add: octo_eq_iff) lemma cnj_zero_iff [iff]: "cnj z = 0 \ z = 0" using cnj_cnj by (metis cnj_zero) lemma cnj_one [simp]: "cnj 1 = 1" by (simp add: octo_eq_iff) lemma cnj_one_iff [simp]: "cnj z = 1 \ z = 1" by (simp add: octo_eq_iff) lemma octo_norm_cnj [simp]: "norm(cnj q) = norm q" by (simp add: norm_octo_def) lemma cnj_add [simp]: "cnj (x + y) = cnj x + cnj y" using octo_eq_iff inner_real_def of_real_0 of_real_inner_1 by simp lemma cnj_sum [simp]: "cnj (sum f S) = (\x\S. cnj (f x))" by (induct S rule: infinite_finite_induct) auto lemma cnj_diff [simp]: "cnj (x - y) = cnj x - cnj y" using octo_eq_iff by (metis add.commute add_left_cancel cnj_add diff_add_cancel) lemma cnj_minus [simp]: "cnj (- x) = - cnj x" using octo_eq_iff cnj_cnj by auto lemma cnj_inverse [simp]: "cnj (inverse x) = inverse (cnj x)" for x y ::octo using octo_eq_iff inner_real_def real_inner_1_right by auto lemma cnj_mult [simp]: "cnj (x * y) = cnj y * cnj x" for x y ::octo using octo_eq_iff times_octo_def octo_mult_components cnj_cnj mult_not_zero nonzero_inverse_mult_distrib by simp lemma cnj_divide [simp]: "cnj (x / y) = (inverse (cnj y) ) * cnj x" for x y ::octo unfolding divide_octo_def times_octo_def using cnj_inverse cnj_mult octo_mult_components by (metis times_octo_def) lemma cnj_power [simp]: "cnj (x ^ y) = (cnj x) ^ y" for x::octo by (induction y) (simp_all add: octo_power_commutes) lemma cnj_of_nat [simp]: "cnj (octo_of_nat x) = octo_of_nat( x)" using cnj_of_real octo_of_real_of_nat_eq by metis lemma cnj_of_int [simp]: "cnj (octo_of_int x) = octo_of_nat( x)" using octo_of_real_def octo_of_real_of_int_eq octo_of_int_def octo_of_nat_def cnj_of_real by auto lemma cnj_numeral [simp]: "cnj (numeral x) = numeral x" by (simp add: numeral_octo_conv_of_nat) lemma cnj_neg_numeral [simp]: "cnj (- numeral x) = - numeral x" by (simp add: numeral_octo_conv_of_nat) lemma cnj_scaleR [simp]: "cnj (scaleR r x) = scaleR r (cnj x)" using octo_eq_iff inner_real_def ln_one of_real_inner_1 by simp lemma cnj_units [simp]: "cnj e1 = -e1" "cnj e2 = -e2" "cnj e3 = -e3" "cnj e4 = -e4" "cnj e5 = -e5" "cnj e6 = -e6" "cnj e7 = -e7" by (simp_all add: octo_eq_iff) lemma cnj_eq_of_real: "cnj q = octo_of_real x \ q = octo_of_real x" proof show "cnj q = octo_of_real x \ q = octo_of_real x" by (metis cnj_of_real cnj_cnj) qed auto lemma octo_trad_cnj : "cnj q = (Ree q) *\<^sub>R e0 - (Im1 q) *\<^sub>R e1 - (Im2 q)*\<^sub>R e2 - (Im3 q) *\<^sub>R e3 - (Im4 q) *\<^sub>R e4 - (Im5 q) *\<^sub>R e5 - (Im6 q) *\<^sub>R e6 - (Im7 q)*\<^sub>R e7 " for q::octo using cnj_cnj octo_unfold octo_trad cnj_def Octonions.cnj.code by auto lemma octonion_conjugate_property: "cnj x = -(1/6) *\<^sub>R (x + (e1 * x) * e1 + (e2 * x) * e2 + (e3 * x) * e3 + (e4 * x) * e4 + (e5 * x) * e5 + ( e6 * x) * e6 + (e7 * x) * e7)" by (simp add: octo_eq_iff octo_mult_components) lemma octo_add_cnj: "q + cnj q = 2 *\<^sub>R (Ree q) *\<^sub>R e0" "cnj q + q = (2*\<^sub>R (Ree q)*\<^sub>R e0)" by (simp_all add: octo_eq_iff) lemma octo_add_cnj1: "q + cnj q = octo_of_real (2*\<^sub>R (Ree q))" "cnj q + q = octo_of_real (2*\<^sub>R (Ree q))" by (auto simp: octo_eq_iff octo_mult_components) lemma octo_subtract_cnj: "q - cnj q = 2 *\<^sub>R (Im1 q *\<^sub>R e1 + Im2 q *\<^sub>R e2 + Im3 q *\<^sub>R e3 + Im4 q *\<^sub>R e4 + Im5 q *\<^sub>R e5 + Im6 q*\<^sub>R e6 + Im7 q *\<^sub>R e7)" by (simp add: octo_eq_iff) lemma octo_mult_cnj_commute: "cnj x * x = x * cnj x" using times_octo_def by auto lemma octo_cnj_mult_conv_norm: "cnj x * x = octo_of_real (norm x) ^ 2" by (simp add: octo_eq_iff octo_mult_components norm_octo_def power2_eq_square flip: octo_of_real_power) lemma octo_mult_cnj_conv_norm: "x * cnj x = octo_of_real (norm x) ^ 2" by (simp add: octo_eq_iff octo_mult_components norm_octo_def power2_eq_square flip: octo_of_real_power) lemma octo_mult_cnj_conv_norm_aux: "octo_of_real (norm x ^ 2) = x * cnj x " using octo_mult_cnj_conv_norm[of x] by (simp add: octo_mult_cnj_commute) lemma octo_norm_conj: "octo_of_real ( inner x y) = (1/2) *\<^sub>R (x * (cnj y) + y * (cnj x))" by (simp add: octo_eq_iff octo_mult_components inner_octo_def) lemma octo_inverse_cnj: "inverse x = cnj x /\<^sub>R (norm x ^ 2)" by (auto simp: octo_eq_iff norm_octo_def field_simps) lemma inverse_octo_1: "x \ 0 \ x * inverse x = (1 :: octo)" by (simp add: octo_mult_scaleR_right octo_mult_cnj_conv_norm_aux [symmetric] divide_simps octo_inverse_cnj del: octo_of_real_power) lemma inverse_octo_1_sym: "x \ 0 \ inverse x * x = (1 :: octo)" by (metis cnj_cnj cnj_inverse cnj_mult cnj_one cnj_zero inverse_octo_1) lemma inverse_0_octo [simp]: "inverse 0 = (0 :: octo)" by (simp add: octo_eq_iff) lemma inverse_octo_commutes: "inverse x * x = x * (inverse x :: octo)" by (cases "x = 0") (simp_all add: inverse_octo_1 inverse_octo_1_sym) lemma octo_inverse_mult: "inverse (x * y) = inverse y * inverse x" for x y::octo proof- have "inverse (x * y) = (cnj y * cnj x) /\<^sub>R (norm (x * y) ^ 2)" by (simp add: octo_inverse_cnj) also have "\ = (cnj y /\<^sub>R norm y ^ 2) * (cnj x /\<^sub>R norm x ^ 2)" by (simp add: octo_mult_scaleR_left octo_mult_scaleR_right multiplicative_norm_octo power2_eq_square) also have "\ = inverse y * inverse x" by (simp add: octo_inverse_cnj) finally show ?thesis . qed lemma octo_inverse_eq_cnj: "norm q = 1 \ inverse q = cnj q" for q::octo by (simp add: octo_inverse_cnj) lemma octo_in_Reals_if_Re: fixes q ::real shows " Ree( octo_of_real(q)) = q" by simp lemma octo_in_Reals_if_Re_con: assumes "Ree (octo_of_real q) = q" shows "q \ Reals" by (metis Reals_of_real inner_real_def mult.right_neutral of_real_inner_1) lemma octo_in_Reals_if_cnj: fixes q:: real shows " cnj( octo_of_real( q)) = octo_of_real q" by simp lemma octo_in_Reals_if_cnj_con: assumes " cnj( octo_of_real( q)) = octo_of_real q" shows "q \ Reals " by (metis Reals_of_real inner_real_def mult.right_neutral of_real_inner_1) lemma norm_power2: "norm q ^ 2 = Ree (cnj q * q)" by (simp add: octo_mult_components norm_octo_def power2_eq_square) lemma norm_power2_cnj: "norm q ^ 2 = Ree (q * cnj q)" by (simp add: octo_mult_components norm_octo_def power2_eq_square) lemma octo_norm_imaginary: "Ree x = 0 \ x * x = -(octo_of_real (norm x))\<^sup>2" by (simp add: octo_eq_iff octo_mult_components norm_octo_def power2_eq_square flip: octo_of_real_power octo_of_real_mult) subsection\ Linearity and continuity of the components.\ lemma bounded_linear_Ree: "bounded_linear Ree" and bounded_linear_Im1: "bounded_linear Im1" and bounded_linear_Im2: "bounded_linear Im2" and bounded_linear_Im3: "bounded_linear Im3" and bounded_linear_Im4: "bounded_linear Im4" and bounded_linear_Im5: "bounded_linear Im5" and bounded_linear_Im6: "bounded_linear Im6" and bounded_linear_Im7: "bounded_linear Im7" by (simp_all add: bounded_linear_intro [where K=1] norm_octo_def real_le_rsqrt add.assoc) lemmas Cauchy_Ree = bounded_linear.Cauchy [OF bounded_linear_Ree] lemmas Cauchy_Im1 = bounded_linear.Cauchy [OF bounded_linear_Im1] lemmas Cauchy_Im2 = bounded_linear.Cauchy [OF bounded_linear_Im2] lemmas Cauchy_Im3 = bounded_linear.Cauchy [OF bounded_linear_Im3] lemmas Cauchy_Im4 = bounded_linear.Cauchy [OF bounded_linear_Im4] lemmas Cauchy_Im5 = bounded_linear.Cauchy [OF bounded_linear_Im5] lemmas Cauchy_Im6 = bounded_linear.Cauchy [OF bounded_linear_Im6] lemmas Cauchy_Im7 = bounded_linear.Cauchy [OF bounded_linear_Im7] lemmas tendsto_Re [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_Ree] lemmas tendsto_Im1 [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_Im1] lemmas tendsto_Im2 [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_Im2] lemmas tendsto_Im3 [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_Im3] lemmas tendsto_Im4 [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_Im4] lemmas tendsto_Im5 [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_Im5] lemmas tendsto_Im6 [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_Im6] lemmas tendsto_Im7 [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_Im7] lemmas isCont_Ree [simp] = bounded_linear.isCont [OF bounded_linear_Ree] lemmas isCont_Im1 [simp] = bounded_linear.isCont [OF bounded_linear_Im1] lemmas isCont_Im2 [simp] = bounded_linear.isCont [OF bounded_linear_Im2] lemmas isCont_Im3 [simp] = bounded_linear.isCont [OF bounded_linear_Im3] lemmas isCont_Im4 [simp] = bounded_linear.isCont [OF bounded_linear_Im4] lemmas isCont_Im5 [simp] = bounded_linear.isCont [OF bounded_linear_Im5] lemmas isCont_Im6 [simp] = bounded_linear.isCont [OF bounded_linear_Im6] lemmas isCont_Im7 [simp] = bounded_linear.isCont [OF bounded_linear_Im7] lemmas continuous_Ree [simp] = bounded_linear.continuous [OF bounded_linear_Ree] lemmas continuous_Im1 [simp] = bounded_linear.continuous [OF bounded_linear_Im1] lemmas continuous_Im2 [simp] = bounded_linear.continuous [OF bounded_linear_Im2] lemmas continuous_Im3 [simp] = bounded_linear.continuous [OF bounded_linear_Im3] lemmas continuous_Im4 [simp] = bounded_linear.continuous [OF bounded_linear_Im4] lemmas continuous_Im5 [simp] = bounded_linear.continuous [OF bounded_linear_Im5] lemmas continuous_Im6 [simp] = bounded_linear.continuous [OF bounded_linear_Im6] lemmas continuous_Im7 [simp] = bounded_linear.continuous [OF bounded_linear_Im7] lemmas continuous_on_Ree [continuous_intros] = bounded_linear.continuous_on[OF bounded_linear_Ree] lemmas continuous_on_Im1 [continuous_intros] = bounded_linear.continuous_on[OF bounded_linear_Im1] lemmas continuous_on_Im2 [continuous_intros] = bounded_linear.continuous_on[OF bounded_linear_Im2] lemmas continuous_on_Im3 [continuous_intros] = bounded_linear.continuous_on[OF bounded_linear_Im3] lemmas continuous_on_Im4 [continuous_intros] = bounded_linear.continuous_on[OF bounded_linear_Im4] lemmas continuous_on_Im5 [continuous_intros] = bounded_linear.continuous_on[OF bounded_linear_Im5] lemmas continuous_on_Im6 [continuous_intros] = bounded_linear.continuous_on[OF bounded_linear_Im6] lemmas continuous_on_Im7 [continuous_intros] = bounded_linear.continuous_on[OF bounded_linear_Im7] lemmas has_derivative_Ree [derivative_intros] = bounded_linear.has_derivative[OF bounded_linear_Ree] lemmas has_derivative_Im1 [derivative_intros] = bounded_linear.has_derivative[OF bounded_linear_Im1] lemmas has_derivative_Im2 [derivative_intros] = bounded_linear.has_derivative[OF bounded_linear_Im2] lemmas has_derivative_Im3 [derivative_intros] = bounded_linear.has_derivative[OF bounded_linear_Im3] lemmas has_derivative_Im4 [derivative_intros] = bounded_linear.has_derivative[OF bounded_linear_Im4] lemmas has_derivative_Im5 [derivative_intros] = bounded_linear.has_derivative[OF bounded_linear_Im5] lemmas has_derivative_Im6 [derivative_intros] = bounded_linear.has_derivative[OF bounded_linear_Im6] lemmas has_derivative_Im7 [derivative_intros] = bounded_linear.has_derivative[OF bounded_linear_Im7] lemmas sums_Ree = bounded_linear.sums [OF bounded_linear_Ree] lemmas sums_Im1 = bounded_linear.sums [OF bounded_linear_Im1] lemmas sums_Im2 = bounded_linear.sums [OF bounded_linear_Im2] lemmas sums_Im3 = bounded_linear.sums [OF bounded_linear_Im3] lemmas sums_Im4 = bounded_linear.sums [OF bounded_linear_Im4] lemmas sums_Im5 = bounded_linear.sums [OF bounded_linear_Im5] lemmas sums_Im6 = bounded_linear.sums [OF bounded_linear_Im6] lemmas sums_Im7 = bounded_linear.sums [OF bounded_linear_Im7] subsubsection\ Octonionic-specific theorems about sums. \ lemma Ree_sum [simp]: "Ree (sum f S) = sum (\x. Ree(f x)) S" and Im1_sum [simp]: "Im1 (sum f S) = sum (\x. Im1 (f x)) S" and Im2_sum [simp]: "Im2 (sum f S) = sum (\x. Im2 (f x)) S" and Im3_sum [simp]: "Im3 (sum f S) = sum (\x. Im3 (f x)) S" and Im4_sum [simp]: "Im4 (sum f S) = sum (\x. Im4 (f x)) S" and Im5_sum [simp]: "Im5 (sum f S) = sum (\x. Im5 (f x)) S" and Im6_sum [simp]: "Im6 (sum f S) = sum (\x. Im6 (f x)) S" and Im7_sum [simp]: "Im7 (sum f S) = sum (\x. Im7 (f x)) S" by (induct S rule: infinite_finite_induct; simp)+ subsubsection\ Bound results for real and imaginary components of limits. \ lemma Ree_tendsto_upperbound: "\(f \ limit) net; \\<^sub>F x in net. octo.Ree (f x) \ b; net \ bot\ \ Ree limit \ b" by (blast intro: tendsto_upperbound [OF tendsto_Re]) lemma Im1_tendsto_upperbound: "\(f \ limit) net; \\<^sub>F x in net. Im1 (f x) \ b; net \ bot\ \ Im1 limit \ b" by (blast intro: tendsto_upperbound [OF tendsto_Im1]) lemma Im2_tendsto_upperbound: "\(f \ limit) net; \\<^sub>F x in net. Im2 (f x) \ b; net \ bot\ \ Im2 limit \ b" by (blast intro: tendsto_upperbound [OF tendsto_Im2]) lemma Im3_tendsto_upperbound: "\(f \ limit) net; \\<^sub>F x in net. Im3 (f x) \ b; net \ bot\ \ Im3 limit \ b" by (blast intro: tendsto_upperbound [OF tendsto_Im3]) lemma Im4_tendsto_upperbound: "\(f \ limit) net; \\<^sub>F x in net. Im4 (f x) \ b; net \ bot\ \ Im4 limit \ b" by (blast intro: tendsto_upperbound [OF tendsto_Im4]) lemma Im5_tendsto_upperbound: "\(f \ limit) net; \\<^sub>F x in net. Im5 (f x) \ b; net \ bot\ \ Im5 limit \ b" by (blast intro: tendsto_upperbound [OF tendsto_Im5]) lemma Im6_tendsto_upperbound: "\(f \ limit) net; \\<^sub>F x in net. Im6 (f x) \ b; net \ bot\ \ Im6 limit \ b" by (blast intro: tendsto_upperbound [OF tendsto_Im6]) lemma Im7_tendsto_upperbound: "\(f \ limit) net; \\<^sub>F x in net. Im7 (f x) \ b; net \ bot\ \ Im7 limit \ b" by (blast intro: tendsto_upperbound [OF tendsto_Im7]) lemma Ree_tendsto_lowerbound: "\(f \ limit) net; \\<^sub>F x in net. b \ octo.Ree (f x); net \ bot\ \ b \ Ree limit" by (blast intro: tendsto_lowerbound [OF tendsto_Re]) lemma Im1_tendsto_lowerbound: "\(f \ limit) net; \\<^sub>F x in net. b \ Im1 (f x); net \ bot\ \ b \ Im1 limit" by (blast intro: tendsto_lowerbound [OF tendsto_Im1]) lemma Im2_tendsto_lowerbound: "\(f \ limit) net; \\<^sub>F x in net. b \ Im2 (f x); net \ bot\ \ b \ Im2 limit" by (blast intro: tendsto_lowerbound [OF tendsto_Im2]) lemma Im3_tendsto_lowerbound: "\(f \ limit) net; \\<^sub>F x in net. b \ Im3 (f x); net \ bot\ \ b \ Im3 limit" by (blast intro: tendsto_lowerbound [OF tendsto_Im3]) lemma Im4_tendsto_lowerbound: "\(f \ limit) net; \\<^sub>F x in net. b \ Im4 (f x); net \ bot\ \ b \ Im4 limit" by (blast intro: tendsto_lowerbound [OF tendsto_Im4]) lemma Im5_tendsto_lowerbound: "\(f \ limit) net; \\<^sub>F x in net. b \ Im5 (f x); net \ bot\ \ b \ Im5 limit" by (blast intro: tendsto_lowerbound [OF tendsto_Im5]) lemma Im6_tendsto_lowerbound: "\(f \ limit) net; \\<^sub>F x in net. b \ Im6 (f x); net \ bot\ \ b \ Im6 limit" by (blast intro: tendsto_lowerbound [OF tendsto_Im6]) lemma Im7_tendsto_lowerbound: "\(f \ limit) net; \\<^sub>F x in net. b \ Im7 (f x); net \ bot\ \ b \ Im7 limit" by (blast intro: tendsto_lowerbound [OF tendsto_Im7]) lemma octo_of_real_continuous [continuous_intros]: "continuous net f \ continuous net (\x. octo_of_real (f x))" by (auto simp: octo_of_real_def intro: continuous_intros) lemma octo_of_real_continuous_on [continuous_intros]: "continuous_on S f \ continuous_on S (\x. octo_of_real (f x))" by (auto simp: octo_of_real_def intro: continuous_intros) lemma of_real_continuous_iff: "continuous net (\x. octo_of_real (f x)) \ continuous net f" proof safe assume "continuous net (\x. octo_of_real (f x))" hence "continuous net (\x. Ree (octo_of_real (f x)))" by (rule continuous_Ree) thus "continuous net f" by simp qed (auto intro: continuous_intros) lemma of_real_continuous_on_iff: "continuous_on S (\x. octo_of_real(f x)) \ continuous_on S f" proof safe assume "continuous_on S (\x. octo_of_real (f x))" hence "continuous_on S (\x. Ree (octo_of_real (f x)))" by (rule continuous_on_Ree) thus "continuous_on S f" by simp qed (auto intro: continuous_intros) subsection\Octonions for describing 7D isometries\ subsubsection\The \HIm\ operator\ definition HIm :: "octo \ real^7" where "HIm q \ vector[Im1 q, Im2 q, Im3 q, Im4 q, Im5 q, Im6 q, Im7 q]" lemma HIm_Octo: "HIm (Octo w x y z u v q g) = vector[x,y,z, u, v, q, g]" by (simp add: HIm_def) lemma him_eq: "HIm a = HIm b \ Im1 a = Im1 b \ Im2 a = Im2 b \ Im3 a = Im3 b \ Im4 a = Im4 b \ Im5 a = Im5 b \ Im6 a = Im6 b \ Im7 a = Im7 b" by (metis HIm_def vector_7) lemma him_of_real [simp]: "HIm(octo_of_real a) = 0" by (simp add:octo_of_real_eq_Octo HIm_Octo vec_eq_iff vector_def) lemma him_0 [simp]: "HIm 0 = 0" by (metis him_of_real octo_of_real_0) lemma him_1 [simp]: "HIm 1 = 0" using HIm_def him_0 by auto lemma him_cnj: "HIm(cnj q) = - HIm q" by (simp add: HIm_def vec_eq_iff vector_def) lemma him_mult_left [simp]: "HIm (a *\<^sub>R q) = a *\<^sub>R HIm q" by (simp add: HIm_def vec_eq_iff vector_def) lemma him_mult_right [simp]: "HIm (q * octo_of_real a) = HIm q * of_real a" by (metis Octonions.scaleR_conv_octo_of_real Real_Vector_Spaces.scaleR_conv_of_real him_mult_left octo_of_real_times_commute semiring_normalization_rules(7)) lemma him_add [simp]: "HIm (x + y) = HIm x + HIm y" and him_minus [simp]: "HIm (-x) = - HIm x" and him_diff [simp]: "HIm (x - y) = HIm x - HIm y" by (simp_all add: HIm_def vec_eq_iff vector_def) lemma him_sum [simp]: "HIm (sum f S) = (\x\S. HIm (f x))" by (induct S rule: infinite_finite_induct) auto lemma linear_him: "linear HIm" by (simp add: linearI) subsubsection\The \Hv\ operator\ definition Hv :: "real^7 \ octo" where "Hv v \ Octo 0 (v1) (v2) (v3) (v4) (v5) (v6) (v7) " lemma Hv_sel [simp]: "Ree (Hv v) = 0" "Im1 (Hv v) = v  1" "Im2 (Hv v) = v  2" "Im3 (Hv v) = v  3" "Im4 (Hv v) = v  4" "Im5 (Hv v) = v  5" "Im6 (Hv v) = v  6" "Im7 (Hv v) = v  7" by (simp_all add: Hv_def) lemma hv_vec: "Hv(vec r) = Octo 0 r r r r r r r " by (simp add: Hv_def) lemma hv_eq_zero [simp]: "Hv v = 0 \ v = 0" by (simp add: octo_eq_iff vec_eq_iff) (metis exhaust_7) lemma hv_zero [simp]: "Hv 0 = 0" by simp lemma hv_vector [simp]: "Hv(vector[x,y,z,u,v,q,g]) = Octo 0 x y z u v q g" by (simp add: Hv_def) lemma hv_basis: "Hv(axis 1 1) = e1" "Hv(axis 2 1) = e2" "Hv(axis 3 1) = e3" "Hv(axis 4 1) = e4" "Hv(axis 5 1) = e5" "Hv(axis 6 1) = e6" "Hv(axis 7 1) = e7" by (simp_all add: octo_eq_iff) lemma hv_add [simp]: "Hv(x + y) = Hv x + Hv y" by (simp add: Hv_def octo_eq_iff) lemma hv_minus [simp]: "Hv(-x) = -Hv x" by (simp add: Hv_def octo_eq_iff) lemma hv_diff [simp]: "Hv(x - y) = Hv x - Hv y" by (simp add: Hv_def octo_eq_iff) lemma hv_cmult [simp]: "Hv(scaleR a x) = scaleR a ( Hv x)" by (simp add: Hv_def octo_eq_iff) lemma hv_sum [simp]: "Hv (sum f S) = (\x\S. Hv (f x))" by (induct S rule: infinite_finite_induct) auto lemma hv_inj: "Hv x = Hv y \ x = y" by (simp add: Hv_def octo_eq_iff vec_eq_iff) (metis (full_types) exhaust_7) lemma linear_hv: "linear Hv" using octo_of_real_def by (simp add: linearI) lemma him_hv [simp]: "HIm(Hv x) = x" using HIm_def hv_inj octo_eq_iff by fastforce lemma cnj_hv [simp]: "cnj(Hv v) = -Hv v" by (simp add: octo_eq_iff) lemma hv_him: "Hv(HIm q) = Octo 0 (Im1 q) (Im2 q) (Im3 q) (Im4 q) (Im5 q) (Im6 q) (Im7 q) " by (simp add: HIm_def) lemma hv_him_eq: "Hv(HIm q) = q \ Ree q = 0" by (simp add: hv_him octo_eq_iff) lemma dot_hv [simp]: "Hv u \ Hv v = u \ v" by (simp add: Hv_def inner_octo_def inner_vec_def sum_7) lemma norm_hv [simp]: "norm (Hv v) = norm v" by (simp add: norm_eq) subsubsection\Related basic identities \ lemma mult_hv_eq_cross_dot: "Hv x * Hv y = Hv(x \\<^sub>7 y) - octo_of_real (inner x y)" by (simp add: octo_eq_iff inner_octo_def cross7_components octo_mult_components inner_vec_def sum_7) lemma octonion_identity1_cross7 : "Hv (x \\<^sub>7 y) = (1/2) *\<^sub>R (Hv x * Hv y - Hv y * Hv x)" by (simp add: octo_eq_iff octo_mult_components cross7_components) lemma octonion_identity2_cross7: "Hv (x \\<^sub>7 (y \\<^sub>7 z) + y \\<^sub>7 (z \\<^sub>7 x) + z \\<^sub>7 (x \\<^sub>7 y)) = -(3/2) *\<^sub>R ((Hv x * Hv y) * Hv z - Hv x * (Hv y * Hv z))" unfolding octo_eq_iff octo_mult_components cross7_components Hv_sel scaleR_octo.sel vector_add_component minus_octo.sel mult_zero_left mult_zero_right add_0_left add_0_right diff_0 diff_0_right by algebra subsection\ Representing orthogonal transformations as conjugation or congruence with an octonion.\ lemma HIm_nth [simp]: "HIm x  1 = Im1 x" "HIm x  2 = Im2 x" "HIm x  3 = Im3 x" "HIm x  4 = Im4 x" "HIm x  5 = Im5 x" "HIm x  6 = Im6 x" "HIm x  7 = Im7 x" by (simp_all add: HIm_def) lemma orthogonal_transformation_octo_congruence: assumes "norm q = 1" shows "orthogonal_transformation (\x. HIm(cnj q * Hv x * q))" proof - have nq: "(Ree q)\<^sup>2 + (Im1 q)\<^sup>2 + (Im2 q)\<^sup>2 + (Im3 q)\<^sup>2 + (Im4 q)\<^sup>2 + (Im5 q)\<^sup>2 + (Im6 q)\<^sup>2 + (Im7 q)\<^sup>2 = 1" using assms norm_octo_def by auto have "Vector_Spaces.linear (*\<^sub>R) (*\<^sub>R) (\x. HIm (Octonions.cnj q * Hv x * q))" by unfold_locales (simp_all add: octo_distrib_left octo_distrib_right octo_mult_scaleR_left octo_mult_scaleR_right) moreover have "HIm (Octonions.cnj q * Hv v * q) \ HIm (Octonions.cnj q * Hv w * q) = ((Ree q)\<^sup>2 + (Im1 q)\<^sup>2 + (Im2 q)\<^sup>2 + (Im3 q)\<^sup>2+ (Im4 q)\<^sup>2 + (Im5 q)\<^sup>2 + (Im6 q)\<^sup>2 + (Im7 q)\<^sup>2)^2 * (v \ w)" for v w unfolding octo_mult_components cnj.sel Hv_sel inner_vec_def sum_7 HIm_nth inner_real_def by algebra ultimately show ?thesis by (simp add: orthogonal_transformation_def linear_def nq) qed lemma orthogonal_transformation_octo_conjugation: assumes "q \ 0" shows "orthogonal_transformation (\x. HIm (inverse q * Hv x * q))" proof - obtain c d where eq: "q = octo_of_real c * d" and 1: "norm d = 1" proof show 1: "q = octo_of_real (norm q) * (inverse (octo_of_real (norm q)) * q)" using assms norm_eq_zero right_inverse multiplicative_norm_octo by (metis Octonions.scaleR_conv_octo_of_real octo_of_real_inverse scaleR_one scaleR_scaleR) show "norm (inverse (octo_of_real (norm q)) * q) = 1" using assms 1 norm_octo_def norm_mult inverse_octo_1 inverse_octo_1_sym nonzero_octo_of_real_inverse octo_inverse_eq_cnj cnj_of_real mult_cancel_left2 multiplicative_norm_octo norm_eq_zero norm_octo_squared norm_power2_cnj octo_mult_cnj_conv_norm power2_eq_square_octo by metis qed have "c \ 0" using assms eq by (metis Octonions.scaleR_conv_octo_of_real scale_zero_left) then have "HIm (Octonions.cnj d * Hv x * d) = HIm (inverse (octo_of_real c * d) * Hv x * (octo_of_real c * d))" for x proof(simp add: flip: octo_inverse_eq_cnj [OF 1] of_real_inverse) assume "c \ 0" then have "inverse d = inverse d * inverse (c *\<^sub>R 1) * c *\<^sub>R 1" using octo_of_real_def octo_of_real_inverse octo_of_real_inverse_collapse(1) octo_of_real_times_commute octo_of_real_times_left_commute by force then have "inverse d * Hv x * d = inverse (c *\<^sub>R 1 * d) * Hv x * c *\<^sub>R (d * 1)" by (metis (no_types) mult_1_right_octo octo_inverse_mult octo_mult_scaleR_left octo_mult_scaleR_right) then show "HIm (inverse d * Hv x * d) = HIm (inverse (octo_of_real c * d) * Hv x * (octo_of_real c * d))" using octo_mult_scaleR_right octo_of_real_def octo_of_real_times_commute by presburger qed then show ?thesis using orthogonal_transformation_octo_congruence [OF 1] by (simp add: eq) qed unbundle no_cross7_syntax bundle octonion_syntax begin notation octo_e0 ("e0") notation octo_e1 ("e1") notation octo_e2 ("e2") notation octo_e3 ("e3") notation octo_e4 ("e4") notation octo_e5 ("e5") notation octo_e6 ("e6") notation octo_e7 ("e7") end bundle no_octonion_syntax begin no_notation octo_e0 ("e0") no_notation octo_e1 ("e1") no_notation octo_e2 ("e2") no_notation octo_e3 ("e3") no_notation octo_e4 ("e4") no_notation octo_e5 ("e5") no_notation octo_e6 ("e6") no_notation octo_e7 ("e7") end unbundle no_octonion_syntax hide_const (open) Octonions.cnj end \ No newline at end of file diff --git a/thys/Octonions/ROOT b/thys/Octonions/ROOT --- a/thys/Octonions/ROOT +++ b/thys/Octonions/ROOT @@ -1,9 +1,9 @@ chapter AFP session "Octonions" = "HOL-Analysis" + options [timeout = 600] theories Octonions document_files "root.bib" - "root.tex" \ No newline at end of file + "root.tex" diff --git a/thys/Order_Lattice_Props/Closure_Operators.thy b/thys/Order_Lattice_Props/Closure_Operators.thy --- a/thys/Order_Lattice_Props/Closure_Operators.thy +++ b/thys/Order_Lattice_Props/Closure_Operators.thy @@ -1,514 +1,516 @@ (* Title: Closure and Co-Closure Operators Author: Georg Struth Maintainer: Georg Struth *) section \Closure and Co-Closure Operators\ theory Closure_Operators imports Galois_Connections begin subsection \Closure Operators\ text \Closure and coclosure operators in orders and complete lattices are defined in this section, and some basic properties are proved. Isabelle infers the appropriate types. Facts are taken mainly from the Compendium of Continuous Lattices~\<^cite>\"GierzHKLMS80"\ and Rosenthal's book on quantales~\<^cite>\"Rosenthal90"\.\ definition clop :: "('a::order \ 'a) \ bool" where "clop f = (id \ f \ mono f \ f \ f \ f)" lemma clop_extensive: "clop f \ id \ f" by (simp add: clop_def) lemma clop_extensive_var: "clop f \ x \ f x" by (simp add: clop_def le_fun_def) lemma clop_iso: "clop f \ mono f" by (simp add: clop_def) lemma clop_iso_var: "clop f \ x \ y \ f x \ f y" by (simp add: clop_def mono_def) lemma clop_idem: "clop f \ f \ f = f" by (simp add: antisym clop_def le_fun_def) lemma clop_Fix_range: "clop f \ (Fix f = range f)" by (simp add: clop_idem retraction_prop_fix) lemma clop_idem_var: "clop f \ f (f x) = f x" by (simp add: clop_idem retraction_prop) lemma clop_Inf_closed_var: fixes f :: "'a::complete_lattice \ 'a" shows "clop f \ f \ Inf \ () f = Inf \ () f" unfolding clop_def mono_def comp_def le_fun_def by (metis (mono_tags, lifting) antisym id_apply le_INF_iff order_refl) lemma clop_top: fixes f :: "'a::complete_lattice \ 'a" shows "clop f \ f \ = \" by (simp add: clop_extensive_var top.extremum_uniqueI) lemma "clop (f::'a::complete_lattice \ 'a) \ f (\x \ X. f x) = (\x \ X. f x)" (*nitpick*) oops lemma "clop (f::'a::complete_lattice \ 'a) \ f (f x \ f y) = f x \ f y" (*nitpick*) oops lemma "clop (f::'a::complete_lattice \ 'a) \ f \ = \" (*nitpick *) oops lemma "clop (f::'a set \ 'a set) \ f (\x \ X. f x) = (\x \ X. f x)" (*nitpick*) oops lemma "clop (f::'a set \ 'a set) \ f (f x \ f y) = f x \ f y" (*nitpick*) oops lemma "clop (f::'a set \ 'a set) \ f \ = \" (*nitpick *) oops lemma clop_closure: "clop f \ (x \ range f) = (f x = x)" by (simp add: clop_idem retraction_prop) lemma clop_closure_set: "clop f \ range f = Fix f" by (simp add: clop_Fix_range) lemma clop_closure_prop: "(clop::('a::complete_lattice_with_dual\ 'a) \ bool) (Inf \$$" by (simp add: clop_def mono_def) lemma clop_closure_prop_var: "clop (\x::'a::complete_lattice. \{y. x \ y})" unfolding clop_def comp_def le_fun_def mono_def by (simp add: Inf_lower le_Inf_iff) lemma clop_alt: "(clop f) = (\x y. x \ f y \ f x \ f y)" unfolding clop_def mono_def le_fun_def comp_def id_def by (meson dual_order.refl order_trans) text \Finally it is shown that adjoints in a Galois connection yield closure operators.\ lemma clop_adj: fixes f :: "'a::order \ 'b::order" shows "f \ g \ clop (g \ f)" by (simp add: adj_cancel2 adj_idem2 adj_iso4 clop_def) text \Closure operators are monads for posets, and monads arise from adjunctions. This fact is not formalised at this point. But here is the first step: every function can be decomposed into a surjection followed by an injection.\ definition "surj_on f Y = (\y \ Y. \x. y = f x)" lemma surj_surj_on: "surj f \ surj_on f Y" by (simp add: surjD surj_on_def) lemma fun_surj_inj: "\g h. f = g \ h \ surj_on h (range f) \ inj_on g (range f)" proof- obtain h where a: "\x. f x = h x" by blast then have "surj_on h (range f)" by (metis (mono_tags, lifting) imageE surj_on_def) then show ?thesis unfolding inj_on_def surj_on_def fun_eq_iff using a by auto qed text \Connections between downsets, upsets and closure operators are outlined next.\ lemma preorder_clop: "clop (\::'a::preorder set \ 'a set)" by (simp add: clop_def downset_set_ext downset_set_iso) lemma clop_preorder_aux: "clop f \ (x \ f {y} \ f {x} \ f {y})" by (simp add: clop_alt) lemma clop_preorder: "clop f \ class.preorder (\x y. f {x} \ f {y}) (\x y. f {x} \ f {y})" unfolding clop_def mono_def le_fun_def id_def comp_def by standard (auto simp: subset_not_subset_eq) lemma preorder_clop_dual: "clop (\::'a::preorder_with_dual set \ 'a set)" by (simp add: clop_def upset_set_anti upset_set_ext) text \The closed elements of any closure operator over a complete lattice form an Inf-closed set (a Moore family).\ lemma clop_Inf_closed: fixes f :: "'a::complete_lattice \ 'a" shows "clop f \ Inf_closed_set (Fix f)" unfolding clop_def Inf_closed_set_def mono_def le_fun_def comp_def id_def Fix_def - by (smt Inf_greatest Inf_lower antisym mem_Collect_eq subsetCE) + by (smt (verit) Inf_greatest Inf_lower antisym mem_Collect_eq subsetCE) lemma clop_top_Fix: fixes f :: "'a::complete_lattice \ 'a" shows "clop f \ \ \ Fix f" by (simp add: clop_Fix_range clop_closure clop_top) text \Conversely, every Inf-closed subset of a complete lattice is the set of fixpoints of some closure operator.\ lemma Inf_closed_clop: fixes X :: "'a::complete_lattice set" shows "Inf_closed_set X \ clop (\y. \{x \ X. y \ x})" - by (smt Collect_mono_iff Inf_superset_mono clop_alt dual_order.trans le_Inf_iff mem_Collect_eq) + by (smt (verit) Collect_mono_iff Inf_superset_mono clop_alt dual_order.trans le_Inf_iff mem_Collect_eq) lemma Inf_closed_clop_var: fixes X :: "'a::complete_lattice set" shows "clop f \ \x \ X. x \ range f \ \X \ range f" by (metis Inf_closed_set_def clop_Fix_range clop_Inf_closed subsetI) text \It is well known that downsets and upsets over an ordering form subalgebras of the complete powerset lattice.\ typedef (overloaded) 'a downsets = "range (\::'a::order set \ 'a set)" by fastforce setup_lifting type_definition_downsets typedef (overloaded) 'a upsets = "range (\::'a::order set \ 'a set)" by fastforce setup_lifting type_definition_upsets instantiation downsets :: (order) Inf_lattice begin lift_definition Inf_downsets :: "'a downsets set \ 'a downsets" is "Abs_downsets \ Inf \ () Rep_downsets". lift_definition less_eq_downsets :: "'a downsets \ 'a downsets \ bool" is "\X Y. Rep_downsets X \ Rep_downsets Y". lift_definition less_downsets :: "'a downsets \ 'a downsets \ bool" is "\X Y. Rep_downsets X \ Rep_downsets Y". instance apply intro_classes apply (transfer, simp) apply (transfer, blast) apply (simp add: Closure_Operators.less_eq_downsets.abs_eq Rep_downsets_inject) - apply (transfer, smt Abs_downsets_inverse INF_lower Inf_closed_clop_var Rep_downsets image_iff o_def preorder_clop) - by transfer (smt comp_def Abs_downsets_inverse Inf_closed_clop_var Rep_downsets image_iff le_INF_iff preorder_clop) + apply (transfer, smt (verit) Abs_downsets_inverse INF_lower Inf_closed_clop_var Rep_downsets image_iff o_def preorder_clop) + apply (transfer, smt (verit) comp_def Abs_downsets_inverse Inf_closed_clop_var Rep_downsets image_iff le_INF_iff preorder_clop) + done end instantiation upsets :: (order_with_dual) Inf_lattice begin lift_definition Inf_upsets :: "'a upsets set \ 'a upsets" is "Abs_upsets \ Inf \ () Rep_upsets". lift_definition less_eq_upsets :: "'a upsets \ 'a upsets \ bool" is "\X Y. Rep_upsets X \ Rep_upsets Y". lift_definition less_upsets :: "'a upsets \ 'a upsets \ bool" is "\X Y. Rep_upsets X \ Rep_upsets Y". instance apply intro_classes apply (transfer, simp) apply (transfer, blast) apply (simp add: Closure_Operators.less_eq_upsets.abs_eq Rep_upsets_inject) - apply (transfer, smt Abs_upsets_inverse Inf_closed_clop_var Inf_lower Rep_upsets comp_apply image_iff preorder_clop_dual) - by transfer (smt comp_def Abs_upsets_inverse Inf_closed_clop_var Inter_iff Rep_upsets image_iff preorder_clop_dual subsetCE subsetI) + apply (transfer, smt (verit) Abs_upsets_inverse Inf_closed_clop_var Inf_lower Rep_upsets comp_apply image_iff preorder_clop_dual) + apply (transfer, smt (verit) comp_def Abs_upsets_inverse Inf_closed_clop_var Inter_iff Rep_upsets image_iff preorder_clop_dual subsetCE subsetI) + done end text \It has already been shown in the section on representations that the map ds, which maps elements of the order to its downset, is an order embedding. However, the duality between the underlying ordering and the lattices of up- and down-closed sets as categories can probably not be expressed, as there is no easy access to contravariant functors. \ subsection \Co-Closure Operators\ text \Next, the co-closure (or kernel) operation satisfies dual laws.\ definition coclop :: "('a::order \ 'a::order) \ bool" where "coclop f = (f \ id \ mono f \ f \ f \ f)" lemma coclop_dual: "(coclop::('a::order_with_dual \ 'a) \ bool) = clop \ \\<^sub>F" unfolding coclop_def clop_def id_def mono_def map_dual_def comp_def fun_eq_iff le_fun_def by (metis invol_dual_var ord_dual) lemma coclop_dual_var: fixes f :: "'a::order_with_dual \ 'a" shows "coclop f = clop (\\<^sub>F f)" by (simp add: coclop_dual) lemma clop_dual: "(clop::('a::order_with_dual \ 'a) \ bool) = coclop \ \\<^sub>F" by (simp add: coclop_dual comp_assoc map_dual_invol) lemma clop_dual_var: fixes f :: "'a::order_with_dual \ 'a" shows "clop f = coclop (\\<^sub>F f)" by (simp add: clop_dual) lemma coclop_coextensive: "coclop f \ f \ id" by (simp add: coclop_def) lemma coclop_coextensive_var: "coclop f \ f x \ x" using coclop_def le_funD by fastforce lemma coclop_iso: "coclop f \ mono f" by (simp add: coclop_def) lemma coclop_iso_var: "coclop f \ (x \ y \ f x \ f y)" by (simp add: coclop_iso monoD) lemma coclop_idem: "coclop f \ f \ f = f" by (simp add: antisym coclop_def le_fun_def) lemma coclop_closure: "coclop f \ (x \ range f) = (f x = x)" by (simp add: coclop_idem retraction_prop) lemma coclop_Fix_range: "coclop f \ (Fix f = range f)" by (simp add: coclop_idem retraction_prop_fix) lemma coclop_idem_var: "coclop f \ f (f x) = f x" by (simp add: coclop_idem retraction_prop) lemma coclop_Sup_closed_var: fixes f :: "'a::complete_lattice_with_dual \ 'a" shows "coclop f \ f \ Sup \ () f = Sup \ () f" unfolding coclop_def mono_def comp_def le_fun_def by (metis (mono_tags, lifting) SUP_le_iff antisym id_apply order_refl) lemma Sup_closed_coclop_var: fixes X :: "'a::complete_lattice set" shows "coclop f \ \x \ X. x \ range f \ \X \ range f" - by (smt Inf.INF_id_eq Sup.SUP_cong antisym coclop_closure coclop_coextensive_var coclop_iso id_apply mono_SUP) + by (smt (verit) Inf.INF_id_eq Sup.SUP_cong antisym coclop_closure coclop_coextensive_var coclop_iso id_apply mono_SUP) lemma coclop_bot: fixes f :: "'a::complete_lattice_with_dual \ 'a" shows "coclop f \ f \ = \" by (simp add: bot.extremum_uniqueI coclop_coextensive_var) lemma "coclop (f::'a::complete_lattice \ 'a) \ f (\x \ X. f x) = (\x \ X. f x)" (*nitpick*) oops lemma "coclop (f::'a::complete_lattice \ 'a) \ f (f x \ f y) = f x \ f y" (*nitpick*) oops lemma "coclop (f::'a::complete_lattice \ 'a) \ f \ = \" (*nitpick*) oops lemma "coclop (f::'a set \ 'a set) \ f (\x \ X. f x) = (\x \ X. f x)" (*nitpick*) oops lemma "coclop (f::'a set \ 'a set) \ f (f x \ f y) = f x \ f y" (*nitpick*) oops lemma "coclop (f::'a set \ 'a set) \ f \ = \" (*nitpick *) oops lemma coclop_coclosure: "coclop f \ f x = x \ x \ range f" by (simp add: coclop_idem retraction_prop) lemma coclop_coclosure_set: "coclop f \ range f = Fix f" by (simp add: coclop_idem retraction_prop_fix) lemma coclop_coclosure_prop: "(coclop::('a::complete_lattice \ 'a) \ bool) (Sup \ \)" by (simp add: coclop_def mono_def) lemma coclop_coclosure_prop_var: "coclop (\x::'a::complete_lattice. \{y. y \ x})" by (metis (mono_tags, lifting) Sup_atMost atMost_def coclop_def comp_apply eq_id_iff eq_refl mono_def) lemma coclop_alt: "(coclop f) = (\x y. f x \ y \ f x \ f y)" unfolding coclop_def mono_def le_fun_def comp_def id_def by (meson dual_order.refl order_trans) lemma coclop_adj: fixes f :: "'a::order \ 'b::order" shows "f \ g \ coclop (f \ g)" by (simp add: adj_cancel1 adj_idem1 adj_iso3 coclop_def) text \Finally, a subset of a complete lattice is Sup-closed if and only if it is the set of fixpoints of some co-closure operator.\ lemma coclop_Sup_closed: fixes f :: "'a::complete_lattice \ 'a" shows "coclop f \ Sup_closed_set (Fix f)" unfolding coclop_def Sup_closed_set_def mono_def le_fun_def comp_def id_def Fix_def - by (smt Sup_least Sup_upper antisym_conv mem_Collect_eq subsetCE) + by (smt (verit) Sup_least Sup_upper antisym_conv mem_Collect_eq subsetCE) lemma Sup_closed_coclop: fixes X :: "'a::complete_lattice set" shows "Sup_closed_set X \ coclop (\y. \{x \ X. x \ y})" unfolding Sup_closed_set_def coclop_def mono_def le_fun_def comp_def apply safe apply (metis (no_types, lifting) Sup_least eq_id_iff mem_Collect_eq) - apply (smt Collect_mono_iff Sup_subset_mono dual_order.trans) + apply (smt (verit) Collect_mono_iff Sup_subset_mono dual_order.trans) by (simp add: Collect_mono_iff Sup_subset_mono Sup_upper) subsection \Complete Lattices of Closed Elements\ text \The machinery developed allows showing that the closed elements in a complete lattice (with respect to some closure operation) form themselves a complete lattice.\ class cl_op = ord + fixes cl_op :: "'a \ 'a" assumes clop_ext: "x \ cl_op x" and clop_iso: "x \ y \ cl_op x \ cl_op y" and clop_wtrans: "cl_op (cl_op x) \ cl_op x" class clattice_with_clop = complete_lattice + cl_op begin lemma clop_cl_op: "clop cl_op" unfolding clop_def le_fun_def comp_def by (simp add: cl_op_class.clop_ext cl_op_class.clop_iso cl_op_class.clop_wtrans order_class.mono_def) lemma clop_idem [simp]: "cl_op \ cl_op = cl_op" using clop_ext clop_wtrans order.antisym by auto lemma clop_idem_var [simp]: "cl_op (cl_op x) = cl_op x" by (simp add: order.antisym clop_ext clop_wtrans) lemma clop_range_Fix: "range cl_op = Fix cl_op" by (simp add: retraction_prop_fix) lemma Inf_closed_cl_op_var: fixes X :: "'a set" shows "\x \ X. x \ range cl_op \ \X \ range cl_op" proof- assume h: "\x \ X. x \ range cl_op" hence "\x \ X. cl_op x = x" by (simp add: retraction_prop) hence "cl_op (\X) = \X" by (metis Inf_lower clop_ext clop_iso dual_order.antisym le_Inf_iff) thus ?thesis by (metis rangeI) qed lemma inf_closed_cl_op_var: "x \ range cl_op \ y \ range cl_op \ x \ y \ range cl_op" - by (smt Inf_closed_cl_op_var UnI1 insert_iff insert_is_Un inf_Inf) + by (smt (verit) Inf_closed_cl_op_var UnI1 insert_iff insert_is_Un inf_Inf) end typedef (overloaded) 'a::clattice_with_clop cl_op_im = "range (cl_op::'a \ 'a)" by force setup_lifting type_definition_cl_op_im lemma cl_op_prop [iff]: "(cl_op (x \ y) = cl_op y) = (cl_op (x::'a::clattice_with_clop) \ cl_op y)" - by (smt cl_op_class.clop_iso clop_ext clop_wtrans inf_sup_ord(4) le_iff_sup sup.absorb_iff1 sup_left_commute) + by (smt (verit) cl_op_class.clop_iso clop_ext clop_wtrans inf_sup_ord(4) le_iff_sup sup.absorb_iff1 sup_left_commute) lemma cl_op_prop_var [iff]: "(cl_op (x \ cl_op y) = cl_op y) = (cl_op (x::'a::clattice_with_clop) \ cl_op y)" by (metis cl_op_prop clattice_with_clop_class.clop_idem_var) instantiation cl_op_im :: (clattice_with_clop) complete_lattice begin lift_definition Inf_cl_op_im :: "'a cl_op_im set \ 'a cl_op_im" is Inf by (simp add: Inf_closed_cl_op_var) lift_definition Sup_cl_op_im :: "'a cl_op_im set \ 'a cl_op_im" is "\X. cl_op (\X)" by simp lift_definition inf_cl_op_im :: "'a cl_op_im \ 'a cl_op_im \ 'a cl_op_im" is inf by (simp add: inf_closed_cl_op_var) lift_definition sup_cl_op_im :: "'a cl_op_im \ 'a cl_op_im \ 'a cl_op_im" is "\x y. cl_op (x \ y)" by simp lift_definition less_eq_cl_op_im :: "'a cl_op_im \ 'a cl_op_im \ bool" is "(\)". lift_definition less_cl_op_im :: "'a cl_op_im \ 'a cl_op_im \ bool" is "(<)". lift_definition bot_cl_op_im :: "'a cl_op_im" is "cl_op \" by simp lift_definition top_cl_op_im :: "'a cl_op_im" is "\" by (simp add: clop_cl_op clop_closure clop_top) instance apply (intro_classes; transfer) apply (simp_all add: less_le_not_le Inf_lower Inf_greatest) apply (meson clop_cl_op clop_extensive_var dual_order.trans inf_sup_ord(3)) apply (meson clop_cl_op clop_extensive_var dual_order.trans sup_ge2) apply (metis cl_op_class.clop_iso clop_cl_op clop_closure le_sup_iff) apply (meson Sup_upper clop_cl_op clop_extensive_var dual_order.trans) by (metis Sup_le_iff cl_op_class.clop_iso clop_cl_op clop_closure) end text \This statement is perhaps less useful as it might seem, because it is difficult to make it cooperate with concrete closure operators, which one would not generally like to define within a type class. Alternatively, a sublocale statement could perhaps be given. It would also have been nice to prove this statement for Sup-lattices---this would have cut down the number of proof obligations significantly. But this would require a tighter integration of these structures. A similar statement could have been proved for co-closure operators. But this would not lead to new insights.\ text \Next I show that for every surjective Sup-preserving function between complete lattices there is a closure operator such that the set of closed elements is isomorphic to the range of the surjection.\ lemma surj_Sup_pres_id: fixes f :: "'a::complete_lattice_with_dual \ 'b::complete_lattice_with_dual" assumes "surj f" and "Sup_pres f" shows "f \ (radj f) = id" proof- have "f \ (radj f)" using Sup_pres_ladj assms(2) radj_adj by auto thus ?thesis using adj_sur_inv assms(1) by blast qed lemma surj_Sup_pres_inj: fixes f :: "'a::complete_lattice_with_dual \ 'b::complete_lattice_with_dual" assumes "surj f" and "Sup_pres f" shows "inj (radj f)" by (metis assms comp_eq_dest_lhs id_apply injI surj_Sup_pres_id) lemma surj_Sup_pres_inj_on: fixes f :: "'a::complete_lattice_with_dual \ 'b::complete_lattice_with_dual" assumes "surj f" and "Sup_pres f" shows "inj_on f (range (radj f \ f))" - by (smt Sup_pres_ladj_aux adj_idem2 assms(2) comp_apply inj_on_def retraction_prop) + by (smt (verit) Sup_pres_ladj_aux adj_idem2 assms(2) comp_apply inj_on_def retraction_prop) lemma surj_Sup_pres_bij_on: fixes f :: "'a::complete_lattice_with_dual \ 'b::complete_lattice_with_dual" assumes "surj f" and "Sup_pres f" shows "bij_betw f (range (radj f \ f)) UNIV" unfolding bij_betw_def apply safe apply (simp add: assms(1) assms(2) surj_Sup_pres_inj_on cong del: image_cong_simp) apply auto apply (metis (mono_tags) UNIV_I assms(1) assms(2) comp_apply id_apply image_image surj_Sup_pres_id surj_def) done text \Thus the restriction of $f$ to the set of closed elements is indeed a bijection. The final fact shows that it preserves Sups of closed elements, and hence is an isomorphism of complete lattices.\ lemma surj_Sup_pres_iso: fixes f :: "'a::complete_lattice_with_dual \ 'b::complete_lattice_with_dual" assumes "surj f" and "Sup_pres f" shows "f ((radj f \ f) (\X)) = (\x \ X. f x)" by (metis assms(1) assms(2) comp_def pointfree_idE surj_Sup_pres_id) subsection \A Quick Example: Dedekind-MacNeille Completions\ text \I only outline the basic construction. Additional facts about join density, and that the completion yields the least complete lattice that contains all Sups and Infs of the underlying posets, are left for future consideration.\ abbreviation "dm \ lb_set \ ub_set" lemma up_set_prop: "(X::'a::preorder set) \ {} \ ub_set X = \{\x |x. x \ X}" unfolding ub_set_def upset_def upset_set_def by (safe, simp_all, blast) lemma lb_set_prop: "(X::'a::preorder set) \ {} \ lb_set X = \{\x |x. x \ X}" unfolding lb_set_def downset_def downset_set_def by (safe, simp_all, blast) lemma dm_downset_var: "dm {x} = $$x::'a::preorder)" unfolding lb_set_def ub_set_def downset_def downset_set_def by (clarsimp, meson order_refl order_trans) lemma dm_downset: "dm \ \ = (\::'a::preorder \ 'a set)" using dm_downset_var fun.map_cong by fastforce lemma dm_inj: "inj ((dm::'a::order set \ 'a set) \$$" by (simp add: dm_downset downset_inj) lemma "clop (lb_set \ ub_set)" unfolding clop_def lb_set_def ub_set_def apply safe unfolding le_fun_def comp_def id_def mono_def by auto end diff --git a/thys/Order_Lattice_Props/Galois_Connections.thy b/thys/Order_Lattice_Props/Galois_Connections.thy --- a/thys/Order_Lattice_Props/Galois_Connections.thy +++ b/thys/Order_Lattice_Props/Galois_Connections.thy @@ -1,243 +1,243 @@ (* Title: Galois Connections Author: Georg Struth Maintainer: Georg Struth *) section \Galois Connections\ theory Galois_Connections imports Order_Lattice_Props begin subsection \Definitions and Basic Properties\ text \The approach follows the Compendium of Continuous Lattices~\<^cite>\"GierzHKLMS80"\, without attempting completeness. First, left and right adjoints of a Galois connection are defined.\ definition adj :: "('a::ord \ 'b::ord) \ ('b \ 'a) \ bool" (infixl "\" 70) where "(f \ g) = (\x y. (f x \ y) = (x \ g y))" definition "ladj (g::'a::Inf \ 'b::ord) = (\x. \{y. x \ g y})" definition "radj (f::'a::Sup \ 'b::ord) = (\y. \{x. f x \ y})" lemma ladj_radj_dual: fixes f :: "'a::complete_lattice_with_dual \ 'b::ord_with_dual" shows "ladj f x = \ (radj (\\<^sub>F f) (\ x))" proof- have "ladj f x = \ ($$\  {y. \ (f y) \ \ x}))" unfolding ladj_def by (metis (no_types, lifting) Collect_cong Inf_dual_var dual_dual_ord dual_iff) also have "... = \ (\{\ y|y. \ (f y) \ \ x})" by (simp add: setcompr_eq_image) ultimately show ?thesis unfolding ladj_def radj_def map_dual_def comp_def - by (smt Collect_cong invol_dual_var) + by (smt (verit) Collect_cong invol_dual_var) qed lemma radj_ladj_dual: fixes f :: "'a::complete_lattice_with_dual \ 'b::ord_with_dual" shows "radj f x = \ (ladj (\\<^sub>F f) (\ x))" by (metis fun_dual5 invol_dual_var ladj_radj_dual map_dual_def) lemma ladj_prop: fixes g :: "'b::Inf \ 'a::ord_with_dual" shows "ladj g = Inf \ (-) g \ \" unfolding ladj_def vimage_def upset_prop fun_eq_iff comp_def by simp lemma radj_prop: fixes f :: "'b::Sup \ 'a::ord" shows "radj f = Sup \ (-) f \ \" unfolding radj_def vimage_def downset_prop fun_eq_iff comp_def by simp text \The first set of properties holds without any sort assumptions.\ lemma adj_iso1: "f \ g \ mono f" unfolding adj_def mono_def by (meson dual_order.refl dual_order.trans) lemma adj_iso2: "f \ g \ mono g" unfolding adj_def mono_def by (meson dual_order.refl dual_order.trans) lemma adj_comp: "f \ g \ adj h k \ (f \ h) \ (k \ g)" by (simp add: adj_def) lemma adj_dual: fixes f :: "'a::ord_with_dual \ 'b::ord_with_dual" shows "f \ g = (\\<^sub>F g) \ (\\<^sub>F f)" unfolding adj_def map_dual_def comp_def by (metis (mono_tags, opaque_lifting) dual_dual_ord invol_dual_var) subsection \Properties for (Pre)Orders\ text \The next set of properties holds in preorders or orders.\ lemma adj_cancel1: fixes f :: "'a::preorder \ 'b::ord" shows "f \ g \ f \ g \ id" by (simp add: adj_def le_funI) lemma adj_cancel2: fixes f :: "'a::ord \ 'b::preorder" shows "f \ g \ id \ g \ f" by (simp add: adj_def eq_iff le_funI) lemma adj_prop: fixes f :: "'a::preorder \'a" shows "f \ g \ f \ g \ g \ f" using adj_cancel1 adj_cancel2 order_trans by blast lemma adj_cancel_eq1: fixes f :: "'a::preorder \ 'b::order" shows "f \ g \ f \ g \ f = f" unfolding adj_def comp_def fun_eq_iff by (meson eq_iff order_refl order_trans) lemma adj_cancel_eq2: fixes f :: "'a::order \ 'b::preorder" shows "f \ g \ g \ f \ g = g" unfolding adj_def comp_def fun_eq_iff by (meson eq_iff order_refl order_trans) lemma adj_idem1: fixes f :: "'a::preorder \ 'b::order" shows "f \ g \ (f \ g) \ (f \ g) = f \ g" by (simp add: adj_cancel_eq1 rewriteL_comp_comp) lemma adj_idem2: fixes f :: "'a::order \ 'b::preorder" shows "f \ g \ (g \ f) \ (g \ f) = g \ f" by (simp add: adj_cancel_eq2 rewriteL_comp_comp) lemma adj_iso3: fixes f :: "'a::order \ 'b::order" shows "f \ g \ mono (f \ g)" by (simp add: adj_iso1 adj_iso2 monoD monoI) lemma adj_iso4: fixes f :: "'a::order \ 'b::order" shows "f \ g \ mono (g \ f)" by (simp add: adj_iso1 adj_iso2 monoD monoI) lemma adj_canc1: fixes f :: "'a::order \ 'b::ord" shows "f \ g \ ((f \ g) x = (f \ g) y \ g x = g y)" unfolding adj_def comp_def by (metis eq_iff) lemma adj_canc2: fixes f :: "'a::ord \ 'b::order" shows "f \ g \ ((g \ f) x = (g \ f) y \ f x = f y)" unfolding adj_def comp_def by (metis eq_iff) lemma adj_sur_inv: fixes f :: "'a::preorder \ 'b::order" shows "f \ g \ ((surj f) = (f \ g = id))" unfolding adj_def surj_def comp_def by (metis eq_id_iff eq_iff order_refl order_trans) lemma adj_surj_inj: fixes f :: "'a::order \ 'b::order" shows "f \ g \ ((surj f) = (inj g))" unfolding adj_def inj_def surj_def by (metis eq_iff order_trans) lemma adj_inj_inv: fixes f :: "'a::preorder \ 'b::order" shows "f \ g \ ((inj f) = (g \ f = id))" by (metis adj_cancel_eq1 eq_id_iff inj_def o_apply) lemma adj_inj_surj: fixes f :: "'a::order \ 'b::order" shows "f \ g \ ((inj f) = (surj g))" unfolding adj_def inj_def surj_def by (metis eq_iff order_trans) lemma surj_id_the_inv: "surj f \ g \ f = id \ g = the_inv f" by (metis comp_apply id_apply inj_on_id inj_on_imageI2 surj_fun_eq the_inv_f_f) lemma inj_id_the_inv: "inj f \ f \ g = id \ f = the_inv g" proof - assume a1: "inj f" assume "f \ g = id" hence "\x. the_inv g x = f x" using a1 by (metis (no_types) comp_apply eq_id_iff inj_on_id inj_on_imageI2 the_inv_f_f) thus ?thesis by presburger qed subsection \Properties for Complete Lattices\ text \The next laws state that a function between complete lattices preserves infs if and only if it has a lower adjoint.\ lemma radj_Inf_pres: fixes g :: "'b::complete_lattice \ 'a::complete_lattice" shows "(\f. f \ g) \ Inf_pres g" apply (rule antisym, simp_all add: le_fun_def adj_def, safe) apply (meson INF_greatest Inf_lower dual_order.refl dual_order.trans) by (meson Inf_greatest dual_order.refl le_INF_iff) lemma ladj_Sup_pres: fixes f :: "'a::complete_lattice_with_dual \ 'b::complete_lattice_with_dual" shows "(\g. f \ g) \ Sup_pres f" using Sup_pres_map_dual_var adj_dual radj_Inf_pres by blast lemma radj_adj: fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows "f \ g \ g = (radj f)" unfolding adj_def radj_def by (metis (mono_tags, lifting) cSup_eq_maximum eq_iff mem_Collect_eq) lemma ladj_adj: fixes g :: "'b::complete_lattice_with_dual \ 'a::complete_lattice_with_dual" shows "f \ g \ f = (ladj g)" unfolding adj_def ladj_def by (metis (no_types, lifting) cInf_eq_minimum eq_iff mem_Collect_eq) lemma Inf_pres_radj_aux: fixes g :: "'a::complete_lattice \ 'b::complete_lattice" shows "Inf_pres g \ (ladj g) \ g" proof- assume a: "Inf_pres g" {fix x y assume b: "ladj g x \ y" hence "g (ladj g x) \ g y" by (simp add: Inf_subdistl_iso a monoD) hence "\{g y |y. x \ g y} \ g y" by (metis a comp_eq_dest_lhs setcompr_eq_image ladj_def) hence "x \ g y" using dual_order.trans le_Inf_iff by blast hence "ladj g x \ y \ x \ g y" by simp} thus ?thesis unfolding adj_def ladj_def by (meson CollectI Inf_lower) qed lemma Sup_pres_ladj_aux: fixes f :: "'a::complete_lattice_with_dual \ 'b::complete_lattice_with_dual" shows "Sup_pres f \ f \ (radj f)" by (metis (no_types, opaque_lifting) Inf_pres_radj_aux Sup_pres_map_dual_var adj_dual fun_dual5 map_dual_def radj_adj) lemma Inf_pres_radj: fixes g :: "'b::complete_lattice \ 'a::complete_lattice" shows "Inf_pres g \ (\f. f \ g)" using Inf_pres_radj_aux by fastforce lemma Sup_pres_ladj: fixes f :: "'a::complete_lattice_with_dual \ 'b::complete_lattice_with_dual" shows "Sup_pres f \ (\g. f \ g)" using Sup_pres_ladj_aux by fastforce lemma Inf_pres_upper_adj_eq: fixes g :: "'b::complete_lattice \ 'a::complete_lattice" shows "(Inf_pres g) = (\f. f \ g)" using radj_Inf_pres Inf_pres_radj by blast lemma Sup_pres_ladj_eq: fixes f :: "'a::complete_lattice_with_dual \ 'b::complete_lattice_with_dual" shows "(Sup_pres f) = (\g. f \ g)" using Sup_pres_ladj ladj_Sup_pres by blast lemma Sup_downset_adj: "(Sup::'a::complete_lattice set \ 'a) \ \" unfolding adj_def downset_prop Sup_le_iff by force lemma Sup_downset_adj_var: "(Sup (X::'a::complete_lattice set) \ y) = (X \ \y)" using Sup_downset_adj adj_def by auto text \Once again many statements arise by duality, which Isabelle usually picks up.\ end \ No newline at end of file diff --git a/thys/Order_Lattice_Props/Order_Duality.thy b/thys/Order_Lattice_Props/Order_Duality.thy --- a/thys/Order_Lattice_Props/Order_Duality.thy +++ b/thys/Order_Lattice_Props/Order_Duality.thy @@ -1,315 +1,315 @@ (* Title: Ad-Hoc Duality for Orderings and Lattices Author: Georg Struth Maintainer: Georg Struth *) section \Ad-Hoc Duality for Orderings and Lattices\ theory Order_Duality imports Sup_Lattice begin text \This component presents an "explicit" formalisation of order and lattice duality. It augments the data type based one used by Wenzel in his lattice components \<^cite>\"Wenzel"\, and complements the "implicit" formalisation given by locales. It uses a functor dual, supplied within a type class, which is simply a bijection (isomorphism) between types, with the constraint that the dual of a dual object is the original object. In Wenzel's formalisation, by contrast, dual is a bijection, but not idempotent or involutive. In the past, Preoteasa has used a similar approach with Isabelle~\<^cite>\"Preoteasa11b"\.\ text \Duality is such a fundamental concept in order and lattice theory that it probably deserves to be included in the type classes for these objects, as in this section.\ class dual = fixes dual :: "'a \ 'a" ("\") assumes inj_dual: "inj \" and invol_dual [simp]: "\ \ \ = id" text \This type class allows one to define a type dual. It is actually a dependent type for which dual can be instantiated.\ typedef (overloaded) 'a dual = "range (dual::'a::dual \ 'a)" by fastforce setup_lifting type_definition_dual text \At the moment I have no use for this type.\ context dual begin lemma invol_dual_var [simp]: "\ (\ x) = x" by (simp add: pointfree_idE) lemma surj_dual: "surj \" unfolding surj_def by (metis invol_dual_var) lemma bij_dual: "bij \" by (simp add: bij_def inj_dual surj_dual) lemma inj_dual_iff: "(\ x = \ y) = (x = y)" by (meson inj_dual injD) lemma dual_iff: "(\ x = y) = (x = \ y)" by auto lemma the_inv_dual: "the_inv \ = \" by (metis comp_apply id_def invol_dual_var inj_dual surj_dual surj_fun_eq the_inv_f_o_f_id) end text \In boolean algebras, duality is of course De Morgan duality and can be expressed within the language.\ sublocale boolean_algebra \ ba_dual: dual "uminus" by (unfold_locales, simp_all add: inj_def) definition map_dual:: "('a \ 'b) \ 'a::dual \ 'b::dual" ("\\<^sub>F") where "\\<^sub>F f = \ \ f \ \" lemma map_dual_func1: "\\<^sub>F (f \ g) = \\<^sub>F f \ \\<^sub>F g" by (metis (no_types, lifting) comp_assoc comp_id invol_dual map_dual_def) lemma map_dual_func2 [simp]: "\\<^sub>F id = id" by (simp add: map_dual_def) lemma map_dual_nat_iso: "\\<^sub>F f \ \ = \ \ id f" by (simp add: comp_assoc map_dual_def) lemma map_dual_invol [simp]: "\\<^sub>F \ \\<^sub>F = id" unfolding map_dual_def comp_def fun_eq_iff by simp text \Thus map-dual is naturally isomorphic to the identify functor: The function dual is a natural transformation between map-dual and the identity functor, and, because it has a two-sided inverse --- itself, it is a natural isomorphism.\ text \The generic function set-dual provides another natural transformation (see below). Before introducing it, we introduce useful notation for a widely used function.\ abbreviation "\ \ (\x. {x})" lemma eta_inj: "inj \" by simp definition "set_dual = \ \ \" lemma set_dual_prop: "set_dual (\ x) = {x}" by (metis comp_apply dual_iff set_dual_def) text \The next four lemmas show that (functional) image and preimage are functors (on functions). This does not really belong here, but it is useful for what follows. The interaction between duality and (pre)images is needed in applications.\ lemma image_func1: "() (f \ g) = () f \ () g" unfolding fun_eq_iff by (simp add: image_comp) lemma image_func2: "() id = id" by simp lemma vimage_func1: "(-) (f \ g) = (-) g \ (-) f" unfolding fun_eq_iff by (simp add: vimage_comp) lemma vimage_func2: "(-) id = id" by simp lemma iso_image: "mono (() f)" by (simp add: image_mono monoI) lemma iso_preimage: "mono ((-) f)" by (simp add: monoI vimage_mono) context dual begin lemma image_dual [simp]: "() \ \ () \ = id" by (metis image_func1 image_func2 invol_dual) lemma vimage_dual [simp]: "(-) \ \ (-) \ = id" by (simp add: set.comp) end text \The following natural transformation between the powerset functor (image) and the identity functor is well known.\ lemma power_set_func_nat_trans: "\ \ id f = () f \ \" unfolding fun_eq_iff comp_def by simp text \As an instance, set-dual is a natural transformation with built-in type coercion.\ lemma dual_singleton: "() \ \ \ = \ \ \" by auto lemma finite_dual [simp]: "finite \ () \ = finite" unfolding fun_eq_iff comp_def using inj_dual finite_vimageI inj_vimage_image_eq by fastforce lemma finite_dual_var [simp]: "finite (\  X) = finite X" by (metis comp_def finite_dual) lemma subset_dual: "(X = \  Y) = (\  X = Y)" by (metis image_dual pointfree_idE) lemma subset_dual1: "(X \ Y) = (\  X \ \  Y)" by (simp add: inj_dual inj_image_subset_iff) lemma dual_empty [simp]: "\  {} = {}" by simp lemma dual_UNIV [simp]: "\  UNIV = UNIV" by (simp add: surj_dual) lemma fun_dual1: "(f = g \$$ = (f \ \ = g)" by (metis comp_assoc comp_id invol_dual) lemma fun_dual2: "(f = \ \ g) = (\ \ f = g)" by (metis comp_assoc fun.map_id invol_dual) lemma fun_dual3: "(f = g \ () \) = (f \ () \ = g)" by (metis comp_id image_dual o_assoc) lemma fun_dual4: "(f = () \ \ g) = (() \ \ f = g)" by (metis comp_assoc id_comp image_dual) lemma fun_dual5: "(f = \ \ g \ \) = (\ \ f \ \ = g)" by (metis comp_assoc fun_dual1 fun_dual2) lemma fun_dual6: "(f = () \ \ g \ () \) = (() \ \ f \ () \ = g)" by (simp add: comp_assoc fun_dual3 fun_dual4) lemma fun_dual7: "(f = \ \ g \ () \) = (\ \ f \ () \ = g)" by (simp add: comp_assoc fun_dual2 fun_dual3) lemma fun_dual8: "(f = () \ \ g \ \) = (() \ \ f \ \ = g)" by (simp add: comp_assoc fun_dual1 fun_dual4) lemma map_dual_dual: "(\\<^sub>F f = g) = (\\<^sub>F g = f)" by (metis map_dual_invol pointfree_idE) text \The next facts show incrementally that the dual of a complete lattice is a complete lattice.\ class ord_with_dual = dual + ord + assumes ord_dual: "x \ y \ \ y \ \ x" begin lemma dual_dual_ord: "(\ x \ \ y) = (y \ x)" by (metis dual_iff ord_dual) end lemma ord_pres_dual: fixes f :: "'a::ord_with_dual \ 'b::ord_with_dual" shows "ord_pres f \ ord_pres (\\<^sub>F f)" by (simp add: dual_dual_ord map_dual_def ord_pres_def) lemma map_dual_anti: "(f::'a::ord_with_dual \ 'b::ord_with_dual) \ g \ \\<^sub>F g \ \\<^sub>F f" by (simp add: le_fun_def map_dual_def ord_dual) class preorder_with_dual = ord_with_dual + preorder begin lemma less_dual_def_var: "(\ y < \ x) = (x < y)" by (simp add: dual_dual_ord less_le_not_le) end class order_with_dual = preorder_with_dual + order lemma iso_map_dual: fixes f :: "'a::order_with_dual \ 'b::order_with_dual" shows "mono f \ mono (\\<^sub>F f)" by (simp add: ord_pres_dual ord_pres_mono) class lattice_with_dual = lattice + dual + assumes sup_dual_def: "\ (x \ y) = \ x \ \ y" begin subclass order_with_dual by (unfold_locales, metis inf.absorb_iff2 sup_absorb1 sup_commute sup_dual_def) lemma inf_dual: "\ (x \ y) = \ x \ \ y" by (metis invol_dual_var sup_dual_def) lemma inf_to_sup: "x \ y = \ (\ x \ \ y)" using inf_dual dual_iff by fastforce lemma sup_to_inf: "x \ y = \ (\ x \ \ y)" by (simp add: inf_dual) end class bounded_lattice_with_dual = lattice_with_dual + bounded_lattice begin lemma bot_dual: "\ \ = \" by (metis dual_dual_ord dual_iff le_bot top_greatest) lemma top_dual: "\ \ = \" using bot_dual dual_iff by force end class boolean_algebra_with_dual = lattice_with_dual + boolean_algebra sublocale boolean_algebra \ badual: boolean_algebra_with_dual _ _ _ _ _ _ _ _ uminus by unfold_locales simp_all class Sup_lattice_with_dual = Sup_lattice + dual + assumes Sups_dual_def: "\ \ Sup = Infs \ () \" class Inf_lattice_with_dual = Inf_lattice + dual + assumes Sups_dual_def: "\ \ Supi = Inf \ () \" class complete_lattice_with_dual = complete_lattice + dual + assumes Sups_dual_def: "\ \ Sup = Inf \ () \" sublocale Sup_lattice_with_dual \ sclatd: complete_lattice_with_dual Infs Sup infs "(\)" le sups bots tops "\" by (unfold_locales, simp add: Sups_dual_def) sublocale Inf_lattice_with_dual \ iclatd: complete_lattice_with_dual Inf Supi infi "(\)" le supi boti topi "\" by (unfold_locales, simp add: Sups_dual_def) context complete_lattice_with_dual begin lemma Inf_dual: "\ \ Inf = Sup \ () \" by (metis comp_assoc comp_id fun.map_id Sups_dual_def image_dual invol_dual) lemma Inf_dual_var: "\ (\X) = $$\  X)" using comp_eq_dest Inf_dual by fastforce lemma Inf_to_Sup: "Inf = \ \ Sup \ () \" by (auto simp add: Sups_dual_def image_comp) lemma Inf_to_Sup_var: "\X = \ (\(\  X))" using Inf_dual_var dual_iff by fastforce lemma Sup_to_Inf: "Sup = \ \ Inf \ () \" by (auto simp add: Inf_dual image_comp) lemma Sup_to_Inf_var: "\X = \ (\(\  X))" using Sup_to_Inf by force lemma Sup_dual_def_var: "\ (\X) = \ (\  X)" using comp_eq_dest Sups_dual_def by fastforce lemma bot_dual_def: "\ \ = \" - by (smt Inf_UNIV Sup_UNIV Sups_dual_def surj_dual o_eq_dest) + by (smt (verit) Inf_UNIV Sup_UNIV Sups_dual_def surj_dual o_eq_dest) lemma top_dual_def: "\ \ = \" using bot_dual_def dual_iff by blast lemma inf_dual2: "\ (x \ y) = \ x \ \ y" - by (smt comp_eq_elim Inf_dual Inf_empty Inf_insert SUP_insert inf_top.right_neutral) + by (smt (verit) comp_eq_elim Inf_dual Inf_empty Inf_insert SUP_insert inf_top.right_neutral) lemma sup_dual: "\ (x \ y) = \ x \ \ y" by (metis inf_dual2 dual_iff) subclass lattice_with_dual by (unfold_locales, auto simp: inf_dual sup_dual) subclass bounded_lattice_with_dual.. end end diff --git a/thys/Order_Lattice_Props/Order_Lattice_Props.thy b/thys/Order_Lattice_Props/Order_Lattice_Props.thy --- a/thys/Order_Lattice_Props/Order_Lattice_Props.thy +++ b/thys/Order_Lattice_Props/Order_Lattice_Props.thy @@ -1,1227 +1,1227 @@ (* Title: Properties of Orderings and Lattices Author: Georg Struth Maintainer: Georg Struth *) section \Properties of Orderings and Lattices\ theory Order_Lattice_Props imports Order_Duality begin subsection \Basic Definitions for Orderings and Lattices\ text \The first definition is for order morphisms --- isotone (order-preserving, monotone) functions. An order isomorphism is an order-preserving bijection. This should be defined in the class ord, but mono requires order.\ definition ord_homset :: "('a::order \ 'b::order) set" where "ord_homset = {f::'a::order \ 'b::order. mono f}" definition ord_embed :: "('a::order \ 'b::order) \ bool" where "ord_embed f = (\x y. f x \ f y \ x \ y)" definition ord_iso :: "('a::order \ 'b::order) \ bool" where "ord_iso = bij \ mono \ (mono \ the_inv)" lemma ord_embed_alt: "ord_embed f = (mono f \ (\x y. f x \ f y \ x \ y))" using mono_def ord_embed_def by auto lemma ord_embed_homset: "ord_embed f \ f \ ord_homset" by (simp add: mono_def ord_embed_def ord_homset_def) lemma ord_embed_inj: "ord_embed f \ inj f" unfolding ord_embed_def inj_def by (simp add: eq_iff) lemma ord_iso_ord_embed: "ord_iso f \ ord_embed f" unfolding ord_iso_def ord_embed_def bij_def inj_def mono_def by (clarsimp, metis inj_def the_inv_f_f) lemma ord_iso_alt: "ord_iso f = (ord_embed f \ surj f)" unfolding ord_iso_def ord_embed_def surj_def bij_def inj_def mono_def apply safe by simp_all (metis eq_iff inj_def the_inv_f_f)+ lemma ord_iso_the_inv: "ord_iso f \ mono (the_inv f)" by (simp add: ord_iso_def) lemma ord_iso_inv1: "ord_iso f \ (the_inv f) \ f = id" using ord_embed_inj ord_iso_ord_embed the_inv_into_f_f by fastforce lemma ord_iso_inv2: "ord_iso f \ f \ (the_inv f) = id" using f_the_inv_into_f ord_embed_inj ord_iso_alt by fastforce typedef (overloaded) ('a,'b) ord_homset = "ord_homset::('a::order \ 'b::order) set" by (force simp: ord_homset_def mono_def) setup_lifting type_definition_ord_homset text \The next definition is for the set of fixpoints of a given function. It is important in the context of orders, for instance for proving Tarski's fixpoint theorem, but does not really belong here.\ definition Fix :: "('a \ 'a) \ 'a set" where "Fix f = {x. f x = x}" lemma retraction_prop: "f \ f = f \ f x = x \ x \ range f" by (metis comp_apply f_inv_into_f rangeI) lemma retraction_prop_fix: "f \ f = f \ range f = Fix f" unfolding Fix_def using retraction_prop by fastforce lemma Fix_map_dual: "Fix \ \\<^sub>F = () \ \ Fix" unfolding Fix_def map_dual_def comp_def fun_eq_iff - by (smt Collect_cong invol_dual pointfree_idE setcompr_eq_image) + by (smt (verit) Collect_cong invol_dual pointfree_idE setcompr_eq_image) lemma Fix_map_dual_var: "Fix (\\<^sub>F f) = \  (Fix f)" by (metis Fix_map_dual o_def) lemma gfp_dual: "(\::'a::complete_lattice_with_dual \ 'a) \ gfp = lfp \ \\<^sub>F" proof- {fix f:: "'a \ 'a" have "\ (gfp f) = \ (\{u. u \ f u})" by (simp add: gfp_def) also have "... = \(\  {u. u \ f u})" by (simp add: Sup_dual_def_var) also have "... = \{\ u |u. u \ f u}" by (simp add: setcompr_eq_image) also have "... = \{u |u. (\\<^sub>F f) u \ u}" by (metis (no_types, opaque_lifting) dual_dual_ord dual_iff map_dual_def o_def) finally have "\ (gfp f) = lfp (\\<^sub>F f)" by (metis lfp_def)} thus ?thesis by auto qed lemma gfp_dual_var: fixes f :: "'a::complete_lattice_with_dual \ 'a" shows "\ (gfp f) = lfp (\\<^sub>F f)" using comp_eq_elim gfp_dual by blast lemma gfp_to_lfp: "gfp = (\::'a::complete_lattice_with_dual \ 'a) \ lfp \ \\<^sub>F" by (simp add: comp_assoc fun_dual2 gfp_dual) lemma gfp_to_lfp_var: fixes f :: "'a::complete_lattice_with_dual \ 'a" shows "gfp f = \ (lfp (\\<^sub>F f))" by (metis gfp_dual_var invol_dual_var) lemma lfp_dual: "(\::'a::complete_lattice_with_dual \ 'a) \ lfp = gfp \ \\<^sub>F" by (simp add: comp_assoc gfp_to_lfp map_dual_invol) lemma lfp_dual_var: fixes f :: "'a::complete_lattice_with_dual \ 'a" shows "\ (lfp f) = gfp (map_dual f)" using comp_eq_dest_lhs lfp_dual by fastforce lemma lfp_to_gfp: "lfp = (\::'a::complete_lattice_with_dual \ 'a) \ gfp \ \\<^sub>F" by (simp add: comp_assoc gfp_dual map_dual_invol) lemma lfp_to_gfp_var: fixes f :: "'a::complete_lattice_with_dual \ 'a" shows "lfp f = \ (gfp (\\<^sub>F f))" by (metis invol_dual_var lfp_dual_var) lemma lfp_in_Fix: fixes f :: "'a::complete_lattice \ 'a" shows "mono f \ lfp f \ Fix f" by (metis (mono_tags, lifting) Fix_def lfp_unfold mem_Collect_eq) lemma gfp_in_Fix: fixes f :: "'a::complete_lattice \ 'a" shows "mono f \ gfp f \ Fix f" by (metis (mono_tags, lifting) Fix_def gfp_unfold mem_Collect_eq) lemma nonempty_Fix: fixes f :: "'a::complete_lattice \ 'a" shows "mono f \ Fix f \ {}" using lfp_in_Fix by fastforce text \Next the minimal and maximal elements of an ordering are defined.\ context ord begin definition min_set :: "'a set \ 'a set" where "min_set X = {y \ X. \x \ X. x \ y \ x = y}" definition max_set :: "'a set \ 'a set" where "max_set X = {x \ X. \y \ X. x \ y \ x = y}" end context ord_with_dual begin lemma min_max_set_dual: "() \ \ min_set = max_set \ () \" unfolding max_set_def min_set_def fun_eq_iff comp_def apply safe using dual_dual_ord inj_dual_iff by auto lemma min_max_set_dual_var: "\  (min_set X) = max_set (\  X)" using comp_eq_dest min_max_set_dual by fastforce lemma max_min_set_dual: "() \ \ max_set = min_set \ () \" by (metis (no_types, opaque_lifting) comp_id fun.map_comp id_comp image_dual min_max_set_dual) lemma min_to_max_set: "min_set = () \ \ max_set \ () \" by (metis comp_id image_dual max_min_set_dual o_assoc) lemma max_min_set_dual_var: "\  (max_set X) = min_set (\  X)" using comp_eq_dest max_min_set_dual by fastforce lemma min_to_max_set_var: "min_set X = \  (max_set (\  X))" by (simp add: max_min_set_dual_var pointfree_idE) end text \Next, directed and filtered sets, upsets, downsets, filters and ideals in posets are defined.\ context ord begin definition directed :: "'a set \ bool" where "directed X = (\Y. finite Y \ Y \ X \ (\x \ X. \y \ Y. y \ x))" definition filtered :: "'a set \ bool" where "filtered X = (\Y. finite Y \ Y \ X \ (\x \ X. \y \ Y. x \ y))" definition downset_set :: "'a set \ 'a set" ("\") where "\X = {y. \x \ X. y \ x}" definition upset_set :: "'a set \ 'a set" ("\") where "\X = {y. \x \ X. x \ y}" definition downset :: "'a \ 'a set" ("\") where "\ = \ \ \" definition upset :: "'a \ 'a set" ("\") where "\ = \ \ \" definition downsets :: "'a set set" where "downsets = Fix \" definition upsets :: "'a set set" where "upsets = Fix \" definition "downclosed_set X = (X \ downsets)" definition "upclosed_set X = (X \ upsets)" definition ideals :: "'a set set" where "ideals = {X. X \ {} \ downclosed_set X \ directed X}" definition filters :: "'a set set" where "filters = {X. X \ {} \ upclosed_set X \ filtered X}" abbreviation "idealp X \ X \ ideals" abbreviation "filterp X \ X \ filters" end text \These notions are pair-wise dual.\ text \Filtered and directed sets are dual.\ context ord_with_dual begin lemma filtered_directed_dual: "filtered \ () \ = directed" unfolding filtered_def directed_def fun_eq_iff comp_def apply clarsimp apply safe apply (meson finite_imageI imageI image_mono dual_dual_ord) - by (smt finite_subset_image imageE ord_dual) + by (smt (verit, ccfv_threshold) finite_subset_image imageE ord_dual) lemma directed_filtered_dual: "directed \ () \ = filtered" using filtered_directed_dual by (metis comp_id image_dual o_assoc) lemma filtered_to_directed: "filtered X = directed (\  X)" by (metis comp_apply directed_filtered_dual) text \Upsets and downsets are dual.\ lemma downset_set_upset_set_dual: "() \ \ \ = \ \ () \" unfolding downset_set_def upset_set_def fun_eq_iff comp_def apply safe apply (meson image_eqI ord_dual) by (clarsimp, metis (mono_tags, lifting) dual_iff image_iff mem_Collect_eq ord_dual) lemma upset_set_downset_set_dual: "() \ \ \ = \ \ () \" using downset_set_upset_set_dual by (metis (no_types, opaque_lifting) comp_id id_comp image_dual o_assoc) lemma upset_set_to_downset_set: "\ = () \ \ \ \ () \" by (simp add: comp_assoc downset_set_upset_set_dual) lemma upset_set_to_downset_set2: "\ X = \  (\ (\  X))" by (simp add: upset_set_to_downset_set) lemma downset_upset_dual: "() \ \ \ = \ \ \" using downset_def upset_def upset_set_to_downset_set by fastforce lemma upset_to_downset: "() \ \ \ = \ \ \" by (metis comp_assoc id_apply ord.downset_def ord.upset_def power_set_func_nat_trans upset_set_downset_set_dual) lemma upset_to_downset2: "\ = () \ \ \ \ \" by (simp add: comp_assoc downset_upset_dual) lemma upset_to_downset3: "\ x = \  (\ (\ x))" by (simp add: upset_to_downset2) lemma downsets_upsets_dual: "(X \ downsets) = (\  X \ upsets)" unfolding downsets_def upsets_def Fix_def - by (smt comp_eq_dest downset_set_upset_set_dual image_inv_f_f inj_dual mem_Collect_eq) + by (smt (verit) comp_eq_dest downset_set_upset_set_dual image_inv_f_f inj_dual mem_Collect_eq) lemma downset_setp_upset_setp_dual: "upclosed_set \ () \ = downclosed_set" unfolding downclosed_set_def upclosed_set_def using downsets_upsets_dual by fastforce lemma upsets_to_downsets: "(X \ upsets) = (\  X \ downsets)" by (simp add: downsets_upsets_dual image_comp) lemma upset_setp_downset_setp_dual: "downclosed_set \ () \ = upclosed_set" by (metis comp_id downset_setp_upset_setp_dual image_dual o_assoc) text \Filters and ideals are dual.\ lemma ideals_filters_dual: "(X \ ideals) = ((\  X) \ filters)" - by (smt comp_eq_dest_lhs directed_filtered_dual image_inv_f_f image_is_empty inv_unique_comp filters_def ideals_def inj_dual invol_dual mem_Collect_eq upset_setp_downset_setp_dual) + by (smt (verit) comp_eq_dest_lhs directed_filtered_dual image_inv_f_f image_is_empty inv_unique_comp filters_def ideals_def inj_dual invol_dual mem_Collect_eq upset_setp_downset_setp_dual) lemma idealp_filterp_dual: "idealp = filterp \ () \" unfolding fun_eq_iff by (simp add: ideals_filters_dual) lemma filters_to_ideals: "(X \ filters) = ((\  X) \ ideals)" by (simp add: ideals_filters_dual image_comp) lemma filterp_idealp_dual: "filterp = idealp \ () \" unfolding fun_eq_iff by (simp add: filters_to_ideals) end subsection \Properties of Orderings\ context ord begin lemma directed_nonempty: "directed X \ X \ {}" unfolding directed_def by fastforce lemma directed_ub: "directed X \ (\x \ X. \y \ X. \z \ X. x \ z \ y \ z)" by (meson empty_subsetI directed_def finite.emptyI finite_insert insert_subset order_refl) lemma downset_set_prop: "\ = Union \ () \" unfolding downset_set_def downset_def fun_eq_iff by fastforce lemma downset_set_prop_var: "\X = (\x \ X. \x)" by (simp add: downset_set_prop) lemma downset_prop: "\x = {y. y \ x}" unfolding downset_def downset_set_def fun_eq_iff by fastforce lemma downset_prop2: "y \ x \ y \ \x" by (simp add: downset_prop) lemma ideals_downsets: "X \ ideals \ X \ downsets" by (simp add: downclosed_set_def ideals_def) lemma ideals_directed: "X \ ideals \ directed X" by (simp add: ideals_def) end context preorder begin lemma directed_prop: "X \ {} \ (\x \ X. \y \ X. \z \ X. x \ z \ y \ z) \ directed X" proof- assume h1: "X \ {}" and h2: "\x \ X. \y \ X. \z \ X. x \ z \ y \ z" {fix Y have "finite Y \ Y \ X \ (\x \ X. \y \ Y. y \ x)" proof (induct rule: finite_induct) case empty then show ?case using h1 by blast next case (insert x F) then show ?case by (metis h2 insert_iff insert_subset order_trans) qed} thus ?thesis by (simp add: directed_def) qed lemma directed_alt: "directed X = (X \ {} \ (\x \ X. \y \ X. \z \ X. x \ z \ y \ z))" by (metis directed_prop directed_nonempty directed_ub) lemma downset_set_prop_var2: "x \ \X \ y \ x \ y \ \X" unfolding downset_set_def using order_trans by blast lemma downclosed_set_iff: "downclosed_set X = (\x \ X. \y. y \ x \ y \ X)" unfolding downclosed_set_def downsets_def Fix_def downset_set_def by auto lemma downclosed_downset_set: "downclosed_set (\X)" by (simp add: downclosed_set_iff downset_set_prop_var2 downset_def) lemma downclosed_downset: "downclosed_set (\x)" by (simp add: downclosed_downset_set downset_def) lemma downset_set_ext: "id \ \" unfolding le_fun_def id_def downset_set_def by auto lemma downset_set_iso: "mono \" unfolding mono_def downset_set_def by blast lemma downset_set_idem [simp]: "\ \ \ = \" unfolding fun_eq_iff downset_set_def using order_trans by auto lemma downset_faithful: "\x \ \y \ x \ y" by (simp add: downset_prop subset_eq) lemma downset_iso_iff: "(\x \ \y) = (x \ y)" using atMost_iff downset_prop order_trans by blast text \The following proof uses the Axiom of Choice.\ lemma downset_directed_downset_var [simp]: "directed (\X) = directed X" proof assume h1: "directed X" {fix Y assume h2: "finite Y" and h3: "Y \ \X" hence "\y. \x. y \ Y \ x \ X \ y \ x" by (force simp: downset_set_def) hence "\f. \y. y \ Y \ f y \ X \ y \ f y" by (rule choice) hence "\f. finite (f  Y) \ f  Y \ X \ (\y \ Y. y \ f y)" by (metis finite_imageI h2 image_subsetI) hence "\Z. finite Z \ Z \ X \ (\y \ Y. \ z \ Z. y \ z)" by fastforce hence "\Z. finite Z \ Z \ X \ (\y \ Y. \ z \ Z. y \ z) \ (\x \ X. \ z \ Z. z \ x)" by (metis directed_def h1) hence "\x \ X. \y \ Y. y \ x" by (meson order_trans)} thus "directed (\X)" unfolding directed_def downset_set_def by fastforce next assume "directed (\X)" thus "directed X" unfolding directed_def downset_set_def apply clarsimp - by (smt Ball_Collect order_refl order_trans subsetCE) + by (smt (verit) Ball_Collect order_refl order_trans subsetCE) qed lemma downset_directed_downset [simp]: "directed \ \ = directed" unfolding fun_eq_iff by simp lemma directed_downset_ideals: "directed (\X) = (\X \ ideals)" by (metis (mono_tags, lifting) CollectI Fix_def directed_alt downset_set_idem downclosed_set_def downsets_def ideals_def o_def ord.ideals_directed) lemma downclosed_Fix: "downclosed_set X = (\X = X)" by (metis (mono_tags, lifting) CollectD Fix_def downclosed_downset_set downclosed_set_def downsets_def) end lemma downset_iso: "mono (\::'a::order \ 'a set)" by (simp add: downset_iso_iff mono_def) lemma mono_downclosed: fixes f :: "'a::order \ 'b::order" assumes "mono f" shows "\Y. downclosed_set Y \ downclosed_set (f - Y)" by (simp add: assms downclosed_set_iff monoD) lemma fixes f :: "'a::order \ 'b::order" assumes "mono f" shows "\Y. downclosed_set X \ downclosed_set (f  X)" (*nitpick*) oops lemma downclosed_mono: fixes f :: "'a::order \ 'b::order" assumes "\Y. downclosed_set Y \ downclosed_set (f - Y)" shows "mono f" proof- {fix x y :: "'a::order" assume h: "x \ y" have "downclosed_set (\ (f y))" unfolding downclosed_set_def downsets_def Fix_def downset_set_def downset_def by auto hence "downclosed_set (f - (\ (f y)))" by (simp add: assms) hence "downclosed_set {z. f z \ f y}" unfolding vimage_def downset_def downset_set_def by auto hence "\z w. (f z \ f y \ w \ z) \ f w \ f y" unfolding downclosed_set_def downclosed_set_def downsets_def Fix_def downset_set_def by force hence "f x \ f y" using h by blast} thus ?thesis.. qed lemma mono_downclosed_iff: "mono f = (\Y. downclosed_set Y \ downclosed_set (f - Y))" using mono_downclosed downclosed_mono by auto context order begin lemma downset_inj: "inj \" by (metis injI downset_iso_iff order.eq_iff) lemma "(X \ Y) = (\X \ \Y)" (*nitpick*) oops end context lattice begin lemma lat_ideals: "X \ ideals = (X \ {} \ X \ downsets \ (\x \ X. \ y \ X. x \ y \ X))" unfolding ideals_def directed_alt downsets_def Fix_def downset_set_def downclosed_set_def - by (clarsimp, smt sup.cobounded1 sup.orderE sup.orderI sup_absorb2 sup_left_commute mem_Collect_eq) + using local.sup.bounded_iff local.sup_ge2 by blast + end context bounded_lattice begin lemma bot_ideal: "X \ ideals \ \ \ X" unfolding ideals_def downclosed_set_def downsets_def Fix_def downset_set_def by fastforce end context complete_lattice begin lemma Sup_downset_id [simp]: "Sup \ \ = id" using Sup_atMost atMost_def downset_prop by fastforce lemma downset_Sup_id: "id \ \ \ Sup" by (simp add: Sup_upper downset_prop le_funI subsetI) lemma Inf_Sup_var: "\(\x \ X. \x) = \X" unfolding downset_prop by (simp add: Collect_ball_eq Inf_eq_Sup) lemma Inf_pres_downset_var: "(\x \ X. \x) = \(\X)" unfolding downset_prop by (safe, simp_all add: le_Inf_iff) end subsection \Dual Properties of Orderings\ context ord_with_dual begin lemma filtered_nonempty: "filtered X \ X \ {}" using filtered_to_directed ord.directed_nonempty by auto lemma filtered_lb: "filtered X \ (\x \ X. \y \ X. \z \ X. z \ x \ z \ y)" using filtered_to_directed directed_ub dual_dual_ord by fastforce lemma upset_set_prop_var: "\X = (\x \ X. \x)" by (simp add: image_Union downset_set_prop_var upset_set_to_downset_set2 upset_to_downset2) lemma upset_set_prop: "\ = Union \ () \" unfolding fun_eq_iff by (simp add: upset_set_prop_var) lemma upset_prop: "\x = {y. x \ y}" unfolding upset_to_downset3 downset_prop image_def using dual_dual_ord by fastforce lemma upset_prop2: "x \ y \ y \ \x" by (simp add: upset_prop) lemma filters_upsets: "X \ filters \ X \ upsets" by (simp add: upclosed_set_def filters_def) lemma filters_filtered: "X \ filters \ filtered X" by (simp add: filters_def) end context preorder_with_dual begin lemma filtered_prop: "X \ {} \ (\x \ X. \y \ X. \z \ X. z \ x \ z \ y) \ filtered X" unfolding filtered_to_directed by (rule directed_prop, blast, metis (full_types) image_iff ord_dual) lemma filtered_alt: "filtered X = (X \ {} \ (\x \ X. \y \ X. \z \ X. z \ x \ z \ y))" by (metis image_empty directed_alt filtered_to_directed filtered_lb filtered_prop) lemma up_set_prop_var2: "x \ \X \ x \ y \ y \ \X" using downset_set_prop_var2 dual_iff ord_dual upset_set_to_downset_set2 by fastforce lemma upclosed_set_iff: "upclosed_set X = (\x \ X. \y. x \ y \ y \ X)" unfolding upclosed_set_def upsets_def Fix_def upset_set_def by auto lemma upclosed_upset_set: "upclosed_set (\X)" using up_set_prop_var2 upclosed_set_iff by blast lemma upclosed_upset: "upclosed_set (\x)" by (simp add: upset_def upclosed_upset_set) lemma upset_set_ext: "id \ \" - by (smt comp_def comp_id image_mono le_fun_def downset_set_ext image_dual upset_set_to_downset_set2) + by (smt (verit) comp_def comp_id image_mono le_fun_def downset_set_ext image_dual upset_set_to_downset_set2) lemma upset_set_anti: "mono \" by (metis image_mono downset_set_iso upset_set_to_downset_set2 mono_def) lemma up_set_idem [simp]: "\ \ \ = \" by (metis comp_assoc downset_set_idem upset_set_downset_set_dual upset_set_to_downset_set) lemma upset_faithful: "\x \ \y \ y \ x" by (metis inj_image_subset_iff downset_faithful dual_dual_ord inj_dual upset_to_downset3) lemma upset_anti_iff: "(\y \ \x) = (x \ y)" by (metis downset_iso_iff ord_dual upset_to_downset3 subset_image_iff upset_faithful) lemma upset_filtered_upset [simp]: "filtered \ \ = filtered" by (metis comp_assoc directed_filtered_dual downset_directed_downset upset_set_downset_set_dual) lemma filtered_upset_filters: "filtered (\X) = (\X \ filters)" by (metis comp_apply directed_downset_ideals filtered_to_directed filterp_idealp_dual upset_set_downset_set_dual) lemma upclosed_Fix: "upclosed_set X = (\X = X)" by (simp add: Fix_def upclosed_set_def upsets_def) end lemma upset_anti: "antimono (\::'a::order_with_dual \ 'a set)" by (simp add: antimono_def upset_anti_iff) lemma mono_upclosed: fixes f :: "'a::order_with_dual \ 'b::order_with_dual" assumes "mono f" shows "\Y. upclosed_set Y \ upclosed_set (f - Y)" by (simp add: assms monoD upclosed_set_iff) lemma mono_upclosed: fixes f :: "'a::order_with_dual \ 'b::order_with_dual" assumes "mono f" shows "\Y. upclosed_set X \ upclosed_set (f  X)" (*nitpick*) oops lemma upclosed_mono: fixes f :: "'a::order_with_dual \ 'b::order_with_dual" assumes "\Y. upclosed_set Y \ upclosed_set (f - Y)" shows "mono f" by (metis (mono_tags, lifting) assms dual_order.refl mem_Collect_eq monoI order.trans upclosed_set_iff vimageE vimageI2) lemma mono_upclosed_iff: fixes f :: "'a::order_with_dual \ 'b::order_with_dual" shows "mono f = (\Y. upclosed_set Y \ upclosed_set (f - Y))" using mono_upclosed upclosed_mono by auto context order_with_dual begin lemma upset_inj: "inj \" by (metis inj_compose inj_on_imageI2 downset_inj inj_dual upset_to_downset) lemma "(X \ Y) = (\Y \ \X)" (*nitpick*) oops end context lattice_with_dual begin lemma lat_filters: "X \ filters = (X \ {} \ X \ upsets \ (\x \ X. \ y \ X. x \ y \ X))" unfolding filters_to_ideals upsets_to_downsets inf_to_sup lat_ideals - by (smt image_iff image_inv_f_f image_is_empty inj_image_mem_iff inv_unique_comp inj_dual invol_dual) + by (smt (verit) image_iff image_inv_f_f image_is_empty inj_image_mem_iff inv_unique_comp inj_dual invol_dual) end context bounded_lattice_with_dual begin lemma top_filter: "X \ filters \ \ \ X" using bot_ideal inj_image_mem_iff inj_dual filters_to_ideals top_dual by fastforce end context complete_lattice_with_dual begin lemma Inf_upset_id [simp]: "Inf \ \ = id" by (metis comp_assoc comp_id Sup_downset_id Sups_dual_def downset_upset_dual invol_dual) lemma upset_Inf_id: "id \ \ \ Inf" by (simp add: Inf_lower le_funI subsetI upset_prop) lemma Sup_Inf_var: " \(\x \ X. \x) = \X" unfolding upset_prop by (simp add: Collect_ball_eq Sup_eq_Inf) lemma Sup_dual_upset_var: "(\x \ X. \x) = \(\X)" unfolding upset_prop by (safe, simp_all add: Sup_le_iff) end subsection \Properties of Complete Lattices\ definition "Inf_closed_set X = (\Y \ X. \Y \ X)" definition "Sup_closed_set X = (\Y \ X. \Y \ X)" definition "inf_closed_set X = (\x \ X. \y \ X. x \ y \ X)" definition "sup_closed_set X = (\x \ X. \y \ X. x \ y \ X)" text \The following facts about complete lattices add to those in the Isabelle libraries.\ context complete_lattice begin text \The translation between sup and Sup could be improved. The sup-theorems should be direct consequences of Sup-ones. In addition, duality between sup and inf is currently not exploited.\ lemma sup_Sup: "x \ y = \{x,y}" by simp lemma inf_Inf: "x \ y = \{x,y}" by simp text \The next two lemmas are about Sups and Infs of indexed families. These are interesting for iterations and fixpoints.\ lemma fSup_unfold: "(f::nat \ 'a) 0 \ (\n. f (Suc n)) = (\n. f n)" apply (intro order.antisym sup_least) apply (rule Sup_upper, force) apply (rule Sup_mono, force) apply (safe intro!: Sup_least) by (case_tac n, simp_all add: Sup_upper le_supI2) lemma fInf_unfold: "(f::nat \ 'a) 0 \ (\n. f (Suc n)) = (\n. f n)" apply (intro order.antisym inf_greatest) apply (rule Inf_greatest, safe) apply (case_tac n) apply simp_all using Inf_lower inf.coboundedI2 apply force apply (simp add: Inf_lower) by (auto intro: Inf_mono) end lemma Sup_sup_closed: "Sup_closed_set (X::'a::complete_lattice set) \ sup_closed_set X" by (metis Sup_closed_set_def empty_subsetI insert_subsetI sup_Sup sup_closed_set_def) lemma Inf_inf_closed: "Inf_closed_set (X::'a::complete_lattice set) \ inf_closed_set X" by (metis Inf_closed_set_def empty_subsetI inf_Inf inf_closed_set_def insert_subset) subsection \Sup- and Inf-Preservation\ text \Next, important notation for morphism between posets and lattices is introduced: sup-preservation, inf-preservation and related properties.\ abbreviation Sup_pres :: "('a::Sup \ 'b::Sup) \ bool" where "Sup_pres f \ f \ Sup = Sup \ () f" abbreviation Inf_pres :: "('a::Inf \ 'b::Inf) \ bool" where "Inf_pres f \ f \ Inf = Inf \ () f" abbreviation sup_pres :: "('a::sup \ 'b::sup) \ bool" where "sup_pres f \ (\x y. f (x \ y) = f x \ f y)" abbreviation inf_pres :: "('a::inf \ 'b::inf) \ bool" where "inf_pres f \ (\x y. f (x \ y) = f x \ f y)" abbreviation bot_pres :: "('a::bot \ 'b::bot) \ bool" where "bot_pres f \ f \ = \" abbreviation top_pres :: "('a::top \ 'b::top) \ bool" where "top_pres f \ f \ = \" abbreviation Sup_dual :: "('a::Sup \ 'b::Inf) \ bool" where "Sup_dual f \ f \ Sup = Inf \ () f" abbreviation Inf_dual :: "('a::Inf \ 'b::Sup) \ bool" where "Inf_dual f \ f \ Inf = Sup \ () f" abbreviation sup_dual :: "('a::sup \ 'b::inf) \ bool" where "sup_dual f \ (\x y. f (x \ y) = f x \ f y)" abbreviation inf_dual :: "('a::inf \ 'b::sup) \ bool" where "inf_dual f \ (\x y. f (x \ y) = f x \ f y)" abbreviation bot_dual :: "('a::bot \ 'b::top) \ bool" where "bot_dual f \ f \ = \" abbreviation top_dual :: "('a::top \ 'b::bot) \ bool" where "top_dual f \ f \ = \" text \Inf-preservation and sup-preservation relate with duality.\ lemma Inf_pres_map_dual_var: "Inf_pres f = Sup_pres (\\<^sub>F f)" for f :: "'a::complete_lattice_with_dual \ 'b::complete_lattice_with_dual" proof - { fix x :: "'a set" assume "\ (f (\ (\  x))) = (\y\x. \ (f (\ y)))" for x then have "\ (f  \  A) = f (\ (\ A))" for A by (metis (no_types) Sup_dual_def_var image_image invol_dual_var subset_dual) then have "\ (f  x) = f (\ x)" by (metis Sup_dual_def_var subset_dual) } then show ?thesis by (auto simp add: map_dual_def fun_eq_iff Inf_dual_var Sup_dual_def_var image_comp) qed lemma Inf_pres_map_dual: "Inf_pres = Sup_pres \ (\\<^sub>F::('a::complete_lattice_with_dual \ 'b::complete_lattice_with_dual) \ 'a \ 'b)" proof- {fix f::"'a \ 'b" have "Inf_pres f = (Sup_pres \ \\<^sub>F) f" by (simp add: Inf_pres_map_dual_var)} thus ?thesis by force qed lemma Sup_pres_map_dual_var: fixes f :: "'a::complete_lattice_with_dual \ 'b::complete_lattice_with_dual" shows "Sup_pres f = Inf_pres (\\<^sub>F f)" by (metis Inf_pres_map_dual_var fun_dual5 map_dual_def) lemma Sup_pres_map_dual: "Sup_pres = Inf_pres \ (\\<^sub>F::('a::complete_lattice_with_dual \ 'b::complete_lattice_with_dual) \ 'a \ 'b)" by (simp add: Inf_pres_map_dual comp_assoc map_dual_invol) text \The following lemmas relate isotonicity of functions between complete lattices with weak (left) preservation properties of sups and infs.\ lemma fun_isol: "mono f \ mono (($$ f)" by (simp add: le_fun_def mono_def) lemma fun_isor: "mono f \ mono (\x. x \ f)" by (simp add: le_fun_def mono_def) lemma Sup_sup_pres: fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows "Sup_pres f \ sup_pres f" by (metis (no_types, opaque_lifting) Sup_empty Sup_insert comp_apply image_insert sup_bot.right_neutral) lemma Inf_inf_pres: fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows"Inf_pres f \ inf_pres f" - by (smt INF_insert Inf_empty Inf_insert comp_eq_elim inf_top.right_neutral) + by (smt (verit) INF_insert Inf_empty Inf_insert comp_eq_elim inf_top.right_neutral) lemma Sup_bot_pres: fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows "Sup_pres f \ bot_pres f" by (metis SUP_empty Sup_empty comp_eq_elim) lemma Inf_top_pres: fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows "Inf_pres f \ top_pres f" by (metis INF_empty Inf_empty comp_eq_elim) lemma Sup_sup_dual: fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows "Sup_dual f \ sup_dual f" - by (smt comp_eq_elim image_empty image_insert inf_Inf sup_Sup) + by (smt (verit) comp_eq_elim image_empty image_insert inf_Inf sup_Sup) lemma Inf_inf_dual: fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows "Inf_dual f \ inf_dual f" - by (smt comp_eq_elim image_empty image_insert inf_Inf sup_Sup) + by (smt (verit) comp_eq_elim image_empty image_insert inf_Inf sup_Sup) lemma Sup_bot_dual: fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows "Sup_dual f \ bot_dual f" by (metis INF_empty Sup_empty comp_eq_elim) lemma Inf_top_dual: fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows "Inf_dual f \ top_dual f" by (metis Inf_empty SUP_empty comp_eq_elim) text \However, Inf-preservation does not imply top-preservation and Sup-preservation does not imply bottom-preservation.\ lemma fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows "Sup_pres f \ top_pres f" (*nitpick*) oops lemma fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows "Inf_pres f \ bot_pres f" (*nitpick*) oops context complete_lattice begin lemma iso_Inf_subdistl: fixes f :: "'a \ 'b::complete_lattice" shows "mono f \f \ Inf \ Inf \ () f" by (simp add: complete_lattice_class.le_Inf_iff le_funI Inf_lower monoD) lemma iso_Sup_supdistl: fixes f :: "'a \ 'b::complete_lattice" shows "mono f \ Sup \ () f \ f \ Sup" by (simp add: complete_lattice_class.Sup_le_iff le_funI Sup_upper monoD) lemma Inf_subdistl_iso: fixes f :: "'a \ 'b::complete_lattice" shows "f \ Inf \ Inf \ () f \ mono f" unfolding mono_def le_fun_def comp_def by (metis complete_lattice_class.le_INF_iff Inf_atLeast atLeast_iff) lemma Sup_supdistl_iso: fixes f :: "'a \ 'b::complete_lattice" shows "Sup \ () f \ f \ Sup \ mono f" unfolding mono_def le_fun_def comp_def by (metis complete_lattice_class.SUP_le_iff Sup_atMost atMost_iff) lemma supdistl_iso: fixes f :: "'a \ 'b::complete_lattice" shows "(Sup \ () f \ f \ Sup) = mono f" using Sup_supdistl_iso iso_Sup_supdistl by force lemma subdistl_iso: fixes f :: "'a \ 'b::complete_lattice" shows "(f \ Inf \ Inf \ () f) = mono f" using Inf_subdistl_iso iso_Inf_subdistl by force end lemma ord_iso_Inf_pres: fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows "ord_iso f \ Inf \ () f = f \ Inf" proof- let ?g = "the_inv f" assume h: "ord_iso f" hence a: "mono ?g" by (simp add: ord_iso_the_inv) {fix X :: "'a::complete_lattice set" {fix y :: "'b::complete_lattice" have "(y \ f (\X)) = (?g y \ \X)" by (metis (mono_tags, lifting) UNIV_I f_the_inv_into_f h monoD ord_embed_alt ord_embed_inj ord_iso_alt) also have "... = (\x \ X. ?g y \ x)" by (simp add: le_Inf_iff) also have "... = (\x \ X. y \ f x)" by (metis (mono_tags, lifting) UNIV_I f_the_inv_into_f h monoD ord_embed_alt ord_embed_inj ord_iso_alt) also have "... = (y \ \ (f  X))" by (simp add: le_INF_iff) finally have "(y \ f (\X)) = (y \ \ (f  X))".} hence "f (\X) = \ (f  X)" by (meson dual_order.antisym order_refl)} thus ?thesis unfolding fun_eq_iff by simp qed lemma ord_iso_Sup_pres: fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows "ord_iso f \ Sup \ () f = f \ Sup" proof- let ?g = "the_inv f" assume h: "ord_iso f" hence a: "mono ?g" by (simp add: ord_iso_the_inv) {fix X :: "'a::complete_lattice set" {fix y :: "'b::complete_lattice" have "(f (\X) \ y) = (\X \ ?g y)" by (metis (mono_tags, lifting) UNIV_I f_the_inv_into_f h monoD ord_embed_alt ord_embed_inj ord_iso_alt) also have "... = (\x \ X. x \ ?g y)" by (simp add: Sup_le_iff) also have "... = (\x \ X. f x \ y)" by (metis (mono_tags, lifting) UNIV_I f_the_inv_into_f h monoD ord_embed_alt ord_embed_inj ord_iso_alt) also have "... = (\ (f  X) \ y)" by (simp add: SUP_le_iff) finally have "(f (\X) \ y) = (\ (f  X) \ y)".} hence "f (\X) = \ (f  X)" by (meson dual_order.antisym order_refl)} thus ?thesis unfolding fun_eq_iff by simp qed text \Right preservation of sups and infs is trivial.\ lemma fSup_distr: "Sup_pres (\x. x \ f)" unfolding fun_eq_iff by (simp add: image_comp) lemma fSup_distr_var: "\F \ g = (\f \ F. f \ g)" unfolding fun_eq_iff by (simp add: image_comp) lemma fInf_distr: "Inf_pres (\x. x \ f)" unfolding fun_eq_iff comp_def - by (smt INF_apply Inf_fun_def Sup.SUP_cong) + by (smt (verit) INF_apply Inf_fun_def Sup.SUP_cong) lemma fInf_distr_var: "\F \ g = (\f \ F. f \ g)" unfolding fun_eq_iff comp_def - by (smt INF_apply INF_cong INF_image Inf_apply image_comp image_def image_image) + by (smt (verit) INF_apply INF_cong INF_image Inf_apply image_comp image_def image_image) text \The next set of lemma revisits the preservation properties in the function space.\ lemma fSup_subdistl: assumes "mono (f::'a::complete_lattice \ 'b::complete_lattice)" shows "Sup \ () ((\) f) \ (\) f \ Sup" using assms by (simp add: fun_isol supdistl_iso) lemma fSup_subdistl_var: fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows "mono f \ (\g \ G. f \ g) \ f \ \G" by (simp add: fun_isol mono_Sup) lemma fInf_subdistl: fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows "mono f \ (\) f \ Inf \ Inf \ () ((\) f)" by (simp add: fun_isol subdistl_iso) lemma fInf_subdistl_var: fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows "mono f \ f \ \G \ (\g \ G. f \ g)" by (simp add: fun_isol mono_Inf) lemma fSup_distl: "Sup_pres f \ Sup_pres ((\) f)" unfolding fun_eq_iff by (simp add: image_comp) lemma fSup_distl_var: "Sup_pres f \ f \ \G = (\g \ G. f \ g)" unfolding fun_eq_iff by (simp add: image_comp) lemma fInf_distl: "Inf_pres f \ Inf_pres ((\) f)" unfolding fun_eq_iff by (simp add: image_comp) lemma fInf_distl_var: "Inf_pres f \ f \ \G = (\g \ G. f \ g)" unfolding fun_eq_iff by (simp add: image_comp) text \Downsets preserve infs whereas upsets preserve sups.\ lemma Inf_pres_downset: "Inf_pres (\::'a::complete_lattice_with_dual \ 'a set)" unfolding downset_prop fun_eq_iff by (safe, simp_all add: le_Inf_iff) lemma Sup_dual_upset: "Sup_dual (\::'a::complete_lattice_with_dual \ 'a set)" unfolding upset_prop fun_eq_iff by (safe, simp_all add: Sup_le_iff) text \Images of Sup-morphisms are closed under Sups and images of Inf-morphisms are closed under Infs.\ lemma Sup_pres_Sup_closed: "Sup_pres f \ Sup_closed_set (range f)" by (metis (mono_tags, lifting) Sup_closed_set_def comp_eq_elim range_eqI subset_image_iff) lemma Inf_pres_Inf_closed: "Inf_pres f \ Inf_closed_set (range f)" by (metis (mono_tags, lifting) Inf_closed_set_def comp_eq_elim range_eqI subset_image_iff) text \It is well known that functions into complete lattices form complete lattices. Here, such results are shown for the subclasses of isotone functions, where additional closure conditions must be respected.\ typedef (overloaded) 'a iso = "{f::'a::order \ 'a::order. mono f}" by (metis Abs_ord_homset_cases ord_homset_def) setup_lifting type_definition_iso instantiation iso :: (complete_lattice) complete_lattice begin lift_definition Inf_iso :: "'a::complete_lattice iso set \ 'a iso" is Sup by (metis (mono_tags, lifting) SUP_subset_mono Sup_apply mono_def subsetI) lift_definition Sup_iso :: "'a::complete_lattice iso set \ 'a iso" is Inf - by (smt INF_lower2 Inf_apply le_INF_iff mono_def) + by (smt (verit) INF_lower2 Inf_apply le_INF_iff mono_def) lift_definition bot_iso :: "'a::complete_lattice iso" is "\" by (simp add: monoI) lift_definition sup_iso :: "'a::complete_lattice iso \ 'a iso \ 'a iso" is inf - by (smt inf_apply inf_mono monoD monoI) + by (smt (verit) inf_apply inf_mono monoD monoI) lift_definition top_iso :: "'a::complete_lattice iso" is "\" by (simp add: mono_def) lift_definition inf_iso :: "'a::complete_lattice iso \ 'a iso \ 'a iso" is sup - by (smt mono_def sup.mono sup_apply) + by (smt (verit) mono_def sup.mono sup_apply) lift_definition less_eq_iso :: "'a::complete_lattice iso \ 'a iso \ bool" is "(\)". lift_definition less_iso :: "'a::complete_lattice iso \ 'a iso \ bool" is "(>)". instance by (intro_classes; transfer, simp_all add: less_fun_def Sup_upper Sup_least Inf_lower Inf_greatest) end text \Duality has been baked into this result because of its relevance for predicate transformers. A proof where Sups are mapped to Sups and Infs to Infs is certainly possible, but two instantiation of the same type and the same classes are unfortunately impossible. Interpretations could be used instead. A corresponding result for Inf-preseving functions and Sup-lattices, is proved in components on transformers, as more advanced properties about Inf-preserving functions are needed.\ subsection \Alternative Definitions for Complete Boolean Algebras\ text \The current definitions of complete boolean algebras deviates from that in most textbooks in that a distributive law with infinite sups and infinite infs is used. There are interesting applications, for instance in topology, where weaker laws are needed --- for instance for frames and locales.\ class complete_heyting_algebra = complete_lattice + assumes ch_dist: "x \ \Y = (\y \ Y. x \ y)" text \Complete Heyting algebras are also known as frames or locales (they differ with respect to their morphisms).\ class complete_co_heyting_algebra = complete_lattice + assumes co_ch_dist: "x \ \Y = (\y \ Y. x \ y)" class complete_boolean_algebra_alt = complete_lattice + boolean_algebra instance set :: (type) complete_boolean_algebra_alt.. context complete_boolean_algebra_alt begin subclass complete_heyting_algebra proof fix x Y {fix t have "(x \ \Y \ t) = (\Y \ -x \ t)" by (simp add: inf.commute shunt1[symmetric]) also have "... = (\y \ Y. y \ -x \ t)" using Sup_le_iff by blast also have "... = (\y \ Y. x \ y \ t)" by (simp add: inf.commute shunt1) finally have "(x \ \Y \ t) = ((\y\Y. x \ y) \ t)" by (simp add: local.SUP_le_iff)} thus "x \ \Y = (\y\Y. x \ y)" using order.eq_iff by blast qed subclass complete_co_heyting_algebra apply unfold_locales apply (rule order.antisym) apply (simp add: INF_greatest Inf_lower2) by (meson eq_refl le_INF_iff le_Inf_iff shunt2) lemma de_morgan1: "-(\X) = (\x \ X. -x)" proof- {fix y have "(y \ -(\X)) = (\X \ -y)" using compl_le_swap1 by blast also have "... = (\x \ X. x \ -y)" by (simp add: Sup_le_iff) also have "... = (\x \ X. y \ -x)" using compl_le_swap1 by blast also have "... = (y \ (\x \ X. -x))" using le_INF_iff by force finally have "(y \ -(\X)) = (y $$\x \ X. -x))".} thus ?thesis using order.antisym by blast qed lemma de_morgan2: "-(\X) = (\x \ X. -x)" by (metis de_morgan1 ba_dual.dual_iff ba_dual.image_dual pointfree_idE) end class complete_boolean_algebra_alt_with_dual = complete_lattice_with_dual + complete_boolean_algebra_alt instantiation set :: (type) complete_boolean_algebra_alt_with_dual begin definition dual_set :: "'a set \ 'a set" where "dual_set = uminus" instance by intro_classes (simp_all add: ba_dual.inj_dual dual_set_def comp_def uminus_Sup id_def) end context complete_boolean_algebra_alt begin sublocale cba_dual: complete_boolean_algebra_alt_with_dual _ _ _ _ _ _ _ _ uminus _ _ by unfold_locales (auto simp: de_morgan2 de_morgan1) end subsection \Atomic Boolean Algebras\ text \Next, atomic boolean algebras are defined.\ context bounded_lattice begin text \Atoms are covers of bottom.\ definition "atom x = (x \ \ \ \(\y. \ < y \ y < x))" definition "atom_map x = {y. atom y \ y \ x}" lemma atom_map_def_var: "atom_map x = \x \ Collect atom" unfolding atom_map_def downset_def downset_set_def comp_def atom_def by fastforce lemma atom_map_atoms: "\(range atom_map) = Collect atom" unfolding atom_map_def atom_def by auto end typedef (overloaded) 'a atoms = "range (atom_map::'a::bounded_lattice \ 'a set)" by blast setup_lifting type_definition_atoms definition at_map :: "'a::bounded_lattice \ 'a atoms" where "at_map = Abs_atoms \ atom_map" class atomic_boolean_algebra = boolean_algebra + assumes atomicity: "x \ \ \ (\y. atom y \ y \ x)" class complete_atomic_boolean_algebra = complete_lattice + atomic_boolean_algebra begin subclass complete_boolean_algebra_alt.. end text \Here are two equivalent definitions for atoms; first in boolean algebras, and then in complete boolean algebras.\ context boolean_algebra begin text \The following two conditions are taken from Koppelberg's book~\<^cite>\"Koppelberg89"\.\ lemma atom_neg: "atom x \ x \ \ \ (\y z. x \ y \ x \ -y)" by (auto simp add: atom_def) (metis local.dual_order.not_eq_order_implies_strict local.inf.cobounded1 local.inf.cobounded2 local.inf_shunt) lemma atom_sup: "(\y. x \ y \ x \ -y) \ (\y z. (x \ y \ x \ z) = (x \ y \ z))" by (metis inf.orderE le_supI1 shunt2) lemma sup_atom: "x \ \ \ (\y z. (x \ y \ x \ z) = (x \ y \ z)) \ atom x" by (auto simp add: atom_def) (metis (full_types) local.inf.boundedI local.inf.cobounded2 local.inf_shunt local.inf_sup_ord(4) local.le_iff_sup local.shunt1 local.sup.absorb1 local.sup.strict_order_iff) lemma atom_sup_iff: "atom x = (x \ \ \ (\y z. (x \ y \ x \ z) = (x \ y \ z)))" by rule (auto simp add: atom_neg atom_sup sup_atom) lemma atom_neg_iff: "atom x = (x \ \ \ (\y z. x \ y \ x \ -y))" by rule (auto simp add: atom_neg atom_sup sup_atom) lemma atom_map_bot_pres: "atom_map \ = {}" using atom_def atom_map_def le_bot by auto lemma atom_map_top_pres: "atom_map \ = Collect atom" using atom_map_def by auto end context complete_boolean_algebra_alt begin lemma atom_Sup: "\Y. x \ \ \ (\y. x \ y \ x \ -y) \ ((\y \ Y. x \ y) = (x \ \Y))" by (metis Sup_least Sup_upper2 compl_le_swap1 le_iff_inf inf_shunt) lemma Sup_atom: "x \ \ \ (\Y. (\y \ Y. x \ y) = (x \ \Y)) \ atom x" proof- assume h1: "x \ \" and h2: "\Y. (\y \ Y. x \ y) = (x \ \Y)" hence "\y z. (x \ y \ x \ z) = (x \ y \ z)" - - by (smt insert_iff sup_Sup sup_bot.right_neutral) + by (smt (verit) insert_iff sup_Sup sup_bot.right_neutral) thus "atom x" by (simp add: h1 sup_atom) qed lemma atom_Sup_iff: "atom x = (x \ \ \ (\Y. (\y \ Y. x \ y) = (x \ \Y)))" by standard (auto simp: atom_neg atom_Sup Sup_atom) end end diff --git a/thys/Order_Lattice_Props/Order_Lattice_Props_Loc.thy b/thys/Order_Lattice_Props/Order_Lattice_Props_Loc.thy --- a/thys/Order_Lattice_Props/Order_Lattice_Props_Loc.thy +++ b/thys/Order_Lattice_Props/Order_Lattice_Props_Loc.thy @@ -1,575 +1,575 @@ (* Title: Locale-Based Duality Author: Georg Struth Maintainer:Georg Struth *) section \Locale-Based Duality\ theory Order_Lattice_Props_Loc imports Main begin unbundle lattice_syntax text \This section explores order and lattice duality based on locales. Used within the context of a class or locale, this is very effective, though more opaque than the previous approach. Outside of such a context, however, it apparently cannot be used for dualising theorems. Examples are properties of functions between orderings or lattices.\ definition Fix :: "('a \ 'a) \ 'a set" where "Fix f = {x. f x = x}" context ord begin definition min_set :: "'a set \ 'a set" where "min_set X = {y \ X. \x \ X. x \ y \ x = y}" definition max_set :: "'a set \ 'a set" where "max_set X = {x \ X. \y \ X. x \ y \ x = y}" definition directed :: "'a set \ bool" where "directed X = (\Y. finite Y \ Y \ X \ (\x \ X. \y \ Y. y \ x))" definition filtered :: "'a set \ bool" where "filtered X = (\Y. finite Y \ Y \ X \ (\x \ X. \y \ Y. x \ y))" definition downset_set :: "'a set \ 'a set" ("\") where "\X = {y. \x \ X. y \ x}" definition upset_set :: "'a set \ 'a set" ("\") where "\X = {y. \x \ X. x \ y}" definition downset :: "'a \ 'a set" ("\") where "\ = \ \ (\x. {x})" definition upset :: "'a \ 'a set" ("\") where "\ = \ \ (\x. {x})" definition downsets :: "'a set set" where "downsets = Fix \" definition upsets :: "'a set set" where "upsets = Fix \" abbreviation "downset_setp X \ X \ downsets" abbreviation "upset_setp X \ X \ upsets" definition ideals :: "'a set set" where "ideals = {X. X \ {} \ downset_setp X \ directed X}" definition filters :: "'a set set" where "filters = {X. X \ {} \ upset_setp X \ filtered X}" abbreviation "idealp X \ X \ ideals" abbreviation "filterp X \ X \ filters" end abbreviation Sup_pres :: "('a::Sup \ 'b::Sup) \ bool" where "Sup_pres f \ f \ Sup = Sup \ () f" abbreviation Inf_pres :: "('a::Inf \ 'b::Inf) \ bool" where "Inf_pres f \ f \ Inf = Inf \ () f" abbreviation sup_pres :: "('a::sup \ 'b::sup) \ bool" where "sup_pres f \ (\x y. f (x \ y) = f x \ f y)" abbreviation inf_pres :: "('a::inf \ 'b::inf) \ bool" where "inf_pres f \ (\x y. f (x \ y) = f x \ f y)" abbreviation bot_pres :: "('a::bot \ 'b::bot) \ bool" where "bot_pres f \ f \ = \" abbreviation top_pres :: "('a::top \ 'b::top) \ bool" where "top_pres f \ f \ = \" abbreviation Sup_dual :: "('a::Sup \ 'b::Inf) \ bool" where "Sup_dual f \ f \ Sup = Inf \ () f" abbreviation Inf_dual :: "('a::Inf \ 'b::Sup) \ bool" where "Inf_dual f \ f \ Inf = Sup \ () f" abbreviation sup_dual :: "('a::sup \ 'b::inf) \ bool" where "sup_dual f \ (\x y. f (x \ y) = f x \ f y)" abbreviation inf_dual :: "('a::inf \ 'b::sup) \ bool" where "inf_dual f \ (\x y. f (x \ y) = f x \ f y)" abbreviation bot_dual :: "('a::bot \ 'b::top) \ bool" where "bot_dual f \ f \ = \" abbreviation top_dual :: "('a::top \ 'b::bot) \ bool" where "top_dual f \ f \ = \" subsection \Duality via Locales\ sublocale ord \ dual_ord: ord "($$" "(>)" rewrites dual_max_set: "max_set = dual_ord.min_set" and dual_filtered: "filtered = dual_ord.directed" and dual_upset_set: "upset_set = dual_ord.downset_set" and dual_upset: "upset = dual_ord.downset" and dual_upsets: "upsets = dual_ord.downsets" and dual_filters: "filters = dual_ord.ideals" apply unfold_locales unfolding max_set_def ord.min_set_def fun_eq_iff apply blast unfolding filtered_def ord.directed_def apply simp unfolding upset_set_def ord.downset_set_def apply simp apply (simp add: ord.downset_def ord.downset_set_def ord.upset_def ord.upset_set_def) unfolding upsets_def ord.downsets_def apply (metis ord.downset_set_def upset_set_def) unfolding filters_def ord.ideals_def Fix_def ord.downsets_def upsets_def ord.downset_set_def upset_set_def ord.directed_def filtered_def by simp sublocale preorder \ dual_preorder: preorder "(\)" "(>)" apply unfold_locales apply (simp add: less_le_not_le) apply simp using order_trans by blast sublocale order \ dual_order: order "(\)" "(>)" by (unfold_locales, simp) sublocale lattice \ dual_lattice: lattice sup "(\)" "(>)" inf by (unfold_locales, simp_all) sublocale bounded_lattice \ dual_bounded_lattice: bounded_lattice sup "(\)" "(>)" inf \ \ by (unfold_locales, simp_all) sublocale boolean_algebra \ dual_boolean_algebra: boolean_algebra "\x y. x \ -y" uminus sup "(\)" "(>)" inf \ \ by (unfold_locales, simp_all add: inf_sup_distrib1) sublocale complete_lattice \ dual_complete_lattice: complete_lattice Sup Inf sup "(\)" "(>)" inf \ \ rewrites dual_gfp: "gfp = dual_complete_lattice.lfp" proof- show "class.complete_lattice Sup Inf sup (\) (>) inf \ \" by (unfold_locales, simp_all add: Sup_upper Sup_least Inf_lower Inf_greatest) then interpret dual_complete_lattice: complete_lattice Sup Inf sup "(\)" "(>)" inf \ \. show "gfp = dual_complete_lattice.lfp" unfolding gfp_def dual_complete_lattice.lfp_def fun_eq_iff by simp qed context ord begin lemma dual_min_set: "min_set = dual_ord.max_set" by (simp add: dual_ord.dual_max_set) lemma dual_directed: "directed = dual_ord.filtered" by (simp add:dual_ord.dual_filtered) lemma dual_downset: "downset = dual_ord.upset" by (simp add: dual_ord.dual_upset) lemma dual_downset_set: "downset_set = dual_ord.upset_set" by (simp add: dual_ord.dual_upset_set) lemma dual_downsets: "downsets = dual_ord.upsets" by (simp add: dual_ord.dual_upsets) lemma dual_ideals: "ideals = dual_ord.filters" by (simp add: dual_ord.dual_filters) end context complete_lattice begin lemma dual_lfp: "lfp = dual_complete_lattice.gfp" by (simp add: dual_complete_lattice.dual_gfp) end subsection \Properties of Orderings, Again\ context ord begin lemma directed_nonempty: "directed X \ X \ {}" unfolding directed_def by fastforce lemma directed_ub: "directed X \ (\x \ X. \y \ X. \z \ X. x \ z \ y \ z)" by (meson empty_subsetI directed_def finite.emptyI finite_insert insert_subset order_refl) lemma downset_set_prop: "\ = Union \ () \" unfolding downset_set_def downset_def fun_eq_iff by fastforce lemma downset_set_prop_var: "\X = (\x \ X. \x)" by (simp add: downset_set_prop) lemma downset_prop: "\x = {y. y \ x}" unfolding downset_def downset_set_def fun_eq_iff comp_def by fastforce end context preorder begin lemma directed_prop: "X \ {} \ (\x \ X. \y \ X. \z \ X. x \ z \ y \ z) \ directed X" proof- assume h1: "X \ {}" and h2: "\x \ X. \y \ X. \z \ X. x \ z \ y \ z" {fix Y have "finite Y \ Y \ X \ (\x \ X. \y \ Y. y \ x)" proof (induct rule: finite_induct) case empty then show ?case using h1 by blast next case (insert x F) then show ?case by (metis h2 insert_iff insert_subset order_trans) qed} thus ?thesis by (simp add: directed_def) qed lemma directed_alt: "directed X = (X \ {} \ (\x \ X. \y \ X. \z \ X. x \ z \ y \ z))" by (metis directed_prop directed_nonempty directed_ub) lemma downset_set_ext: "id \ \" unfolding le_fun_def id_def downset_set_def by auto lemma downset_set_iso: "mono \" unfolding mono_def downset_set_def by blast lemma downset_set_idem [simp]: "\ \ \ = \" unfolding fun_eq_iff downset_set_def comp_def using order_trans by auto lemma downset_faithful: "\x \ \y \ x \ y" by (simp add: downset_prop subset_eq) lemma downset_iso_iff: "(\x \ \y) = (x \ y)" using atMost_iff downset_prop order_trans by blast lemma downset_directed_downset_var [simp]: "directed (\X) = directed X" proof assume h1: "directed X" {fix Y assume h2: "finite Y" and h3: "Y \ \X" hence "\y. \x. y \ Y \ x \ X \ y \ x" by (force simp: downset_set_def) hence "\f. \y. y \ Y \ f y \ X \ y \ f y" by (rule choice) hence "\f. finite (f  Y) \ f  Y \ X \ (\y \ Y. y \ f y)" by (metis finite_imageI h2 image_subsetI) hence "\Z. finite Z \ Z \ X \ (\y \ Y. \ z \ Z. y \ z)" by fastforce hence "\Z. finite Z \ Z \ X \ (\y \ Y. \ z \ Z. y \ z) \ (\x \ X. \ z \ Z. z \ x)" by (metis directed_def h1) hence "\x \ X. \y \ Y. y \ x" by (meson order_trans)} thus "directed (\X)" unfolding directed_def downset_set_def by fastforce next assume "directed (\X)" thus "directed X" unfolding directed_def downset_set_def apply clarsimp - by (smt Ball_Collect order_refl order_trans subsetCE) + by (smt (verit) Ball_Collect order_refl order_trans subsetCE) qed lemma downset_directed_downset [simp]: "directed \ \ = directed" unfolding fun_eq_iff comp_def by simp lemma directed_downset_ideals: "directed (\X) = (\X \ ideals)" by (metis (mono_tags, lifting) Fix_def comp_apply directed_alt downset_set_idem downsets_def ideals_def mem_Collect_eq) end lemma downset_iso: "mono (\::'a::order \ 'a set)" by (simp add: downset_iso_iff mono_def) context order begin lemma downset_inj: "inj \" by (metis injI downset_iso_iff order.eq_iff) end context lattice begin lemma lat_ideals: "X \ ideals = (X \ {} \ X \ downsets \ (\x \ X. \ y \ X. x \ y \ X))" unfolding ideals_def directed_alt downsets_def Fix_def downset_set_def - by (clarsimp, smt sup.cobounded1 sup.orderE sup.orderI sup_absorb2 sup_left_commute mem_Collect_eq) + using local.sup.bounded_iff by blast end context bounded_lattice begin lemma bot_ideal: "X \ ideals \ \ \ X" unfolding ideals_def downsets_def Fix_def downset_set_def by fastforce end context complete_lattice begin lemma Sup_downset_id [simp]: "Sup \ \ = id" using Sup_atMost atMost_def downset_prop by fastforce lemma downset_Sup_id: "id \ \ \ Sup" by (simp add: Sup_upper downset_prop le_funI subsetI) lemma Inf_Sup_var: "$$\x \ X. \x) = \X" unfolding downset_prop by (simp add: Collect_ball_eq Inf_eq_Sup) lemma Inf_pres_downset_var: "(\x \ X. \x) = \(\X)" unfolding downset_prop by (safe, simp_all add: le_Inf_iff) end lemma lfp_in_Fix: fixes f :: "'a::complete_lattice \ 'a" shows "mono f \ lfp f \ Fix f" using Fix_def lfp_unfold by fastforce lemma gfp_in_Fix: fixes f :: "'a::complete_lattice \ 'a" shows "mono f \ gfp f \ Fix f" using Fix_def gfp_unfold by fastforce lemma nonempty_Fix: fixes f :: "'a::complete_lattice \ 'a" shows "mono f \ Fix f \ {}" using lfp_in_Fix by fastforce subsection \Dual Properties of Orderings from Locales\ text \These properties can be proved very smoothly overall. But only within the context of a class or locale!\ context ord begin lemma filtered_nonempty: "filtered X \ X \ {}" by (simp add: dual_filtered dual_ord.directed_nonempty) lemma filtered_lb: "filtered X \ (\x \ X. \y \ X. \z \ X. z \ x \ z \ y)" by (simp add: dual_filtered dual_ord.directed_ub) lemma upset_set_prop: "\ = Union \ () \" by (simp add: dual_ord.downset_set_prop dual_upset dual_upset_set) lemma upset_set_prop_var: "\X = (\x \ X. \x)" by (simp add: dual_ord.downset_set_prop_var dual_upset dual_upset_set) lemma upset_prop: "\x = {y. x \ y}" by (simp add: dual_ord.downset_prop dual_upset) end context preorder begin lemma filtered_prop: "X \ {} \ (\x \ X. \y \ X. \z \ X. z \ x \ z \ y) \ filtered X" by (simp add: dual_filtered dual_preorder.directed_prop) lemma filtered_alt: "filtered X = (X \ {} \ (\x \ X. \y \ X. \z \ X. z \ x \ z \ y))" by (simp add: dual_filtered dual_preorder.directed_alt) lemma upset_set_ext: "id \ \" by (simp add: dual_preorder.downset_set_ext dual_upset_set) lemma upset_set_anti: "mono \" by (simp add: dual_preorder.downset_set_iso dual_upset_set) lemma up_set_idem [simp]: "\ \ \ = \" by (simp add: dual_upset_set) lemma upset_faithful: "\x \ \y \ y \ x" by (metis dual_preorder.downset_faithful dual_upset) lemma upset_anti_iff: "(\y \ \x) = (x \ y)" by (simp add: dual_preorder.downset_iso_iff dual_upset) lemma upset_filtered_upset [simp]: "filtered \ \ = filtered" by (simp add: dual_filtered dual_upset_set) lemma filtered_upset_filters: "filtered (\X) = (\X \ filters)" using dual_filtered dual_preorder.directed_downset_ideals dual_upset_set ord.dual_filters by fastforce end context order begin lemma upset_inj: "inj \" by (simp add: dual_order.downset_inj dual_upset) end context lattice begin lemma lat_filters: "X \ filters = (X \ {} \ X \ upsets \ (\x \ X. \ y \ X. x \ y \ X))" by (simp add: dual_filters dual_lattice.lat_ideals dual_ord.downsets_def dual_upset_set upsets_def) end context bounded_lattice begin lemma top_filter: "X \ filters \ \ \ X" by (simp add: dual_bounded_lattice.bot_ideal dual_filters) end context complete_lattice begin lemma Inf_upset_id [simp]: "Inf \ \ = id" by (simp add: dual_upset) lemma upset_Inf_id: "id \ \ \ Inf" by (simp add: dual_complete_lattice.downset_Sup_id dual_upset) lemma Sup_Inf_var: " \(\x \ X. \x) = \X" by (simp add: dual_complete_lattice.Inf_Sup_var dual_upset) lemma Sup_dual_upset_var: "(\x \ X. \x) = \(\X)" by (simp add: dual_complete_lattice.Inf_pres_downset_var dual_upset) end subsection \Examples that Do Not Dualise\ lemma upset_anti: "antimono (\::'a::order \ 'a set)" by (simp add: antimono_def upset_anti_iff) context complete_lattice begin lemma fSup_unfold: "(f::nat \ 'a) 0 \ (\n. f (Suc n)) = (\n. f n)" apply (intro order.antisym sup_least) apply (rule Sup_upper, force) apply (rule Sup_mono, force) apply (safe intro!: Sup_least) by (case_tac n, simp_all add: Sup_upper le_supI2) lemma fInf_unfold: "(f::nat \ 'a) 0 \ (\n. f (Suc n)) = (\n. f n)" apply (intro order.antisym inf_greatest) apply (rule Inf_greatest, safe) apply (case_tac n) apply simp_all using Inf_lower inf.coboundedI2 apply force apply (simp add: Inf_lower) by (auto intro: Inf_mono) end lemma fun_isol: "mono f \ mono (($$ f)" by (simp add: le_fun_def mono_def) lemma fun_isor: "mono f \ mono (\x. x \ f)" by (simp add: le_fun_def mono_def) lemma Sup_sup_pres: fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows "Sup_pres f \ sup_pres f" by (metis (no_types, opaque_lifting) Sup_empty Sup_insert comp_apply image_insert sup_bot.right_neutral) lemma Inf_inf_pres: fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows"Inf_pres f \ inf_pres f" - by (smt INF_insert comp_eq_elim dual_complete_lattice.Sup_empty dual_complete_lattice.Sup_insert inf_top.right_neutral) + by (smt (verit) INF_insert comp_eq_elim dual_complete_lattice.Sup_empty dual_complete_lattice.Sup_insert inf_top.right_neutral) lemma Sup_bot_pres: fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows "Sup_pres f \ bot_pres f" by (metis SUP_empty Sup_empty comp_eq_elim) lemma Inf_top_pres: fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows "Inf_pres f \ top_pres f" by (metis INF_empty comp_eq_elim dual_complete_lattice.Sup_empty) context complete_lattice begin lemma iso_Inf_subdistl: assumes "mono (f::'a \ 'b::complete_lattice)" shows "f \ Inf \ Inf \ () f" by (simp add: assms complete_lattice_class.le_Inf_iff le_funI Inf_lower monoD) lemma iso_Sup_supdistl: assumes "mono (f::'a \ 'b::complete_lattice)" shows "Sup \ () f \ f \ Sup" by (simp add: assms complete_lattice_class.SUP_le_iff le_funI dual_complete_lattice.Inf_lower monoD) lemma Inf_subdistl_iso: fixes f :: "'a \ 'b::complete_lattice" shows "f \ Inf \ Inf \ () f \ mono f" unfolding mono_def le_fun_def comp_def by (metis complete_lattice_class.le_INF_iff Inf_atLeast atLeast_iff) lemma Sup_supdistl_iso: fixes f :: "'a \ 'b::complete_lattice" shows "Sup \ () f \ f \ Sup \ mono f" unfolding mono_def le_fun_def comp_def by (metis complete_lattice_class.SUP_le_iff Sup_atMost atMost_iff) lemma supdistl_iso: fixes f :: "'a \ 'b::complete_lattice" shows "(Sup \ () f \ f \ Sup) = mono f" using Sup_supdistl_iso iso_Sup_supdistl by force lemma subdistl_iso: fixes f :: "'a \ 'b::complete_lattice" shows "(f \ Inf \ Inf \ () f) = mono f" using Inf_subdistl_iso iso_Inf_subdistl by force end lemma fSup_distr: "Sup_pres (\x. x \ f)" unfolding fun_eq_iff comp_def - by (smt Inf.INF_cong SUP_apply Sup_apply) + by (smt (verit) Inf.INF_cong SUP_apply Sup_apply) lemma fSup_distr_var: "\F \ g = (\f \ F. f \ g)" unfolding fun_eq_iff comp_def - by (smt Inf.INF_cong SUP_apply Sup_apply) + by (smt (verit) Inf.INF_cong SUP_apply Sup_apply) lemma fInf_distr: "Inf_pres (\x. x \ f)" unfolding fun_eq_iff comp_def - by (smt INF_apply Inf.INF_cong Inf_apply) + by (smt (verit) INF_apply Inf.INF_cong Inf_apply) lemma fInf_distr_var: "\F \ g = (\f \ F. f \ g)" unfolding fun_eq_iff comp_def - by (smt INF_apply Inf.INF_cong Inf_apply) + by (smt (verit) INF_apply Inf.INF_cong Inf_apply) lemma fSup_subdistl: assumes "mono (f::'a::complete_lattice \ 'b::complete_lattice)" shows "Sup \ () ((\) f) \ (\) f \ Sup" using assms by (simp add: SUP_least Sup_upper le_fun_def monoD image_comp) lemma fSup_subdistl_var: fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows "mono f \ (\g \ G. f \ g) \ f \ \G" by (simp add: SUP_least Sup_upper le_fun_def monoD image_comp) lemma fInf_subdistl: fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows "mono f \ (\) f \ Inf \ Inf \ () ((\) f)" by (simp add: INF_greatest Inf_lower le_fun_def monoD image_comp) lemma fInf_subdistl_var: fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows "mono f \ f \ \G \ (\g \ G. f \ g)" by (simp add: INF_greatest Inf_lower le_fun_def monoD image_comp) lemma Inf_pres_downset: "Inf_pres (\::'a::complete_lattice \ 'a set)" unfolding downset_prop fun_eq_iff comp_def by (safe, simp_all add: le_Inf_iff) lemma Sup_dual_upset: "Sup_dual (\::'a::complete_lattice \ 'a set)" unfolding upset_prop fun_eq_iff comp_def by (safe, simp_all add: Sup_le_iff) text \This approach could probably be combined with the explicit functor-based one. This may be good for proofs, but seems conceptually rather ugly.\ end \ No newline at end of file diff --git a/thys/Order_Lattice_Props/ROOT b/thys/Order_Lattice_Props/ROOT --- a/thys/Order_Lattice_Props/ROOT +++ b/thys/Order_Lattice_Props/ROOT @@ -1,19 +1,17 @@ chapter AFP session Order_Lattice_Props = "HOL-Library" + options [timeout = 600] - theories Sup_Lattice Order_Duality Order_Lattice_Props Representations Galois_Connections Fixpoint_Fusion Closure_Operators Order_Lattice_Props_Loc Order_Lattice_Props_Wenzel - document_files "root.tex" - "root.bib" \ No newline at end of file + "root.bib" diff --git a/thys/Order_Lattice_Props/Representations.thy b/thys/Order_Lattice_Props/Representations.thy --- a/thys/Order_Lattice_Props/Representations.thy +++ b/thys/Order_Lattice_Props/Representations.thy @@ -1,620 +1,621 @@ (* Title: Representation Theorems for Orderings and Lattices Author: Georg Struth Maintainer: Georg Struth *) section \Representation Theorems for Orderings and Lattices\ theory Representations imports Order_Lattice_Props begin subsection \Representation of Posets\ text \The isomorphism between partial orders and downsets with set inclusion is well known. It forms the basis of Priestley and Stone duality. I show it not only for objects, but also order morphisms, hence establish equivalences and isomorphisms between categories.\ typedef (overloaded) 'a downset = "range (\::'a::ord \ 'a set)" by fastforce setup_lifting type_definition_downset text \The map ds yields the isomorphism between the set and the powerset level if its range is restricted to downsets.\ definition ds :: "'a::ord \ 'a downset" where "ds = Abs_downset \ \" text \In a complete lattice, its inverse is Sup.\ definition SSup :: "'a::complete_lattice downset \ 'a" where "SSup = Sup \ Rep_downset" lemma ds_SSup_inv: "ds \ SSup = (id::'a::complete_lattice downset \ 'a downset)" unfolding ds_def SSup_def - by (smt Rep_downset Rep_downset_inverse cSup_atMost eq_id_iff imageE o_def ord_class.atMost_def ord_class.downset_prop) + by (smt (verit) Rep_downset Rep_downset_inverse cSup_atMost eq_id_iff imageE o_def ord_class.atMost_def ord_class.downset_prop) lemma SSup_ds_inv: "SSup \ ds = (id::'a::complete_lattice \ 'a)" unfolding ds_def SSup_def fun_eq_iff id_def comp_def by (simp add: Abs_downset_inverse pointfree_idE) instantiation downset :: (ord) order begin lift_definition less_eq_downset :: "'a downset \ 'a downset \ bool" is "(\X Y. Rep_downset X \ Rep_downset Y)" . lift_definition less_downset :: "'a downset \ 'a downset \ bool" is "(\X Y. Rep_downset X \ Rep_downset Y)" . instance by (intro_classes, transfer, auto simp: Rep_downset_inject less_eq_downset_def) end lemma ds_iso: "mono ds" unfolding mono_def ds_def fun_eq_iff comp_def by (metis Abs_downset_inverse downset_iso_iff less_eq_downset.rep_eq rangeI) lemma ds_faithful: "ds x \ ds y \ x \ (y::'a::order)" by (simp add: Abs_downset_inverse downset_faithful ds_def less_eq_downset.rep_eq) lemma ds_inj: "inj (ds::'a::order \ 'a downset)" by (simp add: ds_faithful dual_order.antisym injI) lemma ds_surj: "surj ds" by (metis (no_types, opaque_lifting) Rep_downset Rep_downset_inverse ds_def image_iff o_apply surj_def) lemma ds_bij: "bij (ds::'a::order \ 'a downset)" by (simp add: bijI ds_inj ds_surj) lemma ds_ord_iso: "ord_iso ds" - unfolding ord_iso_def comp_def inf_bool_def by (smt UNIV_I ds_bij ds_faithful ds_inj ds_iso ds_surj f_the_inv_into_f inf1I mono_def) + unfolding ord_iso_def comp_def inf_bool_def by (smt (verit) UNIV_I ds_bij ds_faithful ds_inj ds_iso ds_surj f_the_inv_into_f inf1I mono_def) text \The morphishms between orderings and downsets are isotone functions. One can define functors mapping back and forth between these.\ definition map_ds :: "('a::complete_lattice \ 'b::complete_lattice) \ ('a downset \ 'b downset)" where "map_ds f = ds \ f \ SSup" text \This definition is actually contrived. We have shown that a function f between posets P and Q is isotone if and only if the inverse image of f maps downclosed sets in Q to downclosed sets in P. There is the following duality: ds is a natural transformation between the identity functor and the preimage functor as a contravariant functor from P to Q. Hence orderings with isotone maps and downsets with downset-preserving maps are dual, which is a first step towards Stone duality. I don't see a way of proving this with Isabelle, as the types of the preimage of f are the wrong way and I don't see how I could capture opposition with what I have.\ (*lemma "mono (f::'a::complete_lattice \ 'b::complete_lattimap_ds f = Abs_downset \ (-) f \ Rep_downset" doesn't work! *) lemma map_ds_prop: fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows "map_ds f \ ds = ds \ f" unfolding map_ds_def by (simp add: SSup_ds_inv comp_assoc) lemma map_ds_prop2: fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows "map_ds f \ ds = ds \ id f" unfolding map_ds_def by (simp add: SSup_ds_inv comp_assoc) text \This is part of showing that map-ds is naturally isomorphic to the identity functor, ds being the natural isomorphism.\ definition map_SSup :: "('a downset \ 'b downset) \ ('a::complete_lattice \ 'b::complete_lattice)" where "map_SSup F = SSup \ F \ ds" lemma map_ds_iso_pres: fixes f :: "'a::complete_lattice \ 'b::complete_lattice" shows "mono f \ mono (map_ds f)" unfolding fun_eq_iff mono_def map_ds_def ds_def SSup_def comp_def by (metis Abs_downset_inverse Sup_subset_mono downset_iso_iff less_eq_downset.rep_eq rangeI) lemma map_SSup_iso_pres: fixes F :: "'a::complete_lattice downset \ 'b::complete_lattice downset" shows "mono F \ mono (map_SSup F)" unfolding fun_eq_iff mono_def map_SSup_def ds_def SSup_def comp_def by (metis Abs_downset_inverse Sup_subset_mono downset_iso_iff less_eq_downset.rep_eq rangeI) lemma map_SSup_prop: fixes F :: "'a::complete_lattice downset \ 'b::complete_lattice downset" shows "ds \ map_SSup F = F \ ds" unfolding map_SSup_def by (metis ds_SSup_inv fun.map_id0 id_def rewriteL_comp_comp) lemma map_SSup_prop2: fixes F :: "'a::complete_lattice downset \ 'b::complete_lattice downset" shows "ds \ map_SSup F = id F \ ds" by (simp add: map_SSup_prop) lemma map_ds_func1: "map_ds id = (id::'a::complete_lattice downset\ 'a downset)" by (simp add: ds_SSup_inv map_ds_def) lemma map_ds_func2: fixes g :: "'a::complete_lattice \ 'b::complete_lattice" shows "map_ds (f \ g) = map_ds f \ map_ds g" unfolding map_ds_def fun_eq_iff comp_def ds_def SSup_def by (metis Abs_downset_inverse Sup_atMost atMost_def downset_prop rangeI) lemma map_SSup_func1: "map_SSup (id::'a::complete_lattice downset\ 'a downset) = id" by (simp add: SSup_ds_inv map_SSup_def) lemma map_SSup_func2: fixes F :: "'c::complete_lattice downset \ 'b::complete_lattice downset" and G :: "'a::complete_lattice downset \ 'c downset" shows "map_SSup (F \ G) = map_SSup F \ map_SSup G" unfolding map_SSup_def fun_eq_iff comp_def id_def ds_def by (metis comp_apply ds_SSup_inv ds_def id_apply) lemma map_SSup_map_ds_inv: "map_SSup \ map_ds = (id::('a::complete_lattice \ 'b::complete_lattice) \ ('a \ 'b))" by (metis (no_types, opaque_lifting) SSup_ds_inv comp_def eq_id_iff fun.map_comp fun.map_id0 id_apply map_SSup_prop map_ds_prop) lemma map_ds_map_SSup_inv: "map_ds \ map_SSup = (id::('a::complete_lattice downset \ 'b::complete_lattice downset) \ ('a downset \ 'b downset))" unfolding map_SSup_def map_ds_def SSup_def ds_def id_def comp_def fun_eq_iff by (metis (no_types, lifting) Rep_downset Rep_downset_inverse Sup_downset_id image_iff pointfree_idE) lemma inj_map_ds: "inj (map_ds::('a::complete_lattice \ 'b::complete_lattice) \ ('a downset \ 'b downset))" by (metis (no_types, lifting) SSup_ds_inv fun.map_id0 id_comp inj_def map_ds_prop rewriteR_comp_comp2) lemma inj_map_SSup: "inj (map_SSup::('a::complete_lattice downset \ 'b::complete_lattice downset) \ ('a \ 'b))" by (metis inj_on_id inj_on_imageI2 map_ds_map_SSup_inv) lemma map_ds_map_SSup_iff: fixes g :: "'a::complete_lattice \ 'b::complete_lattice" shows "(f = map_ds g) = (map_SSup f = g)" by (metis inj_eq inj_map_ds map_ds_map_SSup_inv pointfree_idE) text \This gives an isomorphism between categories.\ lemma surj_map_ds: "surj (map_ds::('a::complete_lattice \ 'b::complete_lattice) \ ('a downset \ 'b downset))" by (simp add: map_ds_map_SSup_iff surj_def) lemma surj_map_SSup: "surj (map_SSup::('a::complete_lattice_with_dual downset \ 'b::complete_lattice_with_dual downset) \ ('a \ 'b))" by (metis map_ds_map_SSup_iff surjI) text \There is of course a dual result for upsets with the reverse inclusion ordering. Once again, it seems impossible to capture the "real" duality that uses the inverse image functor.\ typedef (overloaded) 'a upset = "range (\::'a::ord \ 'a set)" by fastforce setup_lifting type_definition_upset definition us :: "'a::ord \ 'a upset" where "us = Abs_upset \ \" definition IInf :: "'a::complete_lattice upset \ 'a" where "IInf = Inf \ Rep_upset" lemma us_ds: "us = Abs_upset \ () \ \ Rep_downset \ ds \ (\::'a::ord_with_dual \ 'a)" unfolding us_def ds_def fun_eq_iff comp_def by (simp add: Abs_downset_inverse upset_to_downset2) lemma IInf_SSup: "IInf = \ \ SSup \ Abs_downset \ () (\::'a::complete_lattice_with_dual \ 'a) \ Rep_upset" unfolding IInf_def SSup_def fun_eq_iff comp_def by (metis (no_types, opaque_lifting) Abs_downset_inverse Rep_upset Sup_dual_def_var image_iff rangeI subset_dual upset_to_downset3) lemma us_IInf_inv: "us \ IInf = (id::'a::complete_lattice_with_dual upset \ 'a upset)" unfolding us_def IInf_def fun_eq_iff id_def comp_def by (metis (no_types, lifting) Inf_upset_id Rep_upset Rep_upset_inverse f_the_inv_into_f pointfree_idE upset_inj) lemma IInf_us_inv: "IInf \ us = (id::'a::complete_lattice_with_dual \ 'a)" unfolding us_def IInf_def fun_eq_iff id_def comp_def by (metis Abs_upset_inverse Sup_Inf_var Sup_atLeastAtMost Sup_dual_upset_var order_refl rangeI) instantiation upset :: (ord) order begin lift_definition less_eq_upset :: "'a upset \ 'a upset \ bool" is "(\X Y. Rep_upset X \ Rep_upset Y)" . lift_definition less_upset :: "'a upset \ 'a upset \ bool" is "(\X Y. Rep_upset X \ Rep_upset Y)" . instance by (intro_classes, transfer, simp_all add: less_le_not_le less_eq_upset.rep_eq Rep_upset_inject) end lemma us_iso: "x \ y \ us x \ us (y::'a::order_with_dual)" by (simp add: Abs_upset_inverse less_eq_upset.rep_eq upset_anti_iff us_def) lemma us_faithful: "us x \ us y \ x \ (y::'a::order_with_dual)" by (simp add: Abs_upset_inverse upset_faithful us_def less_eq_upset.rep_eq) lemma us_inj: "inj (us::'a::order_with_dual \ 'a upset)" unfolding inj_def by (simp add: us_faithful dual_order.antisym) lemma us_surj: "surj (us::'a::order_with_dual \ 'a upset)" unfolding surj_def by (metis Rep_upset Rep_upset_inverse comp_def image_iff us_def) lemma us_bij: "bij (us::'a::order_with_dual \ 'a upset)" by (simp add: bij_def us_surj us_inj) lemma us_ord_iso: "ord_iso (us::'a::order_with_dual \ 'a upset)" unfolding ord_iso_def by (simp, metis (no_types, lifting) UNIV_I f_the_inv_into_f monoI us_iso us_bij us_faithful us_inj us_surj) definition map_us :: "('a::complete_lattice \ 'b::complete_lattice) \ ('a upset \ 'b upset)" where "map_us f = us \ f \ IInf" lemma map_us_prop: "map_us f \ (us::'a::complete_lattice_with_dual \ 'a upset) = us \ id f" unfolding map_us_def by (simp add: IInf_us_inv comp_assoc) definition map_IInf :: "('a upset \ 'b upset) \ ('a::complete_lattice \ 'b::complete_lattice)" where "map_IInf F = IInf \ F \ us" lemma map_IInf_prop: "(us::'a::complete_lattice_with_dual \ 'a upset) \ map_IInf F = id F \ us" proof- have "us \ map_IInf F = (us \ IInf) \ F \ us" by (simp add: fun.map_comp map_IInf_def) thus ?thesis by (simp add: us_IInf_inv) qed lemma map_us_func1: "map_us id = (id::'a::complete_lattice_with_dual upset \ 'a upset)" unfolding map_us_def fun_eq_iff comp_def us_def id_def IInf_def by (metis (no_types, lifting) Inf_upset_id Rep_upset Rep_upset_inverse image_iff pointfree_idE) lemma map_us_func2: fixes f :: "'c::complete_lattice_with_dual \ 'b::complete_lattice_with_dual" and g :: "'a::complete_lattice_with_dual \ 'c" shows "map_us (f \ g) = map_us f \ map_us g" unfolding map_us_def fun_eq_iff comp_def us_def IInf_def by (metis Abs_upset_inverse Sup_Inf_var Sup_atLeastAtMost Sup_dual_upset_var order_refl rangeI) lemma map_IInf_func1: "map_IInf id = (id::'a::complete_lattice_with_dual \ 'a)" unfolding map_IInf_def fun_eq_iff comp_def id_def us_def IInf_def by (simp add: Abs_upset_inverse pointfree_idE) lemma map_IInf_func2: fixes F :: "'c::complete_lattice_with_dual upset \ 'b::complete_lattice_with_dual upset" and G :: "'a::complete_lattice_with_dual upset \ 'c upset" shows "map_IInf (F \ G) = map_IInf F \ map_IInf G" unfolding map_IInf_def fun_eq_iff comp_def id_def us_def by (metis comp_apply id_apply us_IInf_inv us_def) lemma map_IInf_map_us_inv: "map_IInf \ map_us = (id::('a::complete_lattice_with_dual \ 'b::complete_lattice_with_dual) \ ('a \ 'b))" unfolding map_IInf_def map_us_def IInf_def us_def id_def comp_def fun_eq_iff by (simp add: Abs_upset_inverse pointfree_idE) lemma map_us_map_IInf_inv: "map_us \ map_IInf = (id::('a::complete_lattice_with_dual upset \ 'b::complete_lattice_with_dual upset) \ ('a upset \ 'b upset))" unfolding map_IInf_def map_us_def IInf_def us_def id_def comp_def fun_eq_iff by (metis (no_types, lifting) Inf_upset_id Rep_upset Rep_upset_inverse image_iff pointfree_idE) lemma inj_map_us: "inj (map_us::('a::complete_lattice_with_dual \ 'b::complete_lattice_with_dual) \ ('a upset \ 'b upset))" unfolding map_us_def us_def IInf_def inj_def comp_def fun_eq_iff by (metis (no_types, opaque_lifting) Abs_upset_inverse Inf_upset_id pointfree_idE rangeI) lemma inj_map_IInf: "inj (map_IInf::('a::complete_lattice_with_dual upset \ 'b::complete_lattice_with_dual upset) \ ('a \ 'b))" unfolding map_IInf_def fun_eq_iff inj_def comp_def IInf_def us_def by (metis (no_types, opaque_lifting) Inf_upset_id Rep_upset Rep_upset_inverse image_iff pointfree_idE) lemma map_us_map_IInf_iff: fixes g :: "'a::complete_lattice_with_dual \ 'b::complete_lattice_with_dual" shows "(f = map_us g) = (map_IInf f = g)" by (metis inj_eq inj_map_us map_us_map_IInf_inv pointfree_idE) lemma map_us_mono_pres: fixes f :: "'a::complete_lattice_with_dual \ 'b::complete_lattice_with_dual" shows "mono f \ mono (map_us f)" unfolding mono_def map_us_def comp_def us_def IInf_def by (metis Abs_upset_inverse Inf_superset_mono less_eq_upset.rep_eq rangeI upset_anti_iff) lemma map_IInf_mono_pres: fixes F :: "'a::complete_lattice_with_dual upset \ 'b::complete_lattice_with_dual upset" shows "mono F \ mono (map_IInf F)" unfolding mono_def map_IInf_def comp_def us_def IInf_def oops lemma surj_map_us: "surj (map_us::('a::complete_lattice_with_dual \ 'b::complete_lattice_with_dual) \ ('a upset \ 'b upset))" by (simp add: map_us_map_IInf_iff surj_def) lemma surj_map_IInf: "surj (map_IInf::('a::complete_lattice_with_dual upset \ 'b::complete_lattice_with_dual upset) \ ('a \ 'b))" by (metis map_us_map_IInf_iff surjI) text \Hence we have again an isomorphism --- or rather equivalence --- between categories. Here, however, duality is not consistently picked up.\ subsection \Stone's Theorem in the Presence of Atoms\ text \Atom-map is a boolean algebra morphism.\ context boolean_algebra begin lemma atom_map_compl_pres: "atom_map (-x) = Collect atom - atom_map x" proof- {fix y have "(y \ atom_map (-x)) = (atom y \ y \ -x)" by (simp add: atom_map_def) also have "... = (atom y \ $$y \ x))" by (metis atom_sup_iff inf.orderE inf_shunt sup_compl_top top.ordering_top_axioms ordering_top.extremum) also have "... = (y \ Collect atom - atom_map x)" using atom_map_def by auto finally have "(y \ atom_map (-x)) = (y \ Collect atom - atom_map x)".} thus ?thesis by blast qed lemma atom_map_sup_pres: "atom_map (x \ y) = atom_map x \ atom_map y" proof- {fix z have "(z \ atom_map (x \ y)) = (atom z \ z \ x \ y)" by (simp add: atom_map_def) also have "... = (atom z \ (z \ x \ z \ y))" using atom_sup_iff by auto also have "... = (z \ atom_map x \ atom_map y)" using atom_map_def by auto finally have "(z \ atom_map (x \ y)) = (z \ atom_map x \ atom_map y)" by blast} thus ?thesis by blast qed lemma atom_map_inf_pres: "atom_map (x \ y) = atom_map x \ atom_map y" - by (smt Diff_Un atom_map_compl_pres atom_map_sup_pres compl_inf double_compl) + by (smt (verit) Diff_Un atom_map_compl_pres atom_map_sup_pres compl_inf double_compl) lemma atom_map_minus_pres: "atom_map (x - y) = atom_map x - atom_map y" using atom_map_compl_pres atom_map_def diff_eq by auto end text \The homomorphic images of boolean algebras under atom-map are boolean algebras --- in fact powerset boolean algebras.\ instantiation atoms :: (boolean_algebra) boolean_algebra begin lift_definition minus_atoms :: "'a atoms \ 'a atoms \ 'a atoms" is "\x y. Abs_atoms (Rep_atoms x - Rep_atoms y)". lift_definition uminus_atoms :: "'a atoms \ 'a atoms" is "\x. Abs_atoms (Collect atom - Rep_atoms x)". lift_definition bot_atoms :: "'a atoms" is "Abs_atoms {}". lift_definition sup_atoms :: "'a atoms \ 'a atoms \ 'a atoms" is "\x y. Abs_atoms (Rep_atoms x \ Rep_atoms y)". lift_definition top_atoms :: "'a atoms" is "Abs_atoms (Collect atom)". lift_definition inf_atoms :: "'a atoms \ 'a atoms \ 'a atoms" is "\x y. Abs_atoms (Rep_atoms x \ Rep_atoms y)". lift_definition less_eq_atoms :: "'a atoms \ 'a atoms \ bool" is "(\x y. Rep_atoms x \ Rep_atoms y)". lift_definition less_atoms :: "'a atoms \ 'a atoms \ bool" is "(\x y. Rep_atoms x \ Rep_atoms y)". instance apply intro_classes apply (transfer, simp add: less_le_not_le) apply (transfer, simp) apply (transfer, blast) apply (simp add: Rep_atoms_inject less_eq_atoms.abs_eq) - apply (transfer, smt Abs_atoms_inverse Rep_atoms atom_map_inf_pres image_iff inf_le1 rangeI) - apply (transfer, smt Abs_atoms_inverse Rep_atoms atom_map_inf_pres image_iff inf_le2 rangeI) - apply (transfer, smt Abs_atoms_inverse Rep_atoms atom_map_inf_pres image_iff le_iff_sup rangeI sup_inf_distrib1) - apply (transfer, smt Abs_atoms_inverse Rep_atoms atom_map_sup_pres image_iff image_iff inf.orderE inf_sup_aci(6) le_iff_sup order_refl rangeI rangeI) - apply (transfer, smt Abs_atoms_inverse Rep_atoms atom_map_sup_pres image_iff inf_sup_aci(6) le_iff_sup rangeI sup.left_commute sup.right_idem) + apply (transfer, smt (verit) Abs_atoms_inverse Rep_atoms atom_map_inf_pres image_iff inf_le1 rangeI) + apply (transfer, smt (verit) Abs_atoms_inverse Rep_atoms atom_map_inf_pres image_iff inf_le2 rangeI) + apply (transfer, smt (verit) Abs_atoms_inverse Rep_atoms atom_map_inf_pres image_iff le_iff_sup rangeI sup_inf_distrib1) + apply (transfer, smt (verit) Abs_atoms_inverse Rep_atoms atom_map_sup_pres image_iff image_iff inf.orderE inf_sup_aci(6) le_iff_sup order_refl rangeI rangeI) + apply (transfer, smt (verit) Abs_atoms_inverse Rep_atoms atom_map_sup_pres image_iff inf_sup_aci(6) le_iff_sup rangeI sup.left_commute sup.right_idem) apply (transfer, subst Abs_atoms_inverse, metis (no_types, lifting) Rep_atoms atom_map_sup_pres image_iff rangeI, simp) apply transfer using Abs_atoms_inverse atom_map_bot_pres apply blast apply (transfer, metis Abs_atoms_inverse Rep_atoms atom_map_compl_pres atom_map_top_pres diff_eq double_compl inf_le1 rangeE rangeI) - apply (transfer, smt Abs_atoms_inverse Rep_atoms atom_map_inf_pres atom_map_sup_pres image_iff rangeI sup_inf_distrib1) + apply (transfer, smt (verit, ccfv_threshold) Abs_atoms_inverse Rep_atoms atom_map_inf_pres atom_map_sup_pres image_iff rangeI sup_inf_distrib1) apply (transfer, metis (no_types, opaque_lifting) Abs_atoms_inverse Diff_disjoint Rep_atoms atom_map_compl_pres rangeE rangeI) apply (transfer, smt Abs_atoms_inverse uminus_atoms.abs_eq Rep_atoms Un_Diff_cancel atom_map_compl_pres atom_map_inf_pres atom_map_minus_pres atom_map_sup_pres atom_map_top_pres diff_eq double_compl inf_compl_bot_right rangeE rangeI sup_commute sup_compl_top) - by transfer (smt Abs_atoms_inverse Rep_atoms atom_map_compl_pres atom_map_inf_pres atom_map_minus_pres diff_eq rangeE rangeI) + apply (transfer, smt Abs_atoms_inverse Rep_atoms atom_map_compl_pres atom_map_inf_pres atom_map_minus_pres diff_eq rangeE rangeI) + done end text \The homomorphism atom-map can then be restricted in its output type to the powerset boolean algebra.\ lemma at_map_bot_pres: "at_map \ = \" by (simp add: at_map_def atom_map_bot_pres bot_atoms.transfer) lemma at_map_top_pres: "at_map \ = \" by (simp add: at_map_def atom_map_top_pres top_atoms.transfer) lemma at_map_compl_pres: "at_map \ uminus = uminus \ at_map" unfolding fun_eq_iff by (simp add: Abs_atoms_inverse at_map_def atom_map_compl_pres uminus_atoms.abs_eq) lemma at_map_sup_pres: "at_map (x \ y) = at_map x \ at_map y" unfolding at_map_def comp_def by (metis (mono_tags, lifting) Abs_atoms_inverse atom_map_sup_pres rangeI sup_atoms.transfer) lemma at_map_inf_pres: "at_map (x \ y) = at_map x \ at_map y" unfolding at_map_def comp_def by (metis (mono_tags, lifting) Abs_atoms_inverse atom_map_inf_pres inf_atoms.transfer rangeI) lemma at_map_minus_pres: "at_map (x - y) = at_map x - at_map y" unfolding at_map_def comp_def by (simp add: Abs_atoms_inverse atom_map_minus_pres minus_atoms.abs_eq) context atomic_boolean_algebra begin text \In atomic boolean algebras, atom-map is an embedding that maps atoms of the boolean algebra to those of the powerset boolean algebra. Analogous properties hold for at-map.\ lemma inj_atom_map: "inj atom_map" proof- {fix x y ::'a assume "x \ y" hence "x \ -y \ \ \ -x \ y \ \" by (auto simp: inf_shunt) hence "\z. atom z \ (z \ x \ -y \ z \ -x \ y)" using atomicity by blast hence "\z. atom z \ ((z \ atom_map x \ \(z \ atom_map y)) \ (\(z \ atom_map x) \ z \ atom_map y))" unfolding atom_def atom_map_def by (clarsimp, metis diff_eq inf.orderE diff_shunt_var) hence "atom_map x \ atom_map y" by blast} thus ?thesis by (meson injI) qed lemma atom_map_atom_pres: "atom x \ atom_map x = {x}" unfolding atom_def atom_map_def by (auto simp: bot_less dual_order.order_iff_strict) lemma atom_map_atom_pres2: "atom x \ atom (atom_map x)" proof- assume "atom x" hence "atom_map x = {x}" by (simp add: atom_map_atom_pres) thus "atom (atom_map x)" using bounded_lattice_class.atom_def by auto qed end lemma inj_at_map: "inj (at_map::'a::atomic_boolean_algebra \ 'a atoms)" unfolding at_map_def comp_def by (metis (no_types, lifting) Abs_atoms_inverse inj_atom_map inj_def rangeI) lemma at_map_atom_pres: "atom (x::'a::atomic_boolean_algebra) \ at_map x = Abs_atoms {x}" unfolding at_map_def comp_def by (simp add: atom_map_atom_pres) lemma at_map_atom_pres2: "atom (x::'a::atomic_boolean_algebra) \ atom (at_map x)" unfolding at_map_def comp_def by (metis Abs_atoms_inverse atom_def atom_map_atom_pres2 atom_map_bot_pres bot_atoms.abs_eq less_atoms.abs_eq rangeI) text \Homomorphic images of atomic boolean algebras under atom-map are therefore atomic (rather obviously).\ instance atoms :: (atomic_boolean_algebra) atomic_boolean_algebra proof intro_classes fix x::"'a atoms" assume "x \ \" hence "\y. x = at_map y \ x \ \" unfolding at_map_def comp_def by (metis Abs_atoms_cases rangeE) hence "\y. x = at_map y \ (\z. atom z \ z \ y)" using at_map_bot_pres atomicity by force hence "\y. x = at_map y \ (\z. atom (at_map z) \ at_map z \ at_map y)" by (metis at_map_atom_pres2 at_map_sup_pres sup.orderE sup_ge2) thus "\y. atom y \ y \ x" by fastforce qed context complete_boolean_algebra_alt begin text \In complete boolean algebras, atom-map is surjective; more precisely it is the left inverse of Sup, at least for sets of atoms. Below, this statement is made more explicit for at-map.\ lemma surj_atom_map: "Y \ Collect atom \ Y = atom_map (\Y)" proof assume "Y \ Collect atom" thus "Y \ atom_map (\Y)" using Sup_upper atom_map_def by force next assume "Y \ Collect atom" hence a: "\y. y \ Y \ atom y" by blast {fix z assume h: "z \ Collect atom - Y" hence "\y \ Y. y \ z = \" by (metis DiffE a h atom_def dual_order.not_eq_order_implies_strict inf.absorb_iff2 inf_le2 inf_shunt mem_Collect_eq) hence "\Y \ z = \" using Sup_least inf_shunt by simp hence "z \ atom_map (\Y)" using atom_map_bot_pres atom_map_def by force} thus "atom_map (\Y) \ Y" using atom_map_def by force qed text \In this setting, atom-map is a complete boolean algebra morphism.\ lemma atom_map_Sup_pres: "atom_map (\X) = (\x \ X. atom_map x)" proof- {fix z have "(z \ atom_map (\X)) = (atom z \ z \ \X)" by (simp add: atom_map_def) also have "... = (atom z \ (\x \ X. z \ x))" using atom_Sup_iff by auto also have "... = (z \ (\x \ X. atom_map x))" using atom_map_def by auto finally have "(z \ atom_map (\X)) = (z \ (\x \ X. atom_map x))" by blast} thus ?thesis by blast qed lemma atom_map_Sup_pres_var: "atom_map \ Sup = Sup \ () atom_map" unfolding fun_eq_iff comp_def by (simp add: atom_map_Sup_pres) text \For Inf-preservation, it is important that Infs are restricted to homomorphic images; hence they need to be pushed into the set of all atoms.\ lemma atom_map_Inf_pres: "atom_map (\X) = Collect atom \ (\x \ X. atom_map x)" proof- have "atom_map (\X) = atom_map (-(\x \ X. -x))" by (smt Collect_cong SUP_le_iff atom_map_def compl_le_compl_iff compl_le_swap1 le_Inf_iff) also have "... = Collect atom - atom_map (\x \ X. -x)" using atom_map_compl_pres by blast also have "... = Collect atom - (\x \ X. atom_map (-x))" by (simp add: atom_map_Sup_pres) also have "... = Collect atom - (\x \ X. Collect atom - atom_map (x))" using atom_map_compl_pres by blast also have "... = Collect atom \ (\x \ X. atom_map x)" by blast finally show ?thesis. qed end text \It follows that homomorphic images of complete boolean algebras under atom-map form complete boolean algebras.\ instantiation atoms :: (complete_boolean_algebra_alt) complete_boolean_algebra_alt begin lift_definition Inf_atoms :: "'a::complete_boolean_algebra_alt atoms set \ 'a::complete_boolean_algebra_alt atoms" is "\X. Abs_atoms (Collect atom \ Inter (() Rep_atoms X))". lift_definition Sup_atoms :: "'a::complete_boolean_algebra_alt atoms set \ 'a::complete_boolean_algebra_alt atoms" is "\X. Abs_atoms (Union (() Rep_atoms X))". instance apply (intro_classes; transfer) apply (metis (no_types, opaque_lifting) Abs_atoms_inverse image_iff inf_le1 le_Inf_iff le_infI2 order_refl rangeI surj_atom_map) apply (metis (no_types, lifting) Abs_atoms_inverse Int_subset_iff Rep_atoms Sup_upper atom_map_atoms inf_le1 le_INF_iff rangeI surj_atom_map) apply (metis Abs_atoms_inverse Rep_atoms SUP_least SUP_upper Sup_upper atom_map_atoms rangeI surj_atom_map) apply (metis Abs_atoms_inverse Rep_atoms SUP_least Sup_upper atom_map_atoms rangeI surj_atom_map) by simp_all end text \Once more, properties proved above can now be restricted to at-map.\ lemma surj_at_map_var: "at_map \ Sup \ Rep_atoms = (id::'a::complete_boolean_algebra_alt atoms \ 'a atoms)" unfolding at_map_def comp_def fun_eq_iff id_def by (metis Rep_atoms Rep_atoms_inverse Sup_upper atom_map_atoms surj_atom_map) lemma surj_at_map: "surj (at_map::'a::complete_boolean_algebra_alt \ 'a atoms)" unfolding surj_def at_map_def comp_def by (metis Rep_atoms Rep_atoms_inverse image_iff) lemma at_map_Sup_pres: "at_map \ Sup = Sup \ () (at_map::'a::complete_boolean_algebra_alt \ 'a atoms)" unfolding fun_eq_iff at_map_def comp_def atom_map_Sup_pres by (smt Abs_atoms_inverse Sup.SUP_cong Sup_atoms.transfer UN_extend_simps(10) rangeI) lemma at_map_Sup_pres_var: "at_map (\X) = (\(x::'a::complete_boolean_algebra_alt) \ X. (at_map x))" using at_map_Sup_pres comp_eq_elim by blast lemma at_map_Inf_pres: "at_map (\X) = Abs_atoms (Collect atom \ (\x \ X. (Rep_atoms (at_map (x::'a::complete_boolean_algebra_alt)))))" unfolding at_map_def comp_def by (metis (no_types, lifting) Abs_atoms_inverse Sup.SUP_cong atom_map_Inf_pres rangeI) lemma at_map_Inf_pres_var: "at_map \ Inf = Inf \ () (at_map::'a::complete_boolean_algebra_alt \ 'a atoms)" unfolding fun_eq_iff comp_def by (metis Inf_atoms.abs_eq at_map_Inf_pres image_image) text \Finally, on complete atomic boolean algebras (CABAs), at-map is an isomorphism, that is, a bijection that preserves the complete boolean algebra operations. Thus every CABA is isomorphic to a powerset boolean algebra and every powerset boolean algebra is a CABA. The bijective pair is given by at-map and Sup (defined on the powerset algebra). This theorem is a little version of Stone's theorem. In the general case, ultrafilters play the role of atoms.\ lemma "Sup \ atom_map = (id::'a::complete_atomic_boolean_algebra \ 'a)" unfolding fun_eq_iff comp_def id_def by (metis Union_upper atom_map_atoms inj_atom_map inj_def rangeI surj_atom_map) lemma inj_at_map_var: "Sup \ Rep_atoms \ at_map = (id ::'a::complete_atomic_boolean_algebra \ 'a)" unfolding at_map_def comp_def fun_eq_iff id_def by (metis Abs_atoms_inverse Union_upper atom_map_atoms inj_atom_map inj_def rangeI surj_atom_map) lemma bij_at_map: "bij (at_map::'a::complete_atomic_boolean_algebra \ 'a atoms)" unfolding bij_def by (simp add: inj_at_map surj_at_map) instance atoms :: (complete_atomic_boolean_algebra) complete_atomic_boolean_algebra.. text \A full consideration of Stone duality is left for future work.\ (* Failed attempt to prove Tarski's fixpoint theorem: The problem is that we want to use mono, but this has two type parameters. It doesn't work inside of the one-type-parameter typedef. Yet isotonicity is needed to prove inhabitance of the type. I could develop a theory of isotone endos and prove the existence of lfps and gfps, duplicating the more general facts for mono. But that's not the point. Because of this I see no direct way of proving Tarski's fixpoint theorem. Any way out? class complete_lattice_with_iso = complete_lattice + fixes f :: "'a \ 'a" (* assumes isof: "x \ y \ f x \ f y"*) typedef (overloaded) 'a Fix = "Fix (f::'a::complete_lattice_with_iso \ 'a)" setup_lifting type_definition_Fix *) end diff --git a/thys/Ordered_Resolution_Prover/FO_Ordered_Resolution_Prover.thy b/thys/Ordered_Resolution_Prover/FO_Ordered_Resolution_Prover.thy --- a/thys/Ordered_Resolution_Prover/FO_Ordered_Resolution_Prover.thy +++ b/thys/Ordered_Resolution_Prover/FO_Ordered_Resolution_Prover.thy @@ -1,1360 +1,1360 @@ (* Title: An Ordered Resolution Prover for First-Order Clauses Author: Anders Schlichtkrull , 2016, 2017 Author: Jasmin Blanchette , 2014, 2017 Author: Dmitriy Traytel , 2014 Maintainer: Anders Schlichtkrull *) section \An Ordered Resolution Prover for First-Order Clauses\ theory FO_Ordered_Resolution_Prover imports FO_Ordered_Resolution begin text \ This material is based on Section 4.3 (A Simple Resolution Prover for First-Order Clauses'') of Bachmair and Ganzinger's chapter. Specifically, it formalizes the RP prover defined in Figure 5 and its related lemmas and theorems, including Lemmas 4.10 and 4.11 and Theorem 4.13 (completeness). \ definition is_least :: "(nat \ bool) \ nat \ bool" where "is_least P n \ P n \ (\n' < n. \ P n')" lemma least_exists: "P n \ \n. is_least P n" using exists_least_iff unfolding is_least_def by auto text \ The following corresponds to page 42 and 43 of Section 4.3, from the explanation of RP to Lemma 4.10. \ type_synonym 'a state = "'a clause set \ 'a clause set \ 'a clause set" locale FO_resolution_prover = FO_resolution subst_atm id_subst comp_subst renamings_apart atm_of_atms mgu less_atm + selection S for S :: "('a :: wellorder) clause \ 'a clause" and subst_atm :: "'a \ 's \ 'a" and id_subst :: "'s" and comp_subst :: "'s \ 's \ 's" and renamings_apart :: "'a clause list \ 's list" and atm_of_atms :: "'a list \ 'a" and mgu :: "'a set set \ 's option" and less_atm :: "'a \ 'a \ bool" + assumes sel_stable: "\\ C. is_renaming \ \ S (C \$$ = S C \ \" begin fun N_of_state :: "'a state \ 'a clause set" where "N_of_state (N, P, Q) = N" fun P_of_state :: "'a state \ 'a clause set" where "P_of_state (N, P, Q) = P" text \ \O\ denotes relation composition in Isabelle, so the formalization uses \Q\ instead. \ fun Q_of_state :: "'a state \ 'a clause set" where "Q_of_state (N, P, Q) = Q" abbreviation clss_of_state :: "'a state \ 'a clause set" where "clss_of_state St \ N_of_state St \ P_of_state St \ Q_of_state St" abbreviation grounding_of_state :: "'a state \ 'a clause set" where "grounding_of_state St \ grounding_of_clss (clss_of_state St)" interpretation ord_FO_resolution: inference_system "ord_FO_\ S" . text \ The following inductive predicate formalizes the resolution prover in Figure 5. \ inductive RP :: "'a state \ 'a state \ bool" (infix "\" 50) where tautology_deletion: "Neg A \# C \ Pos A \# C \ (N \ {C}, P, Q) \ (N, P, Q)" | forward_subsumption: "D \ P \ Q \ subsumes D C \ (N \ {C}, P, Q) \ (N, P, Q)" | backward_subsumption_P: "D \ N \ strictly_subsumes D C \ (N, P \ {C}, Q) \ (N, P, Q)" | backward_subsumption_Q: "D \ N \ strictly_subsumes D C \ (N, P, Q \ {C}) \ (N, P, Q)" | forward_reduction: "D + {#L'#} \ P \ Q \ - L = L' \l \ \ D \ \ \# C \ (N \ {C + {#L#}}, P, Q) \ (N \ {C}, P, Q)" | backward_reduction_P: "D + {#L'#} \ N \ - L = L' \l \ \ D \ \ \# C \ (N, P \ {C + {#L#}}, Q) \ (N, P \ {C}, Q)" | backward_reduction_Q: "D + {#L'#} \ N \ - L = L' \l \ \ D \ \ \# C \ (N, P, Q \ {C + {#L#}}) \ (N, P \ {C}, Q)" | clause_processing: "(N \ {C}, P, Q) \ (N, P \ {C}, Q)" | inference_computation: "N = concls_of (ord_FO_resolution.inferences_between Q C) \ ({}, P \ {C}, Q) \ (N, P, Q \ {C})" lemma final_RP: "\ ({}, {}, Q) \ St" by (auto elim: RP.cases) definition Sup_state :: "'a state llist \ 'a state" where "Sup_state Sts = (Sup_llist (lmap N_of_state Sts), Sup_llist (lmap P_of_state Sts), Sup_llist (lmap Q_of_state Sts))" definition Liminf_state :: "'a state llist \ 'a state" where "Liminf_state Sts = (Liminf_llist (lmap N_of_state Sts), Liminf_llist (lmap P_of_state Sts), Liminf_llist (lmap Q_of_state Sts))" context fixes Sts Sts' :: "'a state llist" assumes Sts: "lfinite Sts" "lfinite Sts'" "\ lnull Sts" "\ lnull Sts'" "llast Sts' = llast Sts" begin lemma N_of_Liminf_state_fin: "N_of_state (Liminf_state Sts') = N_of_state (Liminf_state Sts)" and P_of_Liminf_state_fin: "P_of_state (Liminf_state Sts') = P_of_state (Liminf_state Sts)" and Q_of_Liminf_state_fin: "Q_of_state (Liminf_state Sts') = Q_of_state (Liminf_state Sts)" using Sts by (simp_all add: Liminf_state_def lfinite_Liminf_llist llast_lmap) lemma Liminf_state_fin: "Liminf_state Sts' = Liminf_state Sts" using N_of_Liminf_state_fin P_of_Liminf_state_fin Q_of_Liminf_state_fin by (simp add: Liminf_state_def) end context fixes Sts Sts' :: "'a state llist" assumes Sts: "\ lfinite Sts" "emb Sts Sts'" begin lemma N_of_Liminf_state_inf: "N_of_state (Liminf_state Sts') \ N_of_state (Liminf_state Sts)" and P_of_Liminf_state_inf: "P_of_state (Liminf_state Sts') \ P_of_state (Liminf_state Sts)" and Q_of_Liminf_state_inf: "Q_of_state (Liminf_state Sts') \ Q_of_state (Liminf_state Sts)" using Sts by (simp_all add: Liminf_state_def emb_Liminf_llist_infinite emb_lmap) lemma clss_of_Liminf_state_inf: "clss_of_state (Liminf_state Sts') \ clss_of_state (Liminf_state Sts)" using N_of_Liminf_state_inf P_of_Liminf_state_inf Q_of_Liminf_state_inf by blast end definition fair_state_seq :: "'a state llist \ bool" where "fair_state_seq Sts \ N_of_state (Liminf_state Sts) = {} \ P_of_state (Liminf_state Sts) = {}" text \ The following formalizes Lemma 4.10. \ context fixes Sts :: "'a state llist" begin definition S_Q :: "'a clause \ 'a clause" where "S_Q = S_M S (Q_of_state (Liminf_state Sts))" interpretation sq: selection S_Q unfolding S_Q_def using S_M_selects_subseteq S_M_selects_neg_lits selection_axioms by unfold_locales auto interpretation gr: ground_resolution_with_selection S_Q by unfold_locales interpretation sr: standard_redundancy_criterion_reductive gr.ord_\ by unfold_locales interpretation sr: standard_redundancy_criterion_counterex_reducing gr.ord_\ "ground_resolution_with_selection.INTERP S_Q" by unfold_locales text \ The extension of ordered resolution mentioned in 4.10. We let it consist of all sound rules. \ definition ground_sound_\:: "'a inference set" where "ground_sound_\ = {Infer CC D E | CC D E. (\I. I \m CC \ I \ D \ I \ E)}" text \ We prove that we indeed defined an extension. \ lemma gd_ord_\_ngd_ord_\: "gr.ord_\ \ ground_sound_\" unfolding ground_sound_\_def using gr.ord_\_def gr.ord_resolve_sound by fastforce lemma sound_ground_sound_\: "sound_inference_system ground_sound_\" unfolding sound_inference_system_def ground_sound_\_def by auto lemma sat_preserving_ground_sound_\: "sat_preserving_inference_system ground_sound_\" using sound_ground_sound_\ sat_preserving_inference_system.intro sound_inference_system.\_sat_preserving by blast definition sr_ext_Ri :: "'a clause set \ 'a inference set" where "sr_ext_Ri N = sr.Ri N \ (ground_sound_\ - gr.ord_\)" interpretation sr_ext: sat_preserving_redundancy_criterion ground_sound_\ sr.Rf sr_ext_Ri unfolding sat_preserving_redundancy_criterion_def sr_ext_Ri_def using sat_preserving_ground_sound_\ redundancy_criterion_standard_extension gd_ord_\_ngd_ord_\ sr.redundancy_criterion_axioms by auto lemma strict_subset_subsumption_redundant_clause: assumes sub: "D \ \ \# C" and ground_\: "is_ground_subst \" shows "C \ sr.Rf (grounding_of_cls D)" proof - from sub have "\I. I \ D \ \ \ I \ C" unfolding true_cls_def by blast moreover have "C > D \ \" using sub by (simp add: subset_imp_less_mset) moreover have "D \ \ \ grounding_of_cls D" using ground_\ by (metis (mono_tags) mem_Collect_eq substitution_ops.grounding_of_cls_def) ultimately have "set_mset {#D \ \#} \ grounding_of_cls D" "(\I. I \m {#D \ \#} \ I \ C)" "(\D'. D' \# {#D \ \#} \ D' < C)" by auto then show ?thesis using sr.Rf_def by blast qed lemma strict_subset_subsumption_redundant_clss: assumes "D \ \ \# C" and "is_ground_subst \" and "D \ CC" shows "C \ sr.Rf (grounding_of_clss CC)" using assms proof - have "C \ sr.Rf (grounding_of_cls D)" using strict_subset_subsumption_redundant_clause assms by auto then show ?thesis using assms unfolding grounding_of_clss_def by (metis (no_types) sr.Rf_mono sup_ge1 SUP_absorb contra_subsetD) qed lemma strict_subset_subsumption_grounding_redundant_clss: assumes D\_subset_C: "D \ \ \# C" and D_in_St: "D \ CC" shows "grounding_of_cls C \ sr.Rf (grounding_of_clss CC)" proof fix C\ assume "C\ \ grounding_of_cls C" then obtain \ where \_p: "C\ = C \ \ \ is_ground_subst \" unfolding grounding_of_cls_def by auto have D\\C\: "D \ \ \ \ \# C \ \" using D\_subset_C subst_subset_mono by auto then show "C\ \ sr.Rf (grounding_of_clss CC)" using \_p strict_subset_subsumption_redundant_clss[of D "\ \ \" "C \ \"] D_in_St by auto qed lemma derive_if_remove_subsumed: assumes "D \ clss_of_state St" and "subsumes D C" shows "sr_ext.derive (grounding_of_state St \ grounding_of_cls C) (grounding_of_state St)" proof - from assms obtain \ where "D \ \ = C \ D \ \ \# C" by (auto simp: subsumes_def subset_mset_def) then have "D \ \ = C \ D \ \ \# C" by (simp add: subset_mset_def) then show ?thesis proof assume "D \ \ = C" then have "grounding_of_cls C \ grounding_of_cls D" using subst_cls_eq_grounding_of_cls_subset_eq by (auto dest: sym) then have "(grounding_of_state St \ grounding_of_cls C) = grounding_of_state St" using assms unfolding grounding_of_clss_def by auto then show ?thesis by (auto intro: sr_ext.derive.intros) next assume a: "D \ \ \# C" then have "grounding_of_cls C \ sr.Rf (grounding_of_state St)" using strict_subset_subsumption_grounding_redundant_clss assms by auto then show ?thesis unfolding grounding_of_clss_def by (force intro: sr_ext.derive.intros) qed qed lemma reduction_in_concls_of: assumes "C\ \ grounding_of_cls C" and "D + {#L'#} \ CC" and "- L = L' \l \" and "D \ \ \# C" shows "C\ \ concls_of (sr_ext.inferences_from (grounding_of_clss (CC \ {C + {#L#}})))" proof - from assms obtain \ where \_p: "C\ = C \ \ \ is_ground_subst \" unfolding grounding_of_cls_def by auto define \ where "\ = Infer {#(C + {#L#}) \ \#} ((D + {#L'#}) \ \ \ \) (C \ \)" have "(D + {#L'#}) \ \ \ \ \ grounding_of_clss (CC \ {C + {#L#}})" unfolding grounding_of_clss_def grounding_of_cls_def by (rule UN_I[of "D + {#L'#}"], use assms(2) in simp, metis (mono_tags, lifting) \_p is_ground_comp_subst mem_Collect_eq subst_cls_comp_subst) moreover have "(C + {#L#}) \ \ \ grounding_of_clss (CC \ {C + {#L#}})" using \_p unfolding grounding_of_clss_def grounding_of_cls_def by auto moreover have "\I. I \ D \ \ \ \ + {#- (L \l \)#} \ I \ C \ \ + {#L \l \#} \ I \ D \ \ \ \ + C \ \" by auto then have "\I. I \ (D + {#L'#}) \ \ \ \ \ I \ (C + {#L#}) \ \ \ I \ D \ \ \ \ + C \ \" using assms by (metis add_mset_add_single subst_cls_add_mset subst_cls_union subst_minus) then have "\I. I \ (D + {#L'#}) \ \ \ \ \ I \ (C + {#L#}) \ \ \ I \ C \ \" using assms by (metis (no_types, lifting) subset_mset.le_iff_add subst_cls_union true_cls_union) then have "\I. I \m {#(D + {#L'#}) \ \ \ \#} \ I \ (C + {#L#}) \ \ \ I \ C \ \" by (meson true_cls_mset_singleton) ultimately have "\ \ sr_ext.inferences_from (grounding_of_clss (CC \ {C + {#L#}}))" unfolding sr_ext.inferences_from_def unfolding ground_sound_\_def infer_from_def \_def by auto then have "C \ \ \ concls_of (sr_ext.inferences_from (grounding_of_clss (CC \ {C + {#L#}})))" using image_iff unfolding \_def by fastforce then show "C\ \ concls_of (sr_ext.inferences_from (grounding_of_clss (CC \ {C + {#L#}})))" using \_p by auto qed lemma reduction_derivable: assumes "D + {#L'#} \ CC" and "- L = L' \l \" and "D \ \ \# C" shows "sr_ext.derive (grounding_of_clss (CC \ {C + {#L#}})) (grounding_of_clss (CC \ {C}))" proof - from assms have "grounding_of_clss (CC \ {C}) - grounding_of_clss (CC \ {C + {#L#}}) \ concls_of (sr_ext.inferences_from (grounding_of_clss (CC \ {C + {#L#}})))" using reduction_in_concls_of unfolding grounding_of_clss_def by auto moreover have "grounding_of_cls (C + {#L#}) \ sr.Rf (grounding_of_clss (CC \ {C}))" using strict_subset_subsumption_grounding_redundant_clss[of C "id_subst"] by auto then have "grounding_of_clss (CC \ {C + {#L#}}) - grounding_of_clss (CC \ {C}) \ sr.Rf (grounding_of_clss (CC \ {C}))" unfolding grounding_of_clss_def by auto ultimately show "sr_ext.derive (grounding_of_clss (CC \ {C + {#L#}})) (grounding_of_clss (CC \ {C}))" using sr_ext.derive.intros[of "grounding_of_clss (CC \ {C})" "grounding_of_clss (CC \ {C + {#L#}})"] by auto qed text \ The following corresponds the part of Lemma 4.10 that states we have a theorem proving process: \ lemma RP_ground_derive: "St \ St' \ sr_ext.derive (grounding_of_state St) (grounding_of_state St')" proof (induction rule: RP.induct) case (tautology_deletion A C N P Q) { fix C\ assume "C\ \ grounding_of_cls C" then obtain \ where "C\ = C \ \" unfolding grounding_of_cls_def by auto then have "Neg (A \a \) \# C\ \ Pos (A \a \) \# C\" using tautology_deletion Neg_Melem_subst_atm_subst_cls Pos_Melem_subst_atm_subst_cls by auto then have "C\ \ sr.Rf (grounding_of_state (N, P, Q))" using sr.tautology_Rf by auto } then have "grounding_of_state (N \ {C}, P, Q) - grounding_of_state (N, P, Q) \ sr.Rf (grounding_of_state (N, P, Q))" unfolding grounding_of_clss_def by auto moreover have "grounding_of_state (N, P, Q) - grounding_of_state (N \ {C}, P, Q) = {}" unfolding grounding_of_clss_def by auto ultimately show ?case using sr_ext.derive.intros[of "grounding_of_state (N, P, Q)" "grounding_of_state (N \ {C}, P, Q)"] by auto next case (forward_subsumption D P Q C N) then show ?case using derive_if_remove_subsumed[of D "(N, P, Q)" C] unfolding grounding_of_clss_def by (simp add: sup_commute sup_left_commute) next case (backward_subsumption_P D N C P Q) then show ?case using derive_if_remove_subsumed[of D "(N, P, Q)" C] strictly_subsumes_def unfolding grounding_of_clss_def by (simp add: sup_commute sup_left_commute) next case (backward_subsumption_Q D N C P Q) then show ?case using derive_if_remove_subsumed[of D "(N, P, Q)" C] strictly_subsumes_def unfolding grounding_of_clss_def by (simp add: sup_commute sup_left_commute) next case (forward_reduction D L' P Q L \ C N) then show ?case using reduction_derivable[of _ _ "N \ P \ Q"] by force next case (backward_reduction_P D L' N L \ C P Q) then show ?case using reduction_derivable[of _ _ "N \ P \ Q"] by force next case (backward_reduction_Q D L' N L \ C P Q) then show ?case using reduction_derivable[of _ _ "N \ P \ Q"] by force next case (clause_processing N C P Q) then show ?case using sr_ext.derive.intros by auto next case (inference_computation N Q C P) { fix E\ assume "E\ \ grounding_of_clss N" then obtain \ E where E_\_p: "E\ = E \ \ \ E \ N \ is_ground_subst \" unfolding grounding_of_clss_def grounding_of_cls_def by auto then have E_concl: "E \ concls_of (ord_FO_resolution.inferences_between Q C)" using inference_computation by auto then obtain \ where \_p: "\ \ ord_FO_\ S \ infer_from (Q \ {C}) \ \ C \# prems_of \ \ concl_of \ = E" unfolding ord_FO_resolution.inferences_between_def by auto then obtain CC CAs D AAs As \ where \_p2: "\ = Infer CC D E \ ord_resolve_rename S CAs D AAs As \ E \ mset CAs = CC" unfolding ord_FO_\_def by auto define \ where "\ = hd (renamings_apart (D # CAs))" define \s where "\s = tl (renamings_apart (D # CAs))" define \_ground where "\_ground = Infer (mset (CAs \\cl \s) \cm \ \cm \) (D \ \ \ \ \ \) (E \ \)" have "\I. I \m mset (CAs \\cl \s) \cm \ \cm \ \ I \ D \ \ \ \ \ \ \ I \ E \ \" using ord_resolve_rename_ground_inst_sound[of _ _ _ _ _ _ _ _ _ _ \] \_def \s_def E_\_p \_p2 by auto then have "\_ground \ {Infer cc d e | cc d e. \I. I \m cc \ I \ d \ I \ e}" unfolding \_ground_def by auto moreover have "set_mset (prems_of \_ground) \ grounding_of_state ({}, P \ {C}, Q)" proof - have "D = C \ D \ Q" unfolding \_ground_def using E_\_p \_p2 \_p unfolding infer_from_def unfolding grounding_of_clss_def grounding_of_cls_def by simp then have "D \ \ \ \ \ \ \ grounding_of_cls C \ (\x \ Q. D \ \ \ \ \ \ \ grounding_of_cls x)" using E_\_p unfolding grounding_of_cls_def by (metis (mono_tags, lifting) is_ground_comp_subst mem_Collect_eq subst_cls_comp_subst) then have "(D \ \ \ \ \ \ \ grounding_of_cls C \ (\x \ P. D \ \ \ \ \ \ \ grounding_of_cls x) \ (\x \ Q. D \ \ \ \ \ \ \ grounding_of_cls x))" by metis moreover have "\i < length (CAs \\cl \s \cl \ \cl \). (CAs \\cl \s \cl \ \cl \) ! i \ {C \ \ |\. is_ground_subst \} \ ((\C \ P. {C \ \ | \. is_ground_subst \}) \ (\C\Q. {C \ \ | \. is_ground_subst \}))" proof (rule, rule) fix i assume "i < length (CAs \\cl \s \cl \ \cl \)" then have a: "i < length CAs \ i < length \s" by simp moreover from a have "CAs ! i \ {C} \ Q" using \_p2 \_p unfolding infer_from_def by (metis (no_types, lifting) Un_subset_iff inference.sel(1) set_mset_union sup_commute nth_mem_mset subsetCE) ultimately have "(CAs \\cl \s \cl \ \cl \) ! i \ {C \ \ |\. is_ground_subst \} \ ((CAs \\cl \s \cl \ \cl \) ! i \ (\C\P. {C \ \ |\. is_ground_subst \}) \ (CAs \\cl \s \cl \ \cl \) ! i \ (\C \ Q. {C \ \ | \. is_ground_subst \}))" using E_\_p \_p2 \_p unfolding \_ground_def infer_from_def grounding_of_clss_def grounding_of_cls_def apply - apply (cases "CAs ! i = C") subgoal apply (rule disjI1) apply (rule Set.CollectI) apply (rule_tac x = "(\s ! i) \ \ \ \" in exI) using \s_def using renamings_apart_length by (auto; fail) subgoal apply (rule disjI2) apply (rule disjI2) apply (rule_tac a = "CAs ! i" in UN_I) subgoal by blast subgoal apply (rule Set.CollectI) apply (rule_tac x = "(\s ! i) \ \ \ \" in exI) using \s_def using renamings_apart_length by (auto; fail) done done then show "(CAs \\cl \s \cl \ \cl \) ! i \ {C \ \ |\. is_ground_subst \} \ ((\C \ P. {C \ \ |\. is_ground_subst \}) \ (\C \ Q. {C \ \ |\. is_ground_subst \}))" by blast qed then have "\x \# mset (CAs \\cl \s \cl \ \cl \). x \ {C \ \ |\. is_ground_subst \} \ ((\C \ P. {C \ \ |\. is_ground_subst \}) \ (\C \ Q. {C \ \ |\. is_ground_subst \}))" by (metis (lifting) in_set_conv_nth set_mset_mset) then have "set_mset (mset (CAs \\cl \s) \cm \ \cm \) \ grounding_of_cls C \ grounding_of_clss P \ grounding_of_clss Q" unfolding grounding_of_cls_def grounding_of_clss_def using mset_subst_cls_list_subst_cls_mset by auto ultimately show ?thesis unfolding \_ground_def grounding_of_clss_def by auto qed ultimately have "E \ \ \ concls_of (sr_ext.inferences_from (grounding_of_state ({}, P \ {C}, Q)))" unfolding sr_ext.inferences_from_def inference_system.inferences_from_def ground_sound_\_def infer_from_def using \_ground_def by (metis (mono_tags, lifting) image_eqI inference.sel(3) mem_Collect_eq) then have "E\ \ concls_of (sr_ext.inferences_from (grounding_of_state ({}, P \ {C}, Q)))" using E_\_p by auto } then have "grounding_of_state (N, P, Q \ {C}) - grounding_of_state ({}, P \ {C}, Q) \ concls_of (sr_ext.inferences_from (grounding_of_state ({}, P \ {C}, Q)))" unfolding grounding_of_clss_def by auto moreover have "grounding_of_state ({}, P \ {C}, Q) - grounding_of_state (N, P, Q \ {C}) = {}" unfolding grounding_of_clss_def by auto ultimately show ?case using sr_ext.derive.intros[of "(grounding_of_state (N, P, Q \ {C}))" "(grounding_of_state ({}, P \ {C}, Q))"] by auto qed text \ A useful consequence: \ theorem RP_model: "St \ St' \ I \s grounding_of_state St' \ I \s grounding_of_state St" proof (drule RP_ground_derive, erule sr_ext.derive.cases, hypsubst) let ?gSt = "grounding_of_state St" and ?gSt' = "grounding_of_state St'" assume deduct: "?gSt' - ?gSt \ concls_of (sr_ext.inferences_from ?gSt)" (is "_ \ ?concls") and delete: "?gSt - ?gSt' \ sr.Rf ?gSt'" show "I \s ?gSt' \ I \s ?gSt" proof assume bef: "I \s ?gSt" then have "I \s ?concls" unfolding ground_sound_\_def inference_system.inferences_from_def true_clss_def true_cls_mset_def by (auto simp add: image_def infer_from_def dest!: spec[of _ I]) then have diff: "I \s ?gSt' - ?gSt" using deduct by (blast intro: true_clss_mono) then show "I \s ?gSt'" using bef unfolding true_clss_def by blast next assume aft: "I \s ?gSt'" have "I \s ?gSt' \ sr.Rf ?gSt'" - by (rule sr.Rf_model) (smt Diff_eq_empty_iff Diff_subset Un_Diff aft + by (rule sr.Rf_model) (smt (verit) Diff_eq_empty_iff Diff_subset Un_Diff aft standard_redundancy_criterion.Rf_mono sup_bot.right_neutral sup_ge1 true_clss_mono) then have "I \s sr.Rf ?gSt'" using true_clss_union by blast then have diff: "I \s ?gSt - ?gSt'" using delete by (blast intro: true_clss_mono) then show "I \s ?gSt" using aft unfolding true_clss_def by blast qed qed text \ Another formulation of the part of Lemma 4.10 that states we have a theorem proving process: \ lemma ground_derive_chain: "chain (\) Sts \ chain sr_ext.derive (lmap grounding_of_state Sts)" using RP_ground_derive by (simp add: chain_lmap[of "(\)"]) text \ The following is used prove to Lemma 4.11: \ lemma Sup_llist_grounding_of_state_ground: assumes "C \ Sup_llist (lmap grounding_of_state Sts)" shows "is_ground_cls C" proof - have "\j. enat j < llength (lmap grounding_of_state Sts) \ C \ lnth (lmap grounding_of_state Sts) j" using assms Sup_llist_imp_exists_index by fast then show ?thesis unfolding grounding_of_clss_def grounding_of_cls_def by auto qed lemma Liminf_grounding_of_state_ground: "C \ Liminf_llist (lmap grounding_of_state Sts) \ is_ground_cls C" using Liminf_llist_subset_Sup_llist[of "lmap grounding_of_state Sts"] Sup_llist_grounding_of_state_ground by blast lemma in_Sup_llist_in_Sup_state: assumes "C \ Sup_llist (lmap grounding_of_state Sts)" shows "\D \. D \ clss_of_state (Sup_state Sts) \ D \ \ = C \ is_ground_subst \" proof - from assms obtain i where i_p: "enat i < llength Sts \ C \ lnth (lmap grounding_of_state Sts) i" using Sup_llist_imp_exists_index by fastforce then obtain D \ where "D \ clss_of_state (lnth Sts i) \ D \ \ = C \ is_ground_subst \" using assms unfolding grounding_of_clss_def grounding_of_cls_def by fastforce then have "D \ clss_of_state (Sup_state Sts) \ D \ \ = C \ is_ground_subst \" using i_p unfolding Sup_state_def by (metis (no_types, lifting) UnCI UnE contra_subsetD N_of_state.simps P_of_state.simps Q_of_state.simps llength_lmap lnth_lmap lnth_subset_Sup_llist) then show ?thesis by auto qed lemma N_of_state_Liminf: "N_of_state (Liminf_state Sts) = Liminf_llist (lmap N_of_state Sts)" and P_of_state_Liminf: "P_of_state (Liminf_state Sts) = Liminf_llist (lmap P_of_state Sts)" unfolding Liminf_state_def by auto lemma eventually_removed_from_N: assumes d_in: "D \ N_of_state (lnth Sts i)" and fair: "fair_state_seq Sts" and i_Sts: "enat i < llength Sts" shows "\l. D \ N_of_state (lnth Sts l) \ D \ N_of_state (lnth Sts (Suc l)) \ i \ l \ enat (Suc l) < llength Sts" proof (rule ccontr) assume a: "\ ?thesis" have "i \ l \ enat l < llength Sts \ D \ N_of_state (lnth Sts l)" for l using d_in by (induction l, blast, metis a Suc_ile_eq le_SucE less_imp_le) then have "D \ Liminf_llist (lmap N_of_state Sts)" unfolding Liminf_llist_def using i_Sts by auto then show False using fair unfolding fair_state_seq_def by (simp add: N_of_state_Liminf) qed lemma eventually_removed_from_P: assumes d_in: "D \ P_of_state (lnth Sts i)" and fair: "fair_state_seq Sts" and i_Sts: "enat i < llength Sts" shows "\l. D \ P_of_state (lnth Sts l) \ D \ P_of_state (lnth Sts (Suc l)) \ i \ l \ enat (Suc l) < llength Sts" proof (rule ccontr) assume a: "\ ?thesis" have "i \ l \ enat l < llength Sts \ D \ P_of_state (lnth Sts l)" for l using d_in by (induction l, blast, metis a Suc_ile_eq le_SucE less_imp_le) then have "D \ Liminf_llist (lmap P_of_state Sts)" unfolding Liminf_llist_def using i_Sts by auto then show False using fair unfolding fair_state_seq_def by (simp add: P_of_state_Liminf) qed lemma instance_if_subsumed_and_in_limit: assumes deriv: "chain (\) Sts" and ns: "Gs = lmap grounding_of_state Sts" and c: "C \ Liminf_llist Gs - sr.Rf (Liminf_llist Gs)" and d: "D \ clss_of_state (lnth Sts i)" "enat i < llength Sts" "subsumes D C" shows "\\. D \ \ = C \ is_ground_subst \" proof - let ?Ps = "\i. P_of_state (lnth Sts i)" let ?Qs = "\i. Q_of_state (lnth Sts i)" have ground_C: "is_ground_cls C" using c using Liminf_grounding_of_state_ground ns by auto have derivns: "chain sr_ext.derive Gs" using ground_derive_chain deriv ns by auto have "\\. D \ \ = C" proof (rule ccontr) assume "\\. D \ \ = C" moreover from d(3) obtain \_proto where "D \ \_proto \# C" unfolding subsumes_def by blast then obtain \ where \_p: "D \ \ \# C \ is_ground_subst \" using ground_C by (metis is_ground_cls_mono make_ground_subst subset_mset.order_refl) ultimately have subsub: "D \ \ \# C" using subset_mset.le_imp_less_or_eq by auto moreover have "is_ground_subst \" using \_p by auto moreover have "D \ clss_of_state (lnth Sts i)" using d by auto ultimately have "C \ sr.Rf (grounding_of_state (lnth Sts i))" using strict_subset_subsumption_redundant_clss by auto then have "C \ sr.Rf (Sup_llist Gs)" - using d ns by (smt contra_subsetD llength_lmap lnth_lmap lnth_subset_Sup_llist sr.Rf_mono) + using d ns by (smt (verit) contra_subsetD llength_lmap lnth_lmap lnth_subset_Sup_llist sr.Rf_mono) then have "C \ sr.Rf (Liminf_llist Gs)" unfolding ns using local.sr_ext.Rf_limit_Sup derivns ns by auto then show False using c by auto qed then obtain \ where "D \ \ = C \ is_ground_subst \" using ground_C by (metis make_ground_subst) then show ?thesis by auto qed lemma from_Q_to_Q_inf: assumes deriv: "chain (\) Sts" and fair: "fair_state_seq Sts" and ns: "Gs = lmap grounding_of_state Sts" and c: "C \ Liminf_llist Gs - sr.Rf (Liminf_llist Gs)" and d: "D \ Q_of_state (lnth Sts i)" "enat i < llength Sts" "subsumes D C" and d_least: "\E \ {E. E \ (clss_of_state (Sup_state Sts)) \ subsumes E C}. \ strictly_subsumes E D" shows "D \ Q_of_state (Liminf_state Sts)" proof - let ?Ps = "\i. P_of_state (lnth Sts i)" let ?Qs = "\i. Q_of_state (lnth Sts i)" have ground_C: "is_ground_cls C" using c using Liminf_grounding_of_state_ground ns by auto have derivns: "chain sr_ext.derive Gs" using ground_derive_chain deriv ns by auto have "\\. D \ \ = C \ is_ground_subst \" using instance_if_subsumed_and_in_limit[OF deriv] c d unfolding ns by blast then obtain \ where \: "D \ \ = C" "is_ground_subst \" by auto have in_Sts_in_Sts_Suc: "\l \ i. enat (Suc l) < llength Sts \ D \ Q_of_state (lnth Sts l) \ D \ Q_of_state (lnth Sts (Suc l))" proof (rule, rule, rule, rule) fix l assume len: "i \ l" and llen: "enat (Suc l) < llength Sts" and d_in_q: "D \ Q_of_state (lnth Sts l)" have "lnth Sts l \ lnth Sts (Suc l)" using llen deriv chain_lnth_rel by blast then show "D \ Q_of_state (lnth Sts (Suc l))" proof (cases rule: RP.cases) case (backward_subsumption_Q D' N D_removed P Q) moreover { assume "D_removed = D" then obtain D_subsumes where D_subsumes_p: "D_subsumes \ N \ strictly_subsumes D_subsumes D" using backward_subsumption_Q by auto moreover from D_subsumes_p have "subsumes D_subsumes C" using d subsumes_trans unfolding strictly_subsumes_def by blast moreover from backward_subsumption_Q have "D_subsumes \ clss_of_state (Sup_state Sts)" using D_subsumes_p llen by (metis (no_types) UnI1 N_of_state.simps llength_lmap lnth_lmap lnth_subset_Sup_llist rev_subsetD Sup_state_def) ultimately have False using d_least unfolding subsumes_def by auto } ultimately show ?thesis using d_in_q by auto next case (backward_reduction_Q E L' N L \ D' P Q) { assume "D' + {#L#} = D" then have D'_p: "strictly_subsumes D' D \ D' \ ?Ps (Suc l)" using subset_strictly_subsumes[of D' D] backward_reduction_Q by auto then have subc: "subsumes D' C" using d(3) subsumes_trans unfolding strictly_subsumes_def by auto from D'_p have "D' \ clss_of_state (Sup_state Sts)" using llen by (metis (no_types) UnI1 P_of_state.simps llength_lmap lnth_lmap lnth_subset_Sup_llist subsetCE sup_ge2 Sup_state_def) then have False using d_least D'_p subc by auto } then show ?thesis using backward_reduction_Q d_in_q by auto qed (use d_in_q in auto) qed have D_in_Sts: "D \ Q_of_state (lnth Sts l)" and D_in_Sts_Suc: "D \ Q_of_state (lnth Sts (Suc l))" if l_i: "l \ i" and enat: "enat (Suc l) < llength Sts" for l proof - show "D \ Q_of_state (lnth Sts l)" using l_i enat apply (induction "l - i" arbitrary: l) subgoal using d by auto subgoal using d(1) in_Sts_in_Sts_Suc by (metis (no_types, lifting) Suc_ile_eq add_Suc_right add_diff_cancel_left' le_SucE le_Suc_ex less_imp_le) done then show "D \ Q_of_state (lnth Sts (Suc l))" using l_i enat in_Sts_in_Sts_Suc by blast qed have "i \ x \ enat x < llength Sts \ D \ Q_of_state (lnth Sts x)" for x apply (cases x) subgoal using d(1) by (auto intro!: exI[of _ i] simp: less_Suc_eq) subgoal for x' using d(1) D_in_Sts_Suc[of x'] by (cases \i \ x'\) (auto simp: not_less_eq_eq) done then have "D \ Liminf_llist (lmap Q_of_state Sts)" unfolding Liminf_llist_def by (auto intro!: exI[of _ i] simp: d) then show ?thesis unfolding Liminf_state_def by auto qed lemma from_P_to_Q: assumes deriv: "chain (\) Sts" and fair: "fair_state_seq Sts" and ns: "Gs = lmap grounding_of_state Sts" and c: "C \ Liminf_llist Gs - sr.Rf (Liminf_llist Gs)" and d: "D \ P_of_state (lnth Sts i)" "enat i < llength Sts" "subsumes D C" and d_least: "\E \ {E. E \ (clss_of_state (Sup_state Sts)) \ subsumes E C}. \ strictly_subsumes E D" shows "\l. D \ Q_of_state (lnth Sts l) \ enat l < llength Sts" proof - let ?Ns = "\i. N_of_state (lnth Sts i)" let ?Ps = "\i. P_of_state (lnth Sts i)" let ?Qs = "\i. Q_of_state (lnth Sts i)" have ground_C: "is_ground_cls C" using c using Liminf_grounding_of_state_ground ns by auto have derivns: "chain sr_ext.derive Gs" using ground_derive_chain deriv ns by auto have "\\. D \ \ = C \ is_ground_subst \" using instance_if_subsumed_and_in_limit[OF deriv] ns c d by blast then obtain \ where \: "D \ \ = C" "is_ground_subst \" by auto obtain l where l_p: "D \ P_of_state (lnth Sts l) \ D \ P_of_state (lnth Sts (Suc l)) \ i \ l \ enat (Suc l) < llength Sts" using fair using eventually_removed_from_P d unfolding ns by auto then have l_Gs: "enat (Suc l) < llength Gs" using ns by auto from l_p have "lnth Sts l \ lnth Sts (Suc l)" using deriv using chain_lnth_rel by auto then show ?thesis proof (cases rule: RP.cases) case (backward_subsumption_P D' N D_twin P Q) note lrhs = this(1,2) and D'_p = this(3,4) then have twins: "D_twin = D" "?Ns (Suc l) = N" "?Ns l = N" "?Ps (Suc l) = P" "?Ps l = P \ {D_twin}" "?Qs (Suc l) = Q" "?Qs l = Q" using l_p by auto note D'_p = D'_p[unfolded twins(1)] then have subc: "subsumes D' C" unfolding strictly_subsumes_def subsumes_def using \ by (metis subst_cls_comp_subst subst_cls_mono_mset) from D'_p have "D' \ clss_of_state (Sup_state Sts)" unfolding twins(2)[symmetric] using l_p by (metis (no_types) UnI1 N_of_state.simps llength_lmap lnth_lmap lnth_subset_Sup_llist subsetCE Sup_state_def) then have False using d_least D'_p subc by auto then show ?thesis by auto next case (backward_reduction_P E L' N L \ D' P Q) then have twins: "D' + {#L#} = D" "?Ns (Suc l) = N" "?Ns l = N" "?Ps (Suc l) = P \ {D'}" "?Ps l = P \ {D' + {#L#}}" "?Qs (Suc l) = Q" "?Qs l = Q" using l_p by auto then have D'_p: "strictly_subsumes D' D \ D' \ ?Ps (Suc l)" using subset_strictly_subsumes[of D' D] by auto then have subc: "subsumes D' C" using d(3) subsumes_trans unfolding strictly_subsumes_def by auto from D'_p have "D' \ clss_of_state (Sup_state Sts)" using l_p by (metis (no_types) UnI1 P_of_state.simps llength_lmap lnth_lmap lnth_subset_Sup_llist subsetCE sup_ge2 Sup_state_def) then have False using d_least D'_p subc by auto then show ?thesis by auto next case (inference_computation N Q D_twin P) then have twins: "D_twin = D" "?Ps (Suc l) = P" "?Ps l = P \ {D_twin}" "?Qs (Suc l) = Q \ {D_twin}" "?Qs l = Q" using l_p by auto then show ?thesis using d \ l_p by auto qed (use l_p in auto) qed lemma from_N_to_P_or_Q: assumes deriv: "chain (\) Sts" and fair: "fair_state_seq Sts" and ns: "Gs = lmap grounding_of_state Sts" and c: "C \ Liminf_llist Gs - sr.Rf (Liminf_llist Gs)" and d: "D \ N_of_state (lnth Sts i)" "enat i < llength Sts" "subsumes D C" and d_least: "\E \ {E. E \ (clss_of_state (Sup_state Sts)) \ subsumes E C}. \ strictly_subsumes E D" shows "\l D' \'. D' \ P_of_state (lnth Sts l) \ Q_of_state (lnth Sts l) \ enat l < llength Sts \ (\E \ {E. E \ (clss_of_state (Sup_state Sts)) \ subsumes E C}. \ strictly_subsumes E D') \ D' \ \' = C \ is_ground_subst \' \ subsumes D' C" proof - let ?Ns = "\i. N_of_state (lnth Sts i)" let ?Ps = "\i. P_of_state (lnth Sts i)" let ?Qs = "\i. Q_of_state (lnth Sts i)" have ground_C: "is_ground_cls C" using c using Liminf_grounding_of_state_ground ns by auto have derivns: "chain sr_ext.derive Gs" using ground_derive_chain deriv ns by auto have "\\. D \ \ = C \ is_ground_subst \" using instance_if_subsumed_and_in_limit[OF deriv] ns c d by blast then obtain \ where \: "D \ \ = C" "is_ground_subst \" by auto from c have no_taut: "\ (\A. Pos A \# C \ Neg A \# C)" using sr.tautology_Rf by auto have "\l. D \ N_of_state (lnth Sts l) \ D \ N_of_state (lnth Sts (Suc l)) \ i \ l \ enat (Suc l) < llength Sts" using fair using eventually_removed_from_N d unfolding ns by auto then obtain l where l_p: "D \ N_of_state (lnth Sts l) \ D \ N_of_state (lnth Sts (Suc l)) \ i \ l \ enat (Suc l) < llength Sts" by auto then have l_Gs: "enat (Suc l) < llength Gs" using ns by auto from l_p have "lnth Sts l \ lnth Sts (Suc l)" using deriv using chain_lnth_rel by auto then show ?thesis proof (cases rule: RP.cases) case (tautology_deletion A D_twin N P Q) then have "D_twin = D" using l_p by auto then have "Pos (A \a \) \# C \ Neg (A \a \) \# C" using tautology_deletion(3,4) \ by (metis Melem_subst_cls eql_neg_lit_eql_atm eql_pos_lit_eql_atm) then have False using no_taut by metis then show ?thesis by blast next case (forward_subsumption D' P Q D_twin N) note lrhs = this(1,2) and D'_p = this(3,4) then have twins: "D_twin = D" "?Ns (Suc l) = N" "?Ns l = N \ {D_twin}" "?Ps (Suc l) = P " "?Ps l = P" "?Qs (Suc l) = Q" "?Qs l = Q" using l_p by auto note D'_p = D'_p[unfolded twins(1)] from D'_p(2) have subs: "subsumes D' C" using d(3) by (blast intro: subsumes_trans) moreover have "D' \ clss_of_state (Sup_state Sts)" using twins D'_p l_p unfolding Sup_state_def by simp (metis (no_types) contra_subsetD llength_lmap lnth_lmap lnth_subset_Sup_llist) ultimately have "\ strictly_subsumes D' D" using d_least by auto then have "subsumes D D'" unfolding strictly_subsumes_def using D'_p by auto then have v: "variants D D'" using D'_p unfolding variants_iff_subsumes by auto then have mini: "\E \ {E \ clss_of_state (Sup_state Sts). subsumes E C}. \ strictly_subsumes E D'" using d_least D'_p neg_strictly_subsumes_variants[of _ D D'] by auto from v have "\\'. D' \ \' = C" using \ variants_imp_exists_substitution variants_sym by (metis subst_cls_comp_subst) then have "\\'. D' \ \' = C \ is_ground_subst \'" using ground_C by (meson make_ground_subst refl) then obtain \' where \'_p: "D' \ \' = C \ is_ground_subst \'" by metis show ?thesis using D'_p twins l_p subs mini \'_p by auto next case (forward_reduction E L' P Q L \ D' N) then have twins: "D' + {#L#} = D" "?Ns (Suc l) = N \ {D'}" "?Ns l = N \ {D' + {#L#}}" "?Ps (Suc l) = P " "?Ps l = P" "?Qs (Suc l) = Q" "?Qs l = Q" using l_p by auto then have D'_p: "strictly_subsumes D' D \ D' \ ?Ns (Suc l)" using subset_strictly_subsumes[of D' D] by auto then have subc: "subsumes D' C" using d(3) subsumes_trans unfolding strictly_subsumes_def by blast from D'_p have "D' \ clss_of_state (Sup_state Sts)" using l_p by (metis (no_types) UnI1 N_of_state.simps llength_lmap lnth_lmap lnth_subset_Sup_llist subsetCE Sup_state_def) then have False using d_least D'_p subc by auto then show ?thesis by auto next case (clause_processing N D_twin P Q) then have twins: "D_twin = D" "?Ns (Suc l) = N" "?Ns l = N \ {D}" "?Ps (Suc l) = P \ {D}" "?Ps l = P" "?Qs (Suc l) = Q" "?Qs l = Q" using l_p by auto then show ?thesis using d \ l_p d_least by blast qed (use l_p in auto) qed lemma eventually_in_Qinf: assumes deriv: "chain (\) Sts" and D_p: "D \ clss_of_state (Sup_state Sts)" "subsumes D C" "\E \ {E. E \ (clss_of_state (Sup_state Sts)) \ subsumes E C}. \ strictly_subsumes E D" and fair: "fair_state_seq Sts" and ns: "Gs = lmap grounding_of_state Sts" and c: "C \ Liminf_llist Gs - sr.Rf (Liminf_llist Gs)" and ground_C: "is_ground_cls C" shows "\D' \'. D' \ Q_of_state (Liminf_state Sts) \ D' \ \' = C \ is_ground_subst \'" proof - let ?Ns = "\i. N_of_state (lnth Sts i)" let ?Ps = "\i. P_of_state (lnth Sts i)" let ?Qs = "\i. Q_of_state (lnth Sts i)" from D_p obtain i where i_p: "i < llength Sts" "D \ ?Ns i \ D \ ?Ps i \ D \ ?Qs i" unfolding Sup_state_def by simp_all (metis (no_types) Sup_llist_imp_exists_index llength_lmap lnth_lmap) have derivns: "chain sr_ext.derive Gs" using ground_derive_chain deriv ns by auto have "\\. D \ \ = C \ is_ground_subst \" using instance_if_subsumed_and_in_limit[OF deriv ns c] D_p i_p by blast then obtain \ where \: "D \ \ = C" "is_ground_subst \" by blast { assume a: "D \ ?Ns i" then obtain D' \' l where D'_p: "D' \ ?Ps l \ ?Qs l" "D' \ \' = C" "enat l < llength Sts" "is_ground_subst \'" "\E \ {E. E \ (clss_of_state (Sup_state Sts)) \ subsumes E C}. \ strictly_subsumes E D'" "subsumes D' C" using from_N_to_P_or_Q deriv fair ns c i_p(1) D_p(2) D_p(3) by blast then obtain l' where l'_p: "D' \ ?Qs l'" "l' < llength Sts" using from_P_to_Q[OF deriv fair ns c _ D'_p(3) D'_p(6) D'_p(5)] by blast then have "D' \ Q_of_state (Liminf_state Sts)" using from_Q_to_Q_inf[OF deriv fair ns c _ l'_p(2)] D'_p by auto then have ?thesis using D'_p by auto } moreover { assume a: "D \ ?Ps i" then obtain l' where l'_p: "D \ ?Qs l'" "l' < llength Sts" using from_P_to_Q[OF deriv fair ns c a i_p(1) D_p(2) D_p(3)] by auto then have "D \ Q_of_state (Liminf_state Sts)" using from_Q_to_Q_inf[OF deriv fair ns c l'_p(1) l'_p(2)] D_p(3) $$1) \(2) D_p(2) by auto then have ?thesis using D_p \ by auto } moreover { assume a: "D \ ?Qs i" then have "D \ Q_of_state (Liminf_state Sts)" using from_Q_to_Q_inf[OF deriv fair ns c a i_p(1)] \ D_p(2,3) by auto then have ?thesis using D_p \ by auto } ultimately show ?thesis using i_p by auto qed text \ The following corresponds to Lemma 4.11: \ lemma fair_imp_Liminf_minus_Rf_subset_ground_Liminf_state: assumes deriv: "chain ($$ Sts" and fair: "fair_state_seq Sts" and ns: "Gs = lmap grounding_of_state Sts" shows "Liminf_llist Gs - sr.Rf (Liminf_llist Gs) \ grounding_of_clss (Q_of_state (Liminf_state Sts))" proof let ?Ns = "\i. N_of_state (lnth Sts i)" let ?Ps = "\i. P_of_state (lnth Sts i)" let ?Qs = "\i. Q_of_state (lnth Sts i)" have SQinf: "clss_of_state (Liminf_state Sts) = Liminf_llist (lmap Q_of_state Sts)" using fair unfolding fair_state_seq_def Liminf_state_def by auto fix C assume C_p: "C \ Liminf_llist Gs - sr.Rf (Liminf_llist Gs)" then have "C \ Sup_llist Gs" using Liminf_llist_subset_Sup_llist[of Gs] by blast then obtain D_proto where "D_proto \ clss_of_state (Sup_state Sts) \ subsumes D_proto C" using in_Sup_llist_in_Sup_state unfolding ns subsumes_def by blast then obtain D where D_p: "D \ clss_of_state (Sup_state Sts)" "subsumes D C" "\E \ {E. E \ clss_of_state (Sup_state Sts) \ subsumes E C}. \ strictly_subsumes E D" using strictly_subsumes_has_minimum[of "{E. E \ clss_of_state (Sup_state Sts) \ subsumes E C}"] by auto have ground_C: "is_ground_cls C" using C_p using Liminf_grounding_of_state_ground ns by auto have "\D' \'. D' \ Q_of_state (Liminf_state Sts) \ D' \ \' = C \ is_ground_subst \'" using eventually_in_Qinf[of D C Gs] using D_p(1-3) deriv fair ns C_p ground_C by auto then obtain D' \' where D'_p: "D' \ Q_of_state (Liminf_state Sts) \ D' \ \' = C \ is_ground_subst \'" by blast then have "D' \ clss_of_state (Liminf_state Sts)" by simp then have "C \ grounding_of_state (Liminf_state Sts)" unfolding grounding_of_clss_def grounding_of_cls_def using D'_p by auto then show "C \ grounding_of_clss (Q_of_state (Liminf_state Sts))" using SQinf fair fair_state_seq_def by auto qed text \ The following corresponds to (one direction of) Theorem 4.13: \ lemma subseteq_Liminf_state_eventually_always: fixes CC assumes "finite CC" and "CC \ {}" and "CC \ Q_of_state (Liminf_state Sts)" shows "\j. enat j < llength Sts \ (\j' \ enat j. j' < llength Sts \ CC \ Q_of_state (lnth Sts j'))" proof - from assms(3) have "\C \ CC. \j. enat j < llength Sts \ (\j' \ enat j. j' < llength Sts \ C \ Q_of_state (lnth Sts j'))" unfolding Liminf_state_def Liminf_llist_def by force then obtain f where f_p: "\C \ CC. f C < llength Sts \ (\j' \ enat (f C). j' < llength Sts \ C \ Q_of_state (lnth Sts j'))" by moura define j :: nat where "j = Max (f  CC)" have "enat j < llength Sts" unfolding j_def using f_p assms(1) by (metis (mono_tags) Max_in assms(2) finite_imageI imageE image_is_empty) moreover have "\C j'. C \ CC \ enat j \ j' \ j' < llength Sts \ C \ Q_of_state (lnth Sts j')" proof (intro allI impI) fix C :: "'a clause" and j' :: nat assume a: "C \ CC" "enat j \ enat j'" "enat j' < llength Sts" then have "f C \ j'" unfolding j_def using assms(1) Max.bounded_iff by auto then show "C \ Q_of_state (lnth Sts j')" using f_p a by auto qed ultimately show ?thesis by auto qed lemma empty_clause_in_Q_of_Liminf_state: assumes deriv: "chain (\) Sts" and fair: "fair_state_seq Sts" and empty_in: "{#} \ Liminf_llist (lmap grounding_of_state Sts)" shows "{#} \ Q_of_state (Liminf_state Sts)" proof - define Gs :: "'a clause set llist" where ns: "Gs = lmap grounding_of_state Sts" from empty_in have in_Liminf_not_Rf: "{#} \ Liminf_llist Gs - sr.Rf (Liminf_llist Gs)" unfolding ns sr.Rf_def by auto then have "{#} \ grounding_of_clss (Q_of_state (Liminf_state Sts))" using fair_imp_Liminf_minus_Rf_subset_ground_Liminf_state[OF deriv fair ns] by auto then show ?thesis unfolding grounding_of_clss_def grounding_of_cls_def by auto qed lemma grounding_of_state_Liminf_state_subseteq: "grounding_of_state (Liminf_state Sts) \ Liminf_llist (lmap grounding_of_state Sts)" proof fix C :: "'a clause" assume "C \ grounding_of_state (Liminf_state Sts)" then obtain D \ where D_\_p: "D \ clss_of_state (Liminf_state Sts)" "D \ \ = C" "is_ground_subst \" unfolding grounding_of_clss_def grounding_of_cls_def by auto then have ii: "D \ Liminf_llist (lmap N_of_state Sts) \ D \ Liminf_llist (lmap P_of_state Sts) \ D \ Liminf_llist (lmap Q_of_state Sts)" unfolding Liminf_state_def by simp then have "C \ Liminf_llist (lmap grounding_of_clss (lmap N_of_state Sts)) \ C \ Liminf_llist (lmap grounding_of_clss (lmap P_of_state Sts)) \ C \ Liminf_llist (lmap grounding_of_clss (lmap Q_of_state Sts))" unfolding Liminf_llist_def grounding_of_clss_def grounding_of_cls_def using D_\_p apply - apply (erule disjE) subgoal apply (rule disjI1) using D_\_p by auto subgoal apply (erule disjE) subgoal apply (rule disjI2) apply (rule disjI1) using D_\_p by auto subgoal apply (rule disjI2) apply (rule disjI2) using D_\_p by auto done done then show "C \ Liminf_llist (lmap grounding_of_state Sts)" unfolding Liminf_llist_def grounding_of_clss_def by auto qed theorem RP_sound: assumes deriv: "chain (\) Sts" and "{#} \ clss_of_state (Liminf_state Sts)" shows "\ satisfiable (grounding_of_state (lhd Sts))" proof - from assms have "{#} \ grounding_of_state (Liminf_state Sts)" unfolding grounding_of_clss_def by (force intro: ex_ground_subst) then have "{#} \ Liminf_llist (lmap grounding_of_state Sts)" using grounding_of_state_Liminf_state_subseteq by auto then have "\ satisfiable (Liminf_llist (lmap grounding_of_state Sts))" using true_clss_def by auto then have "\ satisfiable (lhd (lmap grounding_of_state Sts))" using sr_ext.sat_limit_iff ground_derive_chain deriv by blast then show ?thesis using chain_not_lnull deriv by fastforce qed theorem RP_saturated_if_fair: assumes deriv: "chain (\) Sts" and fair: "fair_state_seq Sts" and empty_Q0: "Q_of_state (lhd Sts) = {}" shows "sr.saturated_upto (Liminf_llist (lmap grounding_of_state Sts))" proof - define Gs :: "'a clause set llist" where ns: "Gs = lmap grounding_of_state Sts" let ?N = "\i. grounding_of_state (lnth Sts i)" let ?Ns = "\i. N_of_state (lnth Sts i)" let ?Ps = "\i. P_of_state (lnth Sts i)" let ?Qs = "\i. Q_of_state (lnth Sts i)" have ground_ns_in_ground_limit_st: "Liminf_llist Gs - sr.Rf (Liminf_llist Gs) \ grounding_of_clss (Q_of_state (Liminf_state Sts))" using fair deriv fair_imp_Liminf_minus_Rf_subset_ground_Liminf_state ns by blast have derivns: "chain sr_ext.derive Gs" using ground_derive_chain deriv ns by auto { fix \ :: "'a inference" assume \_p: "\ \ gr.ord_\" let ?CC = "side_prems_of \" let ?DA = "main_prem_of \" let ?E = "concl_of \" assume a: "set_mset ?CC \ {?DA} \ Liminf_llist (lmap grounding_of_state Sts) - sr.Rf (Liminf_llist (lmap grounding_of_state Sts))" have ground_ground_Liminf: "is_ground_clss (Liminf_llist (lmap grounding_of_state Sts))" using Liminf_grounding_of_state_ground unfolding is_ground_clss_def by auto have ground_cc: "is_ground_clss (set_mset ?CC)" using a ground_ground_Liminf is_ground_clss_def by auto have ground_da: "is_ground_cls ?DA" using a grounding_ground singletonI ground_ground_Liminf by (simp add: Liminf_grounding_of_state_ground) from \_p obtain CAs AAs As where CAs_p: "gr.ord_resolve CAs ?DA AAs As ?E \ mset CAs = ?CC" unfolding gr.ord_\_def by auto have DA_CAs_in_ground_Liminf: "{?DA} \ set CAs \ grounding_of_clss (Q_of_state (Liminf_state Sts))" using a CAs_p fair unfolding fair_state_seq_def by (metis (no_types, lifting) Un_empty_left ground_ns_in_ground_limit_st a ns set_mset_mset subset_trans sup_commute) then have ground_cas: "is_ground_cls_list CAs" using CAs_p unfolding is_ground_cls_list_def by auto have "\\. ord_resolve S_Q CAs ?DA AAs As \ ?E" by (rule ground_ord_resolve_imp_ord_resolve[OF ground_da ground_cas gr.ground_resolution_with_selection_axioms CAs_p[THEN conjunct1]]) then obtain \ where \_p: "ord_resolve S_Q CAs ?DA AAs As \ ?E" by auto then obtain \s' \' \2' CAs' DA' AAs' As' \' E' where s_p: "is_ground_subst \'" "is_ground_subst_list \s'" "is_ground_subst \2'" "ord_resolve_rename S CAs' DA' AAs' As' \' E'" "CAs' \\cl \s' = CAs" "DA' \ \' = ?DA" "E' \ \2' = ?E" "{DA'} \ set CAs' \ Q_of_state (Liminf_state Sts)" using ord_resolve_rename_lifting[OF sel_stable, of "Q_of_state (Liminf_state Sts)" CAs ?DA] \_p[unfolded S_Q_def] selection_axioms DA_CAs_in_ground_Liminf by metis from this(8) have "\j. enat j < llength Sts \ (set CAs' \ {DA'} \ ?Qs j)" unfolding Liminf_llist_def using subseteq_Liminf_state_eventually_always[of "{DA'} \ set CAs'"] by auto then obtain j where j_p: "is_least (\j. enat j < llength Sts \ set CAs' \ {DA'} \ ?Qs j) j" using least_exists[of "\j. enat j < llength Sts \ set CAs' \ {DA'} \ ?Qs j"] by force then have j_p': "enat j < llength Sts" "set CAs' \ {DA'} \ ?Qs j" unfolding is_least_def by auto then have jn0: "j \ 0" using empty_Q0 by (metis bot_eq_sup_iff gr_implies_not_zero insert_not_empty llength_lnull lnth_0_conv_lhd sup.orderE) then have j_adds_CAs': "\ set CAs' \ {DA'} \ ?Qs (j - 1)" "set CAs' \ {DA'} \ ?Qs j" using j_p unfolding is_least_def apply (metis (no_types) One_nat_def Suc_diff_Suc Suc_ile_eq diff_diff_cancel diff_zero less_imp_le less_one neq0_conv zero_less_diff) using j_p'(2) by blast have "lnth Sts (j - 1) \ lnth Sts j" using j_p'(1) jn0 deriv chain_lnth_rel[of _ _ "j - 1"] by force then obtain C' where C'_p: "?Ns (j - 1) = {}" "?Ps (j - 1) = ?Ps j \ {C'}" "?Qs j = ?Qs (j - 1) \ {C'}" "?Ns j = concls_of (ord_FO_resolution.inferences_between (?Qs (j - 1)) C')" "C' \ set CAs' \ {DA'}" "C' \ ?Qs (j - 1)" using j_adds_CAs' by (induction rule: RP.cases) auto have "E' \ ?Ns j" proof - have "E' \ concls_of (ord_FO_resolution.inferences_between (Q_of_state (lnth Sts (j - 1))) C')" unfolding infer_from_def ord_FO_\_def inference_system.inferences_between_def apply (rule_tac x = "Infer (mset CAs') DA' E'" in image_eqI) subgoal by auto subgoal unfolding infer_from_def by (rule ord_resolve_rename.cases[OF s_p(4)]) (use s_p(4) C'_p(3,5) j_p'(2) in force) done then show ?thesis using C'_p(4) by auto qed then have "E' \ clss_of_state (lnth Sts j)" using j_p' by auto then have "?E \ grounding_of_state (lnth Sts j)" using s_p(7) s_p(3) unfolding grounding_of_clss_def grounding_of_cls_def by force then have "\ \ sr.Ri (grounding_of_state (lnth Sts j))" using sr.Ri_effective \_p by auto then have "\ \ sr_ext_Ri (?N j)" unfolding sr_ext_Ri_def by auto then have "\ \ sr_ext_Ri (Sup_llist (lmap grounding_of_state Sts))" - using j_p' contra_subsetD llength_lmap lnth_lmap lnth_subset_Sup_llist sr_ext.Ri_mono by smt + using j_p' contra_subsetD llength_lmap lnth_lmap lnth_subset_Sup_llist sr_ext.Ri_mono by (smt (verit)) then have "\ \ sr_ext_Ri (Liminf_llist (lmap grounding_of_state Sts))" using sr_ext.Ri_limit_Sup[of Gs] derivns ns by blast } then have "sr_ext.saturated_upto (Liminf_llist (lmap grounding_of_state Sts))" unfolding sr_ext.saturated_upto_def sr_ext.inferences_from_def infer_from_def sr_ext_Ri_def by auto then show ?thesis using gd_ord_\_ngd_ord_\ sr.redundancy_criterion_axioms redundancy_criterion_standard_extension_saturated_upto_iff[of gr.ord_\] unfolding sr_ext_Ri_def by auto qed corollary RP_complete_if_fair: assumes deriv: "chain (\) Sts" and fair: "fair_state_seq Sts" and empty_Q0: "Q_of_state (lhd Sts) = {}" and unsat: "\ satisfiable (grounding_of_state (lhd Sts))" shows "{#} \ Q_of_state (Liminf_state Sts)" proof - have "\ satisfiable (Liminf_llist (lmap grounding_of_state Sts))" using unsat sr_ext.sat_limit_iff[OF ground_derive_chain] chain_not_lnull deriv by fastforce moreover have "sr.saturated_upto (Liminf_llist (lmap grounding_of_state Sts))" by (rule RP_saturated_if_fair[OF deriv fair empty_Q0, simplified]) ultimately have "{#} \ Liminf_llist (lmap grounding_of_state Sts)" using sr.saturated_upto_complete_if by auto then show ?thesis using empty_clause_in_Q_of_Liminf_state[OF deriv fair] by auto qed end end end diff --git a/thys/Ordered_Resolution_Prover/Lazy_List_Chain.thy b/thys/Ordered_Resolution_Prover/Lazy_List_Chain.thy --- a/thys/Ordered_Resolution_Prover/Lazy_List_Chain.thy +++ b/thys/Ordered_Resolution_Prover/Lazy_List_Chain.thy @@ -1,707 +1,707 @@ (* Title: Relational Chains over Lazy Lists Author: Jasmin Blanchette , 2014, 2017 Author: Dmitriy Traytel , 2017 Author: Anders Schlichtkrull , 2017 Maintainer: Anders Schlichtkrull *) section \Relational Chains over Lazy Lists\ theory Lazy_List_Chain imports "HOL-Library.BNF_Corec" Lazy_List_Liminf begin text \ A chain is a lazy list of elements such that all pairs of consecutive elements are related by a given relation. A full chain is either an infinite chain or a finite chain that cannot be extended. The inspiration for this theory is Section 4.1 (Theorem Proving Processes'') of Bachmair and Ganzinger's chapter. \ subsection \Chains\ coinductive chain :: "('a \ 'a \ bool) \ 'a llist \ bool" for R :: "'a \ 'a \ bool" where chain_singleton: "chain R (LCons x LNil)" | chain_cons: "chain R xs \ R x (lhd xs) \ chain R (LCons x xs)" lemma chain_LNil[simp]: "\ chain R LNil" and chain_not_lnull: "chain R xs \ \ lnull xs" by (auto elim: chain.cases) lemma chain_lappend: assumes r_xs: "chain R xs" and r_ys: "chain R ys" and mid: "R (llast xs) (lhd ys)" shows "chain R (lappend xs ys)" proof (cases "lfinite xs") case True then show ?thesis using r_xs mid proof (induct rule: lfinite.induct) case (lfinite_LConsI xs x) note fin = this(1) and ih = this(2) and r_xxs = this(3) and mid = this(4) show ?case proof (cases "xs = LNil") case True then show ?thesis using r_ys mid by simp (rule chain_cons) next case xs_nnil: False have r_xs: "chain R xs" by (metis chain.simps ltl_simps(2) r_xxs xs_nnil) have mid': "R (llast xs) (lhd ys)" by (metis llast_LCons lnull_def mid xs_nnil) have start: "R x (lhd (lappend xs ys))" by (metis (no_types) chain.simps lhd_LCons lhd_lappend chain_not_lnull ltl_simps(2) r_xxs xs_nnil) show ?thesis unfolding lappend_code(2) using ih[OF r_xs mid'] start by (rule chain_cons) qed qed simp qed (simp add: r_xs lappend_inf) lemma chain_length_pos: "chain R xs \ llength xs > 0" by (cases xs) simp+ lemma chain_ldropn: assumes "chain R xs" and "enat n < llength xs" shows "chain R (ldropn n xs)" using assms by (induct n arbitrary: xs, simp, metis chain.cases ldrop_eSuc_ltl ldropn_LNil ldropn_eq_LNil ltl_simps(2) not_less) lemma inf_chain_ldropn_chain: "chain R xs \ \ lfinite xs \ chain R (ldropn n xs)" using chain.simps[of R xs] by (simp add: chain_ldropn not_lfinite_llength) lemma inf_chain_ltl_chain: "chain R xs \ \ lfinite xs \ chain R (ltl xs)" by (metis inf_chain_ldropn_chain ldropn_0 ldropn_ltl) lemma chain_lnth_rel: assumes chain: "chain R xs" and len: "enat (Suc j) < llength xs" shows "R (lnth xs j) (lnth xs (Suc j))" proof - define ys where "ys = ldropn j xs" have "llength ys > 1" unfolding ys_def using len by (metis One_nat_def funpow_swap1 ldropn_0 ldropn_def ldropn_eq_LNil ldropn_ltl not_less one_enat_def) obtain y0 y1 ys' where ys: "ys = LCons y0 (LCons y1 ys')" unfolding ys_def by (metis Suc_ile_eq ldropn_Suc_conv_ldropn len less_imp_not_less not_less) have "chain R ys" unfolding ys_def using Suc_ile_eq chain chain_ldropn len less_imp_le by blast then have "R y0 y1" unfolding ys by (auto elim: chain.cases) then show ?thesis using ys_def unfolding ys by (metis ldropn_Suc_conv_ldropn ldropn_eq_LConsD llist.inject) qed lemma infinite_chain_lnth_rel: assumes "\ lfinite c" and "chain r c" shows "r (lnth c i) (lnth c (Suc i))" using assms chain_lnth_rel lfinite_conv_llength_enat by force lemma lnth_rel_chain: assumes "\ lnull xs" and "\j. enat (j + 1) < llength xs \ R (lnth xs j) (lnth xs (j + 1))" shows "chain R xs" using assms proof (coinduction arbitrary: xs rule: chain.coinduct) case chain note nnul = this(1) and nth_chain = this(2) show ?case proof (cases "lnull (ltl xs)") case True have "xs = LCons (lhd xs) LNil" using nnul True by (simp add: llist.expand) then show ?thesis by blast next case nnul': False moreover have "xs = LCons (lhd xs) (ltl xs)" using nnul by simp moreover have "\j. enat (j + 1) < llength (ltl xs) \ R (lnth (ltl xs) j) (lnth (ltl xs) (j + 1))" using nnul nth_chain by (metis Suc_eq_plus1 ldrop_eSuc_ltl ldropn_Suc_conv_ldropn ldropn_eq_LConsD lnth_ltl) moreover have "R (lhd xs) (lhd (ltl xs))" using nnul' nnul nth_chain[rule_format, of 0, simplified] by (metis ldropn_0 ldropn_Suc_conv_ldropn ldropn_eq_LConsD lhd_LCons_ltl lhd_conv_lnth lnth_Suc_LCons ltl_simps(2)) ultimately show ?thesis by blast qed qed lemma chain_lmap: assumes "\x y. R x y \ R' (f x) (f y)" and "chain R xs" shows "chain R' (lmap f xs)" using assms proof (coinduction arbitrary: xs) case chain then have "(\y. xs = LCons y LNil) \ (\ys x. xs = LCons x ys \ chain R ys \ R x (lhd ys))" using chain.simps[of R xs] by auto then show ?case proof assume "\ys x. xs = LCons x ys \ chain R ys \ R x (lhd ys)" then have "\ys x. lmap f xs = LCons x ys \ (\xs. ys = lmap f xs \ (\x y. R x y \ R' (f x) (f y)) \ chain R xs) \ R' x (lhd ys)" using chain by (metis (no_types) lhd_LCons llist.distinct(1) llist.exhaust_sel llist.map_sel(1) lmap_eq_LNil chain_not_lnull ltl_lmap ltl_simps(2)) then show ?thesis by auto qed auto qed lemma chain_mono: assumes "\x y. R x y \ R' x y" and "chain R xs" shows "chain R' xs" using assms by (rule chain_lmap[of _ _ "\x. x", unfolded llist.map_ident]) lemma chain_ldropnI: assumes rel: "\j. j \ i \ enat (Suc j) < llength xs \ R (lnth xs j) (lnth xs (Suc j))" and si_lt: "enat (Suc i) < llength xs" shows "chain R (ldropn i xs)" proof (rule lnth_rel_chain) show "\ lnull (ldropn i xs)" using si_lt by (simp add: Suc_ile_eq less_le_not_le) next show "\j. enat (j + 1) < llength (ldropn i xs) \ R (lnth (ldropn i xs) j) (lnth (ldropn i xs) (j + 1))" - using rel by (smt (z3) One_nat_def Suc_ile_eq add.commute add.right_neutral add_Suc_right - add_le_cancel_right ldropn_eq_LNil ldropn_ldropn less_le_not_le linorder_not_less - lnth_ldropn not_less_zero) + using rel + by (smt (verit, best) Suc_ile_eq add.commute ldropn_eq_LNil ldropn_ldropn leD + le_add1 linorder_le_less_linear lnth_ldropn order_less_imp_le plus_1_eq_Suc) qed lemma chain_ldropn_lmapI: assumes rel: "\j. j \ i \ enat (Suc j) < llength xs \ R (f (lnth xs j)) (f (lnth xs (Suc j)))" and si_lt: "enat (Suc i) < llength xs" shows "chain R (ldropn i (lmap f xs))" proof - have "chain R (lmap f (ldropn i xs))" using chain_lmap[of "\x y. R (f x) (f y)" R f, of "ldropn i xs"] chain_ldropnI[OF rel si_lt] by auto thus ?thesis by auto qed lemma lfinite_chain_imp_rtranclp_lhd_llast: "lfinite xs \ chain R xs \ R\<^sup>*\<^sup>* (lhd xs) (llast xs)" proof (induct rule: lfinite.induct) case (lfinite_LConsI xs x) note fin_xs = this(1) and ih = this(2) and r_x_xs = this(3) show ?case proof (cases "xs = LNil") case xs_nnil: False then have r_xs: "chain R xs" using r_x_xs by (blast elim: chain.cases) then show ?thesis using ih[OF r_xs] xs_nnil r_x_xs by (metis chain.cases converse_rtranclp_into_rtranclp lhd_LCons llast_LCons chain_not_lnull ltl_simps(2)) qed simp qed simp lemma tranclp_imp_exists_finite_chain_list: "R\<^sup>+\<^sup>+ x y \ \xs. chain R (llist_of (x # xs @ [y]))" proof (induct rule: tranclp.induct) case (r_into_trancl x y) then have "chain R (llist_of (x # [] @ [y]))" by (auto intro: chain.intros) then show ?case by blast next case (trancl_into_trancl x y z) note rstar_xy = this(1) and ih = this(2) and r_yz = this(3) obtain xs where xs: "chain R (llist_of (x # xs @ [y]))" using ih by blast define ys where "ys = xs @ [y]" have "chain R (llist_of (x # ys @ [z]))" unfolding ys_def using r_yz chain_lappend[OF xs chain_singleton, of z] by (auto simp: lappend_llist_of_LCons llast_LCons) then show ?case by blast qed inductive_cases chain_consE: "chain R (LCons x xs)" inductive_cases chain_nontrivE: "chain R (LCons x (LCons y xs))" subsection \A Coinductive Puzzle\ primrec prepend where "prepend [] ys = ys" | "prepend (x # xs) ys = LCons x (prepend xs ys)" lemma lnull_prepend[simp]: "lnull (prepend xs ys) = (xs = [] \ lnull ys)" by (induct xs) auto lemma lhd_prepend[simp]: "lhd (prepend xs ys) = (if xs \ [] then hd xs else lhd ys)" by (induct xs) auto lemma prepend_LNil[simp]: "prepend xs LNil = llist_of xs" by (induct xs) auto lemma lfinite_prepend[simp]: "lfinite (prepend xs ys) \ lfinite ys" by (induct xs) auto lemma llength_prepend[simp]: "llength (prepend xs ys) = length xs + llength ys" by (induct xs) (auto simp: enat_0 iadd_Suc eSuc_enat[symmetric]) lemma llast_prepend[simp]: "\ lnull ys \ llast (prepend xs ys) = llast ys" by (induct xs) (auto simp: llast_LCons) lemma prepend_prepend: "prepend xs (prepend ys zs) = prepend (xs @ ys) zs" by (induct xs) auto lemma chain_prepend: "chain R (llist_of zs) \ last zs = lhd xs \ chain R xs \ chain R (prepend zs (ltl xs))" by (induct zs; cases xs) (auto split: if_splits simp: lnull_def[symmetric] intro!: chain_cons elim!: chain_consE) lemma lmap_prepend[simp]: "lmap f (prepend xs ys) = prepend (map f xs) (lmap f ys)" by (induct xs) auto lemma lset_prepend[simp]: "lset (prepend xs ys) = set xs \ lset ys" by (induct xs) auto lemma prepend_LCons: "prepend xs (LCons y ys) = prepend (xs @ [y]) ys" by (induct xs) auto lemma lnth_prepend: "lnth (prepend xs ys) i = (if i < length xs then nth xs i else lnth ys (i - length xs))" by (induct xs arbitrary: i) (auto simp: lnth_LCons' nth_Cons') theorem lfinite_less_induct[consumes 1, case_names less]: assumes fin: "lfinite xs" and step: "\xs. lfinite xs \ (\zs. llength zs < llength xs \ P zs) \ P xs" shows "P xs" using fin proof (induct "the_enat (llength xs)" arbitrary: xs rule: less_induct) case (less xs) show ?case using less(2) by (intro step[OF less(2)] less(1)) (auto dest!: lfinite_llength_enat simp: eSuc_enat elim!: less_enatE llength_eq_enat_lfiniteD) qed theorem lfinite_prepend_induct[consumes 1, case_names LNil prepend]: assumes "lfinite xs" and LNil: "P LNil" and prepend: "\xs. lfinite xs \ (\zs. (\ys. xs = prepend ys zs \ ys \ []) \ P zs) \ P xs" shows "P xs" using assms(1) proof (induct xs rule: lfinite_less_induct) case (less xs) from less(1) show ?case by (cases xs) (force simp: LNil neq_Nil_conv dest: lfinite_llength_enat intro!: prepend[of "LCons _ _"] intro: less)+ qed coinductive emb :: "'a llist \ 'a llist \ bool" where "lfinite xs \ emb LNil xs" | "emb xs ys \ emb (LCons x xs) (prepend zs (LCons x ys))" inductive_cases emb_LConsE: "emb (LCons z zs) ys" inductive_cases emb_LNil1E: "emb LNil ys" inductive_cases emb_LNil2E: "emb xs LNil" lemma emb_lfinite: assumes "emb xs ys" shows "lfinite ys \ lfinite xs" proof assume "lfinite xs" then show "lfinite ys" using assms by (induct xs arbitrary: ys rule: lfinite_induct) (auto simp: lnull_def neq_LNil_conv elim!: emb_LNil1E emb_LConsE) next assume "lfinite ys" then show "lfinite xs" using assms proof (induction ys arbitrary: xs rule: lfinite_less_induct) case (less ys) from less.prems \lfinite ys\ show ?case by (cases xs) (auto simp: eSuc_enat elim!: emb_LNil1E emb_LConsE less.IH[rotated] dest!: lfinite_llength_enat) qed qed inductive prepend_cong1 for X where prepend_cong1_base: "X xs \ prepend_cong1 X xs" | prepend_cong1_prepend: "prepend_cong1 X ys \ prepend_cong1 X (prepend xs ys)" lemma prepend_cong1_alt: "prepend_cong1 X xs \ (\ys zs. xs = prepend ys zs \ X zs)" by (rule iffI, induct xs rule: prepend_cong1.induct) (force simp: prepend_prepend intro: prepend_cong1.intros exI[of _ "[]"])+ lemma emb_prepend_coinduct_cong[rotated, case_names emb]: assumes "(\x1 x2. X x1 x2 \ (\xs. x1 = LNil \ x2 = xs \ lfinite xs) \ (\xs ys x zs. x1 = LCons x xs \ x2 = prepend zs (LCons x ys) \ (prepend_cong1 (X xs) ys \ emb xs ys)))" (is "\x1 x2. X x1 x2 \ ?bisim x1 x2") shows "X x1 x2 \ emb x1 x2" proof (erule emb.coinduct[OF prepend_cong1_base]) fix xs zs assume "prepend_cong1 (X xs) zs" then show "?bisim xs zs" by (induct zs rule: prepend_cong1.induct) (erule assms, force simp: prepend_prepend) qed lemma emb_prepend: "emb xs ys \ emb xs (prepend zs ys)" by (coinduction arbitrary: xs zs ys rule: emb_prepend_coinduct_cong) (force elim: emb.cases simp: prepend_prepend) lemma prepend_cong1_emb: "prepend_cong1 (emb xs) ys = emb xs ys" by (rule iffI, induct ys rule: prepend_cong1.induct) (simp_all add: emb_prepend prepend_cong1_base) lemma prepend_cong_distrib: "prepend_cong1 (P \ Q) xs \ prepend_cong1 P xs \ prepend_cong1 Q xs" unfolding prepend_cong1_alt by auto lemma emb_prepend_coinduct_aux[case_names emb]: assumes "X x1 x2 " "(\x1 x2. X x1 x2 \ (\xs. x1 = LNil \ x2 = xs \ lfinite xs) \ (\xs ys x zs. x1 = LCons x xs \ x2 = prepend zs (LCons x ys) \ (prepend_cong1 (X xs \ emb xs) ys)))" shows "emb x1 x2" using assms unfolding prepend_cong_distrib prepend_cong1_emb by (rule emb_prepend_coinduct_cong) lemma emb_prepend_coinduct[rotated, case_names emb]: assumes "(\x1 x2. X x1 x2 \ (\xs. x1 = LNil \ x2 = xs \ lfinite xs) \ (\xs ys x zs zs'. x1 = LCons x xs \ x2 = prepend zs (LCons x (prepend zs' ys)) \ (X xs ys \ emb xs ys)))" shows "X x1 x2 \ emb x1 x2" by (erule emb_prepend_coinduct_aux[of X]) (force simp: prepend_cong1_alt dest: assms) context begin private coinductive chain' for R where "chain' R (LCons x LNil)" | "chain R (llist_of (x # zs @ [lhd xs])) \ chain' R xs \ chain' R (LCons x (prepend zs xs))" private lemma chain_imp_chain': "chain R xs \ chain' R xs" proof (coinduction arbitrary: xs rule: chain'.coinduct) case chain' then show ?case proof (cases rule: chain.cases) case (chain_cons zs z) then show ?thesis by (intro disjI2 exI[of _ z] exI[of _ "[]"] exI[of _ "zs"]) (auto intro: chain.intros) qed simp qed private lemma chain'_imp_chain: "chain' R xs \ chain R xs" proof (coinduction arbitrary: xs rule: chain.coinduct) case chain then show ?case proof (cases rule: chain'.cases) case (2 y zs ys) then show ?thesis by (intro disjI2 exI[of _ "prepend zs ys"] exI[of _ y]) (force dest!: neq_Nil_conv[THEN iffD1] elim: chain.cases chain_nontrivE intro: chain'.intros) qed simp qed private lemma chain_chain': "chain = chain'" unfolding fun_eq_iff by (metis chain_imp_chain' chain'_imp_chain) lemma chain_prepend_coinduct[case_names chain]: "X x \ (\x. X x \ (\z. x = LCons z LNil) \ (\y xs zs. x = LCons y (prepend zs xs) \ (X xs \ chain R xs) \ chain R (llist_of (y # zs @ [lhd xs])))) \ chain R x" by (subst chain_chain', erule chain'.coinduct) (force simp: chain_chain') end context fixes R :: "'a \ 'a \ bool" begin private definition pick where "pick x y = (SOME xs. chain R (llist_of (x # xs @ [y])))" private lemma pick[simp]: assumes "R\<^sup>+\<^sup>+ x y" shows "chain R (llist_of (x # pick x y @ [y]))" unfolding pick_def using tranclp_imp_exists_finite_chain_list[THEN someI_ex, OF assms] by auto private friend_of_corec prepend where "prepend xs ys = (case xs of [] \ (case ys of LNil \ LNil | LCons x xs \ LCons x xs) | x # xs' \ LCons x (prepend xs' ys))" by (simp split: list.splits llist.splits) transfer_prover private corec wit where "wit xs = (case xs of LCons x (LCons y xs) \ LCons x (prepend (pick x y) (wit (LCons y xs))) | _ \ xs)" private lemma wit_LNil[simp]: "wit LNil = LNil" and wit_lsingleton[simp]: "wit (LCons x LNil) = LCons x LNil" and wit_LCons2: "wit (LCons x (LCons y xs)) = (LCons x (prepend (pick x y) (wit (LCons y xs))))" by (subst wit.code; auto)+ private lemma lnull_wit[simp]: "lnull (wit xs) \ lnull xs" by (subst wit.code) (auto split: llist.splits simp: Let_def) private lemma lhd_wit[simp]: "chain R\<^sup>+\<^sup>+ xs \ lhd (wit xs) = lhd xs" by (erule chain.cases; subst wit.code) (auto split: llist.splits simp: Let_def) private lemma LNil_eq_iff_lnull: "LNil = xs \ lnull xs" by (cases xs) auto lemma emb_wit[simp]: "chain R\<^sup>+\<^sup>+ xs \ emb xs (wit xs)" proof (coinduction arbitrary: xs rule: emb_prepend_coinduct) case (emb xs) then show ?case proof (cases rule: chain.cases) case (chain_cons zs z) then show ?thesis by (subst (2) wit.code) (auto 0 3 split: llist.splits intro: exI[of _ "[]"] exI[of _ "pick z _"] intro!: exI[of _ "_ :: _ llist"]) qed (auto intro!: exI[of _ LNil] exI[of _ "[]"] emb.intros) qed private lemma lfinite_wit[simp]: assumes "chain R\<^sup>+\<^sup>+ xs" shows "lfinite (wit xs) \ lfinite xs" using emb_wit emb_lfinite assms by blast private lemma llast_wit[simp]: assumes "chain R\<^sup>+\<^sup>+ xs" shows "llast (wit xs) = llast xs" proof (cases "lfinite xs") case True from this assms show ?thesis proof (induct rule: lfinite.induct) case (lfinite_LConsI xs x) then show ?case by (cases xs) (auto simp: wit_LCons2 llast_LCons elim: chain_nontrivE) qed auto qed (auto simp: llast_linfinite assms) lemma chain_tranclp_imp_exists_chain: "chain R\<^sup>+\<^sup>+ xs \ \ys. chain R ys \ emb xs ys \ lhd ys = lhd xs \ llast ys = llast xs" proof (intro exI[of _ "wit xs"] conjI, coinduction arbitrary: xs rule: chain_prepend_coinduct) case chain then show ?case by (subst (1 2) wit.code) (erule chain.cases; force split: llist.splits dest: pick) qed auto lemma emb_lset_mono[rotated]: "x \ lset xs \ emb xs ys \ x \ lset ys" by (induct x xs arbitrary: ys rule: llist.set_induct) (auto elim!: emb_LConsE) lemma emb_Ball_lset_antimono: assumes "emb Xs Ys" shows "\Y \ lset Ys. x \ Y \ \X \ lset Xs. x \ X" using emb_lset_mono[OF assms] by blast lemma emb_lfinite_antimono[rotated]: "lfinite ys \ emb xs ys \ lfinite xs" by (induct ys arbitrary: xs rule: lfinite_prepend_induct) (force elim!: emb_LNil2E simp: LNil_eq_iff_lnull prepend_LCons elim: emb.cases)+ lemma emb_Liminf_llist_mono_aux: assumes "emb Xs Ys" and "\ lfinite Xs" and "\ lfinite Ys" and "\j\i. x \ lnth Ys j" shows "\j\i. x \ lnth Xs j" using assms proof (induct i arbitrary: Xs Ys rule: less_induct) case (less i) then show ?case proof (cases i) case 0 then show ?thesis using emb_Ball_lset_antimono[OF less(2), of x] less(5) unfolding Ball_def in_lset_conv_lnth simp_thms not_lfinite_llength[OF less(3)] not_lfinite_llength[OF less(4)] enat_ord_code subset_eq by blast next case [simp]: (Suc nat) from less(2,3) obtain xs as b bs where [simp]: "Xs = LCons b xs" "Ys = prepend as (LCons b bs)" and "emb xs bs" by (auto elim: emb.cases) have IH: "\k\j. x \ lnth xs k" if "\k\j. x \ lnth bs k" "j < i" for j using that less(1)[OF _ \emb xs bs\] less(3,4) by auto from less(5) have "\k\i - length as - 1. x \ lnth xs k" by (intro IH allI) (drule spec[of _ "_ + length as + 1"], auto simp: lnth_prepend lnth_LCons') then show ?thesis by (auto simp: lnth_LCons') qed qed lemma emb_Liminf_llist_infinite: assumes "emb Xs Ys" and "\ lfinite Xs" shows "Liminf_llist Ys \ Liminf_llist Xs" proof - from assms have "\ lfinite Ys" using emb_lfinite_antimono by blast with assms show ?thesis unfolding Liminf_llist_def by (auto simp: not_lfinite_llength dest: emb_Liminf_llist_mono_aux) qed lemma emb_lmap: "emb xs ys \ emb (lmap f xs) (lmap f ys)" proof (coinduction arbitrary: xs ys rule: emb.coinduct) case emb show ?case proof (cases xs) case xs: (LCons x xs') obtain ysa0 and zs0 where ys: "ys = prepend zs0 (LCons x ysa0)" and emb': "emb xs' ysa0" using emb_LConsE[OF emb[unfolded xs]] by metis let ?xa = "f x" let ?xsa = "lmap f xs'" let ?zs = "map f zs0" let ?ysa = "lmap f ysa0" have "lmap f xs = LCons ?xa ?xsa" unfolding xs by simp moreover have "lmap f ys = prepend ?zs (LCons ?xa ?ysa)" unfolding ys by simp moreover have "\xsa ysa. ?xsa = lmap f xsa \ ?ysa = lmap f ysa \ emb xsa ysa" using emb' by blast ultimately show ?thesis by blast qed (simp add: emb_lfinite[OF emb]) qed end lemma chain_inf_llist_if_infinite_chain_function: assumes "\i. r (f (Suc i)) (f i)" shows "\ lfinite (inf_llist f) \ chain r\\ (inf_llist f)" using assms by (simp add: lnth_rel_chain) lemma infinite_chain_function_iff_infinite_chain_llist: "(\f. \i. r (f (Suc i)) (f i)) \ (\c. \ lfinite c \ chain r\\ c)" using chain_inf_llist_if_infinite_chain_function infinite_chain_lnth_rel by blast lemma wfP_iff_no_infinite_down_chain_llist: "wfP r \ (\c. \ lfinite c \ chain r\\ c)" proof - have "wfP r \ wf {(x, y). r x y}" unfolding wfP_def by auto also have "\ \ (\f. \i. (f (Suc i), f i) \ {(x, y). r x y})" using wf_iff_no_infinite_down_chain by blast also have "\ \ (\f. \i. r (f (Suc i)) (f i))" by auto also have "\ \ (\c. \lfinite c \ chain r\\ c)" using infinite_chain_function_iff_infinite_chain_llist by blast finally show ?thesis by auto qed subsection \Full Chains\ coinductive full_chain :: "('a \ 'a \ bool) \ 'a llist \ bool" for R :: "'a \ 'a \ bool" where full_chain_singleton: "(\y. \ R x y) \ full_chain R (LCons x LNil)" | full_chain_cons: "full_chain R xs \ R x (lhd xs) \ full_chain R (LCons x xs)" lemma full_chain_LNil[simp]: "\ full_chain R LNil" and full_chain_not_lnull: "full_chain R xs \ \ lnull xs" by (auto elim: full_chain.cases) lemma full_chain_ldropn: assumes full: "full_chain R xs" and "enat n < llength xs" shows "full_chain R (ldropn n xs)" using assms by (induct n arbitrary: xs, simp, metis full_chain.cases ldrop_eSuc_ltl ldropn_LNil ldropn_eq_LNil ltl_simps(2) not_less) lemma full_chain_iff_chain: "full_chain R xs \ chain R xs \ (lfinite xs \ (\y. \ R (llast xs) y))" proof (intro iffI conjI impI allI; (elim conjE)?) assume full: "full_chain R xs" show chain: "chain R xs" using full by (coinduction arbitrary: xs) (auto elim: full_chain.cases) { fix y assume "lfinite xs" then obtain n where suc_n: "Suc n = llength xs" by (metis chain chain_length_pos lessE less_enatE lfinite_conv_llength_enat) have "full_chain R (ldropn n xs)" by (rule full_chain_ldropn[OF full]) (use suc_n Suc_ile_eq in force) moreover have "ldropn n xs = LCons (llast xs) LNil" using suc_n by (metis enat_le_plus_same(2) enat_ord_simps(2) gen_llength_def ldropn_Suc_conv_ldropn ldropn_all lessI llast_ldropn llast_singleton llength_code) ultimately show "\ R (llast xs) y" by (auto elim: full_chain.cases) } next assume "chain R xs" and "lfinite xs \ (\y. \ R (llast xs) y)" then show "full_chain R xs" by (coinduction arbitrary: xs) (erule chain.cases, simp, metis lfinite_LConsI llast_LCons) qed lemma full_chain_imp_chain: "full_chain R xs \ chain R xs" using full_chain_iff_chain by blast lemma full_chain_length_pos: "full_chain R xs \ llength xs > 0" by (fact chain_length_pos[OF full_chain_imp_chain]) lemma full_chain_lnth_rel: "full_chain R xs \ enat (Suc j) < llength xs \ R (lnth xs j) (lnth xs (Suc j))" by (fact chain_lnth_rel[OF full_chain_imp_chain]) lemma full_chain_lnth_not_rel: assumes full: "full_chain R xs" and sj: "enat (Suc j) = llength xs" shows "\ R (lnth xs j) y" proof - have "lfinite xs" by (metis llength_eq_enat_lfiniteD sj) hence "\ R (llast xs) y" using full_chain_iff_chain full by metis thus ?thesis by (metis eSuc_enat llast_conv_lnth sj) qed inductive_cases full_chain_consE: "full_chain R (LCons x xs)" inductive_cases full_chain_nontrivE: "full_chain R (LCons x (LCons y xs))" lemma full_chain_tranclp_imp_exists_full_chain: assumes full: "full_chain R\<^sup>+\<^sup>+ xs" shows "\ys. full_chain R ys \ emb xs ys \ lhd ys = lhd xs \ llast ys = llast xs" proof - obtain ys where ys: "chain R ys" "emb xs ys" "lhd ys = lhd xs" "llast ys = llast xs" using full_chain_imp_chain[OF full] chain_tranclp_imp_exists_chain by blast have "full_chain R ys" using ys(1,4) emb_lfinite[OF ys(2)] full unfolding full_chain_iff_chain by auto then show ?thesis using ys(2-4) by auto qed end diff --git a/thys/Ordered_Resolution_Prover/Lazy_List_Liminf.thy b/thys/Ordered_Resolution_Prover/Lazy_List_Liminf.thy --- a/thys/Ordered_Resolution_Prover/Lazy_List_Liminf.thy +++ b/thys/Ordered_Resolution_Prover/Lazy_List_Liminf.thy @@ -1,389 +1,389 @@ (* Title: Supremum and Liminf of Lazy Lists Author: Jasmin Blanchette , 2014, 2017, 2020 Author: Dmitriy Traytel , 2014 Maintainer: Jasmin Blanchette *) section \Supremum and Liminf of Lazy Lists\ theory Lazy_List_Liminf imports Coinductive.Coinductive_List begin text \ Lazy lists, as defined in the \emph{Archive of Formal Proofs}, provide finite and infinite lists in one type, defined coinductively. The present theory introduces the concept of the union of all elements of a lazy list of sets and the limit of such a lazy list. The definitions are stated more generally in terms of lattices. The basis for this theory is Section 4.1 (Theorem Proving Processes'') of Bachmair and Ganzinger's chapter. \ subsection \Library\ lemma less_llength_ltake: "i < llength (ltake k Xs) \ i < k \ i < llength Xs" by simp subsection \Supremum\ definition Sup_llist :: "'a set llist \ 'a set" where "Sup_llist Xs = (\i \ {i. enat i < llength Xs}. lnth Xs i)" lemma lnth_subset_Sup_llist: "enat i < llength Xs \ lnth Xs i \ Sup_llist Xs" unfolding Sup_llist_def by auto lemma Sup_llist_imp_exists_index: "x \ Sup_llist Xs \ \i. enat i < llength Xs \ x \ lnth Xs i" unfolding Sup_llist_def by auto lemma exists_index_imp_Sup_llist: "enat i < llength Xs \ x \ lnth Xs i \ x \ Sup_llist Xs" unfolding Sup_llist_def by auto lemma Sup_llist_LNil[simp]: "Sup_llist LNil = {}" unfolding Sup_llist_def by auto lemma Sup_llist_LCons[simp]: "Sup_llist (LCons X Xs) = X \ Sup_llist Xs" unfolding Sup_llist_def proof (intro subset_antisym subsetI) fix x assume "x \ (\i \ {i. enat i < llength (LCons X Xs)}. lnth (LCons X Xs) i)" then obtain i where len: "enat i < llength (LCons X Xs)" and nth: "x \ lnth (LCons X Xs) i" by blast from nth have "x \ X \ i > 0 \ x \ lnth Xs (i - 1)" by (metis lnth_LCons' neq0_conv) then have "x \ X \ (\i. enat i < llength Xs \ x \ lnth Xs i)" by (metis len Suc_pred' eSuc_enat iless_Suc_eq less_irrefl llength_LCons not_less order_trans) then show "x \ X \ (\i \ {i. enat i < llength Xs}. lnth Xs i)" by blast qed ((auto)[], metis i0_lb lnth_0 zero_enat_def, metis Suc_ile_eq lnth_Suc_LCons) lemma lhd_subset_Sup_llist: "\ lnull Xs \ lhd Xs \ Sup_llist Xs" by (cases Xs) simp_all subsection \Supremum up-to\ definition Sup_upto_llist :: "'a set llist \ enat \ 'a set" where "Sup_upto_llist Xs j = (\i \ {i. enat i < llength Xs \ enat i \ j}. lnth Xs i)" lemma Sup_upto_llist_eq_Sup_llist_ltake: "Sup_upto_llist Xs j = Sup_llist (ltake (eSuc j) Xs)" unfolding Sup_upto_llist_def Sup_llist_def - by (smt Collect_cong Sup.SUP_cong iless_Suc_eq lnth_ltake less_llength_ltake mem_Collect_eq) + by (smt (verit) Collect_cong Sup.SUP_cong iless_Suc_eq lnth_ltake less_llength_ltake mem_Collect_eq) lemma Sup_upto_llist_enat_0[simp]: "Sup_upto_llist Xs (enat 0) = (if lnull Xs then {} else lhd Xs)" proof (cases "lnull Xs") case True then show ?thesis unfolding Sup_upto_llist_def by auto next case False show ?thesis unfolding Sup_upto_llist_def image_def by (simp add: lhd_conv_lnth enat_0 enat_0_iff) qed lemma Sup_upto_llist_Suc[simp]: "Sup_upto_llist Xs (enat (Suc j)) = Sup_upto_llist Xs (enat j) \ (if enat (Suc j) < llength Xs then lnth Xs (Suc j) else {})" unfolding Sup_upto_llist_def image_def by (auto intro: le_SucI elim: le_SucE) lemma Sup_upto_llist_infinity[simp]: "Sup_upto_llist Xs \ = Sup_llist Xs" unfolding Sup_upto_llist_def Sup_llist_def by simp lemma Sup_upto_llist_0[simp]: "Sup_upto_llist Xs 0 = (if lnull Xs then {} else lhd Xs)" unfolding zero_enat_def by (rule Sup_upto_llist_enat_0) lemma Sup_upto_llist_eSuc[simp]: "Sup_upto_llist Xs (eSuc j) = (case j of enat k \ Sup_upto_llist Xs (enat (Suc k)) | \ \ Sup_llist Xs)" by (auto simp: eSuc_enat split: enat.split) lemma Sup_upto_llist_mono[simp]: "j \ k \ Sup_upto_llist Xs j \ Sup_upto_llist Xs k" unfolding Sup_upto_llist_def by auto lemma Sup_upto_llist_subset_Sup_llist: "Sup_upto_llist Xs j \ Sup_llist Xs" unfolding Sup_llist_def Sup_upto_llist_def by auto lemma elem_Sup_llist_imp_Sup_upto_llist: "x \ Sup_llist Xs \ \j < llength Xs. x \ Sup_upto_llist Xs (enat j)" unfolding Sup_llist_def Sup_upto_llist_def by blast lemma lnth_subset_Sup_upto_llist: "j < llength Xs \ lnth Xs j \ Sup_upto_llist Xs j" unfolding Sup_upto_llist_def by auto lemma finite_Sup_llist_imp_Sup_upto_llist: assumes "finite X" and "X \ Sup_llist Xs" shows "\k. X \ Sup_upto_llist Xs (enat k)" using assms proof induct case (insert x X) then have x: "x \ Sup_llist Xs" and X: "X \ Sup_llist Xs" by simp+ from x obtain k where k: "x \ Sup_upto_llist Xs (enat k)" using elem_Sup_llist_imp_Sup_upto_llist by fast from X obtain k' where k': "X \ Sup_upto_llist Xs (enat k')" using insert.hyps(3) by fast have "insert x X \ Sup_upto_llist Xs (max k k')" using k k' by (metis (mono_tags) Sup_upto_llist_mono enat_ord_simps(1) insert_subset max.cobounded1 max.cobounded2 subset_iff) then show ?case by fast qed simp subsection \Liminf\ definition Liminf_llist :: "'a set llist \ 'a set" where "Liminf_llist Xs = (\i \ {i. enat i < llength Xs}. \j \ {j. i \ j \ enat j < llength Xs}. lnth Xs j)" lemma Liminf_llist_LNil[simp]: "Liminf_llist LNil = {}" unfolding Liminf_llist_def by simp lemma Liminf_llist_LCons: "Liminf_llist (LCons X Xs) = (if lnull Xs then X else Liminf_llist Xs)" (is "?lhs = ?rhs") proof (cases "lnull Xs") case nnull: False show ?thesis proof { fix x assume "\i. enat i \ llength Xs \ (\j. i \ j \ enat j \ llength Xs \ x \ lnth (LCons X Xs) j)" then have "\i. enat (Suc i) \ llength Xs \ (\j. Suc i \ j \ enat j \ llength Xs \ x \ lnth (LCons X Xs) j)" by (cases "llength Xs", metis not_lnull_conv[THEN iffD1, OF nnull] Suc_le_D eSuc_enat eSuc_ile_mono llength_LCons not_less_eq_eq zero_enat_def zero_le, metis Suc_leD enat_ord_code(3)) then have "\i. enat i < llength Xs \ (\j. i \ j \ enat j < llength Xs \ x \ lnth Xs j)" by (metis Suc_ile_eq Suc_n_not_le_n lift_Suc_mono_le lnth_Suc_LCons nat_le_linear) } then show "?lhs \ ?rhs" by (simp add: Liminf_llist_def nnull) (rule subsetI, simp) { fix x assume "\i. enat i < llength Xs \ (\j. i \ j \ enat j < llength Xs \ x \ lnth Xs j)" then obtain i where i: "enat i < llength Xs" and j: "\j. i \ j \ enat j < llength Xs \ x \ lnth Xs j" by blast have "enat (Suc i) \ llength Xs" using i by (simp add: Suc_ile_eq) moreover have "\j. Suc i \ j \ enat j \ llength Xs \ x \ lnth (LCons X Xs) j" using Suc_ile_eq Suc_le_D j by force ultimately have "\i. enat i \ llength Xs \ (\j. i \ j \ enat j \ llength Xs \ x \ lnth (LCons X Xs) j)" by blast } then show "?rhs \ ?lhs" by (simp add: Liminf_llist_def nnull) (rule subsetI, simp) qed qed (simp add: Liminf_llist_def enat_0_iff(1)) lemma lfinite_Liminf_llist: "lfinite Xs \ Liminf_llist Xs = (if lnull Xs then {} else llast Xs)" proof (induction rule: lfinite_induct) case (LCons xs) then obtain y ys where xs: "xs = LCons y ys" by (meson not_lnull_conv) show ?case unfolding xs by (simp add: Liminf_llist_LCons LCons.IH[unfolded xs, simplified] llast_LCons) qed (simp add: Liminf_llist_def) lemma Liminf_llist_ltl: "\ lnull (ltl Xs) \ Liminf_llist Xs = Liminf_llist (ltl Xs)" by (metis Liminf_llist_LCons lhd_LCons_ltl lnull_ltlI) lemma Liminf_llist_subset_Sup_llist: "Liminf_llist Xs \ Sup_llist Xs" unfolding Liminf_llist_def Sup_llist_def by fast lemma image_Liminf_llist_subset: "f  Liminf_llist Ns \ Liminf_llist (lmap (() f) Ns)" unfolding Liminf_llist_def by auto lemma Liminf_llist_imp_exists_index: "x \ Liminf_llist Xs \ \i. enat i < llength Xs \ x \ lnth Xs i" unfolding Liminf_llist_def by auto lemma not_Liminf_llist_imp_exists_index: "\ lnull Xs \ x \ Liminf_llist Xs \ enat i < llength Xs \ (\j. i \ j \ enat j < llength Xs \ x \ lnth Xs j)" unfolding Liminf_llist_def by auto lemma finite_subset_Liminf_llist_imp_exists_index: assumes nnil: "\ lnull Xs" and fin: "finite X" and in_lim: "X \ Liminf_llist Xs" shows "\i. enat i < llength Xs \ X \ (\j \ {j. i \ j \ enat j < llength Xs}. lnth Xs j)" proof - show ?thesis proof (cases "X = {}") case True then show ?thesis using nnil by (auto intro: exI[of _ 0] simp: zero_enat_def[symmetric]) next case nemp: False have in_lim': "\x \ X. \i. enat i < llength Xs \ x \ (\j \ {j. i \ j \ enat j < llength Xs}. lnth Xs j)" using in_lim[unfolded Liminf_llist_def] in_mono by fastforce obtain i_of where i_of_lt: "\x \ X. enat (i_of x) < llength Xs" and in_inter: "\x \ X. x \ (\j \ {j. i_of x \ j \ enat j < llength Xs}. lnth Xs j)" using bchoice[OF in_lim'] by blast define i_max where "i_max = Max (i_of  X)" have "i_max \ i_of  X" by (simp add: fin i_max_def nemp) then obtain x_max where x_max_in: "x_max \ X" and i_max_is: "i_max = i_of x_max" unfolding i_max_def by blast have le_i_max: "\x \ X. i_of x \ i_max" unfolding i_max_def by (simp add: fin) have "enat i_max < llength Xs" using i_of_lt x_max_in i_max_is by auto moreover have "X \ (\j \ {j. i_max \ j \ enat j < llength Xs}. lnth Xs j)" proof fix x assume x_in: "x \ X" then have x_in_inter: "x \ (\j \ {j. i_of x \ j \ enat j < llength Xs}. lnth Xs j)" using in_inter by auto moreover have "{j. i_max \ j \ enat j < llength Xs} \ {j. i_of x \ j \ enat j < llength Xs}" using x_in le_i_max by auto ultimately show "x \ (\j \ {j. i_max \ j \ enat j < llength Xs}. lnth Xs j)" by auto qed ultimately show ?thesis by auto qed qed lemma Liminf_llist_lmap_image: assumes f_inj: "inj_on f (Sup_llist (lmap g xs))" shows "Liminf_llist (lmap (\x. f  g x) xs) = f  Liminf_llist (lmap g xs)" (is "?lhs = ?rhs") proof show "?lhs \ ?rhs" proof fix x assume "x \ Liminf_llist (lmap (\x. f  g x) xs)" then obtain i where i_lt: "enat i < llength xs" and x_in_fgj: "\j. i \ j \ enat j < llength xs \ x \ f  g (lnth xs j)" unfolding Liminf_llist_def by auto have ex_in_gi: "\y. y \ g (lnth xs i) \ x = f y" using f_inj i_lt x_in_fgj unfolding inj_on_def Sup_llist_def by auto have "\y. \j. i \ j \ enat j < llength xs \ y \ g (lnth xs j) \ x = f y" apply (rule exI[of _ "SOME y. y \ g (lnth xs i) \ x = f y"]) using someI_ex[OF ex_in_gi] x_in_fgj f_inj i_lt x_in_fgj unfolding inj_on_def Sup_llist_def by simp (metis (no_types, lifting) imageE) then show "x \ f  Liminf_llist (lmap g xs)" using i_lt unfolding Liminf_llist_def by auto qed next show "?rhs \ ?lhs" using image_Liminf_llist_subset[of f "lmap g xs", unfolded llist.map_comp] by auto qed lemma Liminf_llist_lmap_union: assumes "\x \ lset xs. \Y \ lset xs. g x \ h Y = {}" shows "Liminf_llist (lmap (\x. g x \ h x) xs) = Liminf_llist (lmap g xs) \ Liminf_llist (lmap h xs)" (is "?lhs = ?rhs") proof (intro equalityI subsetI) fix x assume x_in: "x \ ?lhs" then obtain i where i_lt: "enat i < llength xs" and j: "\j. i \ j \ enat j < llength xs \ x \ g (lnth xs j) \ x \ h (lnth xs j)" using x_in[unfolded Liminf_llist_def, simplified] by blast then have "(\i'. enat i' < llength xs \ (\j. i' \ j \ enat j < llength xs \ x \ g (lnth xs j))) \ (\i'. enat i' < llength xs \ (\j. i' \ j \ enat j < llength xs \ x \ h (lnth xs j)))" using assms[unfolded disjoint_iff_not_equal] by (metis in_lset_conv_lnth) then show "x \ ?rhs" unfolding Liminf_llist_def by simp next fix x show "x \ ?rhs \ x \ ?lhs" using assms unfolding Liminf_llist_def by auto qed lemma Liminf_set_filter_commute: "Liminf_llist (lmap (\X. {x \ X. p x}) Xs) = {x \ Liminf_llist Xs. p x}" unfolding Liminf_llist_def by force subsection \Liminf up-to\ definition Liminf_upto_llist :: "'a set llist \ enat \ 'a set" where "Liminf_upto_llist Xs k = (\i \ {i. enat i < llength Xs \ enat i \ k}. \j \ {j. i \ j \ enat j < llength Xs \ enat j \ k}. lnth Xs j)" lemma Liminf_upto_llist_eq_Liminf_llist_ltake: "Liminf_upto_llist Xs j = Liminf_llist (ltake (eSuc j) Xs)" unfolding Liminf_upto_llist_def Liminf_llist_def by (smt Collect_cong Sup.SUP_cong iless_Suc_eq lnth_ltake less_llength_ltake mem_Collect_eq) lemma Liminf_upto_llist_enat[simp]: "Liminf_upto_llist Xs (enat k) = (if enat k < llength Xs then lnth Xs k else if lnull Xs then {} else llast Xs)" proof (cases "enat k < llength Xs") case True then show ?thesis unfolding Liminf_upto_llist_def by force next case k_ge: False show ?thesis proof (cases "lnull Xs") case nil: True then show ?thesis unfolding Liminf_upto_llist_def by simp next case nnil: False then obtain j where j: "eSuc (enat j) = llength Xs" using k_ge by (metis eSuc_enat_iff enat_ile le_less_linear lhd_LCons_ltl llength_LCons) have fin: "lfinite Xs" using k_ge not_lfinite_llength by fastforce have le_k: "enat i < llength Xs \ i \ k \ enat i < llength Xs" for i using k_ge linear order_le_less_subst2 by fastforce have "Liminf_upto_llist Xs (enat k) = llast Xs" using j nnil lfinite_Liminf_llist[OF fin] nnil unfolding Liminf_upto_llist_def Liminf_llist_def using llast_conv_lnth[OF j[symmetric]] by (simp add: le_k) then show ?thesis using k_ge nnil by simp qed qed lemma Liminf_upto_llist_infinity[simp]: "Liminf_upto_llist Xs \ = Liminf_llist Xs" unfolding Liminf_upto_llist_def Liminf_llist_def by simp lemma Liminf_upto_llist_0[simp]: "Liminf_upto_llist Xs 0 = (if lnull Xs then {} else lhd Xs)" unfolding Liminf_upto_llist_def image_def by (simp add: enat_0[symmetric]) (simp add: enat_0 lnth_0_conv_lhd) lemma Liminf_upto_llist_eSuc[simp]: "Liminf_upto_llist Xs (eSuc j) = (case j of enat k \ Liminf_upto_llist Xs (enat (Suc k)) | \ \ Liminf_llist Xs)" by (auto simp: eSuc_enat split: enat.split) lemma elem_Liminf_llist_imp_Liminf_upto_llist: "x \ Liminf_llist Xs \ \i < llength Xs. \j. i \ j \ j < llength Xs \ x \ Liminf_upto_llist Xs (enat j)" unfolding Liminf_llist_def Liminf_upto_llist_def using enat_ord_simps(1) by force end diff --git a/thys/Polynomial_Interpolation/Missing_Polynomial.thy b/thys/Polynomial_Interpolation/Missing_Polynomial.thy --- a/thys/Polynomial_Interpolation/Missing_Polynomial.thy +++ b/thys/Polynomial_Interpolation/Missing_Polynomial.thy @@ -1,1381 +1,1381 @@ (* Author: RenÃ© Thiemann Akihisa Yamada Jose Divason License: BSD *) section \Missing Polynomial\ text \The theory contains some basic results on polynomials which have not been detected in the distribution, especially on linear factors and degrees.\ theory Missing_Polynomial imports "HOL-Computational_Algebra.Polynomial_Factorial" Missing_Unsorted begin subsection \Basic Properties\ lemma degree_0_id: assumes "degree p = 0" shows "[: coeff p 0 :] = p" proof - have "\ x. 0 \ Suc x" by auto thus ?thesis using assms by (metis coeff_pCons_0 degree_pCons_eq_if pCons_cases) qed lemma degree0_coeffs: "degree p = 0 \ \ a. p = [: a :]" by (metis degree_pCons_eq_if old.nat.distinct(2) pCons_cases) lemma degree1_coeffs: "degree p = 1 \ \ a b. p = [: b, a :] \ a \ 0" by (metis One_nat_def degree_pCons_eq_if nat.inject old.nat.distinct(2) pCons_0_0 pCons_cases) lemma degree2_coeffs: "degree p = 2 \ \ a b c. p = [: c, b, a :] \ a \ 0" by (metis Suc_1 Suc_neq_Zero degree1_coeffs degree_pCons_eq_if nat.inject pCons_cases) lemma poly_zero: fixes p :: "'a :: comm_ring_1 poly" assumes x: "poly p x = 0" shows "p = 0 \ degree p = 0" proof assume degp: "degree p = 0" hence "poly p x = coeff p (degree p)" by(subst degree_0_id[OF degp,symmetric], simp) hence "coeff p (degree p) = 0" using x by auto thus "p = 0" by auto qed auto lemma coeff_monom_Suc: "coeff (monom a (Suc d) * p) (Suc i) = coeff (monom a d * p) i" by (simp add: monom_Suc) lemma coeff_sum_monom: assumes n: "n \ d" shows "coeff (\i\d. monom (f i) i) n = f n" (is "?l = _") proof - have "?l = (\i\d. coeff (monom (f i) i) n)" (is "_ = sum ?cmf _") using coeff_sum. also have "{..d} = insert n ({..d}-{n})" using n by auto hence "sum ?cmf {..d} = sum ?cmf ..." by auto also have "... = sum ?cmf ({..d}-{n}) + ?cmf n" by (subst sum.insert,auto) also have "sum ?cmf ({..d}-{n}) = 0" by (subst sum.neutral, auto) finally show ?thesis by simp qed lemma linear_poly_root: "(a :: 'a :: comm_ring_1) \ set as \ poly (\ a \ as. [: - a, 1:]) a = 0" proof (induct as) case (Cons b as) show ?case proof (cases "a = b") case False with Cons have "a \ set as" by auto from Cons(1)[OF this] show ?thesis by simp qed simp qed simp lemma degree_lcoeff_sum: assumes deg: "degree (f q) = n" and fin: "finite S" and q: "q \ S" and degle: "\ p . p \ S - {q} \ degree (f p) < n" and cong: "coeff (f q) n = c" shows "degree (sum f S) = n \ coeff (sum f S) n = c" proof (cases "S = {q}") case True thus ?thesis using deg cong by simp next case False with q obtain p where "p \ S - {q}" by auto from degle[OF this] have n: "n > 0" by auto have "degree (sum f S) = degree (f q + sum f (S - {q}))" unfolding sum.remove[OF fin q] .. also have "\ = degree (f q)" proof (rule degree_add_eq_left) have "degree (sum f (S - {q})) \ n - 1" proof (rule degree_sum_le) fix p show "p \ S - {q} \ degree (f p) \ n - 1" using degle[of p] by auto qed (insert fin, auto) also have "\ < n" using n by simp finally show "degree (sum f (S - {q})) < degree (f q)" unfolding deg . qed finally show ?thesis unfolding deg[symmetric] cong[symmetric] proof (rule conjI) have id: "(\x\S - {q}. coeff (f x) (degree (f q))) = 0" by (rule sum.neutral, rule ballI, rule coeff_eq_0[OF degle[folded deg]]) show "coeff (sum f S) (degree (f q)) = coeff (f q) (degree (f q))" unfolding coeff_sum by (subst sum.remove[OF _ q], unfold id, insert fin, auto) qed qed lemma degree_sum_list_le: "(\ p . p \ set ps \ degree p \ n) \ degree (sum_list ps) \ n" proof (induct ps) case (Cons p ps) hence "degree (sum_list ps) \ n" "degree p \ n" by auto thus ?case unfolding sum_list.Cons by (metis degree_add_le) qed simp lemma degree_prod_list_le: "degree (prod_list ps) \ sum_list (map degree ps)" proof (induct ps) case (Cons p ps) show ?case unfolding prod_list.Cons by (rule order.trans[OF degree_mult_le], insert Cons, auto) qed simp lemma smult_sum: "smult (\i \ S. f i) p = (\i \ S. smult (f i) p)" by (induct S rule: infinite_finite_induct, auto simp: smult_add_left) lemma range_coeff: "range (coeff p) = insert 0 (set (coeffs p))" by (metis nth_default_coeffs_eq range_nth_default) lemma smult_power: "(smult a p) ^ n = smult (a ^ n) (p ^ n)" by (induct n, auto simp: field_simps) lemma poly_sum_list: "poly (sum_list ps) x = sum_list (map (\ p. poly p x) ps)" by (induct ps, auto) lemma poly_prod_list: "poly (prod_list ps) x = prod_list (map (\ p. poly p x) ps)" by (induct ps, auto) lemma sum_list_neutral: "(\ x. x \ set xs \ x = 0) \ sum_list xs = 0" by (induct xs, auto) lemma prod_list_neutral: "(\ x. x \ set xs \ x = 1) \ prod_list xs = 1" by (induct xs, auto) lemma (in comm_monoid_mult) prod_list_map_remove1: "x \ set xs \ prod_list (map f xs) = f x * prod_list (map f (remove1 x xs))" by (induct xs) (auto simp add: ac_simps) lemma poly_as_sum: fixes p :: "'a::comm_semiring_1 poly" shows "poly p x = (\i\degree p. x ^ i * coeff p i)" unfolding poly_altdef by (simp add: ac_simps) lemma poly_prod_0: "finite ps \ poly (prod f ps) x = (0 :: 'a :: field) \ (\ p \ ps. poly (f p) x = 0)" by (induct ps rule: finite_induct, auto) lemma coeff_monom_mult: shows "coeff (monom a d * p) i = (if d \ i then a * coeff p (i-d) else 0)" (is "?l = ?r") proof (cases "d \ i") case False thus ?thesis unfolding coeff_mult by simp next case True let ?f = "\j. coeff (monom a d) j * coeff p (i - j)" have "\j. j \ {0..i} - {d} \ ?f j = 0" by auto hence "0 = (\j \ {0..i} - {d}. ?f j)" by auto also have "... + ?f d = (\j \ insert d ({0..i} - {d}). ?f j)" by(subst sum.insert, auto) also have "... = (\j \ {0..i}. ?f j)" by (subst insert_Diff, insert True, auto) also have "... = (\j\i. ?f j)" by (rule sum.cong, auto) also have "... = ?l" unfolding coeff_mult .. finally show ?thesis using True by auto qed lemma poly_eqI2: assumes "degree p = degree q" and "\i. i \ degree p \ coeff p i = coeff q i" shows "p = q" apply(rule poly_eqI) by (metis assms le_degree) text \A nice extension rule for polynomials.\ lemma poly_ext[intro]: fixes p q :: "'a :: {ring_char_0, idom} poly" assumes "\x. poly p x = poly q x" shows "p = q" unfolding poly_eq_poly_eq_iff[symmetric] using assms by (rule ext) text \Copied from non-negative variants.\ lemma coeff_linear_power_neg[simp]: fixes a :: "'a::comm_ring_1" shows "coeff ([:a, -1:] ^ n) n = (-1)^n" apply (induct n, simp_all) apply (subst coeff_eq_0) apply (auto intro: le_less_trans degree_power_le) done lemma degree_linear_power_neg[simp]: fixes a :: "'a::{idom,comm_ring_1}" shows "degree ([:a, -1:] ^ n) = n" apply (rule order_antisym) apply (rule ord_le_eq_trans [OF degree_power_le], simp) apply (rule le_degree) unfolding coeff_linear_power_neg apply (auto) done subsection \Polynomial Composition\ lemmas [simp] = pcompose_pCons lemma pcompose_eq_0: fixes q :: "'a :: idom poly" assumes q: "degree q \ 0" shows "p \\<^sub>p q = 0 \ p = 0" proof (induct p) case 0 show ?case by auto next case (pCons a p) have id: "(pCons a p) \\<^sub>p q = [:a:] + q * (p \\<^sub>p q)" by simp show ?case proof (cases "p = 0") case True show ?thesis unfolding id unfolding True by simp next case False with pCons(2) have "p \\<^sub>p q \ 0" by auto from degree_mult_eq[OF _ this, of q] q have "degree (q * (p \\<^sub>p q)) \ 0" by force hence deg: "degree ([:a:] + q * (p \\<^sub>p q)) \ 0" by (subst degree_add_eq_right, auto) show ?thesis unfolding id using False deg by auto qed qed declare degree_pcompose[simp] subsection \Monic Polynomials\ abbreviation monic where "monic p \ coeff p (degree p) = 1" lemma unit_factor_field [simp]: "unit_factor (x :: 'a :: {field,normalization_semidom}) = x" by (cases "is_unit x") (auto simp: is_unit_unit_factor dvd_field_iff) lemma poly_gcd_monic: fixes p :: "'a :: {field,factorial_ring_gcd,semiring_gcd_mult_normalize} poly" assumes "p \ 0 \ q \ 0" shows "monic (gcd p q)" proof - from assms have "1 = unit_factor (gcd p q)" by (auto simp: unit_factor_gcd) also have "\ = [:lead_coeff (gcd p q):]" unfolding unit_factor_poly_def by (simp add: monom_0) finally show ?thesis by (metis coeff_pCons_0 degree_1 lead_coeff_1) qed lemma normalize_monic: "monic p \ normalize p = p" by (simp add: normalize_poly_eq_map_poly is_unit_unit_factor) lemma lcoeff_monic_mult: assumes monic: "monic (p :: 'a :: comm_semiring_1 poly)" shows "coeff (p * q) (degree p + degree q) = coeff q (degree q)" proof - let ?pqi = "\ i. coeff p i * coeff q (degree p + degree q - i)" have "coeff (p * q) (degree p + degree q) = (\i\degree p + degree q. ?pqi i)" unfolding coeff_mult by simp also have "\ = ?pqi (degree p) + (sum ?pqi ({.. degree p + degree q} - {degree p}))" by (subst sum.remove[of _ "degree p"], auto) also have "?pqi (degree p) = coeff q (degree q)" unfolding monic by simp also have "(sum ?pqi ({.. degree p + degree q} - {degree p})) = 0" proof (rule sum.neutral, intro ballI) fix d assume d: "d \ {.. degree p + degree q} - {degree p}" show "?pqi d = 0" proof (cases "d < degree p") case True hence "degree p + degree q - d > degree q" by auto hence "coeff q (degree p + degree q - d) = 0" by (rule coeff_eq_0) thus ?thesis by simp next case False with d have "d > degree p" by auto hence "coeff p d = 0" by (rule coeff_eq_0) thus ?thesis by simp qed qed finally show ?thesis by simp qed lemma degree_monic_mult: assumes monic: "monic (p :: 'a :: comm_semiring_1 poly)" and q: "q \ 0" shows "degree (p * q) = degree p + degree q" proof - have "degree p + degree q \ degree (p * q)" by (rule degree_mult_le) also have "degree p + degree q \ degree (p * q)" proof - from q have cq: "coeff q (degree q) \ 0" by auto hence "coeff (p * q) (degree p + degree q) \ 0" unfolding lcoeff_monic_mult[OF monic] . thus "degree (p * q) \ degree p + degree q" by (rule le_degree) qed finally show ?thesis . qed lemma degree_prod_sum_monic: assumes S: "finite S" and nzd: "0 \ (degree o f)  S" and monic: "(\ a . a \ S \ monic (f a))" shows "degree (prod f S) = (sum (degree o f) S) \ coeff (prod f S) (sum (degree o f) S) = 1" proof - from S nzd monic have "degree (prod f S) = sum (degree \ f) S \ (S \ {} \ degree (prod f S) \ 0 \ prod f S \ 0) \ coeff (prod f S) (sum (degree o f) S) = 1" proof (induct S rule: finite_induct) case (insert a S) have IH1: "degree (prod f S) = sum (degree o f) S" using insert by auto have IH2: "coeff (prod f S) (degree (prod f S)) = 1" using insert by auto have id: "degree (prod f (insert a S)) = sum (degree \ f) (insert a S) \ coeff (prod f (insert a S)) (sum (degree o f) (insert a S)) = 1" proof (cases "S = {}") case False with insert have nz: "prod f S \ 0" by auto from insert have monic: "coeff (f a) (degree (f a)) = 1" by auto have id: "(degree \ f) a = degree (f a)" by simp show ?thesis unfolding prod.insert[OF insert(1-2)] sum.insert[OF insert(1-2)] id unfolding degree_monic_mult[OF monic nz] unfolding IH1[symmetric] unfolding lcoeff_monic_mult[OF monic] IH2 by simp qed (insert insert, auto) show ?case using id unfolding sum.insert[OF insert(1-2)] using insert by auto qed simp thus ?thesis by auto qed lemma degree_prod_monic: assumes "\ i. i < n \ degree (f i :: 'a :: comm_semiring_1 poly) = 1" and "\ i. i < n \ coeff (f i) 1 = 1" shows "degree (prod f {0 ..< n}) = n \ coeff (prod f {0 ..< n}) n = 1" proof - from degree_prod_sum_monic[of "{0 ..< n}" f] show ?thesis using assms by force qed lemma degree_prod_sum_lt_n: assumes "\ i. i < n \ degree (f i :: 'a :: comm_semiring_1 poly) \ 1" and i: "i < n" and fi: "degree (f i) = 0" shows "degree (prod f {0 ..< n}) < n" proof - have "degree (prod f {0 ..< n}) \ sum (degree o f) {0 ..< n}" by (rule degree_prod_sum_le, auto) also have "sum (degree o f) {0 ..< n} = (degree o f) i + sum (degree o f) ({0 ..< n} - {i})" by (rule sum.remove, insert i, auto) also have "(degree o f) i = 0" using fi by simp also have "sum (degree o f) ({0 ..< n} - {i}) \ sum (\ _. 1) ({0 ..< n} - {i})" by (rule sum_mono, insert assms, auto) also have "\ = n - 1" using i by simp also have "\ < n" using i by simp finally show ?thesis by simp qed lemma degree_linear_factors: "degree (\ a \ as. [: f a, 1:]) = length as" proof (induct as) case (Cons b as) note IH = this have id: "(\a\b # as. [:f a, 1:]) = [:f b,1 :] * (\a\as. [:f a, 1:])" by simp show ?case unfolding id by (subst degree_monic_mult, insert IH, auto) qed simp lemma monic_mult: fixes p q :: "'a :: idom poly" assumes "monic p" "monic q" shows "monic (p * q)" proof - from assms have nz: "p \ 0" "q \ 0" by auto show ?thesis unfolding degree_mult_eq[OF nz] coeff_mult_degree_sum using assms by simp qed lemma monic_factor: fixes p q :: "'a :: idom poly" assumes "monic (p * q)" "monic p" shows "monic q" proof - from assms have nz: "p \ 0" "q \ 0" by auto from assms[unfolded degree_mult_eq[OF nz] coeff_mult_degree_sum \monic p\] show ?thesis by simp qed lemma monic_prod: fixes f :: "'a \ 'b :: idom poly" assumes "\ a. a \ as \ monic (f a)" shows "monic (prod f as)" using assms proof (induct as rule: infinite_finite_induct) case (insert a as) hence id: "prod f (insert a as) = f a * prod f as" and *: "monic (f a)" "monic (prod f as)" by auto show ?case unfolding id by (rule monic_mult[OF *]) qed auto lemma monic_prod_list: fixes as :: "'a :: idom poly list" assumes "\ a. a \ set as \ monic a" shows "monic (prod_list as)" using assms by (induct as, auto intro: monic_mult) lemma monic_power: assumes "monic (p :: 'a :: idom poly)" shows "monic (p ^ n)" by (induct n, insert assms, auto intro: monic_mult) lemma monic_prod_list_pow: "monic ($$x::'a::idom, i)\xis. [:- x, 1:] ^ Suc i)" proof (rule monic_prod_list, goal_cases) case (1 a) then obtain x i where a: "a = [:-x, 1:]^Suc i" by force show "monic a" unfolding a by (rule monic_power, auto) qed lemma monic_degree_0: "monic p \ (degree p = 0) = (p = 1)" using le_degree poly_eq_iff by force subsection \Roots\ text \The following proof structure is completely similar to the one of @{thm poly_roots_finite}.\ lemma poly_roots_degree: fixes p :: "'a::idom poly" shows "p \ 0 \ card {x. poly p x = 0} \ degree p" proof (induct n \ "degree p" arbitrary: p) case (0 p) then obtain a where "a \ 0" and "p = [:a:]" by (cases p, simp split: if_splits) then show ?case by simp next case (Suc n p) show ?case proof (cases "\x. poly p x = 0") case True then obtain a where a: "poly p a = 0" .. then have "[:-a, 1:] dvd p" by (simp only: poly_eq_0_iff_dvd) then obtain k where k: "p = [:-a, 1:] * k" .. with \p \ 0\ have "k \ 0" by auto with k have "degree p = Suc (degree k)" by (simp add: degree_mult_eq del: mult_pCons_left) with \Suc n = degree p\ have "n = degree k" by simp from Suc.hyps(1)[OF this \k \ 0\] have le: "card {x. poly k x = 0} \ degree k" . have "card {x. poly p x = 0} = card {x. poly ([:-a, 1:] * k) x = 0}" unfolding k .. also have "{x. poly ([:-a, 1:] * k) x = 0} = insert a {x. poly k x = 0}" by auto also have "card \ \ Suc (card {x. poly k x = 0})" unfolding card_insert_if[OF poly_roots_finite[OF \k \ 0\]] by simp also have "\ \ Suc (degree k)" using le by auto finally show ?thesis using \degree p = Suc (degree k)\ by simp qed simp qed lemma poly_root_factor: "(poly ([: r, 1:] * q) (k :: 'a :: idom) = 0) = (k = -r \ poly q k = 0)" (is ?one) "(poly (q * [: r, 1:]) k = 0) = (k = -r \ poly q k = 0)" (is ?two) "(poly [: r, 1 :] k = 0) = (k = -r)" (is ?three) proof - have [simp]: "r + k = 0 \ k = - r" by (simp add: minus_unique) show ?one unfolding poly_mult by auto show ?two unfolding poly_mult by auto show ?three by auto qed lemma poly_root_constant: "c \ 0 \ (poly (p * [:c:]) (k :: 'a :: idom) = 0) = (poly p k = 0)" unfolding poly_mult by auto lemma poly_linear_exp_linear_factors_rev: "([:b,1:])^(length (filter ((=) b) as)) dvd (\ (a :: 'a :: comm_ring_1) \ as. [: a, 1:])" proof (induct as) case (Cons a as) let ?ls = "length (filter ((=) b) (a # as))" let ?l = "length (filter ((=) b) as)" have prod: "(\ a \ Cons a as. [: a, 1:]) = [: a, 1 :] * (\ a \ as. [: a, 1:])" by simp show ?case proof (cases "a = b") case False hence len: "?ls = ?l" by simp show ?thesis unfolding prod len using Cons by (rule dvd_mult) next case True hence len: "[: b, 1 :] ^ ?ls = [: a, 1 :] * [: b, 1 :] ^ ?l" by simp show ?thesis unfolding prod len using Cons using dvd_refl mult_dvd_mono by blast qed qed simp lemma order_max: assumes dvd: "[: -a, 1 :] ^ k dvd p" and p: "p \ 0" shows "k \ order a p" proof (rule ccontr) assume "\ ?thesis" hence "\ j. k = Suc (order a p + j)" by arith then obtain j where k: "k = Suc (order a p + j)" by auto have "[: -a, 1 :] ^ Suc (order a p) dvd p" by (rule power_le_dvd[OF dvd[unfolded k]], simp) with order_2[OF p, of a] show False by blast qed subsection \Divisibility\ context assumes "SORT_CONSTRAINT('a :: idom)" begin lemma poly_linear_linear_factor: assumes dvd: "[:b,1:] dvd (\ (a :: 'a) \ as. [: a, 1:])" shows "b \ set as" proof - let ?p = "\ as. (\ a \ as. [: a, 1:])" let ?b = "[:b,1:]" from assms[unfolded dvd_def] obtain p where id: "?p as = ?b * p" .. from arg_cong[OF id, of "\ p. poly p (-b)"] have "poly (?p as) (-b) = 0" by simp thus ?thesis proof (induct as) case (Cons a as) have "?p (a # as) = [:a,1:] * ?p as" by simp from Cons(2)[unfolded this] have "poly (?p as) (-b) = 0 \ (a - b) = 0" by simp with Cons(1) show ?case by auto qed simp qed lemma poly_linear_exp_linear_factors: assumes dvd: "([:b,1:])^n dvd (\ (a :: 'a) \ as. [: a, 1:])" shows "length (filter ((=) b) as) \ n" proof - let ?p = "\ as. (\ a \ as. [: a, 1:])" let ?b = "[:b,1:]" from dvd show ?thesis proof (induct n arbitrary: as) case (Suc n as) have bs: "?b ^ Suc n = ?b * ?b ^ n" by simp from poly_linear_linear_factor[OF dvd_mult_left[OF Suc(2)[unfolded bs]], unfolded in_set_conv_decomp] obtain as1 as2 where as: "as = as1 @ b # as2" by auto have "?p as = [:b,1:] * ?p (as1 @ as2)" unfolding as proof (induct as1) case (Cons a as1) have "?p (a # as1 @ b # as2) = [:a,1:] * ?p (as1 @ b # as2)" by simp also have "?p (as1 @ b # as2) = [:b,1:] * ?p (as1 @ as2)" unfolding Cons by simp also have "[:a,1:] * \ = [:b,1:] * ([:a,1:] * ?p (as1 @ as2))" by (metis (no_types, lifting) mult.left_commute) finally show ?case by simp qed simp from Suc(2)[unfolded bs this dvd_mult_cancel_left] have "?b ^ n dvd ?p (as1 @ as2)" by simp from Suc(1)[OF this] show ?case unfolding as by simp qed simp qed end lemma const_poly_dvd: "([:a:] dvd [:b:]) = (a dvd b)" proof assume "a dvd b" then obtain c where "b = a * c" unfolding dvd_def by auto hence "[:b:] = [:a:] * [: c:]" by (auto simp: ac_simps) thus "[:a:] dvd [:b:]" unfolding dvd_def by blast next assume "[:a:] dvd [:b:]" then obtain pc where "[:b:] = [:a:] * pc" unfolding dvd_def by blast from arg_cong[OF this, of "\ p. coeff p 0", unfolded coeff_mult] have "b = a * coeff pc 0" by auto thus "a dvd b" unfolding dvd_def by blast qed lemma const_poly_dvd_1 [simp]: "[:a:] dvd 1 \ a dvd 1" by (metis const_poly_dvd one_poly_eq_simps(2)) lemma poly_dvd_1: fixes p :: "'a :: {comm_semiring_1,semiring_no_zero_divisors} poly" shows "p dvd 1 \ degree p = 0 \ coeff p 0 dvd 1" proof (cases "degree p = 0") case False with divides_degree[of p 1] show ?thesis by auto next case True from degree0_coeffs[OF this] obtain a where p: "p = [:a:]" by auto show ?thesis unfolding p by auto qed text \Degree based version of irreducibility.\ definition irreducible\<^sub>d :: "'a :: comm_semiring_1 poly \ bool" where "irreducible\<^sub>d p = (degree p > 0 \ (\ q r. degree q < degree p \ degree r < degree p \ p \ q * r))" lemma irreducible\<^sub>dI [intro]: assumes 1: "degree p > 0" and 2: "\q r. degree q > 0 \ degree q < degree p \ degree r > 0 \ degree r < degree p \ p = q * r \ False" shows "irreducible\<^sub>d p" proof (unfold irreducible\<^sub>d_def, intro conjI allI impI notI 1) fix q r assume "degree q < degree p" and "degree r < degree p" and "p = q * r" with degree_mult_le[of q r] show False by (intro 2, auto) qed lemma irreducible\<^sub>dI2: fixes p :: "'a::{comm_semiring_1,semiring_no_zero_divisors} poly" assumes deg: "degree p > 0" and ndvd: "\ q. degree q > 0 \ degree q \ degree p div 2 \ \ q dvd p" shows "irreducible\<^sub>d p" proof (rule ccontr) assume "\ ?thesis" from this[unfolded irreducible\<^sub>d_def] deg obtain q r where dq: "degree q < degree p" and dr: "degree r < degree p" and p: "p = q * r" by auto from deg have p0: "p \ 0" by auto with p have "q \ 0" "r \ 0" by auto from degree_mult_eq[OF this] p have dp: "degree p = degree q + degree r" by simp show False proof (cases "degree q \ degree p div 2") case True from ndvd[OF _ True] dq dr dp p show False by auto next case False with dp have dr: "degree r \ degree p div 2" by auto from p have dvd: "r dvd p" by auto from ndvd[OF _ dr] dvd dp dq show False by auto qed qed lemma reducible\<^sub>dI: assumes "degree p > 0 \ \q r. degree q < degree p \ degree r < degree p \ p = q * r" shows "\ irreducible\<^sub>d p" using assms by (auto simp: irreducible\<^sub>d_def) lemma irreducible\<^sub>dE [elim]: assumes "irreducible\<^sub>d p" and "degree p > 0 \ (\q r. degree q < degree p \ degree r < degree p \ p \ q * r) \ thesis" shows thesis using assms by (auto simp: irreducible\<^sub>d_def) lemma reducible\<^sub>dE [elim]: assumes red: "\ irreducible\<^sub>d p" and 1: "degree p = 0 \ thesis" and 2: "\q r. degree q > 0 \ degree q < degree p \ degree r > 0 \ degree r < degree p \ p = q * r \ thesis" shows thesis using red[unfolded irreducible\<^sub>d_def de_Morgan_conj not_not not_all not_imp] proof (elim disjE exE conjE) show "\degree p > 0 \ thesis" using 1 by auto next fix q r assume "degree q < degree p" and "degree r < degree p" and "p = q * r" with degree_mult_le[of q r] show thesis by (intro 2, auto) qed lemma irreducible\<^sub>dD: assumes "irreducible\<^sub>d p" shows "degree p > 0" "\q r. degree q < degree p \ degree r < degree p \ p \ q * r" using assms unfolding irreducible\<^sub>d_def by auto theorem irreducible\<^sub>d_factorization_exists: assumes "degree p > 0" shows "\fs. fs \ [] \ (\f \ set fs. irreducible\<^sub>d f \ degree f \ degree p) \ p = prod_list fs" and "\irreducible\<^sub>d p \ \fs. length fs > 1 \ (\f \ set fs. irreducible\<^sub>d f \ degree f < degree p) \ p = prod_list fs" proof (atomize(full), insert assms, induct "degree p" arbitrary:p rule: less_induct) case less then have deg_f: "degree p > 0" by auto show ?case proof (cases "irreducible\<^sub>d p") case True then have "set [p] \ Collect irreducible\<^sub>d" "p = prod_list [p]" by auto with True show ?thesis by (auto intro: exI[of _ "[p]"]) next case False with deg_f obtain g h where deg_g: "degree g < degree p" "degree g > 0" and deg_h: "degree h < degree p" "degree h > 0" and f_gh: "p = g * h" by auto from less.hyps[OF deg_g] less.hyps[OF deg_h] obtain gs hs where emp: "length gs > 0" "length hs > 0" and "\f \ set gs. irreducible\<^sub>d f \ degree f \ degree g" "g = prod_list gs" and "\f \ set hs. irreducible\<^sub>d f \ degree f \ degree h" "h = prod_list hs" by auto with f_gh deg_g deg_h have len: "length (gs@hs) > 1" and mem: "\f \ set (gs@hs). irreducible\<^sub>d f \ degree f < degree p" and p: "p = prod_list (gs@hs)" by (auto simp del: length_greater_0_conv) with False show ?thesis by (auto intro!: exI[of _ "gs@hs"] simp: less_imp_le) qed qed lemma irreducible\<^sub>d_factor: fixes p :: "'a::{comm_semiring_1,semiring_no_zero_divisors} poly" assumes "degree p > 0" shows "\ q r. irreducible\<^sub>d q \ p = q * r \ degree r < degree p" using assms proof (induct "degree p" arbitrary: p rule: less_induct) case (less p) show ?case proof (cases "irreducible\<^sub>d p") case False with less(2) obtain q r where q: "degree q < degree p" "degree q > 0" and r: "degree r < degree p" "degree r > 0" and p: "p = q * r" by auto from less(1)[OF q] obtain s t where IH: "irreducible\<^sub>d s" "q = s * t" by auto from p have p: "p = s * (t * r)" unfolding IH by (simp add: ac_simps) from less(2) have "p \ 0" by auto hence "degree p = degree s + (degree (t * r))" unfolding p by (subst degree_mult_eq, insert p, auto) with irreducible\<^sub>dD[OF IH(1)] have "degree p > degree (t * r)" by auto with p IH show ?thesis by auto next case True show ?thesis by (rule exI[of _ p], rule exI[of _ 1], insert True less(2), auto) qed qed context mult_zero begin (* least class with times and zero *) definition zero_divisor where "zero_divisor a \ \b. b \ 0 \ a * b = 0" lemma zero_divisorI[intro]: assumes "b \ 0" and "a * b = 0" shows "zero_divisor a" using assms by (auto simp: zero_divisor_def) lemma zero_divisorE[elim]: assumes "zero_divisor a" and "\b. b \ 0 \ a * b = 0 \ thesis" shows thesis using assms by (auto simp: zero_divisor_def) end lemma zero_divisor_0[simp]: "zero_divisor (0::'a::{mult_zero,zero_neq_one})" (* No need for one! *) by (auto intro!: zero_divisorI[of 1]) lemma not_zero_divisor_1: "\ zero_divisor (1 :: 'a :: {monoid_mult,mult_zero})" (* No need for associativity! *) by auto lemma zero_divisor_iff_eq_0[simp]: fixes a :: "'a :: {semiring_no_zero_divisors, zero_neq_one}" shows "zero_divisor a \ a = 0" by auto lemma mult_eq_0_not_zero_divisor_left[simp]: fixes a b :: "'a :: mult_zero" assumes "\ zero_divisor a" shows "a * b = 0 \ b = 0" using assms unfolding zero_divisor_def by force lemma mult_eq_0_not_zero_divisor_right[simp]: fixes a b :: "'a :: {ab_semigroup_mult,mult_zero}" (* No need for associativity! *) assumes "\ zero_divisor b" shows "a * b = 0 \ a = 0" using assms unfolding zero_divisor_def by (force simp: ac_simps) lemma degree_smult_not_zero_divisor_left[simp]: assumes "\ zero_divisor c" shows "degree (smult c p) = degree p" proof(cases "p = 0") case False then have "coeff (smult c p) (degree p) \ 0" using assms by auto from le_degree[OF this] degree_smult_le[of c p] show ?thesis by auto qed auto lemma degree_smult_not_zero_divisor_right[simp]: assumes "\ zero_divisor (lead_coeff p)" shows "degree (smult c p) = (if c = 0 then 0 else degree p)" proof(cases "c = 0") case False then have "coeff (smult c p) (degree p) \ 0" using assms by auto from le_degree[OF this] degree_smult_le[of c p] show ?thesis by auto qed auto lemma irreducible\<^sub>d_smult_not_zero_divisor_left: assumes c0: "\ zero_divisor c" assumes L: "irreducible\<^sub>d (smult c p)" shows "irreducible\<^sub>d p" proof (intro irreducible\<^sub>dI) from L have "degree (smult c p) > 0" by auto also note degree_smult_le finally show "degree p > 0" by auto fix q r assume deg_q: "degree q < degree p" and deg_r: "degree r < degree p" and p_qr: "p = q * r" then have 1: "smult c p = smult c q * r" by auto note degree_smult_le[of c q] also note deg_q finally have 2: "degree (smult c q) < degree (smult c p)" using c0 by auto from deg_r have 3: "degree r < \" using c0 by auto from irreducible\<^sub>dD(2)[OF L 2 3] 1 show False by auto qed lemmas irreducible\<^sub>d_smultI = irreducible\<^sub>d_smult_not_zero_divisor_left [where 'a = "'a :: {comm_semiring_1,semiring_no_zero_divisors}", simplified] lemma irreducible\<^sub>d_smult_not_zero_divisor_right: assumes p0: "\ zero_divisor (lead_coeff p)" and L: "irreducible\<^sub>d (smult c p)" shows "irreducible\<^sub>d p" proof- from L have "c \ 0" by auto with p0 have [simp]: "degree (smult c p) = degree p" by simp show "irreducible\<^sub>d p" proof (intro iffI irreducible\<^sub>dI conjI) from L show "degree p > 0" by auto fix q r assume deg_q: "degree q < degree p" and deg_r: "degree r < degree p" and p_qr: "p = q * r" then have 1: "smult c p = smult c q * r" by auto note degree_smult_le[of c q] also note deg_q finally have 2: "degree (smult c q) < degree (smult c p)" by simp from deg_r have 3: "degree r < \" by simp from irreducible\<^sub>dD(2)[OF L 2 3] 1 show False by auto qed qed lemma zero_divisor_mult_left: fixes a b :: "'a :: {ab_semigroup_mult, mult_zero}" assumes "zero_divisor a" shows "zero_divisor (a * b)" proof- from assms obtain c where c0: "c \ 0" and [simp]: "a * c = 0" by auto have "a * b * c = a * c * b" by (simp only: ac_simps) with c0 show ?thesis by auto qed lemma zero_divisor_mult_right: fixes a b :: "'a :: {semigroup_mult, mult_zero}" assumes "zero_divisor b" shows "zero_divisor (a * b)" proof- from assms obtain c where c0: "c \ 0" and [simp]: "b * c = 0" by auto have "a * b * c = a * (b * c)" by (simp only: ac_simps) with c0 show ?thesis by auto qed lemma not_zero_divisor_mult: fixes a b :: "'a :: {ab_semigroup_mult, mult_zero}" assumes "\ zero_divisor (a * b)" shows "\ zero_divisor a" and "\ zero_divisor b" using assms by (auto dest: zero_divisor_mult_right zero_divisor_mult_left) lemma zero_divisor_smult_left: assumes "zero_divisor a" shows "zero_divisor (smult a f)" proof- from assms obtain b where b0: "b \ 0" and "a * b = 0" by auto then have "smult a f * [:b:] = 0" by (simp add: ac_simps) with b0 show ?thesis by (auto intro!: zero_divisorI[of "[:b:]"]) qed lemma unit_not_zero_divisor: fixes a :: "'a :: {comm_monoid_mult, mult_zero}" assumes "a dvd 1" shows "\zero_divisor a" proof from assms obtain b where ab: "1 = a * b" by (elim dvdE) assume "zero_divisor a" then have "zero_divisor (1::'a)" by (unfold ab, intro zero_divisor_mult_left) then show False by auto qed lemma linear_irreducible\<^sub>d: assumes "degree p = 1" shows "irreducible\<^sub>d p" by (rule irreducible\<^sub>dI, insert assms, auto) lemma irreducible\<^sub>d_dvd_smult: fixes p :: "'a::{comm_semiring_1,semiring_no_zero_divisors} poly" assumes "degree p > 0" "irreducible\<^sub>d q" "p dvd q" shows "\ c. c \ 0 \ q = smult c p" proof - from assms obtain r where q: "q = p * r" by (elim dvdE, auto) from degree_mult_eq[of p r] assms(1) q have "\ degree p < degree q" and nz: "p \ 0" "q \ 0" apply (metis assms(2) degree_mult_eq_0 gr_implies_not_zero irreducible\<^sub>dD(2) less_add_same_cancel2) using assms by auto hence deg: "degree p \ degree q" by auto from \p dvd q\ obtain k where q: "q = k * p" unfolding dvd_def by (auto simp: ac_simps) with nz have "k \ 0" by auto from deg[unfolded q degree_mult_eq[OF \k \ 0\ \p \ 0\ ]] have "degree k = 0" unfolding q by auto then obtain c where k: "k = [: c :]" by (metis degree_0_id) with \k \ 0\ have "c \ 0" by auto have "q = smult c p" unfolding q k by simp with \c \ 0\ show ?thesis by auto qed subsection \Map over Polynomial Coefficients\ lemma map_poly_simps: shows "map_poly f (pCons c p) = (if c = 0 \ p = 0 then 0 else pCons (f c) (map_poly f p))" proof (cases "c = 0") case True note c0 = this show ?thesis proof (cases "p = 0") case True thus ?thesis using c0 unfolding map_poly_def by simp next case False thus ?thesis unfolding map_poly_def by auto qed next case False thus ?thesis unfolding map_poly_def by auto qed lemma map_poly_pCons[simp]: assumes "c \ 0 \ p \ 0" shows "map_poly f (pCons c p) = pCons (f c) (map_poly f p)" unfolding map_poly_simps using assms by auto lemma map_poly_map_poly: assumes f0: "f 0 = 0" shows "map_poly f (map_poly g p) = map_poly (f \ g) p" proof (induct p) case (pCons a p) show ?case proof(cases "g a \ 0 \ map_poly g p \ 0") case True show ?thesis unfolding map_poly_pCons[OF pCons(1)] unfolding map_poly_pCons[OF True] unfolding pCons(2) by simp next case False then show ?thesis unfolding map_poly_pCons[OF pCons(1)] unfolding pCons(2)[symmetric] by (simp add: f0) qed qed simp lemma map_poly_zero: assumes f: "\c. f c = 0 \ c = 0" shows [simp]: "map_poly f p = 0 \ p = 0" by (induct p; auto simp: map_poly_simps f) lemma map_poly_add: assumes h0: "h 0 = 0" and h_add: "\p q. h (p + q) = h p + h q" shows "map_poly h (p + q) = map_poly h p + map_poly h q" proof (induct p arbitrary: q) case (pCons a p) note pIH = this show ?case proof(induct "q") case (pCons b q) note qIH = this show ?case unfolding map_poly_pCons[OF qIH(1)] unfolding map_poly_pCons[OF pIH(1)] unfolding add_pCons unfolding pIH(2)[symmetric] unfolding h_add[rule_format,symmetric] unfolding map_poly_simps using h0 by auto qed auto qed auto subsection \Morphismic properties of @{term "pCons 0"}\ lemma monom_pCons_0_monom: "monom (pCons 0 (monom a n)) d = map_poly (pCons 0) (monom (monom a n) d)" apply (induct d) unfolding monom_0 unfolding map_poly_simps apply simp unfolding monom_Suc map_poly_simps by auto lemma pCons_0_add: "pCons 0 (p + q) = pCons 0 p + pCons 0 q" by auto lemma sum_pCons_0_commute: "sum (\i. pCons 0 (f i)) S = pCons 0 (sum f S)" by(induct S rule: infinite_finite_induct;simp) lemma pCons_0_as_mult: fixes p:: "'a :: comm_semiring_1 poly" shows "pCons 0 p = [:0,1:] * p" by auto subsection \Misc\ fun expand_powers :: "(nat \ 'a)list \ 'a list" where "expand_powers [] = []" | "expand_powers ((Suc n, a) # ps) = a # expand_powers ((n,a) # ps)" | "expand_powers ((0,a) # ps) = expand_powers ps" lemma expand_powers: fixes f :: "'a \ 'b :: comm_ring_1" shows "(\ (n,a) \ n_as. f a ^ n) = (\ a \ expand_powers n_as. f a)" by (rule sym, induct n_as rule: expand_powers.induct, auto) lemma poly_smult_zero_iff: fixes x :: "'a :: idom" shows "(poly (smult a p) x = 0) = (a = 0 \ poly p x = 0)" by simp lemma poly_prod_list_zero_iff: fixes x :: "'a :: idom" shows "(poly (prod_list ps) x = 0) = (\ p \ set ps. poly p x = 0)" by (induct ps, auto) lemma poly_mult_zero_iff: fixes x :: "'a :: idom" shows "(poly (p * q) x = 0) = (poly p x = 0 \ poly q x = 0)" by simp lemma poly_power_zero_iff: fixes x :: "'a :: idom" shows "(poly (p^n) x = 0) = (n \ 0 \ poly p x = 0)" by (cases n, auto) lemma sum_monom_0_iff: assumes fin: "finite S" and g: "\ i j. g i = g j \ i = j" shows "sum (\ i. monom (f i) (g i)) S = 0 \ (\ i \ S. f i = 0)" (is "?l = ?r") proof - { assume "\ ?r" then obtain i where i: "i \ S" and fi: "f i \ 0" by auto let ?g = "\ i. monom (f i) (g i)" have "coeff (sum ?g S) (g i) = f i + sum (\ j. coeff (?g j) (g i)) (S - {i})" by (unfold sum.remove[OF fin i], simp add: coeff_sum) also have "sum (\ j. coeff (?g j) (g i)) (S - {i}) = 0" by (rule sum.neutral, insert g, auto) finally have "coeff (sum ?g S) (g i) \ 0" using fi by auto hence "\ ?l" by auto } thus ?thesis by auto qed lemma degree_prod_list_eq: assumes "\ p. p \ set ps \ (p :: 'a :: idom poly) \ 0" shows "degree (prod_list ps) = sum_list (map degree ps)" using assms proof (induct ps) case (Cons p ps) show ?case unfolding prod_list.Cons by (subst degree_mult_eq, insert Cons, auto simp: prod_list_zero_iff) qed simp lemma degree_power_eq: assumes p: "p \ 0" shows "degree (p ^ n) = degree (p :: 'a :: idom poly) * n" proof (induct n) case (Suc n) from p have pn: "p ^ n \ 0" by auto show ?case using degree_mult_eq[OF p pn] Suc by auto qed simp lemma coeff_Poly: "coeff (Poly xs) i = (nth_default 0 xs i)" unfolding nth_default_coeffs_eq[of "Poly xs", symmetric] coeffs_Poly by simp lemma rsquarefree_def': "rsquarefree p = (p \ 0 \ (\a. order a p \ 1))" proof - have "\ a. order a p \ 1 \ order a p = 0 \ order a p = 1" by linarith thus ?thesis unfolding rsquarefree_def by auto qed lemma order_prod_list: "(\ p. p \ set ps \ p \ 0) \ order x (prod_list ps) = sum_list (map (order x) ps)" by (induct ps, auto, subst order_mult, auto simp: prod_list_zero_iff) lemma irreducible\<^sub>d_dvd_eq: fixes a b :: "'a::{comm_semiring_1,semiring_no_zero_divisors} poly" assumes "irreducible\<^sub>d a" and "irreducible\<^sub>d b" and "a dvd b" and "monic a" and "monic b" shows "a = b" using assms by (metis (no_types, lifting) coeff_smult degree_smult_eq irreducible\<^sub>dD(1) irreducible\<^sub>d_dvd_smult mult.right_neutral smult_1_left) lemma monic_gcd_dvd: assumes fg: "f dvd g" and mon: "monic f" and gcd: "gcd g h \ {1, g}" shows "gcd f h \ {1, f}" proof (cases "coprime g h") case True with dvd_refl have "coprime f h" using fg by (blast intro: coprime_divisors) then show ?thesis by simp next case False with gcd have gcd: "gcd g h = g" by (simp add: coprime_iff_gcd_eq_1) with fg have "f dvd gcd g h" by simp then have "f dvd h" by simp then have "gcd f h = normalize f" by (simp add: gcd_proj1_iff) also have "normalize f = f" using mon by (rule normalize_monic) finally show ?thesis by simp qed lemma monom_power: "(monom a b)^n = monom (a^n) (b*n)" by (induct n, auto simp add: mult_monom) lemma poly_const_pow: "[:a:]^b = [:a^b:]" by (metis Groups.mult_ac(2) monom_0 monom_power mult_zero_right) lemma degree_pderiv_le: "degree (pderiv f) \ degree f - 1" proof (rule ccontr) assume "\ ?thesis" hence ge: "degree (pderiv f) \ Suc (degree f - 1)" by auto hence "pderiv f \ 0" by auto hence "coeff (pderiv f) (degree (pderiv f)) \ 0" by auto from this[unfolded coeff_pderiv] have "coeff f (Suc (degree (pderiv f))) \ 0" by auto moreover have "Suc (degree (pderiv f)) > degree f" using ge by auto ultimately show False by (simp add: coeff_eq_0) qed lemma map_div_is_smult_inverse: "map_poly (\x. x / (a :: 'a :: field)) p = smult (inverse a) p" unfolding smult_conv_map_poly by (simp add: divide_inverse_commute) lemma normalize_poly_old_def: "normalize (f :: 'a :: {normalization_semidom,field} poly) = smult (inverse (unit_factor (lead_coeff f))) f" by (simp add: normalize_poly_eq_map_poly map_div_is_smult_inverse) (* was in Euclidean_Algorithm in Number_Theory before, but has been removed *) lemma poly_dvd_antisym: fixes p q :: "'b::idom poly" assumes coeff: "coeff p (degree p) = coeff q (degree q)" assumes dvd1: "p dvd q" and dvd2: "q dvd p" shows "p = q" proof (cases "p = 0") case True with coeff show "p = q" by simp next case False with coeff have "q \ 0" by auto have degree: "degree p = degree q" using \p dvd q\ \q dvd p\ \p \ 0\ \q \ 0\ by (intro order_antisym dvd_imp_degree_le) from \p dvd q\ obtain a where a: "q = p * a" .. with \q \ 0\ have "a \ 0" by auto with degree a \p \ 0\ have "degree a = 0" by (simp add: degree_mult_eq) with coeff a show "p = q" by (cases a, auto split: if_splits) qed lemma coeff_f_0_code[code_unfold]: "coeff f 0 = (case coeffs f of [] \ 0 | x # _ \ x)" by (cases f, auto simp: cCons_def) lemma poly_compare_0_code[code_unfold]: "(f = 0) = (case coeffs f of [] \ True | _ \ False)" using coeffs_eq_Nil list.disc_eq_case(1) by blast text \Getting more efficient code for abbreviation @{term lead_coeff}"\ definition leading_coeff where [code_abbrev, simp]: "leading_coeff = lead_coeff" lemma leading_coeff_code [code]: "leading_coeff f = (let xs = coeffs f in if xs = [] then 0 else last xs)" by (simp add: last_coeffs_eq_coeff_degree) lemma nth_coeffs_coeff: "i < length (coeffs f) \ coeffs f ! i = coeff f i" by (metis nth_default_coeffs_eq nth_default_def) definition monom_mult :: "nat \ 'a :: comm_semiring_1 poly \ 'a poly" where "monom_mult n f = monom 1 n * f" lemma monom_mult_unfold [code_unfold]: "monom 1 n * f = monom_mult n f" "f * monom 1 n = monom_mult n f" by (auto simp: monom_mult_def ac_simps) lemma monom_mult_code [code abstract]: "coeffs (monom_mult n f) = (let xs = coeffs f in if xs = [] then xs else replicate n 0 @ xs)" by (rule coeffs_eqI) (auto simp add: Let_def monom_mult_def coeff_monom_mult nth_default_append nth_default_coeffs_eq) lemma coeff_pcompose_monom: fixes f :: "'a :: comm_ring_1 poly" assumes n: "j < n" shows "coeff (f \\<^sub>p monom 1 n) (n * i + j) = (if j = 0 then coeff f i else 0)" proof (induct f arbitrary: i) case (pCons a f i) note d = pcompose_pCons coeff_add coeff_monom_mult coeff_pCons show ?case proof (cases i) case 0 show ?thesis unfolding d 0 using n by (cases j, auto) next case (Suc ii) have id: "n * Suc ii + j - n = n * ii + j" using n by (simp add: diff_mult_distrib2) have id1: "(n \ n * Suc ii + j) = True" by auto have id2: "(case n * Suc ii + j of 0 \ a | Suc x \ coeff 0 x) = 0" using n by (cases "n * Suc ii + j", auto) show ?thesis unfolding d Suc id id1 id2 pCons(2) if_True by auto qed qed auto lemma coeff_pcompose_x_pow_n: fixes f :: "'a :: comm_ring_1 poly" assumes n: "n \ 0" shows "coeff (f \\<^sub>p monom 1 n) (n * i) = coeff f i" using coeff_pcompose_monom[of 0 n f i] n by auto lemma dvd_dvd_smult: "a dvd b \ f dvd g \ smult a f dvd smult b g" unfolding dvd_def by (metis mult_smult_left mult_smult_right smult_smult) definition sdiv_poly :: "'a :: idom_divide poly \ 'a \ 'a poly" where "sdiv_poly p a = (map_poly (\ c. c div a) p)" lemma smult_map_poly: "smult a = map_poly ((*) a)" by (rule ext, rule poly_eqI, subst coeff_map_poly, auto) lemma smult_exact_sdiv_poly: assumes "\ c. c \ set (coeffs p) \ a dvd c" shows "smult a (sdiv_poly p a) = p" unfolding smult_map_poly sdiv_poly_def by (subst map_poly_map_poly,simp,rule map_poly_idI, insert assms, auto) lemma coeff_sdiv_poly: "coeff (sdiv_poly f a) n = coeff f n div a" unfolding sdiv_poly_def by (rule coeff_map_poly, auto) lemma poly_pinfty_ge: fixes p :: "real poly" assumes "lead_coeff p > 0" "degree p \ 0" shows "\n. \ x \ n. poly p x \ b" proof - let ?p = "p - [:b - lead_coeff p :]" have id: "lead_coeff ?p = lead_coeff p" using assms(2) by (cases p, auto) with assms(1) have "lead_coeff ?p > 0" by auto from poly_pinfty_gt_lc[OF this, unfolded id] obtain n where "\ x. x \ n \ 0 \ poly p x - b" by auto thus ?thesis by auto qed lemma pderiv_sum: "pderiv (sum f I) = sum (\ i. (pderiv (f i))) I" by (induct I rule: infinite_finite_induct, auto simp: pderiv_add) lemma smult_sum2: "smult m (\i \ S. f i) = (\i \ S. smult m (f i))" by (induct S rule: infinite_finite_induct, auto simp add: smult_add_right) lemma degree_mult_not_eq: "degree (f * g) \ degree f + degree g \ lead_coeff f * lead_coeff g = 0" by (rule ccontr, auto simp: coeff_mult_degree_sum degree_mult_le le_antisym le_degree) lemma irreducible\<^sub>d_multD: fixes a b :: "'a :: {comm_semiring_1,semiring_no_zero_divisors} poly" assumes l: "irreducible\<^sub>d (a*b)" shows "degree a = 0 \ a \ 0 \ irreducible\<^sub>d b \ degree b = 0 \ b \ 0 \ irreducible\<^sub>d a" proof- from l have a0: "a \ 0" and b0: "b \ 0" by auto note [simp] = degree_mult_eq[OF this] from l have "degree a = 0 \ degree b = 0" apply (unfold irreducible\<^sub>d_def) by force then show ?thesis proof(elim disjE) assume a: "degree a = 0" with l a0 have "irreducible\<^sub>d b" by (simp add: irreducible\<^sub>d_def) (metis degree_mult_eq degree_mult_eq_0 mult.left_commute plus_nat.add_0) with a a0 show ?thesis by auto next assume b: "degree b = 0" with l b0 have "irreducible\<^sub>d a" unfolding irreducible\<^sub>d_def - by (smt add_cancel_left_right degree_mult_eq degree_mult_eq_0 neq0_conv semiring_normalization_rules(16)) + by (smt (verit) add_cancel_left_right degree_mult_eq degree_mult_eq_0 neq0_conv semiring_normalization_rules(16)) with b b0 show ?thesis by auto qed qed lemma irreducible_connect_field[simp]: fixes f :: "'a :: field poly" shows "irreducible\<^sub>d f = irreducible f" (is "?l = ?r") proof show "?r \ ?l" apply (intro irreducible\<^sub>dI, force simp:is_unit_iff_degree) by (auto dest!: irreducible_multD simp: poly_dvd_1) next assume l: ?l show ?r proof (rule irreducibleI) from l show "f \ 0" "\ is_unit f" by (auto simp: poly_dvd_1) fix a b assume "f = a * b" from l[unfolded this] show "a dvd 1 \ b dvd 1" by (auto dest!: irreducible\<^sub>d_multD simp:is_unit_iff_degree) qed qed lemma is_unit_field_poly[simp]: fixes p :: "'a::field poly" shows "is_unit p \ p \ 0 \ degree p = 0" by (cases "p=0", auto simp: is_unit_iff_degree) lemma irreducible_smult_field[simp]: fixes c :: "'a :: field" shows "irreducible (smult c p) \ c \ 0 \ irreducible p" (is "?L \ ?R") proof (intro iffI conjI irreducible\<^sub>d_smult_not_zero_divisor_left[of c p, simplified]) assume "irreducible (smult c p)" then show "c \ 0" by auto next assume ?R then have c0: "c \ 0" and irr: "irreducible p" by auto show ?L proof (fold irreducible_connect_field, intro irreducible\<^sub>dI, unfold degree_smult_eq if_not_P[OF c0]) show "degree p > 0" using irr by auto fix q r from c0 have "p = smult (1/c) (smult c p)" by simp also assume "smult c p = q * r" finally have [simp]: "p = smult (1/c) \". assume main: "degree q < degree p" "degree r < degree p" have "\irreducible\<^sub>d p" by (rule reducible\<^sub>dI, rule exI[of _ "smult (1/c) q"], rule exI[of _ r], insert irr c0 main, simp) with irr show False by auto qed qed auto lemma irreducible_monic_factor: fixes p :: "'a :: field poly" assumes "degree p > 0" shows "\ q r. irreducible q \ p = q * r \ monic q" proof - from irreducible\<^sub>d_factorization_exists[OF assms] obtain fs where "fs \ []" and "set fs \ Collect irreducible" and "p = prod_list fs" by auto then have q: "irreducible (hd fs)" and p: "p = hd fs * prod_list (tl fs)" by (atomize(full), cases fs, auto) define c where "c = coeff (hd fs) (degree (hd fs))" from q have c: "c \ 0" unfolding c_def irreducible\<^sub>d_def by auto show ?thesis by (rule exI[of _ "smult (1/c) (hd fs)"], rule exI[of _ "smult c (prod_list (tl fs))"], unfold p, insert q c, auto simp: c_def) qed lemma monic_irreducible_factorization: fixes p :: "'a :: field poly" shows "monic p \ \ as f. finite as \ p = prod (\ a. a ^ Suc (f a)) as \ as \ {q. irreducible q \ monic q}" proof (induct "degree p" arbitrary: p rule: less_induct) case (less p) show ?case proof (cases "degree p > 0") case False with less(2) have "p = 1" by (simp add: coeff_eq_0 poly_eq_iff) thus ?thesis by (intro exI[of _ "{}"], auto) next case True from irreducible\<^sub>d_factor[OF this] obtain q r where p: "p = q * r" and q: "irreducible q" and deg: "degree r < degree p" by auto hence q0: "q \ 0" by auto define c where "c = coeff q (degree q)" let ?q = "smult (1/c) q" let ?r = "smult c r" from q0 have c: "c \ 0" "1 / c \ 0" unfolding c_def by auto hence p: "p = ?q * ?r" unfolding p by auto have deg: "degree ?r < degree p" using c deg by auto let ?Q = "{q. irreducible q \ monic (q :: 'a poly)}" have mon: "monic ?q" unfolding c_def using q0 by auto from monic_factor[OF \monic p\[unfolded p] this] have "monic ?r" . from less(1)[OF deg this] obtain f as where as: "finite as" "?r = (\ a \as. a ^ Suc (f a))" "as \ ?Q" by blast from q c have irred: "irreducible ?q" by simp show ?thesis proof (cases "?q \ as") case False let ?as = "insert ?q as" let ?f = "\ a. if a = ?q then 0 else f a" have "p = ?q * (\ a \as. a ^ Suc (f a))" unfolding p as by simp also have "(\ a \as. a ^ Suc (f a)) = (\ a \as. a ^ Suc (?f a))" by (rule prod.cong, insert False, auto) also have "?q * \ = (\ a \ ?as. a ^ Suc (?f a))" by (subst prod.insert, insert as False, auto) finally have p: "p = (\ a \ ?as. a ^ Suc (?f a))" . from as(1) have fin: "finite ?as" by auto from as mon irred have Q: "?as \ ?Q" by auto from fin p Q show ?thesis by(intro exI[of _ ?as] exI[of _ ?f], auto) next case True let ?f = "\ a. if a = ?q then Suc (f a) else f a" have "p = ?q * (\ a \as. a ^ Suc (f a))" unfolding p as by simp also have "(\ a \as. a ^ Suc (f a)) = ?q ^ Suc (f ?q) * (\ a \(as - {?q}). a ^ Suc (f a))" by (subst prod.remove[OF _ True], insert as, auto) also have "(\ a \(as - {?q}). a ^ Suc (f a)) = (\ a \(as - {?q}). a ^ Suc (?f a))" by (rule prod.cong, auto) also have "?q * (?q ^ Suc (f ?q) * \ ) = ?q ^ Suc (?f ?q) * \" by (simp add: ac_simps) also have "\ = (\ a \ as. a ^ Suc (?f a))" by (subst prod.remove[OF _ True], insert as, auto) finally have "p = (\ a \ as. a ^ Suc (?f a))" . with as show ?thesis by (intro exI[of _ as] exI[of _ ?f], auto) qed qed qed lemma monic_irreducible_gcd: "monic (f::'a::{field,euclidean_ring_gcd,semiring_gcd_mult_normalize, normalization_euclidean_semiring_multiplicative} poly) \ irreducible f \ gcd f u \ {1,f}" by (metis gcd_dvd1 irreducible_altdef insertCI is_unit_gcd_iff poly_dvd_antisym poly_gcd_monic) end diff --git a/thys/Relational-Incorrectness-Logic/ROOT b/thys/Relational-Incorrectness-Logic/ROOT --- a/thys/Relational-Incorrectness-Logic/ROOT +++ b/thys/Relational-Incorrectness-Logic/ROOT @@ -1,10 +1,9 @@ chapter AFP session "Relational-Incorrectness-Logic" = "HOL-IMP" + options [timeout = 600] theories - RelationalIncorrectness - + RelationalIncorrectness document_files - "root.bib" - "root.tex" + "root.bib" + "root.tex" diff --git a/thys/Relational-Incorrectness-Logic/RelationalIncorrectness.thy b/thys/Relational-Incorrectness-Logic/RelationalIncorrectness.thy --- a/thys/Relational-Incorrectness-Logic/RelationalIncorrectness.thy +++ b/thys/Relational-Incorrectness-Logic/RelationalIncorrectness.thy @@ -1,834 +1,834 @@ theory RelationalIncorrectness imports "HOL-IMP.Big_Step" begin (* Author: Toby Murray *) section "Under-Approximate Relational Judgement" text \ This is the relational analogue of OHearn's~\<^cite>\"OHearn_19"\ and de Vries \& Koutavas'~\<^cite>\"deVries_Koutavas_11"\ judgements. Note that in our case it doesn't really make sense to talk about erroneous'' states: the presence of an error can be seen only by the violation of a relation. Unlike O'Hearn, we cannot encode it directly into the semantics of our programs, without giving them a relational semantics. We use the standard big step semantics of IMP unchanged. \ type_synonym rassn = "state \ state \ bool" definition ir_valid :: "rassn \ com \ com \ rassn \ bool" where "ir_valid P c c' Q \ (\ t t'. Q t t' \ (\s s'. P s s' \ (c,s) \ t \ (c',s') \ t'))" section "Rules of the Logic" definition flip :: "rassn \ rassn" where "flip P \ \s s'. P s' s" inductive ir_hoare :: "rassn \ com \ com \ rassn \ bool" where ir_Skip: "(\t t'. Q t t' \ \s'. P t s' \ (c',s') \ t') \ ir_hoare P SKIP c' Q" | ir_If_True: "ir_hoare (\s s'. P s s' \ bval b s) c\<^sub>1 c' Q \ ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) c' Q" | ir_If_False: "ir_hoare (\s s'. P s s' \ \ bval b s) c\<^sub>2 c' Q \ ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) c' Q" | ir_Seq1: "ir_hoare P c c' Q \ ir_hoare Q d SKIP R \ ir_hoare P (Seq c d) c' R" | ir_Assign: "ir_hoare (\t t'. \ v. P (t(x := v)) t' \ (t x) = aval e (t(x := v))) SKIP c' Q \ ir_hoare P (Assign x e) c' Q" | ir_While_False: "ir_hoare (\s s'. P s s' \ \ bval b s) SKIP c' Q \ ir_hoare P (WHILE b DO c) c' Q" | ir_While_True: "ir_hoare (\s s'. P s s' \ bval b s) (c;; WHILE b DO c) c' Q \ ir_hoare P (WHILE b DO c) c' Q" | ir_While_backwards_frontier: "(\n. ir_hoare (\ s s'. P n s s' \ bval b s) c SKIP (P (Suc n))) \ ir_hoare (\s s'. \n. P n s s') (WHILE b DO c) c' Q \ ir_hoare (P 0) (WHILE b DO c) c' Q" | ir_conseq: "ir_hoare P c c' Q \ (\s s'. P s s' \ P' s s') \ (\s s'. Q' s s' \ Q s s') \ ir_hoare P' c c' Q'" | ir_disj: "ir_hoare P\<^sub>1 c c' Q\<^sub>1 \ ir_hoare P\<^sub>2 c c' Q\<^sub>2 \ ir_hoare (\s s'. P\<^sub>1 s s' \ P\<^sub>2 s s') c c' (\ t t'. Q\<^sub>1 t t' \ Q\<^sub>2 t t')" | ir_sym: "ir_hoare (flip P) c c' (flip Q) \ ir_hoare P c' c Q" section "Simple Derived Rules" lemma meh_simp[simp]: "(SKIP, s') \ t' = (s' = t')" by auto lemma ir_pre: "ir_hoare P c c' Q \ (\s s'. P s s' \ P' s s') \ ir_hoare P' c c' Q" by(erule ir_conseq, blast+) lemma ir_post: "ir_hoare P c c' Q \ (\s s'. Q' s s' \ Q s s') \ ir_hoare P c c' Q'" by(erule ir_conseq, blast+) section "Soundness" lemma Skip_ir_valid[intro]: "(\t t'. Q t t' \ \s'. P t s' \ (c', s') \ t') \ ir_valid P SKIP c' Q" by(auto simp: ir_valid_def) lemma sym_ir_valid[intro]: "ir_valid (flip P) c' c (flip Q) \ ir_valid P c c' Q" by(fastforce simp: ir_valid_def flip_def) lemma If_True_ir_valid[intro]: "ir_valid (\a c. P a c \ bval b a) c\<^sub>1 c' Q \ ir_valid P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) c' Q" by(fastforce simp: ir_valid_def) lemma If_False_ir_valid[intro]: "ir_valid (\a c. P a c \ \ bval b a) c\<^sub>2 c' Q \ ir_valid P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) c' Q" by(fastforce simp: ir_valid_def) lemma Seq1_ir_valid[intro]: "ir_valid P c c' Q \ ir_valid Q d SKIP R \ ir_valid P (c;; d) c' R" by(fastforce simp: ir_valid_def) lemma Seq2_ir_valid[intro]: "ir_valid P c SKIP Q \ ir_valid Q d c' R \ ir_valid P (c;; d) c' R" by(fastforce simp: ir_valid_def) lemma Seq_ir_valid[intro]: "ir_valid P c c' Q \ ir_valid Q d d' R \ ir_valid P (c;; d) (c';; d') R" by(fastforce simp: ir_valid_def) lemma Assign_blah[intro]: "t x = aval e (t(x := v)) \ (x ::= e, t(x := v)) \ t" using Assign by (metis fun_upd_triv fun_upd_upd) lemma Assign_ir_valid[intro]: "ir_valid (\t t'. \ v. P (t(x := v)) t' \ (t x) = aval e (t(x := v))) SKIP c' Q \ ir_valid P (Assign x e) c' Q" by(fastforce simp: ir_valid_def) lemma While_False_ir_valid[intro]: "ir_valid (\s s'. P s s' \ \ bval b s) SKIP c' Q \ ir_valid P (WHILE b DO c) c' Q" by(fastforce simp: ir_valid_def) lemma While_True_ir_valid[intro]: "ir_valid (\s s'. P s s' \ bval b s) (Seq c (WHILE b DO c)) c' Q \ ir_valid P (WHILE b DO c) c' Q" by(clarsimp simp: ir_valid_def, blast) lemma While_backwards_frontier_ir_valid': assumes asm: "\n. \t t'. P (k + Suc n) t t' \ (\s. P (k + n) s t' \ bval b s \ (c, s) \ t)" assumes last: "\t t'. Q t t' \ (\s s'. (\n. P (k + n) s s') \ (WHILE b DO c, s) \ t \ (c', s') \ t')" assumes post: "Q t t'" shows "\s s'. P k s s' \ (WHILE b DO c, s) \ t \ (c', s') \ t'" proof - from post last obtain s s' n where "P (k + n) s s'" "(WHILE b DO c, s) \ t" "(c', s') \ t'" by blast with asm show ?thesis proof(induction n arbitrary: k t t') case 0 then show ?case by (metis WhileFalse WhileTrue add.right_neutral) next case (Suc n) from Suc obtain r r' where final_iteration: "P (Suc k) r r'" "(WHILE b DO c, r) \ t" "(c', r') \ t'" by (metis add_Suc_shift) from final_iteration(1) obtain q q' where "P k q r' \ bval b q \ (c, q) \ r" by (metis Nat.add_0_right Suc.prems(1) plus_1_eq_Suc semiring_normalization_rules(24)) with final_iteration show ?case by blast qed qed lemma While_backwards_frontier_ir_valid[intro]: "(\n. ir_valid (\ s s'. P n s s' \ bval b s) c SKIP (P (Suc n))) \ ir_valid (\s s'. \n. P n s s') (WHILE b DO c) c' Q \ ir_valid (P 0) (WHILE b DO c) c' Q" by(auto simp: meh_simp ir_valid_def intro: While_backwards_frontier_ir_valid') lemma conseq_ir_valid: "ir_valid P c c' Q \ (\s s'. P s s' \ P' s s') \ (\s s'. Q' s s' \ Q s s') \ ir_valid P' c c' Q'" by(clarsimp simp: ir_valid_def, blast) lemma disj_ir_valid[intro]: "ir_valid P\<^sub>1 c c' Q\<^sub>1 \ ir_valid P\<^sub>2 c c' Q\<^sub>2 \ ir_valid (\s s'. P\<^sub>1 s s' \ P\<^sub>2 s s') c c' (\ t t'. Q\<^sub>1 t t' \ Q\<^sub>2 t t')" by(fastforce simp: ir_valid_def) theorem soundness: "ir_hoare P c c' Q \ ir_valid P c c' Q" apply(induction rule: ir_hoare.induct) apply(blast intro!: Skip_ir_valid) by (blast intro: conseq_ir_valid)+ section "Completeness" lemma ir_Skip_Skip[intro]: "ir_hoare P SKIP SKIP P" by(rule ir_Skip, simp) lemma ir_hoare_Skip_Skip[simp]: "ir_hoare P SKIP SKIP Q = (\s s'. Q s s' \ P s s')" using soundness ir_valid_def meh_simp ir_conseq ir_Skip by metis lemma ir_valid_Seq1: "ir_valid P (c1;; c2) c' Q \ ir_valid P c1 c' (\t t'. \s s'. P s s' \ (c1,s) \ t \ (c',s') \ t' \ (\u. (c2,t) \ u \ Q u t'))" by(auto simp: ir_valid_def) lemma ir_valid_Seq1': "ir_valid P (c1;; c2) c' Q \ ir_valid (\t t'. \s s'. P s s' \ (c1,s) \ t \ (c',s') \ t' \ (\u. (c2,t) \ u \ Q u t')) c2 SKIP Q" by(clarsimp simp: ir_valid_def, meson SeqE) lemma ir_valid_track_history: "ir_valid P c c' Q \ ir_valid P c c' (\t t'. Q s s' \ (\s s'. P s s' \ (c,s) \ t \ (c',s') \ t'))" by(auto simp: ir_valid_def) lemma ir_valid_If: "ir_valid (\s s'. P s s') (IF b THEN c1 ELSE c2) c' Q \ ir_valid (\s s'. P s s' \ bval b s) c1 c' (\t t'. Q t t' \ (\s s'. P s s' \ (c1,s) \ t \ (c',s') \ t' \ bval b s)) \ ir_valid (\s s'. P s s' \ \ bval b s) c2 c' (\t t'. Q t t' \ (\s s'. P s s' \ (c2,s) \ t \ (c',s') \ t' \ \ bval b s))" by(clarsimp simp: ir_valid_def, blast) text \ Inspired by the @{text "p(n) = {\ | you can get back from \ to some state in p by executing C backwards n times}"}'' part of OHearn~\<^cite>\"OHearn_19"\. \ primrec get_back where "get_back P b c 0 = (\t t'. P t t')" | "get_back P b c (Suc n) = (\t t'. \s. (c,s) \ t \ bval b s \ get_back P b c n s t')" (* Currently not used anywhere *) lemma ir_valid_get_back: "ir_valid (get_back P b c (Suc k)) (WHILE b DO c) c' Q \ ir_valid (get_back P b c k) (WHILE b DO c) c' Q" proof(induct k) case 0 then show ?case by(clarsimp simp: ir_valid_def, blast) next case (Suc k) - then show ?case using WhileTrue get_back.simps(2) ir_valid_def by smt + then show ?case using WhileTrue get_back.simps(2) ir_valid_def by (smt (verit)) qed (* both this an the next one get used in the completeness proof *) lemma ir_valid_While1: "ir_valid (get_back P b c k) (WHILE b DO c) c' Q \ (ir_valid (\s s'. get_back P b c k s s' \ bval b s) c SKIP (\t t'. get_back P b c (Suc k) t t' \ (\u u'. (WHILE b DO c,t) \ u \ (c',t') \ u' \ Q u u')))" proof (subst ir_valid_def, clarsimp) fix t t' s u u' assume "ir_valid (get_back P b c k) (WHILE b DO c) c' Q" "(WHILE b DO c, t) \ u" "(c, s) \ t" "(c', t') \ u'" "Q u u'" "bval b s" "get_back P b c k s t'" thus "\s. get_back P b c k s t' \ bval b s \ (c, s) \ t" proof(induction k arbitrary: t t' s u u') case 0 then show ?case by auto next case (Suc k) show ?case using Suc.prems(3) Suc.prems(6) Suc.prems(7) by blast qed qed lemma ir_valid_While3: "ir_valid (get_back P b c k) (WHILE b DO c) c' Q \ (ir_valid (\s s'. get_back P b c k s s' \ bval b s) c c' (\t t'. (\s'. (c',s') \ t' \ get_back P b c (Suc k) t s' \ (\u. (WHILE b DO c,t) \ u \ Q u t'))))" apply(subst ir_valid_def, clarsimp) proof - fix t t' s' s u assume "ir_valid (get_back P b c k) (WHILE b DO c) c' Q" "(WHILE b DO c, t) \ u" "(c, s) \ t" "(c', s') \ t'" "Q u t'" "bval b s" "get_back P b c k s s'" thus "\s s'. get_back P b c k s s' \ bval b s \ (c, s) \ t \ (c',s') \ t'" proof(induction k arbitrary: t t' s' s u) case 0 then show ?case by auto next case (Suc k) show ?case using Suc.prems(3) Suc.prems(4) Suc.prems(6) Suc.prems(7) by blast qed qed (* not used anywhere *) lemma ir_valid_While2: "ir_valid P (WHILE b DO c) c' Q \ ir_valid (\s s'. P s s' \ \ bval b s) SKIP c' (\t t'. Q t t' \ (\s'. (c',s') \ t' \ P t s' \ \ bval b t))" by(clarsimp simp: ir_valid_def, blast) lemma assign_upd_blah: "(\a. if a = x1 then s x1 else (s(x1 := aval x2 s)) a) = s" by(rule ext, auto) lemma Assign_complete: assumes v: "ir_valid P (x1 ::= x2) c' Q" assumes q: "Q t t'" shows "\s'. (\v. P (t(x1 := v)) s' \ t x1 = aval x2 (t(x1 := v))) \ (c', s') \ t'" proof - from v and q obtain s s' where a: "P s s' \ (x1 ::= x2,s) \ t \ (c',s') \ t'" - using ir_valid_def by smt + using ir_valid_def by (smt (verit)) hence "P (\a. if a = x1 then s x1 else (s(x1 := aval x2 s)) a) s' \ aval x2 s = aval x2 (s(x1 := s x1))" using assign_upd_blah by simp thus ?thesis using assign_upd_blah a by (metis AssignE fun_upd_same fun_upd_triv fun_upd_upd) qed lemmas ir_Skip_sym = ir_sym[OF ir_Skip, simplified flip_def] theorem completeness: "ir_valid P c c' Q \ ir_hoare P c c' Q" proof(induct c arbitrary: P c' Q) case SKIP show ?case apply(rule ir_Skip) using SKIP by(fastforce simp: ir_valid_def) next case (Assign x1 x2) show ?case apply(rule ir_Assign) apply(rule ir_Skip) using Assign_complete Assign by blast next case (Seq c1 c2) have a: "ir_hoare P c1 c' (\t t'. \s s'. P s s' \ (c1, s) \ t \ (c', s') \ t' \ (\u. (c2, t) \ u \ Q u t'))" using ir_valid_Seq1 Seq by blast show ?case apply(rule ir_Seq1) apply (blast intro: a) apply(rule ir_Skip_sym) by(metis SeqE ir_valid_def Seq) next case (If x1 c1 c2) have t: "ir_hoare (\s s'. P s s' \ bval x1 s) c1 c' (\t t'. Q t t' \ (\s s'. P s s' \ (c1, s) \ t \ (c', s') \ t' \ bval x1 s))" and f: " ir_hoare (\s s'. P s s' \ \ bval x1 s) c2 c' (\t t'. Q t t' \ (\s s'. P s s' \ (c2, s) \ t \ (c', s') \ t' \ \ bval x1 s))" using ir_valid_If If by blast+ show ?case (* consider both cases of the if via conseq, disj, then _True and _False *) apply(rule ir_conseq) apply(rule ir_disj) apply(rule ir_If_True,fastforce intro: t) apply(rule ir_If_False, fastforce intro: f) apply blast - by (smt IfE ir_valid_def If) + by (smt (verit) IfE ir_valid_def If) next case (While x1 c) have a: "\n. ir_hoare (\s s'. get_back P x1 c n s s' \ bval x1 s) c SKIP (get_back P x1 c (Suc n))" - using ir_valid_While1 While - by (smt get_back.simps(2) ir_valid_def meh_simp) + using ir_valid_While1 While + by (smt (verit, ccfv_threshold) get_back.simps(2) ir_Skip_sym) have b: "ir_hoare (\s s'. P s s' \ bval x1 s) c c' (\t t'. \s'. (c', s') \ t' \ (\s. (c, s) \ t \ bval x1 s \ P s s') \ (\u. (WHILE x1 DO c, t) \ u \ Q u t'))" using ir_valid_While3[where k=0,simplified] While by blast have gb: "\t t'. Q t t' \ (\s'. (c', s') \ t' \ P t s' \ \ bval x1 t) \ \s'. ((\n. get_back P x1 c n t s') \ \ bval x1 t) \ (c', s') \ t'" by (meson get_back.simps(1)) show ?case (* use the frontier rule much as in OHearn POPL *) apply(rule ir_conseq) apply(rule_tac P="get_back P x1 c" in ir_While_backwards_frontier) apply(blast intro: a) (* consider both cases of the While via conseq, disj, then _True and _False *) apply(rule ir_conseq) apply(rule ir_disj) apply(rule_tac P="\s s'. \n. get_back P x1 c n s s'" and Q="(\t t'. Q t t' \ (\s'. (c', s') \ t' \ P t s' \ \ bval x1 t))" in ir_While_False) apply(rule ir_Skip, blast intro: gb) apply(rule ir_While_True) apply(rule ir_Seq1[OF b]) apply(rule ir_Skip_sym) apply(fastforce) apply (metis get_back.simps(1)) apply assumption apply simp by (metis While.prems WhileE ir_valid_def) qed section "A Decomposition Principle: Proofs via Under-Approximate Hoare Logic" text \ We show the under-approximate analogue holds for Beringer's~\<^cite>\"Beringer_11"\ decomposition principle for over-approximate relational logic. \ definition decomp :: "rassn \ com \ com \ rassn \ rassn" where "decomp P c c' Q \ \t s'. \s t'. P s s' \ (c,s) \ t \ (c',s') \ t' \ Q t t'" lemma ir_valid_decomp1: "ir_valid P c c' Q \ ir_valid P c SKIP (decomp P c c' Q) \ ir_valid (decomp P c c' Q) SKIP c' Q" by(fastforce simp: ir_valid_def meh_simp decomp_def) lemma ir_valid_decomp2: "ir_valid P c SKIP R \ ir_valid R SKIP c' Q \ ir_valid P c c' Q" by(fastforce simp: ir_valid_def meh_simp decomp_def) lemma ir_valid_decomp: "ir_valid P c c' Q = (ir_valid P c SKIP (decomp P c c' Q) \ ir_valid (decomp P c c' Q) SKIP c' Q)" using ir_valid_decomp1 ir_valid_decomp2 by blast text \ Completeness with soundness means we can prove proof rules about @{term ir_hoare} in terms of @{term ir_valid}. \ lemma ir_to_Skip: "ir_hoare P c c' Q = (ir_hoare P c SKIP (decomp P c c' Q) \ ir_hoare (decomp P c c' Q) SKIP c' Q)" using soundness completeness ir_valid_decomp by meson text \ O'Hearn's under-approximate Hoare triple, for the ok'' case (since that is the only case we have) This is also likely the same as from the "Reverse Hoare Logic" paper (SEFM). \ type_synonym assn = "state \ bool" definition ohearn :: "assn \ com \ assn \ bool" where "ohearn P c Q \ (\t. Q t \ (\s. P s \ (c,s) \ t))" lemma fold_ohearn1: "ir_valid P c SKIP Q = (\t'. ohearn (\t. P t t') c (\t. Q t t'))" by(fastforce simp add: ir_valid_def ohearn_def) lemma fold_ohearn2: "ir_valid P SKIP c' Q = (\t. ohearn (P t) c' (Q t))" by(simp add: ir_valid_def ohearn_def) theorem relational_via_hoare: "ir_hoare P c c' Q = ((\t'. ohearn (\t. P t t') c (\t. decomp P c c' Q t t')) \ (\t. ohearn (decomp P c c' Q t) c' (Q t)))" proof - have a: "\P c c' Q. ir_hoare P c c' Q = ir_valid P c c' Q" using soundness completeness by auto show ?thesis using ir_to_Skip a fold_ohearn1 fold_ohearn2 by metis qed section "Deriving Proof Rules from Completeness" text \ Note that we can more easily derive proof rules sometimes by appealing to the corresponding properties of @{term ir_valid} than from the proof rules directly. We see more examples of this later on when we consider examples. \ lemma ir_Seq2: "ir_hoare P c SKIP Q \ ir_hoare Q d c' R \ ir_hoare P (Seq c d) c' R" using soundness completeness Seq2_ir_valid by metis lemma ir_Seq: "ir_hoare P c c' Q \ ir_hoare Q d d' R \ ir_hoare P (Seq c d) (Seq c' d') R" using soundness completeness Seq_ir_valid by metis section "Examples" subsection "Some Derived Proof Rules" text \ First derive some proof rules -- here not by appealing to completeness but just using the existing rules \ lemma ir_If_True_False: "ir_hoare (\s s'. P s s' \ bval b s \ \ bval b' s') c\<^sub>1 c\<^sub>2' Q \ ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (IF b' THEN c\<^sub>1' ELSE c\<^sub>2') Q" apply(rule ir_If_True) apply(rule ir_sym) apply(rule ir_If_False) apply(rule ir_sym) by(simp add: flip_def) lemma ir_Assign_Assign: "ir_hoare P (x ::= e) (x' ::= e') (\t t'. \v v'. P (t(x := v)) (t'(x' := v')) \ t x = aval e (t(x := v)) \ t' x' = aval e' (t'(x' := v')))" apply(rule ir_Assign) apply(rule ir_sym) apply(rule ir_Assign) by(simp add: flip_def, auto) subsection "prog1" text \ A tiny insecure program. Note that we only need to reason on one path through this program to detect that it is insecure. \ abbreviation low_eq :: rassn where "low_eq s s' \ s ''low'' = s' ''low''" abbreviation low_neq :: rassn where "low_neq s s' \ \ low_eq s s'" definition prog1 :: com where "prog1 \ (IF (Less (N 0) (V ''x'')) THEN (Assign ''low'' (N 1)) ELSE (Assign ''low'' (N 0)))" text \ We prove that @{term prog1} is definitely insecure. To do that, we need to find some non-empty post-relation that implies insecurity. The following property encodes the idea that the post-relation is non-empty, i.e. represents a feasible pair of execution paths. \ definition nontrivial :: "rassn \ bool" where "nontrivial Q \ (\t t'. Q t t')" text \ Note the property we prove here explicitly encodes the fact that the postcondition can be anything that implies insecurity, i.e. implies @{term low_neq}. In particular we should not necessarily expect it to cover the entirely of all states that satisfy @{term low_neq}. Also note that we also have to prove that the postcondition is non-trivial. This is necessary to make sure that the violation we find is not an infeasible path. \ lemma prog1: "\Q. ir_hoare low_eq prog1 prog1 Q \ (\s s'. Q s s' \ low_neq s s') \ nontrivial Q" apply(rule exI) apply(rule conjI) apply(simp add: prog1_def) apply(rule ir_If_True_False) apply(rule ir_Assign_Assign) apply(rule conjI) apply auto[1] apply(clarsimp simp: nontrivial_def) apply(rule_tac x="\v. 1" in exI) apply simp apply(rule_tac x="\v. 0" in exI) by auto subsection "More Derived Proof Rules for Examples" definition BEq :: "aexp \ aexp \ bexp" where "BEq a b \ And (Less a (Plus b (N 1))) (Less b (Plus a (N 1)))" lemma BEq_aval[simp]: "bval (BEq a b) s = ((aval a s) = (aval b s))" by(auto simp add: BEq_def) lemma ir_If_True_True: "ir_hoare (\s s'. P s s' \ bval b s \ bval b' s') c\<^sub>1 c\<^sub>1' Q\<^sub>1 \ ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (IF b' THEN c\<^sub>1' ELSE c\<^sub>2') (\t t'. Q\<^sub>1 t t')" by(simp add: ir_If_True ir_sym flip_def) lemma ir_If_False_False: "ir_hoare (\s s'. P s s' \ \ bval b s \ \ bval b' s') c\<^sub>2 c\<^sub>2' Q\<^sub>2 \ ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (IF b' THEN c\<^sub>1' ELSE c\<^sub>2') (\t t'. Q\<^sub>2 t t')" by(simp add: ir_If_False ir_sym flip_def) lemma ir_If': "ir_hoare (\s s'. P s s' \ bval b s \ bval b' s') c\<^sub>1 c\<^sub>1' Q\<^sub>1 \ ir_hoare (\s s'. P s s' \ \ bval b s \ \ bval b' s') c\<^sub>2 c\<^sub>2' Q\<^sub>2 \ ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (IF b' THEN c\<^sub>1' ELSE c\<^sub>2') (\t t'. Q\<^sub>1 t t' \ Q\<^sub>2 t t')" apply(rule ir_pre) apply(rule ir_disj) apply(rule ir_If_True_True) apply assumption apply(rule ir_If_False_False) apply assumption apply blast done lemma ir_While_triv: "ir_hoare (\s s'. P s s' \ \ bval b s \ \ bval b' s') SKIP SKIP Q\<^sub>2 \ ir_hoare P (WHILE b DO c) (WHILE b' DO c') (\s s'. (Q\<^sub>2 s s'))" by(simp add: ir_While_False ir_sym flip_def) lemma ir_While': "ir_hoare (\s s'. P s s' \ bval b s \ bval b' s') (c;;WHILE b DO c) (c';;WHILE b' DO c') Q\<^sub>1 \ ir_hoare (\s s'. P s s' \ \ bval b s \ \ bval b' s') SKIP SKIP Q\<^sub>2 \ ir_hoare P (WHILE b DO c) (WHILE b' DO c') (\s s'. (Q\<^sub>1 s s' \ Q\<^sub>2 s s'))" apply(rule ir_pre) apply(rule ir_disj) apply(rule ir_While_True) apply(rule ir_sym) apply(simp add: flip_def) apply(rule ir_While_True) apply(rule ir_sym) apply(simp add: flip_def) apply(rule ir_While_triv) apply assumption apply simp done subsection "client0" definition low_eq_strong where "low_eq_strong s s' \ (s ''high'' \ s' ''high'') \ low_eq s s'" lemma low_eq_strong_upd[simp]: "var \ ''high'' \ var \ ''low'' \ low_eq_strong(s(var := v)) (s'(var := v')) = low_eq_strong s s'" by(auto simp: low_eq_strong_def) text \ A variation on client0 from O'Hearn~\<^cite>\"OHearn_19"\: how to reason about loops via a single unfolding \ definition client0 :: com where "client0 \ (Assign ''x'' (N 0);; (While (Less (N 0) (V ''n'')) ((Assign ''x'' (Plus (V ''x'') (V ''n'')));; (Assign ''n'' (V ''nondet''))));; (If (BEq (V ''x'') (N 2000000)) (Assign ''low'' (V ''high'')) SKIP))" lemma client0: "\Q. ir_hoare low_eq client0 client0 Q \ (\s s'. Q s s' \ low_neq s s') \ nontrivial Q" apply(rule exI, rule conjI, simp add: client0_def) apply(rule_tac P=low_eq_strong in ir_pre) apply(rule ir_Seq) apply(rule ir_Seq) apply(rule ir_Assign_Assign) apply clarsimp apply(rule ir_While') apply clarsimp apply(rule ir_Seq) apply(rule ir_Seq) apply(rule ir_Assign_Assign) apply(rule ir_Assign_Assign) apply clarsimp apply(rule ir_While_triv) apply clarsimp apply assumption apply clarsimp apply assumption apply(rule ir_If_True_True) apply(rule ir_Assign_Assign) apply(fastforce simp: low_eq_strong_def) apply(rule conjI) apply(clarsimp simp: low_eq_strong_def split: if_splits) (* ugh having to manually do constraint solving here... *) apply(clarsimp simp: low_eq_strong_def nontrivial_def) apply(rule_tac x="\v. if v = ''x'' then 2000000 else if v = ''high'' then 1 else if v = ''n'' then -1 else if v = ''nondet'' then -1 else if v = ''low'' then 1 else undefined" in exI) apply(rule_tac x="\v. if v = ''x'' then 2000000 else if v = ''high'' then 0 else if v = ''n'' then -1 else if v = ''nondet'' then -1 else if v = ''low'' then 0 else undefined" in exI) apply clarsimp done (* Not needed? *) lemma ir_While_backwards: "(\n. ir_hoare (\ s s'. P n s s' \ bval b s) c SKIP (P (Suc n))) \ ir_hoare (\s s'. \n. P n s s' \ \ bval b s) SKIP c' Q \ ir_hoare (P 0) (WHILE b DO c) c' Q" apply(rule ir_While_backwards_frontier) apply assumption apply(rule ir_While_False) apply auto done subsection "Derive a variant of the backwards variant rule" text \Here we appeal to completeness again to derive this rule from the corresponding property about @{term ir_valid}.\ subsection "A variant of the frontier rule" text \ Agin we derive this rule by appealing to completeness and the corresponding property of @{term ir_valid} \ lemma While_backwards_frontier_both_ir_valid': assumes asm: "\n. \t t'. P (k + Suc n) t t' \ (\s s'. P (k + n) s s' \ bval b s \ bval b' s' \ (c, s) \ t \ (c', s') \ t')" assumes last: "\t t'. Q t t' \ (\s s'. (\n. P (k + n) s s') \ (WHILE b DO c, s) \ t \ (WHILE b' DO c', s') \ t')" assumes post: "Q t t'" shows "\s s'. P k s s' \ (WHILE b DO c, s) \ t \ (WHILE b' DO c', s') \ t'" proof - from post last obtain s s' n where "P (k + n) s s'" "(WHILE b DO c, s) \ t" "(WHILE b' DO c', s') \ t'" by blast with asm show ?thesis proof(induction n arbitrary: k t t') case 0 then show ?case by (metis WhileFalse WhileTrue add.right_neutral) next case (Suc n) from Suc obtain r r' where final_iteration: "P (Suc k) r r'" "(WHILE b DO c, r) \ t" "(WHILE b' DO c', r') \ t'" by (metis add_Suc_shift) from final_iteration(1) obtain q q' where "P k q q' \ bval b q \ bval b' q' \ (c, q) \ r \ (c', q') \ r'" by (metis Nat.add_0_right Suc.prems(1) plus_1_eq_Suc semiring_normalization_rules(24)) with final_iteration show ?case by blast qed qed lemma While_backwards_frontier_both_ir_valid[intro]: "(\n. ir_valid (\ s s'. P n s s' \ bval b s \ bval b' s') c c' (P (Suc n))) \ ir_valid (\s s'. \n. P n s s') (WHILE b DO c) (WHILE b' DO c') Q \ ir_valid (P 0) (WHILE b DO c) (WHILE b' DO c') (\s s'. Q s s')" by(auto simp: ir_valid_def intro: While_backwards_frontier_both_ir_valid') lemma ir_While_backwards_frontier_both: "\\n. ir_hoare (\s s'. P n s s' \ bval b s \ bval b' s') c c' (P (Suc n)); ir_hoare (\s s'. \n. P n s s') (WHILE b DO c) (WHILE b' DO c') Q\ \ ir_hoare (P 0) (WHILE b DO c) (WHILE b' DO c') (\s s'. Q s s')" using soundness completeness While_backwards_frontier_both_ir_valid by auto text \ The following rule then follows easily as a special case \ lemma ir_While_backwards_both: "(\n. ir_hoare (\ s s'. P n s s' \ bval b s \ bval b' s') c c' (P (Suc n))) \ ir_hoare (P 0) (WHILE b DO c) (WHILE b' DO c') (\s s'. \n. P n s s' \ \ bval b s \ \ bval b' s')" apply(rule ir_While_backwards_frontier_both) apply blast by(simp add: ir_While_False ir_sym flip_def) subsection "client1" text \ An example roughly equivalent to cient1 from O'Hearn~\<^cite>\"OHearn_19"\0 In particular we use the backwards variant rule to reason about the loop. \ definition client1 :: com where "client1 \ (Assign ''x'' (N 0);; (While (Less (V ''x'') (V ''n'')) ((Assign ''x'' (Plus (V ''x'') (N 1)))));; (If (BEq (V ''x'') (N 2000000)) (Assign ''low'' (V ''high'')) SKIP))" lemma client1: "\Q. ir_hoare low_eq client1 client1 Q \ (\s s'. Q s s' \ low_neq s s') \ nontrivial Q" apply(rule exI, rule conjI, simp add: client1_def) apply(rule_tac P=low_eq_strong in ir_pre) apply(rule ir_Seq) apply(rule ir_Seq) apply(rule ir_Assign_Assign) apply clarsimp apply(rule ir_pre) apply(rule ir_While_backwards_both[where P="\n s s'. low_eq_strong s s' \ s ''x'' = int n \ s' ''x'' = int n \ int n \ s ''n'' \ int n \ s' ''n''"]) apply(rule ir_post) apply(rule ir_Assign_Assign) apply clarsimp apply clarsimp apply(rule ir_If_True_True) apply(rule ir_Assign_Assign) apply(fastforce simp: low_eq_strong_def) apply(rule conjI) apply(clarsimp simp: low_eq_strong_def split: if_splits) apply clarsimp (* ugh having to manually do constraint solving here... *) apply(clarsimp simp: low_eq_strong_def nontrivial_def) apply(rule_tac x="\v. if v = ''x'' then 2000000 else if v = ''high'' then 1 else if v = ''n'' then 2000000 else if v = ''nondet'' then -1 else if v = ''low'' then 1 else undefined" in exI) apply(rule_tac x="\v. if v = ''x'' then 2000000 else if v = ''high'' then 0 else if v = ''n'' then 2000000 else if v = ''nondet'' then -1 else if v = ''low'' then 0 else undefined" in exI) apply clarsimp done subsection "client2" text \ An example akin to client2 from O'Hearn~\<^cite>\"OHearn_19"\. Note that this example is carefully written to show use of the frontier rule first to reason up to the broken loop iteration, and then we unfold the loop at that point to reason about the broken iteration, and then use the plain backwards variant rule to reason over the remainder of the loop. \ definition client2 :: com where "client2 \ (Assign ''x'' (N 0);; (While (Less (V ''x'') (N 4000000)) ((Assign ''x'' (Plus (V ''x'') (N 1)));; (If (BEq (V ''x'') (N 2000000)) (Assign ''low'' (V ''high'')) SKIP)) ) )" lemma client2: "\Q. ir_hoare low_eq client2 client2 Q \ (\s s'. Q s s' \ low_neq s s') \ nontrivial Q" apply(rule exI, rule conjI, simp add: client2_def) apply(rule_tac P=low_eq_strong in ir_pre) apply(rule ir_Seq) apply(rule ir_Assign_Assign) apply clarsimp apply(rule ir_pre) apply(rule ir_While_backwards_frontier_both[where P="\n s s'. low_eq_strong s s' \ s ''x'' = int n \ s' ''x'' = int n \ s ''x'' \ 0 \ s ''x'' \ 2000000 - 1 \ s' ''x'' \ 0 \ s' ''x'' \ 2000000 - 1"]) apply(rule ir_Seq) apply(rule ir_Assign_Assign) apply clarsimp apply(rule ir_post) apply(rule ir_If') apply(rule ir_Assign_Assign) apply(rule ir_Skip_Skip) apply clarsimp apply clarsimp apply(rule ir_While') apply clarsimp apply(rule ir_Seq) apply(rule ir_Seq) apply(rule ir_Assign_Assign) apply(rule ir_If_True_True) apply(rule ir_Assign_Assign) apply clarsimp apply(rule ir_pre) apply(rule ir_While_backwards_both[where P="\n s s'. s ''x'' = 2000000 + int n \ s' ''x'' = 2000000 + int n \ s ''x'' \ 2000000 \ s ''x'' \ 4000000 \ s' ''x'' \ 2000000 \ s' ''x'' \ 4000000 \ s ''low'' = s ''high'' \ s' ''low'' = s' ''high'' \ s ''high'' \ s' ''high''"]) apply(rule ir_Seq) apply(rule ir_Assign_Assign) apply(rule ir_If_False_False) apply fastforce apply (fastforce simp: low_eq_strong_def) apply fastforce apply(fastforce simp: low_eq_strong_def) apply(fastforce simp: low_eq_strong_def) apply(rule conjI) apply(clarsimp simp: low_eq_strong_def split: if_splits) apply clarsimp (* ugh having to manually do constraint solving here... *) apply(clarsimp simp: low_eq_strong_def nontrivial_def) apply(rule_tac x="\v. if v = ''x'' then 4000000 else if v = ''high'' then 1 else if v = ''n'' then 2000000 else if v = ''nondet'' then -1 else if v = ''low'' then 1 else undefined" in exI) apply(rule_tac x="\v. if v = ''x'' then 4000000 else if v = ''high'' then 0 else if v = ''n'' then 2000000 else if v = ''nondet'' then -1 else if v = ''low'' then 0 else undefined" in exI) apply clarsimp done end diff --git a/thys/SCC_Bloemen_Sequential/SCC_Bloemen_Sequential.thy b/thys/SCC_Bloemen_Sequential/SCC_Bloemen_Sequential.thy --- a/thys/SCC_Bloemen_Sequential/SCC_Bloemen_Sequential.thy +++ b/thys/SCC_Bloemen_Sequential/SCC_Bloemen_Sequential.thy @@ -1,3439 +1,3438 @@ section \Overview\ text \ Computing the maximal strongly connected components (SCCs) of a finite directed graph is a celebrated problem in the theory of graph algorithms. Although Tarjan's algorithm~\<^cite>\"tarjan:depth-first"\ is perhaps the best-known solution, there are many others. In his PhD thesis, Bloemen~\<^cite>\"bloemen:strong"\ presents an algorithm that is itself based on earlier algorithms by Munro~\<^cite>\"munro:efficient"\ and Dijkstra~\<^cite>\"dijkstra:finding"\. Just like these algorithms, Bloemen's solution is based on enumerating SCCs in a depth-first traversal of the graph. Gabow's algorithm that has already been formalized in Isabelle~\<^cite>\"lammich:gabow"\ also falls into this category of solutions. Nevertheless, Bloemen goes on to present a parallel variant of the algorithm suitable for execution on multi-core processors, based on clever data structures that minimize locking. In the following, we encode the sequential version of the algorithm in the proof assistant Isabelle/HOL, and prove its correctness. Bloemen's thesis briefly and informally explains why the algorithm is correct. Our proof expands on these arguments, making them completely formal. The encoding is based on a direct representation of the algorithm as a pair of mutually recursive functions; we are not aiming at extracting executable code. \ theory SCC_Bloemen_Sequential imports Main begin text \ The record below represents the variables of the algorithm. Most variables correspond to those used in Bloemen's presentation. Thus, the variable @{text \} associates to every node the set of nodes that have already been determined to be part of the same SCC. A core invariant of the algorithm will be that this mapping represents equivalence classes of nodes: for all nodes @{text v} and @{text w}, we maintain the relationship @{text "v \ \ w \ \ v = \ w."} In an actual implementation of this algorithm, this variable could conveniently be represented by a union-find structure. Variable @{text stack} holds the list of roots of these (not yet maximal) SCCs, in depth-first order, @{text visited} and @{text explored} represent the nodes that have already been seen, respectively that have been completely explored, by the algorithm, and @{text sccs} is the set of maximal SCCs that the algorithm has found so far. Additionally, the record holds some auxiliary variables that are used in the proof of correctness. In particular, @{text root} denotes the node on which the algorithm was called, @{text cstack} represents the call stack of the recursion of function @{text dfs}, and @{text vsuccs} stores the successors of each node that have already been visited by the function @{text dfss} that loops over all successors of a given node. \ record 'v env = root :: "'v" \ :: "'v \ 'v set" explored :: "'v set" visited :: "'v set" vsuccs :: "'v \ 'v set" sccs :: "'v set set" stack :: "'v list" cstack :: "'v list" text \ The algorithm is initially called with an environment that initializes the root node and trivializes all other components. \ definition init_env where "init_env v = \ root = v, \ = (\u. {u}), explored = {}, visited = {}, vsuccs = (\u. {}), sccs = {}, stack = [], cstack = [] \" \ \Make the simplifier expand let-constructions automatically.\ declare Let_def[simp] section \Auxiliary lemmas about lists\ text \ We use the precedence order on the elements that appear in a list. In particular, stacks are represented as lists, and a node @{text x} precedes another node @{text y} on the stack if @{text x} was pushed on the stack later than @{text y}. \ definition precedes ("_ \ _ in _" [100,100,100] 39) where "x \ y in xs \ \l r. xs = l @ (x # r) \ y \ set (x # r)" lemma precedes_mem: assumes "x \ y in xs" shows "x \ set xs" "y \ set xs" using assms unfolding precedes_def by auto lemma head_precedes: assumes "y \ set (x # xs)" shows "x \ y in (x # xs)" using assms unfolding precedes_def by force lemma precedes_in_tail: assumes "x \ z" shows "x \ y in (z # zs) \ x \ y in zs" using assms unfolding precedes_def by (auto simp: Cons_eq_append_conv) lemma tail_not_precedes: assumes "y \ x in (x # xs)" "x \ set xs" shows "x = y" using assms unfolding precedes_def by (metis Cons_eq_append_conv Un_iff list.inject set_append) lemma split_list_precedes: assumes "y \ set (ys @ [x])" shows "y \ x in (ys @ x # xs)" using assms unfolding precedes_def by (metis append_Cons append_assoc in_set_conv_decomp rotate1.simps(2) set_ConsD set_rotate1) lemma precedes_refl [simp]: "(x \ x in xs) = (x \ set xs)" proof assume "x \ x in xs" thus "x \ set xs" by (simp add: precedes_mem) next assume "x \ set xs" from this[THEN split_list] show "x \ x in xs" unfolding precedes_def by auto qed lemma precedes_append_left: assumes "x \ y in xs" shows "x \ y in (ys @ xs)" using assms unfolding precedes_def by (metis append.assoc) lemma precedes_append_left_iff: assumes "x \ set ys" shows "x \ y in (ys @ xs) \ x \ y in xs" (is "?lhs = ?rhs") proof assume "?lhs" then obtain l r where lr: "ys @ xs = l @ (x # r)" "y \ set (x # r)" unfolding precedes_def by blast then obtain us where "(ys = l @ us \ us @ xs = x # r) \ (ys @ us = l \ xs = us @ (x # r))" by (auto simp: append_eq_append_conv2) thus ?rhs proof assume us: "ys = l @ us \ us @ xs = x # r" with assms have "us = []" by (metis Cons_eq_append_conv in_set_conv_decomp) with us lr show ?rhs unfolding precedes_def by auto next assume us: "ys @ us = l \ xs = us @ (x # r)" with \y \ set (x # r)\ show ?rhs unfolding precedes_def by blast qed next assume "?rhs" thus "?lhs" by (rule precedes_append_left) qed lemma precedes_append_right: assumes "x \ y in xs" shows "x \ y in (xs @ ys)" using assms unfolding precedes_def by force lemma precedes_append_right_iff: assumes "y \ set ys" shows "x \ y in (xs @ ys) \ x \ y in xs" (is "?lhs = ?rhs") proof assume ?lhs then obtain l r where lr: "xs @ ys = l @ (x # r)" "y \ set (x # r)" unfolding precedes_def by blast then obtain us where "(xs = l @ us \ us @ ys = x # r) \ (xs @ us = l \ ys = us @ (x # r))" by (auto simp: append_eq_append_conv2) thus ?rhs proof assume us: "xs = l @ us \ us @ ys = x # r" with \y \ set (x # r)\ assms show ?rhs unfolding precedes_def by (metis Cons_eq_append_conv Un_iff set_append) next assume us: "xs @ us = l \ ys = us @ (x # r)" with \y \ set (x # r)\ assms show ?rhs by auto \ \contradiction\ qed next assume ?rhs thus ?lhs by (rule precedes_append_right) qed text \ Precedence determines an order on the elements of a list, provided elements have unique occurrences. However, consider a list such as @{text "[2,3,1,2]"}: then 1 precedes 2 and 2 precedes 3, but 1 does not precede 3. \ lemma precedes_trans: assumes "x \ y in xs" and "y \ z in xs" and "distinct xs" shows "x \ z in xs" using assms unfolding precedes_def - by (smt Un_iff append.assoc append_Cons_eq_iff distinct_append - not_distinct_conv_prefix set_append split_list_last) + by (metis assms(2) disjoint_iff distinct_append precedes_append_left_iff precedes_mem(2)) lemma precedes_antisym: assumes "x \ y in xs" and "y \ x in xs" and "distinct xs" shows "x = y" proof - from \x \ y in xs\ \distinct xs\ obtain as bs where 1: "xs = as @ (x # bs)" "y \ set (x # bs)" "y \ set as" unfolding precedes_def by force from \y \ x in xs\ \distinct xs\ obtain cs ds where 2: "xs = cs @ (y # ds)" "x \ set (y # ds)" "x \ set cs" unfolding precedes_def by force from 1 2 have "as @ (x # bs) = cs @ (y # ds)" by simp then obtain zs where "(as = cs @ zs \ zs @ (x # bs) = y # ds) \ (as @ zs = cs \ x # bs = zs @ (y # ds))" (is "?P \ ?Q") by (auto simp: append_eq_append_conv2) then show ?thesis proof assume "?P" with \y \ set as\ show ?thesis by (cases "zs") auto next assume "?Q" with \x \ set cs\ show ?thesis by (cases "zs") auto qed qed section \Finite directed graphs\ text \ We represent a graph as an Isabelle locale that identifies a finite set of vertices (of some base type @{text "'v"}) and associates to each vertex its set of successor vertices. \ locale graph = fixes vertices :: "'v set" and successors :: "'v \ 'v set" assumes vfin: "finite vertices" and sclosed: "\x \ vertices. successors x \ vertices" context graph begin abbreviation edge where "edge x y \ y \ successors x" text \ We inductively define reachability of nodes in the graph. \ inductive reachable where reachable_refl[iff]: "reachable x x" | reachable_succ[elim]: "\edge x y; reachable y z\ \ reachable x z" lemma reachable_edge: "edge x y \ reachable x y" by auto lemma succ_reachable: assumes "reachable x y" and "edge y z" shows "reachable x z" using assms by induct auto lemma reachable_trans: assumes y: "reachable x y" and z: "reachable y z" shows "reachable x z" using assms by induct auto text \ In order to derive a `reverse'' induction rule for @{const "reachable"}, we define an alternative reachability predicate and prove that the two coincide. \ inductive reachable_end where re_refl[iff]: "reachable_end x x" | re_succ: "\reachable_end x y; edge y z\ \ reachable_end x z" lemma succ_re: assumes y: "edge x y" and z: "reachable_end y z" shows "reachable_end x z" using z y by (induction) (auto intro: re_succ) lemma reachable_re: assumes "reachable x y" shows "reachable_end x y" using assms by (induction) (auto intro: succ_re) lemma re_reachable: assumes "reachable_end x y" shows "reachable x y" using assms by (induction) (auto intro: succ_reachable) lemma reachable_end_induct: assumes r: "reachable x y" and base: "\x. P x x" and step: "\x y z. \P x y; edge y z\ \ P x z" shows "P x y" using r[THEN reachable_re] proof (induction) case (re_refl x) from base show ?case . next case (re_succ x y z) with step show ?case by blast qed text \ We also need the following variant of reachability avoiding certain edges. More precisely, @{text y} is reachable from @{text x} avoiding a set @{text E} of edges if there exists a path such that no edge from @{text E} appears along the path. \ inductive reachable_avoiding where ra_refl[iff]: "reachable_avoiding x x E" | ra_succ[elim]: "\reachable_avoiding x y E; edge y z; (y,z) \ E\ \ reachable_avoiding x z E" lemma edge_ra: assumes "edge x y" and "(x,y) \ E" shows "reachable_avoiding x y E" using assms by (meson reachable_avoiding.simps) lemma ra_trans: assumes 1: "reachable_avoiding x y E" and 2: "reachable_avoiding y z E" shows "reachable_avoiding x z E" using 2 1 by induction auto lemma ra_cases: assumes "reachable_avoiding x y E" shows "x=y \ (\z. z \ successors x \ (x,z) \ E \ reachable_avoiding z y E)" using assms proof (induction) case (ra_refl x S) then show ?case by simp next case (ra_succ x y S z) then show ?case by (metis ra_refl reachable_avoiding.ra_succ) qed lemma ra_mono: assumes "reachable_avoiding x y E" and "E' \ E" shows "reachable_avoiding x y E'" using assms by induction auto lemma ra_add_edge: assumes "reachable_avoiding x y E" shows "reachable_avoiding x y (E \ {(v,w)}) \ (reachable_avoiding x v (E \ {(v,w)}) \ reachable_avoiding w y (E \ {(v,w)}))" using assms proof (induction) case (ra_refl x E) then show ?case by simp next case (ra_succ x y E z) then show ?case using reachable_avoiding.ra_succ by auto qed text \ Reachability avoiding some edges obviously implies reachability. Conversely, reachability implies reachability avoiding the empty set. \ lemma ra_reachable: "reachable_avoiding x y E \ reachable x y" by (induction rule: reachable_avoiding.induct) (auto intro: succ_reachable) lemma ra_empty: "reachable_avoiding x y {} = reachable x y" proof assume "reachable_avoiding x y {}" thus "reachable x y" by (rule ra_reachable) next assume "reachable x y" hence "reachable_end x y" by (rule reachable_re) thus "reachable_avoiding x y {}" by induction auto qed section \Strongly connected components\ text \ A strongly connected component is a set @{text S} of nodes such that any two nodes in @{text S} are reachable from each other. This concept is represented by the predicate @{text "is_subscc"} below. We are ultimately interested in non-empty, maximal strongly connected components, represented by the predicate @{text "is_scc"}. \ definition is_subscc where "is_subscc S \ \x \ S. \y \ S. reachable x y" definition is_scc where "is_scc S \ S \ {} \ is_subscc S \ (\S'. S \ S' \ is_subscc S' \ S' = S)" lemma subscc_add: assumes "is_subscc S" and "x \ S" and "reachable x y" and "reachable y x" shows "is_subscc (insert y S)" using assms unfolding is_subscc_def by (metis insert_iff reachable_trans) lemma sccE: \ \Two nodes that are reachable from each other are in the same SCC.\ assumes "is_scc S" and "x \ S" and "reachable x y" and "reachable y x" shows "y \ S" using assms unfolding is_scc_def by (metis insertI1 subscc_add subset_insertI) lemma scc_partition: \ \Two SCCs that contain a common element are identical.\ assumes "is_scc S" and "is_scc S'" and "x \ S \ S'" shows "S = S'" using assms unfolding is_scc_def is_subscc_def by (metis IntE assms(2) sccE subsetI) section \Algorithm for computing strongly connected components\ text \ We now introduce our representation of Bloemen's algorithm in Isabelle/HOL. The auxiliary function @{text unite} corresponds to the inner \textsf{while} loop in Bloemen's pseudo-code~\<^cite>\\p.32\ in "bloemen:strong"\. It is applied to two nodes @{text v} and @{text w} (and the environment @{text e} holding the current values of the program variables) when a loop is found, i.e.\ when @{text w} is a successor of @{text v} in the graph that has already been visited in the depth-first search. In that case, the root of the SCC of node @{text w} determined so far must appear below the root of @{text v}'s SCC in the @{text stack} maintained by the algorithm. The effect of the function is to merge the SCCs of all nodes on the top of the stack above (and including) @{text w}. Node @{text w}'s root will be the root of the merged SCC. \ definition unite :: "'v \ 'v \ 'v env \ 'v env" where "unite v w e \ let pfx = takeWhile (\x. w \ \ e x) (stack e); sfx = dropWhile (\x. w \ \ e x) (stack e); cc = \ { \ e x | x . x \ set pfx \ {hd sfx} } in e\\ := \x. if x \ cc then cc else \ e x, stack := sfx\" text \ We now represent the algorithm as two mutually recursive functions @{text dfs} and @{text dfss} in Isabelle/HOL. The function @{text dfs} corresponds to Bloemen's function \textsf{SetBased}, whereas @{text dfss} corresponds to the \textsf{forall} loop over the successors of the node on which @{text dfs} was called. Instead of using global program variables in imperative style, our functions explicitly pass environments that hold the current values of these variables. A technical complication in the development of the algorithm in Isabelle is the fact that the functions need not terminate when their pre-conditions (introduced below) are violated, for example when @{text dfs} is called for a node that was already visited previously. We therefore cannot prove termination at this point, but will later show that the explicitly given pre-conditions ensure termination. \ function (domintros) dfs :: "'v \ 'v env \ 'v env" and dfss :: "'v \ 'v env \ 'v env" where "dfs v e = (let e1 = e\visited := visited e \ {v}, stack := (v # stack e), cstack := (v # cstack e)\; e' = dfss v e1 in if v = hd(stack e') then e'\sccs := sccs e' \ {\ e' v}, explored := explored e' \ (\ e' v), stack := tl(stack e'), cstack := tl(cstack e')\ else e'\cstack := tl(cstack e')$$" | "dfss v e = (let vs = successors v - vsuccs e v in if vs = {} then e else let w = SOME x. x \ vs; e' = (if w \ explored e then e else if w \ visited e then dfs w e else unite v w e); e'' = (e'\vsuccs := (\x. if x=v then vsuccs e' v \ {w} else vsuccs e' x)\) in dfss v e'')" by pat_completeness (force+) section \Definition of the predicates used in the correctness proof\ text \ Environments are partially ordered according to the following definition. \ definition sub_env where "sub_env e e' \ root e' = root e \ visited e \ visited e' \ explored e \ explored e' \ (\v. vsuccs e v \ vsuccs e' v) \ (\ v. \ e v \ \ e' v) \ (\ {\ e v | v . v \ set (stack e)}) \ (\ {\ e' v | v . v \ set (stack e')}) " lemma sub_env_trans: assumes "sub_env e e'" and "sub_env e' e''" shows "sub_env e e''" using assms unfolding sub_env_def by (metis (no_types, lifting) subset_trans) text \ The set @{text "unvisited e u"} contains all edges @{text "(a,b)"} such that node @{text a} is in the same SCC as node @{text u} and the edge has not yet been followed, in the sense represented by variable @{text vsuccs}. \ definition unvisited where "unvisited e u \ {(a,b) | a b. a \ \ e u \ b \ successors a - vsuccs e a}" subsection \Main invariant\ text \ The following definition characterizes well-formed environments. This predicate will be shown to hold throughout the execution of the algorithm. In words, it asserts the following facts: \begin{itemize} \item Only nodes reachable from the root (for which the algorithm was originally called) are visited. \item The two stacks @{text stack} and @{text cstack} do not contain duplicate nodes, and @{text stack} contains a subset of the nodes on @{text cstack}, in the same order. \item Any node higher on the @{text stack} (i.e., that was pushed later) is reachable from nodes lower in the @{text stack}. This property also holds for nodes on the call stack, but this is not needed for the correctness proof. \item Every explored node, and every node on the call stack, has been visited. \item Nodes reachable from fully explored nodes have themselves been fully explored. \item The set @{text "vsuccs e n"}, for any node @{text n}, is a subset of @{text n}'s successors, and all these nodes are in @{text visited}. The set is empty if @{text "n \ visited"}, and it contains all successors if @{text n} has been fully explored or if @{text n} has been visited, but is no longer on the call stack. \item The sets @{text "\ e n"} represent an equivalence relation. The equivalence classes of nodes that have not yet been visited are singletons. Also, equivalence classes for two distinct nodes on the @{text stack} are disjoint because the stack only stores roots of SCCs, and the union of the equivalence classes for these root nodes corresponds to the set of live nodes, i.e. those nodes that have already been visited but not yet fully explored. \item More precisely, an equivalence class is represented on the stack by the oldest node in the sense of the call order: any node in the class that is still on the call stack precedes the representative on the call stack and was therefore pushed later. \item Equivalence classes represent the maximal available information about strong connectedness: nodes represented by some node @{text n} on the @{text stack} can reach some node @{text m} that is lower in the stack only by taking an edge from some node in @{text n}'s equivalence class that has not yet been followed. (Remember that @{text m} can reach @{text n} by one of the previous conjuncts.) \item Equivalence classes represent partial SCCs in the sense of the predicate @{text is_subscc}. Variable @{text sccs} holds maximal SCCs in the sense of the predicate @{text is_scc}, and their union corresponds to the set of explored nodes. \end{itemize} \ definition wf_env where "wf_env e \ (\n \ visited e. reachable (root e) n) \ distinct (stack e) \ distinct (cstack e) \ (\n m. n \ m in stack e \ n \ m in cstack e) \ (\n m. n \ m in stack e \ reachable m n) \ explored e \ visited e \ set (cstack e) \ visited e \ (\n \ explored e. \m. reachable n m \ m \ explored e) \ (\n. vsuccs e n \ successors n \ visited e) \ (\n. n \ visited e \ vsuccs e n = {}) \ (\n \ explored e. vsuccs e n = successors n) \ (\n \ visited e - set (cstack e). vsuccs e n = successors n) \ (\n m. m