# HG changeset patch # User haftmann # Date 1520710619 0 # Node ID 2249b27ab1dd1a209be4fe517daa749510d01f42 # Parent 8b3d9a91706ea3512ad24939c395972c9543af76 abstract algebraic bit operations diff -r 8b3d9a91706e -r 2249b27ab1dd src/HOL/Divides.thy --- a/src/HOL/Divides.thy Sat Mar 10 20:24:00 2018 +0100 +++ b/src/HOL/Divides.thy Sat Mar 10 19:36:59 2018 +0000 @@ -901,6 +901,9 @@ by simp qed +instance int :: semiring_bits + by standard (simp_all add: pos_zmod_mult_2 pos_zdiv_mult_2 zdiv_zmult2_eq zmod_zmult2_eq) + subsubsection \Quotients of Signs\ diff -r 8b3d9a91706e -r 2249b27ab1dd src/HOL/Parity.thy --- a/src/HOL/Parity.thy Sat Mar 10 20:24:00 2018 +0100 +++ b/src/HOL/Parity.thy Sat Mar 10 19:36:59 2018 +0000 @@ -188,6 +188,10 @@ "a mod 2 = of_bool (odd a)" by (auto elim: oddE) +lemma of_bool_odd_eq_mod_2: + "of_bool (odd a) = a mod 2" + by (simp add: mod_2_eq_odd) + lemma one_mod_2_pow_eq [simp]: "1 mod (2 ^ n) = of_bool (n > 0)" proof - @@ -198,6 +202,10 @@ finally show ?thesis . qed +lemma one_div_2_pow_eq [simp]: + "1 div (2 ^ n) = of_bool (n = 0)" + using div_mult_mod_eq [of 1 "2 ^ n"] by auto + lemma even_of_nat [simp]: "even (of_nat a) \ even a" proof - @@ -356,7 +364,7 @@ subclass comm_ring_1 .. -lemma even_minus [simp]: +lemma even_minus: "even (- a) \ even a" by (fact dvd_minus_iff) @@ -589,19 +597,173 @@ instance int :: ring_parity by standard (simp_all add: dvd_eq_mod_eq_0 divide_int_def division_segment_int_def) -lemma even_diff_iff [simp]: +lemma even_diff_iff: "even (k - l) \ even (k + l)" for k l :: int - using dvd_add_times_triv_right_iff [of 2 "k - l" l] by (simp add: mult_2_right) + by (fact even_diff) -lemma even_abs_add_iff [simp]: +lemma even_abs_add_iff: "even (\k\ + l) \ even (k + l)" for k l :: int - by (cases "k \ 0") (simp_all add: ac_simps) + by simp -lemma even_add_abs_iff [simp]: +lemma even_add_abs_iff: "even (k + \l\) \ even (k + l)" for k l :: int - using even_abs_add_iff [of l k] by (simp add: ac_simps) + by simp lemma even_nat_iff: "0 \ k \ even (nat k) \ even k" by (simp add: even_of_nat [of "nat k", where ?'a = int, symmetric]) + +class semiring_bits = semiring_parity + + assumes div_mult2_eq': "a div (of_nat m * of_nat n) = a div of_nat m div of_nat n" + and mod_mult2_eq': "a mod (of_nat m * of_nat n) = of_nat m * (a div of_nat m mod of_nat n) + a mod of_nat m" + \ \maybe this specifications can be simplified, + or even derived (partially) in @{class unique_euclidean_semiring}\ +begin + +text \The primary purpose of the following operations is + to avoid ad-hoc simplification of concrete expressions @{term "2 ^ n"}\ + +definition bit_push :: "nat \ 'a \ 'a" + where bit_push_eq_mult: "bit_push n a = a * 2 ^ n" + +definition bit_take :: "nat \ 'a \ 'a" + where bit_take_eq_mod: "bit_take n a = a mod of_nat (2 ^ n)" + +definition bit_drop :: "nat \ 'a \ 'a" + where bit_drop_eq_div: "bit_drop n a = a div of_nat (2 ^ n)" + +lemma bit_ident: + "bit_push n (bit_drop n a) + bit_take n a = a" + using div_mult_mod_eq by (simp add: bit_push_eq_mult bit_take_eq_mod bit_drop_eq_div) + +lemma bit_take_bit_take [simp]: + "bit_take n (bit_take n a) = bit_take n a" + by (simp add: bit_take_eq_mod) + +lemma bit_take_0 [simp]: + "bit_take 0 a = 0" + by (simp add: bit_take_eq_mod) + +lemma bit_take_Suc [simp]: + "bit_take (Suc n) a = bit_take n (a div 2) * 2 + of_bool (odd a)" +proof - + have "1 + 2 * (a div 2) mod (2 * 2 ^ n) = (a div 2 * 2 + a mod 2) mod (2 * 2 ^ n)" + if "odd a" + using that mod_mult2_eq' [of "1 + 2 * (a div 2)" 2 "2 ^ n"] + by (simp add: ac_simps odd_iff_mod_2_eq_one mult_mod_right) + also have "\ = a mod (2 * 2 ^ n)" + by (simp only: div_mult_mod_eq) + finally show ?thesis + by (simp add: bit_take_eq_mod algebra_simps mult_mod_right) +qed + +lemma bit_take_of_0 [simp]: + "bit_take n 0 = 0" + by (simp add: bit_take_eq_mod) + +lemma bit_take_plus: + "bit_take n (bit_take n a + bit_take n b) = bit_take n (a + b)" + by (simp add: bit_take_eq_mod mod_simps) + +lemma bit_take_of_1_eq_0_iff [simp]: + "bit_take n 1 = 0 \ n = 0" + by (simp add: bit_take_eq_mod) + +lemma bit_push_eq_0_iff [simp]: + "bit_push n a = 0 \ a = 0" + by (simp add: bit_push_eq_mult) + +lemma bit_drop_0 [simp]: + "bit_drop 0 = id" + by (simp add: fun_eq_iff bit_drop_eq_div) + +lemma bit_drop_of_0 [simp]: + "bit_drop n 0 = 0" + by (simp add: bit_drop_eq_div) + +lemma bit_drop_Suc [simp]: + "bit_drop (Suc n) a = bit_drop n (a div 2)" +proof (cases "even a") + case True + then obtain b where "a = 2 * b" .. + moreover have "bit_drop (Suc n) (2 * b) = bit_drop n b" + by (simp add: bit_drop_eq_div) + ultimately show ?thesis + by simp +next + case False + then obtain b where "a = 2 * b + 1" .. + moreover have "bit_drop (Suc n) (2 * b + 1) = bit_drop n b" + using div_mult2_eq' [of "1 + b * 2" 2 "2 ^ n"] + by (auto simp add: bit_drop_eq_div ac_simps) + ultimately show ?thesis + by simp +qed + +lemma bit_drop_half: + "bit_drop n (a div 2) = bit_drop n a div 2" + by (induction n arbitrary: a) simp_all + +lemma bit_drop_of_bool [simp]: + "bit_drop n (of_bool d) = of_bool (n = 0 \ d)" + by (cases n) simp_all + +lemma even_bit_take_eq [simp]: + "even (bit_take n a) \ n = 0 \ even a" + by (cases n) (simp_all add: bit_take_eq_mod dvd_mod_iff) + +lemma bit_push_0_id [simp]: + "bit_push 0 = id" + by (simp add: fun_eq_iff bit_push_eq_mult) + +lemma bit_push_of_0 [simp]: + "bit_push n 0 = 0" + by (simp add: bit_push_eq_mult) + +lemma bit_push_of_1: + "bit_push n 1 = 2 ^ n" + by (simp add: bit_push_eq_mult) + +lemma bit_push_Suc [simp]: + "bit_push (Suc n) a = bit_push n (a * 2)" + by (simp add: bit_push_eq_mult ac_simps) + +lemma bit_push_double: + "bit_push n (a * 2) = bit_push n a * 2" + by (simp add: bit_push_eq_mult ac_simps) + +lemma bit_drop_bit_take [simp]: + "bit_drop n (bit_take n a) = 0" + by (simp add: bit_drop_eq_div bit_take_eq_mod) + +lemma bit_take_bit_drop_commute: + "bit_drop m (bit_take n a) = bit_take (n - m) (bit_drop m a)" + for m n :: nat +proof (cases "n \ m") + case True + moreover define q where "q = n - m" + ultimately have "n - m = q" and "n = m + q" + by simp_all + moreover have "bit_drop m (bit_take (m + q) a) = bit_take q (bit_drop m a)" + using mod_mult2_eq' [of a "2 ^ m" "2 ^ q"] + by (simp add: bit_drop_eq_div bit_take_eq_mod power_add) + ultimately show ?thesis + by simp +next + case False + moreover define q where "q = m - n" + ultimately have "m - n = q" and "m = n + q" + by simp_all + moreover have "bit_drop (n + q) (bit_take n a) = 0" + using div_mult2_eq' [of "a mod 2 ^ n" "2 ^ n" "2 ^ q"] + by (simp add: bit_drop_eq_div bit_take_eq_mod power_add div_mult2_eq) + ultimately show ?thesis + by simp +qed + end + +instance nat :: semiring_bits + by standard (simp_all add: mod_Suc Suc_double_not_eq_double div_mult2_eq mod_mult2_eq) + +end diff -r 8b3d9a91706e -r 2249b27ab1dd src/HOL/Set_Interval.thy --- a/src/HOL/Set_Interval.thy Sat Mar 10 20:24:00 2018 +0100 +++ b/src/HOL/Set_Interval.thy Sat Mar 10 19:36:59 2018 +0000 @@ -1929,6 +1929,24 @@ lemma sum_diff_distrib: "\x. Q x \ P x \ (\xxxk = 0..k = 0..k = Suc 0..k = Suc 0..k = 0..Shifting bounds\ diff -r 8b3d9a91706e -r 2249b27ab1dd src/HOL/ex/Word_Type.thy --- a/src/HOL/ex/Word_Type.thy Sat Mar 10 20:24:00 2018 +0100 +++ b/src/HOL/ex/Word_Type.thy Sat Mar 10 19:36:59 2018 +0000 @@ -9,82 +9,32 @@ "HOL-Library.Type_Length" begin -subsection \Truncating bit representations of numeric types\ - -class semiring_bits = semiring_parity + - assumes semiring_bits: "(1 + 2 * a) mod of_nat (2 * n) = 1 + 2 * (a mod of_nat n)" -begin - -definition bitrunc :: "nat \ 'a \ 'a" - where bitrunc_eq_mod: "bitrunc n a = a mod of_nat (2 ^ n)" - -lemma bitrunc_bitrunc [simp]: - "bitrunc n (bitrunc n a) = bitrunc n a" - by (simp add: bitrunc_eq_mod) - -lemma bitrunc_0 [simp]: - "bitrunc 0 a = 0" - by (simp add: bitrunc_eq_mod) +lemma bit_take_uminus: + fixes k :: int + shows "bit_take n (- (bit_take n k)) = bit_take n (- k)" + by (simp add: bit_take_eq_mod mod_minus_eq) -lemma bitrunc_Suc [simp]: - "bitrunc (Suc n) a = bitrunc n (a div 2) * 2 + of_bool (odd a)" -proof - - have "1 + 2 * (a div 2) mod (2 * 2 ^ n) = (a div 2 * 2 + a mod 2) mod (2 * 2 ^ n)" - if "odd a" - using that semiring_bits [of "a div 2" "2 ^ n"] - by (simp add: algebra_simps odd_iff_mod_2_eq_one mult_mod_right) - also have "\ = a mod (2 * 2 ^ n)" - by (simp only: div_mult_mod_eq) - finally show ?thesis - by (simp add: bitrunc_eq_mod algebra_simps mult_mod_right) -qed - -lemma bitrunc_of_0 [simp]: - "bitrunc n 0 = 0" - by (simp add: bitrunc_eq_mod) - -lemma bitrunc_plus: - "bitrunc n (bitrunc n a + bitrunc n b) = bitrunc n (a + b)" - by (simp add: bitrunc_eq_mod mod_simps) +lemma bit_take_minus: + fixes k l :: int + shows "bit_take n (bit_take n k - bit_take n l) = bit_take n (k - l)" + by (simp add: bit_take_eq_mod mod_diff_eq) -lemma bitrunc_of_1_eq_0_iff [simp]: - "bitrunc n 1 = 0 \ n = 0" - by (simp add: bitrunc_eq_mod) - -end - -instance nat :: semiring_bits - by standard (simp add: mod_Suc Suc_double_not_eq_double) - -instance int :: semiring_bits - by standard (simp add: pos_zmod_mult_2) - -lemma bitrunc_uminus: +lemma bit_take_nonnegative [simp]: fixes k :: int - shows "bitrunc n (- (bitrunc n k)) = bitrunc n (- k)" - by (simp add: bitrunc_eq_mod mod_minus_eq) + shows "bit_take n k \ 0" + by (simp add: bit_take_eq_mod) -lemma bitrunc_minus: - fixes k l :: int - shows "bitrunc n (bitrunc n k - bitrunc n l) = bitrunc n (k - l)" - by (simp add: bitrunc_eq_mod mod_diff_eq) - -lemma bitrunc_nonnegative [simp]: - fixes k :: int - shows "bitrunc n k \ 0" - by (simp add: bitrunc_eq_mod) +definition signed_bit_take :: "nat \ int \ int" + where signed_bit_take_eq_bit_take: + "signed_bit_take n k = bit_take (Suc n) (k + 2 ^ n) - 2 ^ n" -definition signed_bitrunc :: "nat \ int \ int" - where signed_bitrunc_eq_bitrunc: - "signed_bitrunc n k = bitrunc (Suc n) (k + 2 ^ n) - 2 ^ n" - -lemma signed_bitrunc_eq_bitrunc': +lemma signed_bit_take_eq_bit_take': assumes "n > 0" - shows "signed_bitrunc (n - Suc 0) k = bitrunc n (k + 2 ^ (n - 1)) - 2 ^ (n - 1)" - using assms by (simp add: signed_bitrunc_eq_bitrunc) + shows "signed_bit_take (n - Suc 0) k = bit_take n (k + 2 ^ (n - 1)) - 2 ^ (n - 1)" + using assms by (simp add: signed_bit_take_eq_bit_take) -lemma signed_bitrunc_0 [simp]: - "signed_bitrunc 0 k = - (k mod 2)" +lemma signed_bit_take_0 [simp]: + "signed_bit_take 0 k = - (k mod 2)" proof (cases "even k") case True then have "odd (k + 1)" @@ -92,54 +42,54 @@ then have "(k + 1) mod 2 = 1" by (simp add: even_iff_mod_2_eq_zero) with True show ?thesis - by (simp add: signed_bitrunc_eq_bitrunc) + by (simp add: signed_bit_take_eq_bit_take) next case False then show ?thesis - by (simp add: signed_bitrunc_eq_bitrunc odd_iff_mod_2_eq_one) + by (simp add: signed_bit_take_eq_bit_take odd_iff_mod_2_eq_one) qed -lemma signed_bitrunc_Suc [simp]: - "signed_bitrunc (Suc n) k = signed_bitrunc n (k div 2) * 2 + k mod 2" - by (simp add: odd_iff_mod_2_eq_one signed_bitrunc_eq_bitrunc algebra_simps) +lemma signed_bit_take_Suc [simp]: + "signed_bit_take (Suc n) k = signed_bit_take n (k div 2) * 2 + k mod 2" + by (simp add: odd_iff_mod_2_eq_one signed_bit_take_eq_bit_take algebra_simps) -lemma signed_bitrunc_of_0 [simp]: - "signed_bitrunc n 0 = 0" - by (simp add: signed_bitrunc_eq_bitrunc bitrunc_eq_mod) +lemma signed_bit_take_of_0 [simp]: + "signed_bit_take n 0 = 0" + by (simp add: signed_bit_take_eq_bit_take bit_take_eq_mod) -lemma signed_bitrunc_of_minus_1 [simp]: - "signed_bitrunc n (- 1) = - 1" +lemma signed_bit_take_of_minus_1 [simp]: + "signed_bit_take n (- 1) = - 1" by (induct n) simp_all -lemma signed_bitrunc_eq_iff_bitrunc_eq: +lemma signed_bit_take_eq_iff_bit_take_eq: assumes "n > 0" - shows "signed_bitrunc (n - Suc 0) k = signed_bitrunc (n - Suc 0) l \ bitrunc n k = bitrunc n l" (is "?P \ ?Q") + shows "signed_bit_take (n - Suc 0) k = signed_bit_take (n - Suc 0) l \ bit_take n k = bit_take n l" (is "?P \ ?Q") proof - from assms obtain m where m: "n = Suc m" by (cases n) auto show ?thesis proof assume ?Q - have "bitrunc (Suc m) (k + 2 ^ m) = - bitrunc (Suc m) (bitrunc (Suc m) k + bitrunc (Suc m) (2 ^ m))" - by (simp only: bitrunc_plus) + have "bit_take (Suc m) (k + 2 ^ m) = + bit_take (Suc m) (bit_take (Suc m) k + bit_take (Suc m) (2 ^ m))" + by (simp only: bit_take_plus) also have "\ = - bitrunc (Suc m) (bitrunc (Suc m) l + bitrunc (Suc m) (2 ^ m))" + bit_take (Suc m) (bit_take (Suc m) l + bit_take (Suc m) (2 ^ m))" by (simp only: \?Q\ m [symmetric]) - also have "\ = bitrunc (Suc m) (l + 2 ^ m)" - by (simp only: bitrunc_plus) + also have "\ = bit_take (Suc m) (l + 2 ^ m)" + by (simp only: bit_take_plus) finally show ?P - by (simp only: signed_bitrunc_eq_bitrunc m) simp + by (simp only: signed_bit_take_eq_bit_take m) simp next assume ?P with assms have "(k + 2 ^ (n - Suc 0)) mod 2 ^ n = (l + 2 ^ (n - Suc 0)) mod 2 ^ n" - by (simp add: signed_bitrunc_eq_bitrunc' bitrunc_eq_mod) + by (simp add: signed_bit_take_eq_bit_take' bit_take_eq_mod) then have "(i + (k + 2 ^ (n - Suc 0))) mod 2 ^ n = (i + (l + 2 ^ (n - Suc 0))) mod 2 ^ n" for i by (metis mod_add_eq) then have "k mod 2 ^ n = l mod 2 ^ n" by (metis add_diff_cancel_right' uminus_add_conv_diff) then show ?Q - by (simp add: bitrunc_eq_mod) + by (simp add: bit_take_eq_mod) qed qed @@ -148,7 +98,7 @@ subsubsection \Basic properties\ -quotient_type (overloaded) 'a word = int / "\k l. bitrunc LENGTH('a) k = bitrunc LENGTH('a::len0) l" +quotient_type (overloaded) 'a word = int / "\k l. bit_take LENGTH('a) k = bit_take LENGTH('a::len0) l" by (auto intro!: equivpI reflpI sympI transpI) instantiation word :: (len0) "{semiring_numeral, comm_semiring_0, comm_ring}" @@ -164,19 +114,19 @@ lift_definition plus_word :: "'a word \ 'a word \ 'a word" is plus - by (subst bitrunc_plus [symmetric]) (simp add: bitrunc_plus) + by (subst bit_take_plus [symmetric]) (simp add: bit_take_plus) lift_definition uminus_word :: "'a word \ 'a word" is uminus - by (subst bitrunc_uminus [symmetric]) (simp add: bitrunc_uminus) + by (subst bit_take_uminus [symmetric]) (simp add: bit_take_uminus) lift_definition minus_word :: "'a word \ 'a word \ 'a word" is minus - by (subst bitrunc_minus [symmetric]) (simp add: bitrunc_minus) + by (subst bit_take_minus [symmetric]) (simp add: bit_take_minus) lift_definition times_word :: "'a word \ 'a word \ 'a word" is times - by (auto simp add: bitrunc_eq_mod intro: mod_mult_cong) + by (auto simp add: bit_take_eq_mod intro: mod_mult_cong) instance by standard (transfer; simp add: algebra_simps)+ @@ -209,7 +159,7 @@ begin lift_definition unsigned :: "'b::len0 word \ 'a" - is "of_nat \ nat \ bitrunc LENGTH('b)" + is "of_nat \ nat \ bit_take LENGTH('b)" by simp lemma unsigned_0 [simp]: @@ -231,8 +181,8 @@ begin lift_definition signed :: "'b::len word \ 'a" - is "of_int \ signed_bitrunc (LENGTH('b) - 1)" - by (simp add: signed_bitrunc_eq_iff_bitrunc_eq [symmetric]) + is "of_int \ signed_bit_take (LENGTH('b) - 1)" + by (simp add: signed_bit_take_eq_iff_bit_take_eq [symmetric]) lemma signed_0 [simp]: "signed 0 = 0" @@ -241,8 +191,8 @@ end lemma unsigned_of_nat [simp]: - "unsigned (of_nat n :: 'a word) = bitrunc LENGTH('a::len) n" - by transfer (simp add: nat_eq_iff bitrunc_eq_mod zmod_int) + "unsigned (of_nat n :: 'a word) = bit_take LENGTH('a::len) n" + by transfer (simp add: nat_eq_iff bit_take_eq_mod zmod_int) lemma of_nat_unsigned [simp]: "of_nat (unsigned a) = a" @@ -257,17 +207,17 @@ lemma word_eq_iff_signed: "a = b \ signed a = signed b" - by safe (transfer; auto simp add: signed_bitrunc_eq_iff_bitrunc_eq) + by safe (transfer; auto simp add: signed_bit_take_eq_iff_bit_take_eq) end lemma signed_of_int [simp]: - "signed (of_int k :: 'a word) = signed_bitrunc (LENGTH('a::len) - 1) k" + "signed (of_int k :: 'a word) = signed_bit_take (LENGTH('a::len) - 1) k" by transfer simp lemma of_int_signed [simp]: "of_int (signed a) = a" - by transfer (simp add: signed_bitrunc_eq_bitrunc bitrunc_eq_mod mod_simps) + by transfer (simp add: signed_bit_take_eq_bit_take bit_take_eq_mod mod_simps) subsubsection \Properties\ @@ -279,11 +229,11 @@ begin lift_definition divide_word :: "'a word \ 'a word \ 'a word" - is "\a b. bitrunc LENGTH('a) a div bitrunc LENGTH('a) b" + is "\a b. bit_take LENGTH('a) a div bit_take LENGTH('a) b" by simp lift_definition modulo_word :: "'a word \ 'a word \ 'a word" - is "\a b. bitrunc LENGTH('a) a mod bitrunc LENGTH('a) b" + is "\a b. bit_take LENGTH('a) a mod bit_take LENGTH('a) b" by simp instance .. @@ -297,11 +247,11 @@ begin lift_definition less_eq_word :: "'a word \ 'a word \ bool" - is "\a b. bitrunc LENGTH('a) a \ bitrunc LENGTH('a) b" + is "\a b. bit_take LENGTH('a) a \ bit_take LENGTH('a) b" by simp lift_definition less_word :: "'a word \ 'a word \ bool" - is "\a b. bitrunc LENGTH('a) a < bitrunc LENGTH('a) b" + is "\a b. bit_take LENGTH('a) a < bit_take LENGTH('a) b" by simp instance @@ -318,7 +268,7 @@ lemma word_less_iff_unsigned: "a < b \ unsigned a < unsigned b" - by (transfer fixing: less) (auto dest: preorder_class.le_less_trans [OF bitrunc_nonnegative]) + by (transfer fixing: less) (auto dest: preorder_class.le_less_trans [OF bit_take_nonnegative]) end