Hint Resolve shatter_word_0.
Definition weq : forall sz (x y : word sz), {x = y} + {x <> y}.
refine (fix weq sz (x : word sz) : forall y : word sz, {x = y} + {x <> y} :=
match x in word sz return forall y : word sz, {x = y} + {x <> y} with
| WO => fun _ => left _ _
| WS b x' => fun y => if bool_dec b (whd y)
then if weq _ x' (wtl y) then left _ _ else right _ _
else right _ _
end); clear weq.
abstract (symmetry; apply shatter_word_0).
abstract (subst; symmetry; apply (shatter_word (n:=S _) _)).
let y' := y in (* kludge around warning of mechanically generated names not playing well with [abstract] *)
abstract (rewrite (shatter_word y'); simpl; intro H; injection H; intros;
eauto using inj_pair2_eq_dec, eq_nat_dec).
let y' := y in (* kludge around warning of mechanically generated names not playing well with [abstract] *)
abstract (rewrite (shatter_word y'); simpl; intro H; injection H; auto).
Defined.
Fixpoint weqb sz (x : word sz) : word sz -> bool :=
match x in word sz return word sz -> bool with
| WO => fun _ => true
| WS b x' => fun y =>
if eqb b (whd y)
then if @weqb _ x' (wtl y) then true else false
else false
end.
(** * Combining and splitting *)
Fixpoint combine (sz1 : nat) (w : word sz1) : forall sz2, word sz2 -> word (sz1 + sz2) :=
match w in word sz1 return forall sz2, word sz2 -> word (sz1 + sz2) with
| WO => fun _ w' => w'
| WS b w' => fun _ w'' => WS b (combine w' w'')
end.
Fixpoint split1 (sz1 sz2 : nat) : word (sz1 + sz2) -> word sz1 :=
match sz1 with
| O => fun _ => WO
| S sz1' => fun w => WS (whd w) (split1 sz1' sz2 (wtl w))
end.
Fixpoint split2 (sz1 sz2 : nat) : word (sz1 + sz2) -> word sz2 :=
match sz1 with
| O => fun w => w
| S sz1' => fun w => split2 sz1' sz2 (wtl w)
end.
(** * Extension operators *)
Definition sext (sz : nat) (w : word sz) (sz' : nat) : word (sz + sz') :=
if wmsb w false then
combine w (wones sz')
else
combine w (wzero sz').
Definition zext (sz : nat) (w : word sz) (sz' : nat) : word (sz + sz') :=
combine w (wzero sz').
(** * Arithmetic *)
Definition wneg sz (x : word sz) : word sz :=
NToWord sz (Npow2 sz - wordToN x).
Definition wordBin (f : N -> N -> N) sz (x y : word sz) : word sz :=
NToWord sz (f (wordToN x) (wordToN y)).
Definition wplus := wordBin Nplus.
Definition wmult := wordBin Nmult.
Definition wdiv := wordBin N.div.
Definition wmod := wordBin Nmod.
Definition wmult' sz (x y : word sz) : word sz :=
split2 sz sz (NToWord (sz + sz) (Nmult (wordToN x) (wordToN y))).
Definition wminus sz (x y : word sz) : word sz := wplus x (wneg y).
Definition wnegN sz (x : word sz) : word sz :=
natToWord sz (pow2 sz - wordToNat x).
Definition wordBinN (f : nat -> nat -> nat) sz (x y : word sz) : word sz :=
natToWord sz (f (wordToNat x) (wordToNat y)).
Definition wplusN := wordBinN plus.
Definition wmultN := wordBinN mult.
Definition wmultN' sz (x y : word sz) : word sz :=
split2 sz sz (natToWord (sz + sz) (mult (wordToNat x) (wordToNat y))).
Definition wminusN sz (x y : word sz) : word sz := wplusN x (wnegN y).
Module Import ArithmeticNotations.
Notation "w ~ 1" := (WS true w) : word_scope.
Notation "w ~ 0" := (WS false w) : word_scope.
Notation "^~" := wneg : word_scope.
Notation "l ^+ r" := (@wplus _ l%word r%word) : word_scope.
Notation "l ^* r" := (@wmult _ l%word r%word) : word_scope.
Notation "l ^- r" := (@wminus _ l%word r%word) : word_scope.
Notation "l ^/ r" := (@wdiv _ l%word r%word) : word_scope.
Notation "l ^% r" := (@wmod _ l%word r%word) : word_scope.
End ArithmeticNotations.
(** * Bitwise operators *)
Fixpoint wnot sz (w : word sz) : word sz :=
match w with
| WO => WO
| WS b w' => WS (negb b) (wnot w')
end.
Fixpoint bitwp (f : bool -> bool -> bool) sz (w1 : word sz) : word sz -> word sz :=
match w1 with
| WO => fun _ => WO
| WS b w1' => fun w2 => WS (f b (whd w2)) (bitwp f w1' (wtl w2))
end.
Definition wnot' sz := bitwp xorb (wones sz).
Definition wor := bitwp orb.
Definition wand := bitwp andb.
Definition wxor := bitwp xorb.
Module Import BitwiseNotations.
Notation "l ^| r" := (@wor _ l%word r%word) : word_scope.
Notation "l ^& r" := (@wand _ l%word r%word) : word_scope.
End BitwiseNotations.
(** * Conversion to and from [Z] *)
Definition wordToZ sz (w : word sz) : Z :=
if wmsb w false then
(** Negative **)
match wordToN (wneg w) with
| N0 => 0%Z
| Npos x => Zneg x
end
else
(** Positive **)
match wordToN w with
| N0 => 0%Z
| Npos x => Zpos x
end.
Definition uwordToZ sz (w : word sz) : Z := Z.of_N (wordToN w).
Definition ZToWord (sz : nat) (z : Z) : word sz :=
match z with
| Z0 => wzero' sz
| Zpos x => posToWord sz x
| Zneg x => wneg (posToWord sz x)
end.
(** * Arithmetic by [Z] *)
Definition wordBinZ (f : Z -> Z -> Z) sz (x y : word sz) : word sz :=
ZToWord sz (f (wordToZ x) (wordToZ y)).
Definition wplusZ := wordBinZ Z.add.
Definition wminusZ := wordBinZ Z.sub.
Definition wmultZ := wordBinZ Z.mul.
Definition wmultZsu sz (x y : word sz) :=
ZToWord sz (Z.mul (wordToZ x) (Z.of_N (wordToN y))).
Definition wdivZ := wordBinZ Z.quot.
Definition wdivZsu sz (x y : word sz) :=
ZToWord sz (Z.div (wordToZ x) (Z.of_N (wordToN y))).
Definition wremZ := wordBinZ Z.rem.
Definition wremZsu sz (x y : word sz) :=
ZToWord sz (Z.modulo (wordToZ x) (Z.of_N (wordToN y))).
(** * Comparison predicates and deciders *)
Definition wlt sz (l r : word sz) : Prop :=
N.lt (wordToN l) (wordToN r).
Definition wslt sz (l r : word sz) : Prop :=
Z.lt (wordToZ l) (wordToZ r).
Module Import ComparisonNotations.
Notation "w1 > w2" := (@wlt _ w2%word w1%word) : word_scope.
Notation "w1 >= w2" := (~(@wlt _ w1%word w2%word)) : word_scope.
Notation "w1 < w2" := (@wlt _ w1%word w2%word) : word_scope.
Notation "w1 <= w2" := (~(@wlt _ w2%word w1%word)) : word_scope.
Notation "w1 '>s' w2" := (@wslt _ w2%word w1%word) : word_scope.
Notation "w1 '>s=' w2" := (~(@wslt _ w1%word w2%word)) : word_scope.
Notation "w1 '<s' w2" := (@wslt _ w1%word w2%word) : word_scope.
Notation "w1 '<s=' w2" := (~(@wslt _ w2%word w1%word)) : word_scope.
End ComparisonNotations.
Definition wlt_dec : forall sz (l r : word sz), {l < r} + {l >= r}.
refine (fun sz l r =>
match N.compare (wordToN l) (wordToN r) as k return N.compare (wordToN l) (wordToN r) = k -> _ with
| Lt => fun pf => left _ _
| _ => fun pf => right _ _
end (refl_equal _));
abstract congruence.
Defined.
Definition wslt_dec : forall sz (l r : word sz), {l <s r} + {l >s= r}.
refine (fun sz l r =>
match Z.compare (wordToZ l) (wordToZ r) as c return Z.compare (wordToZ l) (wordToZ r) = c -> _ with
| Lt => fun pf => left _ _
| _ => fun pf => right _ _
end (refl_equal _));
abstract congruence.
Defined.
Definition wltb{sz: nat}(l r: word sz): bool := BinNat.N.ltb (wordToN l) (wordToN r).
Definition wsltb{sz: nat}(l r: word sz): bool := Z.ltb (wordToZ l) (wordToZ r).
Module Import ConversionNotations.
Notation "$ n" := (natToWord _ n) : word_scope.
Notation "# n" := (wordToNat n).
End ConversionNotations.
(** * Bit shifting *)
Fact sz_minus_nshift : forall sz nshift, (nshift < sz)%nat -> sz = sz - nshift + nshift.
Fact nshift_plus_nkeep : forall sz nshift, (nshift < sz)%nat -> nshift + (sz - nshift) = sz.
Definition wlshift (sz : nat) (w : word sz) (n : nat) : word sz.
refine (split1 sz n _).
rewrite plus_comm.
exact (combine (wzero n) w).
Defined.
Definition wrshift (sz : nat) (w : word sz) (n : nat) : word sz.
refine (split2 n sz _).
rewrite plus_comm.
exact (combine w (wzero n)).
Defined.
Definition wrshifta (sz : nat) (w : word sz) (n : nat) : word sz.
refine (split2 n sz _).
rewrite plus_comm.
exact (sext w _).
Defined.
(* Redefine shifts so that they do not use eq_rect, which matches on add_comm, which is an opaque proof, which makes cbv blow up. If you ever want to reduce terms inside Coq with cbv, you should use the shifts below!  *)
Definition wlshift' {sz : nat} (w : word sz) (n : nat) : word sz.
refine (split1 sz n (nat_cast _ _ _)).
apply PeanoNat.Nat.add_comm.
exact (combine (wzero n) w).
Defined.
Definition wrshift' {sz : nat} (w : word sz) (n : nat) : word sz.
refine (split2 n sz (nat_cast _ _ _)).
apply PeanoNat.Nat.add_comm.
exact (combine w (wzero n)).
Defined.
Definition wrshifta' {sz : nat} (w : word sz) (n : nat) : word sz.
refine (split2 n sz (nat_cast _ _ _)).
apply PeanoNat.Nat.add_comm.
exact (sext w _).
Defined.
Definition extz {sz} (w: word sz) (n: nat) := combine (wzero n) w.
Fixpoint wpow2 sz: word (S sz) :=
match sz with
| O => WO~1
| S sz' => (wpow2 sz')~0
end.
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.

(* Specifications: *)
Theorem eq_rect_word_offset : forall n n' offset w Heq,
eq_rect n (fun n => word (offset + n)) w n' Heq =
eq_rect (offset + n) (fun n => word n) w (offset + n') (eq_rect_word_offset_helper _ _ _ Heq).
Theorem eq_rect_word_mult : forall n n' scale w Heq,
eq_rect n (fun n => word (n * scale)) w n' Heq =
eq_rect (n * scale) (fun n => word n) w (n' * scale) (eq_rect_word_mult_helper _ _ _ Heq).
Theorem eq_rect_word_match : forall n n' (w : word n) (H : n = n'),
match H in (_ = N) return (word N) with
| eq_refl => w
end = eq_rect n (fun n => word n) w n' H.
Theorem whd_match : forall n n' (w : word (S n)) (Heq : S n = S n'),
whd w = whd (match Heq in (_ = N) return (word N) with
| eq_refl => w
end).
Theorem wtl_match : forall n n' (w : word (S n)) (Heq : S n = S n') (Heq' : n = n'),
(match Heq' in (_ = N) return (word N) with
| eq_refl => wtl w
end) = wtl (match Heq in (_ = N) return (word N) with
| eq_refl => w
end).
Theorem word0: forall (w : word 0), w = WO.
Theorem wordToNat_wordToNat' : forall sz (w : word sz),
wordToNat w = wordToNat' w.
Theorem natToWord_wordToNat : forall sz w, natToWord sz (wordToNat w) = w.
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.