Module Import ShiftNotations.
Notation "l ^<< r" := (@wlshift' _ l%word r) : word_scope.
Notation "l ^>> r" := (@wrshift' _ l%word r) : word_scope.
End ShiftNotations.
(** * Setting an individual bit *)
Definition wbit sz sz' (n : word sz') := natToWord sz (pow2 (wordToNat n)).
(*! Facts *)
Hint Rewrite div2_double div2_S_double: div2.
Local Hint Resolve mod2_S_double mod2_double.
induction w as [|b]; rewrite wordToNat_wordToNat'; intuition; f_equal; unfold natToWord, wordToNat'; fold natToWord; fold wordToNat';
destruct b; f_equal; autorewrite with div2; intuition.
Qed.
induction sz; simpl; intuition.
Qed.
Hint Rewrite roundTrip_0 : wordToNat.
induction sz as [|sz IHsz]; simpl; intro w; intuition; repeat rewrite untimes2.
exists w; intuition.
case_eq (mod2 w); intro Hmw.
specialize (IHsz (div2 w)); firstorder.
rewrite wordToNat_wordToNat' in *.
let x' := match goal with H : _ + ?x * _ = _ |- _ => x end in
rename x' into x. (* force non-auto-generated name *)
exists x; intuition.
rewrite mult_assoc.
rewrite (mult_comm x 2).
rewrite mult_comm. simpl mult at 1.
rewrite (plus_Sn_m (2 * wordToNat' (natToWord sz (div2 w)))).
rewrite <- mult_assoc.
rewrite <- mult_plus_distr_l.
rewrite H; clear H.
symmetry; apply div2_odd; auto.
specialize (IHsz (div2 w)); firstorder.
let x' := match goal with H : _ + ?x * _ = _ |- _ => x end in
rename x' into x. (* force non-auto-generated name *)
exists x; intuition.
rewrite mult_assoc.
rewrite (mult_comm x 2).
rewrite <- mult_assoc.
rewrite mult_comm.
rewrite <- mult_plus_distr_l.
match goal with H : _ |- _ => rewrite H; clear H end.
symmetry; apply div2_even; auto.
Qed.
intros b1 b2 sz w1 w2 ? H0; intuition.
apply (f_equal (@whd _)) in H0; tauto.
apply (f_equal (@wtl _)) in H0; tauto.
Qed.
Ltac shatterer := simpl; intuition;
match goal with
| [ w : _ |- _ ] => rewrite (shatter_word w); simpl
end; f_equal; auto.
induction sz1; shatterer.
Qed.
induction sz1; shatterer.
Qed.
induction sz1; shatterer.
Qed.
Hint Rewrite combine_split.
Hint Rewrite split1_combine.
Hint Rewrite split2_combine.
induction w1 as [|?? w1 IHw1]; simpl; intros n2 n3 w2 w3 Heq; intuition.
rewrite (UIP_dec eq_nat_dec Heq (refl_equal _)); reflexivity.
rewrite (IHw1 _ _ _ _ (plus_assoc _ _ _)); clear IHw1.
repeat match goal with
| [ |- context[match ?pf with refl_equal => _ end] ] => generalize pf
end.
generalize dependent (combine w1 (combine w2 w3)).
rewrite plus_assoc; intros w Heq0 e.
rewrite (UIP_dec eq_nat_dec e (refl_equal _)).
rewrite (UIP_dec eq_nat_dec Heq0 (refl_equal _)).
reflexivity.
Qed.
induction n1 as [|n1 IHn1]; simpl; intros n2 n3 Heq w; intuition.
rewrite (UIP_dec eq_nat_dec Heq (refl_equal _)); reflexivity.
rewrite (IHn1 _ _ (plus_assoc _ _ _)).
f_equal.
apply wtl_match.
Qed.
induction n1 as [|n1 IHn1]; simpl; intros n2 n3 Heq w.
rewrite (UIP_dec eq_nat_dec Heq (refl_equal _)).
apply combine_split.
rewrite (shatter_word w) in *.
simpl.
eapply trans_eq; [ | apply IHn1 with (Heq := plus_assoc _ _ _) ]; clear IHn1.
repeat f_equal.
repeat match goal with
| [ |- context[match ?pf with refl_equal => _ end] ] => generalize pf
end.
simpl.
generalize dependent w.
rewrite plus_assoc.
intros.
rewrite (UIP_dec eq_nat_dec e (refl_equal _)).
rewrite (UIP_dec eq_nat_dec Heq0 (refl_equal _)).
reflexivity.
Qed.
Fact eq_rect_combine_dist_helper1 : forall a b c d, b * c = d -> (a + b) * c = a * c + d.
Local Hint Extern 1 (@eq nat _ _) => omega.
induction n as [n] using strong; intros.
destruct n; simpl in *.
elimtype False; omega.
destruct n; simpl in *; auto.
destruct k as [|k]; simpl in *.
discriminate.
apply H with k; auto.
Qed.
unfold wzero; induction sz; simpl; intuition.
congruence.
Qed.
induction p as [ p IHp | p IHp | ]; destruct sz; simpl; intuition; f_equal; try rewrite wzero'_def in *.
rewrite ZL6.
destruct (ZL4 p) as [x Heq]; rewrite Heq; simpl.
replace (x + S x) with (S (2 * x)) by omega.
symmetry; apply mod2_S_double.
rewrite IHp.
rewrite ZL6.
destruct (nat_of_P p); simpl; intuition.
replace (n + S n) with (S (2 * n)) by omega.
rewrite div2_S_double; auto.
unfold nat_of_P; simpl.
rewrite ZL6.
replace (nat_of_P p + nat_of_P p) with (2 * nat_of_P p) by omega.
symmetry; apply mod2_double.
rewrite IHp.
unfold nat_of_P; simpl.
rewrite ZL6.
replace (nat_of_P p + nat_of_P p) with (2 * nat_of_P p) by omega.
rewrite div2_double.
auto.
auto.
Qed.
destruct n; simpl; intuition; try rewrite wzero'_def in *.
auto.
apply posToWord_nat.
Qed.
unfold wplusN, wplus, wordBinN, wordBin; intros.
repeat rewrite wordToN_nat; repeat rewrite NToWord_nat.
rewrite nat_of_Nplus.
repeat rewrite nat_of_N_of_nat.
reflexivity.
Qed.
unfold wmultN, wmult, wordBinN, wordBin; intros.
repeat rewrite wordToN_nat; repeat rewrite NToWord_nat.
rewrite nat_of_Nmult.
repeat rewrite nat_of_N_of_nat.
reflexivity.
Qed.
unfold wnegN, wneg; intros.
repeat rewrite wordToN_nat; repeat rewrite NToWord_nat.
rewrite nat_of_Nminus.
do 2 f_equal.
apply Npow2_nat.
apply nat_of_N_of_nat.
Qed.
intros; unfold wminusN, wminus; rewrite wneg_alt; apply wplus_alt.
Qed.
intros; rewrite wplus_alt; unfold wplusN, wordBinN; intros.
rewrite roundTrip_0; apply natToWord_wordToNat.
Qed.
intros; repeat rewrite wplus_alt; unfold wplusN, wordBinN; f_equal; auto.
Qed.
Local Hint Extern 1 (_ <= _)%nat => omega.
intros sz x y z *; repeat rewrite wplus_alt; unfold wplusN, wordBinN; intros.
repeat match goal with
| [ |- context[wordToNat (natToWord ?sz ?w)] ] =>
let Heq := fresh "Heq" in
destruct (wordToNat_natToWord sz w) as [? [Heq ?]]; rewrite Heq
end.
match goal with
| [ |- context[wordToNat ?x + wordToNat ?y - ?x1 * pow2 ?sz + wordToNat ?z] ]
=> replace (wordToNat x + wordToNat y - x1 * pow2 sz + wordToNat z)
with (wordToNat x + wordToNat y + wordToNat z - x1 * pow2 sz) by auto
end.
match goal with
| [ |- context[wordToNat ?x + (wordToNat ?y + wordToNat ?z - ?x0 * pow2 ?sz)] ]
=> replace (wordToNat x + (wordToNat y + wordToNat z - x0 * pow2 sz))
with (wordToNat x + wordToNat y + wordToNat z - x0 * pow2 sz) by auto
end.
repeat rewrite drop_sub; auto.
Qed.
induction sz; simpl in *; intuition.
Qed.
intros sz x b. rewrite wordToNat_wordToNat'.
destruct b; simpl.
rewrite untimes2.
case_eq (2 * wordToNat x); intuition.
eapply mod2_S; eauto.
rewrite <- (mod2_double (wordToNat x)); f_equal; omega.
Qed.
destruct b; rewrite wordToNat_wordToNat'; unfold wordToNat'; fold wordToNat'.
apply div2_S_double.
apply div2_double.
Qed.
intros sz x; rewrite wmult_alt; unfold wmultN, wordBinN; intros.
destruct sz; simpl.
rewrite (shatter_word x); reflexivity.
rewrite roundTrip_0; simpl.
rewrite plus_0_r.
rewrite (shatter_word x).
f_equal.
apply mod2_WS.
rewrite div2_WS.
apply natToWord_wordToNat.
Qed.
intros; repeat rewrite wmult_alt; unfold wmultN, wordBinN; auto with arith.
Qed.
intros sz x y z; repeat rewrite wmult_alt; unfold wmultN, wordBinN; intros.
repeat match goal with
| [ |- context[wordToNat (natToWord ?sz ?w)] ] =>
let Heq := fresh "Heq" in
destruct (wordToNat_natToWord sz w) as [? [Heq ?]]; rewrite Heq
end.
rewrite mult_minus_distr_l.
rewrite mult_minus_distr_r.
match goal with
| [ |- natToWord _ (_ - _ * (?x0' * _)) = natToWord _ (_ - ?x1' * _ * _) ]
=> rename x0' into x0, x1' into x1 (* force the names to not be autogenerated *)
end.
rewrite (mult_assoc (wordToNat x) x0).
rewrite <- (mult_assoc x1).
rewrite (mult_comm (pow2 sz)).
rewrite (mult_assoc x1).
repeat rewrite drop_sub; auto with arith.
rewrite (mult_comm x1).
rewrite <- (mult_assoc (wordToNat x)).
rewrite (mult_comm (wordToNat y)).
rewrite mult_assoc.
rewrite (mult_comm (wordToNat x)).
repeat rewrite <- mult_assoc.
auto with arith.
repeat rewrite <- mult_assoc.
auto with arith.
Qed.
intros sz x y z; repeat rewrite wmult_alt; repeat rewrite wplus_alt; unfold wmultN, wplusN, wordBinN; intros.
repeat match goal with
| [ |- context[wordToNat (natToWord ?sz ?w)] ] =>
let Heq := fresh "Heq" in
destruct (wordToNat_natToWord sz w) as [? [Heq ?]]; rewrite Heq
end.
rewrite mult_minus_distr_r.
match goal with
| [ |- natToWord _ (_ - ?x0' * _ * _) = natToWord _ (_ - ?x1' * _ + (_ - ?x2' * _)) ]
=> rename x0' into x0, x1' into x1, x2' into x2 (* force the names to not be autogenerated *)
end.
rewrite <- (mult_assoc x0).
rewrite (mult_comm (pow2 sz)).
rewrite (mult_assoc x0).
replace (wordToNat x * wordToNat z - x1 * pow2 sz +
(wordToNat y * wordToNat z - x2 * pow2 sz))
with (wordToNat x * wordToNat z + wordToNat y * wordToNat z - x1 * pow2 sz - x2 * pow2 sz).
repeat rewrite drop_sub; auto with arith.
rewrite (mult_comm x0).
rewrite (mult_comm (wordToNat x + wordToNat y)).
rewrite <- (mult_assoc (wordToNat z)).
auto with arith.
generalize dependent (wordToNat x * wordToNat z).
generalize dependent (wordToNat y * wordToNat z).
intros.
omega.
Qed.
reflexivity.
Qed.
induction w as [|b]; simpl; intuition.
destruct b; simpl; omega.
Qed.
induction sz as [|sz]; simpl; intuition.
generalize (div2_double (pow2 sz)); simpl; intro Hr; rewrite Hr; clear Hr.
f_equal.
generalize (mod2_double (pow2 sz)); auto.
auto.
Qed.
intros sz x; rewrite wneg_alt; rewrite wplus_alt; unfold wnegN, wplusN, wzero, wordBinN; intros.
repeat match goal with
| [ |- context[wordToNat (natToWord ?sz ?w)] ] =>
let Heq := fresh "Heq" in
destruct (wordToNat_natToWord sz w) as [? [Heq ?]]; rewrite Heq
end.
match goal with
| [ |- context[wordToNat ?x + (pow2 ?sz - wordToNat ?x - ?x0 * pow2 ?sz)] ]
=> replace (wordToNat x + (pow2 sz - wordToNat x - x0 * pow2 sz))
with (pow2 sz - x0 * pow2 sz)
end.
rewrite drop_sub; auto with arith.
apply natToWord_pow2.
generalize (wordToNat_bound x).
omega.
Qed.
Definition wring (sz : nat) : ring_theory (wzero sz) (wone sz) (@wplus sz) (@wmult sz) (@wminus sz) (@wneg sz) (@eq _) :=
mk_rt _ _ _ _ _ _ _
(@wplus_unit _) (@wplus_comm _) (@wplus_assoc _)
(@wmult_unit _) (@wmult_comm _) (@wmult_assoc _)
(@wmult_plus_distr _) (@wminus_def _) (@wminus_inv _).
Arguments weqb_sound : clear implicits.
Ltac is_nat_cst n :=
match eval hnf in n with
| O => constr:(true)
| S ?n' => is_nat_cst n'
| _ => constr:(false)
end.
Ltac isWcst w :=
match eval hnf in w with
| WO => constr:(true)
| WS ?b ?w' =>
match eval hnf in b with
| true => isWcst w'
| false => isWcst w'
| _ => constr:(false)
end
| natToWord _ ?n => is_nat_cst n
| _ => constr:(false)
end.
Ltac wcst w :=
let b := isWcst w in
match b with
| true => w
| _ => constr:(NotConstant)
end.
(* Here's how you can add a ring for a specific bit-width. There doesn't seem to be a polymorphic method, so this code really does need to be copied. *)
(* Definition wring8 := wring 8. Add Ring wring8 : wring8 (decidable (weqb_sound 8), constants [wcst]). *)
Ltac noptac x := idtac.
Ltac PackWring sz F :=
let RNG := (fun proj => proj
inv_morph_nothing inv_morph_nothing noptac noptac
(word sz) (@eq (word sz)) (wzero sz) (wone sz)
(@wplus sz) (@wmult sz) (@wminus sz) (@wneg sz)
(BinNums.Z) (BinNums.N) (id_phi_N)
(pow_N (wone sz) (@wmult sz))
(ring_correct (@Eqsth (word sz))
(Eq_ext _ _ _)
(Rth_ARth (@Eqsth (word sz)) (Eq_ext _ _ _) (wring sz))
(gen_phiZ_morph (@Eqsth (word sz)) (Eq_ext _ _ _) (wring sz))
(pow_N_th _ _ (@Eqsth (word sz)))
(triv_div_th (@Eqsth (word sz))
(Eq_ext _ _ _)
(Rth_ARth (@Eqsth (word sz)) (Eq_ext _ _ _) (wring sz))
(gen_phiZ_morph (@Eqsth (word sz)) (Eq_ext _ _ _) (wring sz)))
)
tt) in
F RNG (@nil (word sz)) (@nil (word sz)).
Ltac ring_sz sz := PackWring sz Ring_gen.
Fact bitwp_wtl : forall sz (w w' : word (S sz)) op, bitwp op (wtl w) (wtl w') = wtl (bitwp op w w').
Fact eq_rect_bitwp' : forall a b Heq f w1 w2,
eq_rect b word (bitwp f w1 w2) a Heq = bitwp f (eq_rect b word w1 a Heq) (eq_rect b word w2 a Heq).
Fact eq_rect_bitwp_1 : forall a b Heq f w1 w2,
bitwp f (eq_rect a word w1 b Heq) w2 = eq_rect a word (bitwp f w1 (eq_rect b word w2 a (eq_sym Heq))) b Heq.
Definition wbring (sz : nat) : semi_ring_theory (wzero sz) (wones sz) (@wor sz) (@wand sz) (@eq _) :=
mk_srt _ _ _ _ _
(@wor_unit _) (@wor_comm _) (@wor_assoc _)
(@wand_unit _) (@wand_kill _) (@wand_comm _) (@wand_assoc _)
(@wand_or_distr _).
(** * Inequality proofs *)
Ltac word_simpl := unfold sext, zext, wzero in *; simpl in *.
Ltac word_eq := ring.
Ltac word_eq1 := match goal with
| _ => ring
| [ H : _ = _ |- _ ] => ring [H]
end.
intros; intro; subst.
unfold wminus in H.
rewrite wminus_inv in H.
tauto.
Qed.
Ltac word_neq := apply word_neq; let H := fresh "H" in intro H; simpl in H; ring_simplify in H; try discriminate.
Ltac word_contra := match goal with
| [ H : _ <> _ |- False ] => apply H; ring
end.
Ltac word_contra1 := match goal with
| [ H : _ <> _ |- False ] => apply H;
match goal with
| _ => ring
| [ H' : _ = _ |- _ ] => ring [H']
end
end.
Hint Resolve word_neq lt_le eq_le sub_0_eq le_neq_lt : worder.
Ltac shatter_word x :=
match type of x with
| word 0 => try rewrite (shatter_word_0 x) in *
| word (S ?N) =>
let x' := fresh in
let H := fresh in
destruct (@shatter_word_S N x) as [ ? [ x' H ] ];
rewrite H in *; clear H; shatter_word x'
end.
(** * Some more useful derived facts *)
destruct sz as [|sz]; intros n m; intuition.
rewrite wplus_alt.
unfold wplusN, wordBinN.
destruct (wordToNat_natToWord (S sz) n); intuition.
destruct (wordToNat_natToWord (S sz) m); intuition.
do 2 match goal with H : _ |- _ => rewrite H; clear H end.
match goal with
| [ |- context[?n - ?x * pow2 (S ?sz) + (?m - ?x0 * pow2 (S ?sz))] ]
=> replace (n - x * pow2 (S sz) + (m - x0 * pow2 (S sz))) with (n + m - x * pow2 (S sz) - x0 * pow2 (S sz))
by omega
end.
repeat rewrite drop_sub; auto; omega.
Qed.
intros sz n; change (S n) with (1 + n); apply natToWord_plus.
Qed.
intros sz n m H H0 H1.
apply (f_equal (@wordToNat _)) in H.
destruct (wordToNat_natToWord sz n) as [x H2].
destruct (wordToNat_natToWord sz m) as [x0 H3].
intuition.
match goal with
| [ H : wordToNat ?x = wordToNat ?y, H' : wordToNat ?x = ?a, H'' : wordToNat ?y = ?b |- _ ]
=> let H0 := fresh in assert (H0 : a = b) by congruence; clear H H' H''; rename H0 into H
end.
assert (x = 0).
destruct x; auto.
simpl in *.
generalize dependent (x * pow2 sz).
intros.
omega.
assert (x0 = 0).
destruct x0; auto.
simpl in *.
generalize dependent (x0 * pow2 sz).
intros.
omega.
subst; simpl in *; omega.
Qed.
intros sz n H.
destruct (wordToNat_natToWord sz n) as [x]; intuition.
destruct x as [|x].
simpl in *; omega.
simpl in *.
apply Nlt_out in H.
autorewrite with N in *.
rewrite Npow2_nat in *.
generalize dependent (x * pow2 sz).
intros; omega.
Qed.
intros sz a b c H.
apply (f_equal (fun x => x ^+ ^~ c)) in H.
repeat rewrite <- wplus_assoc in H.
rewrite wminus_inv in H.
repeat rewrite (wplus_comm _ (wzero sz)) in H.
repeat rewrite wplus_unit in H.
assumption.
Qed.
Hint Resolve lt_word_le_nat.
Ltac wlt_ind :=
match goal with
| [ |- forall (n: word ?len), ?P ] =>
refine (well_founded_ind (@wlt_wf len) (fun n => P) _)
end.
Definition bit_dec : forall (a : word 1), {a = $0} + {a = $1}.
intro.
rewrite (shatter_word a).
replace (wtl a) with WO by auto.
destruct (whd a).
right; apply eq_refl.
left; apply eq_refl.
Defined.

Theorem wlshift_bitwp : forall sz (w1 w2 : word sz) f n,
wlshift (bitwp f w1 w2) n = split1 sz n (
eq_rec _ word (combine (wzero n) (bitwp f w1 w2)) _ (eq_sym (Nat.add_comm sz n))).