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.

Theorem roundTrip_1 : forall sz, wordToNat (natToWord (S sz) 1) = 1.