(* ================================================================== *)
Section EX.

Variables (A:Set) (P : A->Prop).
Variable Q:Prop.

(* Check the type of an expression. *)
Check P.
Check Set.
Check A -> Prop.

Variable a:A.

Check P a.

Lemma trivial : forall x:A, P x -> P x.
Proof.
  intros.
  assumption.
Qed.

(* Prints the definition of an identifier. *)
Print trivial.

Lemma example : forall x:A, (Q -> Q -> P x) -> Q -> P x.
Proof using .
  intros x H H0.
  apply H.
  assumption.
  assumption.
Qed.

Print example.

Proposition nova : Q -> ~ ~ Q.
Proof.
  intros.
  unfold not.
  intros.
  apply H0.
  assumption.
Qed.           (* when we close the proof the definition of the identifier
                  "nova" goes to the global environment *)

Theorem demo : forall y,  Q -> (~ ~ Q -> P y) -> P y.
Proof.
  intros.
  apply H0.
  apply nova.   (* we can use a definition in the global environment *)
  assumption.
Qed.

End EX.

Print trivial.
Print example.
(* ================================================================== *)

(* ================================================================== *)
(* ====================== Propositional Logic ======================= *)
(* ================================================================== *)

Section ExamplesPL.

Variables Q P :Prop.

Lemma ex1 : (P -> Q) -> ~Q -> ~P.
Proof.
  tauto.
Qed.

Print ex1.

Lemma ex1' : (P -> Q) -> ~Q -> ~P.
Proof.
  intros.
  intro.
  apply H0.
  apply H.
  assumption.
Qed.

Print ex1'.

Lemma ex2 : P /\ Q -> Q /\ P.
Proof.
  intro H.
  split.
  destruct H as [H1 H2].
  exact H2.
  destruct H; assumption.
Qed.

(* We can itemize the subgoals using - for each of them. Note that whem entering in this mode the other subgoals are not displayed. For nested item use the symbols -, +, *, --, ++, **, ... *)
Lemma ex2' : P /\ Q -> Q /\ P.
Proof.
  intro H.  split.
  - destruct H as [H1 H2]. exact H2.
  - destruct H; assumption.
Qed.

Lemma ex3 : P \/ Q -> Q \/ P.
Proof.
  intros.
  destruct H as [h1 | h2].
  - right. assumption.
  - left; assumption.
Qed.

Theorem ex4 : forall A:Prop, A -> ~~A.
Proof.
  intros.
  intro.
  unfold not in H0.
  apply H0.
  exact H.
Qed.

Lemma ex4' : forall A:Prop, A -> ~~A.
Proof.
  intros.
  red.     (* does only the unfolding of the head of the goal *)
  intro.
  unfold not in H0.   (* unfold – applies the delta rule for a transparent constant. *)
  apply H0; assumption.   (* exact (H0 H) *)
Qed.

Axiom double_neg_law : forall A:Prop, ~~A -> A.  (* classical *)

(* CAUTION: Axiom is a global declaration.
   Even after the section is closed double_neg_law is assume in the enviroment, and can be used.
   If we want to avoid this we should declare double_neg_law using the command Hypothesis.
*)

Lemma ex5 : (~Q -> ~P) -> P -> Q.   (* this result is only valid classically *)
Proof.
  intros.
  apply double_neg_law.
  intro.
  (* apply H; assumption. *)
  apply H.
  - assumption.
  - assumption.
Qed.

Lemma ex6 : (P\/Q)/\~P -> Q.
Proof.
  intros.
  elim H. intros .
  destruct H0.
  - contradiction.
  - assumption.
Qed.

Lemma ex7 : ~(P \/ Q) <-> ~P /\ ~Q.
Proof.
  red.
  split.
  - intros.
    split.
    + unfold not in H.
      intro H1.
      apply H.
      left; assumption.
    + intro H1; apply H; right; assumption.
  - intros H H1.
    destruct H.
    destruct H1.
    + contradiction.
    + contradiction.
Qed.

Lemma ex7' : ~(P \/ Q) <-> ~P /\ ~Q.
Proof.
  tauto.
Qed.

Variable B :Prop.
Variable C :Prop.

(* exercise *)
Lemma ex8 : (P->Q) /\ (B->C) /\ P /\ B -> Q/\C.
Proof using .
  intros.
  destruct H.
  destruct H0.
  destruct H1.
  split.
  - apply H. assumption.
  - apply H0. assumption.
Qed.

(* exercise *)
Lemma ex9 : ~ (P /\ ~P).
Proof using .
  red.
  intro.
  destruct H.
  apply H0.
  assumption.
Qed.

End ExamplesPL.

(* ================================================================== *)
(* =======================  First-Order Logic ======================= *)
(* ================================================================== *)

Section ExamplesFOL.

Variable X :Set.
Variable t :X.
Variables R W : X -> Prop.

Lemma ex10 : R(t) -> (forall x, R(x)->~W(x)) -> ~W(t).
Proof.
  intros.
  apply H0.
  exact H.
Qed.

Lemma ex11 : forall x, R x -> exists x, R x.
Proof.
  intros.
  exists x.
  assumption.
Qed.

Lemma ex11' : forall x, R x -> exists x, R x.
Proof.
  firstorder.
Qed.

Lemma ex12 : (exists x, ~(R x)) -> ~ (forall x, R x).
Proof.
  intros H H1.
  destruct H as [x0 H0].
  apply H0.
  apply H1.
Qed.

(* Exercise *)
Lemma ex13 : (forall x, R x) \/ (forall x, W x) -> forall x, (R x) \/ (W x).
Proof using .
  intros.
  destruct H as [H1|H2].
  - left.
    apply H1.
  - right.
    apply H2.
Qed.

Variable G : X->X->Prop.

(* Exercise *)
Lemma ex14 : (exists x, exists y, (G x y)) -> exists y, exists x, (G x y).
Proof.
  intros.
  firstorder.
Qed.

(* Exercise *)
Proposition ex15: (forall x, W x)/\(forall x, R x) -> (forall x, W x /\ R x).
Proof.
  firstorder.
Qed.

(* ------- Note that we can have nested sections ----------- *)
Section Relations.

Variable D : Set.
Variable Rel : D->D->Prop.

Hypothesis R_symmetric : forall x y:D, Rel x y -> Rel y x.
Hypothesis R_transitive : forall x y z:D, Rel x y -> Rel y z -> Rel x z.

Lemma refl_if : forall x:D, (exists y, Rel x y) -> Rel x x.
Proof.
  intros.
  destruct H.
  (* try "apply R_transitive" to see de error message *)
  apply R_transitive with x0.
  - assumption.
  - apply R_symmetric.
    assumption.
Qed.

Check refl_if.

End Relations.

Check refl_if. (* Note the difference after the end of the section Relations. *)

(* ====== OTHER USES OF AXIOMS ====== *)

(* --- A stack abstract data type --- *)
Section Stack.

Variable U:Type.

Parameter stack : Type -> Type.
Parameter emptyS : stack U.
Parameter push : U -> stack U -> stack U.
Parameter pop : stack U -> stack U.
Parameter top : stack U -> U.
Parameter isEmpty : stack U -> Prop.

Axiom emptyS_isEmpty : isEmpty emptyS.
Axiom push_notEmpty : forall x s, ~isEmpty (push x s).
Axiom pop_push : forall x s, pop (push x s) = s.
Axiom top_push : forall x s, top (push x s) = x.

End Stack.

Check pop_push.

(* Now we can make use of stacks in our formalisation!!! *)

(* A NOTE OF CAUTION!!! *)
(* The capability to extend the underlying theory with arbitary axiom
   is a powerful but dangerous mechanism. We must avoid inconsistency.
*)
Section Caution.

Check False_ind.

Hypothesis ABSURD : False.

Theorem oops : forall (P:Prop), P /\ ~P.
elim ABSURD.
Qed.

End Caution. (* We have declared ABSURD as an hypothesis to avoid its use outside this section. *)


(** Fixed precision machine words *)

Require Import Coq.Arith.Arith Coq.Arith.Div2 Coq.NArith.NArith Coq.Bool.Bool Coq.omega.Omega.
Require Import Bedrock.Nomega.

Set Implicit Arguments.

(** * Basic definitions and conversion to and from [nat] *)

Inductive word : nat -> Set :=
| WO : word O
| WS : bool -> forall n, word n -> word (S n).

Fixpoint wordToNat sz (w : word sz) : nat :=
  match w with
    | WO => O
    | WS false _ w' => (wordToNat w') * 2
    | WS true _ w' => S (wordToNat w' * 2)
  end.

Fixpoint wordToNat' sz (w : word sz) : nat :=
  match w with
    | WO => O
    | WS false _ w' => 2 * wordToNat w'
    | WS true _ w' => S (2 * wordToNat w')
  end.

Theorem wordToNat_wordToNat' : forall sz (w : word sz),
  wordToNat w = wordToNat' w.
Proof.
  induction w. auto. simpl. rewrite mult_comm. reflexivity.
Qed.

Fixpoint mod2 (n : nat) : bool :=
  match n with
    | 0 => false
    | 1 => true
    | S (S n') => mod2 n'
  end.

Fixpoint natToWord (sz n : nat) : word sz :=
  match sz with
    | O => WO
    | S sz' => WS (mod2 n) (natToWord sz' (div2 n))
  end.

Fixpoint wordToN sz (w : word sz) : N :=
  match w with
    | WO => 0
    | WS false _ w' => 2 * wordToN w'
    | WS true _ w' => Nsucc (2 * wordToN w')
  end%N.

Definition Nmod2 (n : N) : bool :=
  match n with
    | N0 => false
    | Npos (xO _) => false
    | _ => true
  end.

Definition wzero sz := natToWord sz 0.

Fixpoint wzero' (sz : nat) : word sz :=
  match sz with
    | O => WO
    | S sz' => WS false (wzero' sz')
  end.

Fixpoint posToWord (sz : nat) (p : positive) {struct p} : word sz :=
  match sz with
    | O => WO
    | S sz' =>
      match p with
        | xI p' => WS true (posToWord sz' p')
        | xO p' => WS false (posToWord sz' p')
        | xH => WS true (wzero' sz')
      end
  end.

Definition NToWord (sz : nat) (n : N) : word sz :=
  match n with
    | N0 => wzero' sz
    | Npos p => posToWord sz p
  end.

Fixpoint Npow2 (n : nat) : N :=
  match n with
    | O => 1
    | S n' => 2 * Npow2 n'
  end%N.

Ltac rethink :=
  match goal with
    | [ H : ?f ?n = _ |- ?f ?m = _ ] => replace m with n; simpl; auto
  end.

Theorem mod2_S_double : forall n, mod2 (S (2 * n)) = true.
  induction n; simpl; intuition; rethink.
Qed.

Theorem mod2_double : forall n, mod2 (2 * n) = false.
  induction n; simpl; intuition; rewrite <- plus_n_Sm; rethink.
Qed.

Local Hint Resolve mod2_S_double mod2_double.

Theorem div2_double : forall n, div2 (2 * n) = n.
  induction n; simpl; intuition; rewrite <- plus_n_Sm; f_equal; rethink.
Qed.

Theorem div2_S_double : forall n, div2 (S (2 * n)) = n.
  induction n; simpl; intuition; f_equal; rethink.
Qed.

Hint Rewrite div2_double div2_S_double : div2.

Theorem natToWord_wordToNat : forall sz w, natToWord sz (wordToNat w) = w.
  induction w; rewrite wordToNat_wordToNat'; intuition; f_equal; unfold natToWord, wordToNat'; fold natToWord; fold wordToNat';
    destruct b; f_equal; autorewrite with div2; intuition.
Qed.

Fixpoint pow2 (n : nat) : nat :=
  match n with
    | O => 1
    | S n' => 2 * pow2 n'
  end.

Theorem roundTrip_0 : forall sz, wordToNat (natToWord sz 0) = 0.
  induction sz; simpl; intuition.
Qed.

Hint Rewrite roundTrip_0 : wordToNat.

Local Hint Extern 1 (@eq nat _ _) => omega.

Theorem untimes2 : forall n, n + (n + 0) = 2 * n.
  auto.
Qed.

Section strong.
  Variable P : nat -> Prop.

  Hypothesis PH : forall n, (forall m, m < n -> P m) -> P n.

  Lemma strong' : forall n m, m <= n -> P m.
    induction n; simpl; intuition; apply PH; intuition.
    elimtype False; omega.
  Qed.

  Theorem strong : forall n, P n.
    intros; eapply strong'; eauto.
  Qed.
End strong.

Theorem div2_odd : forall n,
  mod2 n = true
  -> n = S (2 * div2 n).
  induction n using strong; simpl; intuition.

  destruct n; simpl in *; intuition.
    discriminate.
  destruct n; simpl in *; intuition.
  do 2 f_equal.
  replace (div2 n + S (div2 n + 0)) with (S (div2 n + (div2 n + 0))); auto.
Qed.

Theorem div2_even : forall n,
  mod2 n = false
  -> n = 2 * div2 n.
  induction n using strong; simpl; intuition.

  destruct n; simpl in *; intuition.
  destruct n; simpl in *; intuition.
    discriminate.
  f_equal.
  replace (div2 n + S (div2 n + 0)) with (S (div2 n + (div2 n + 0))); auto.
Qed.

Lemma wordToNat_natToWord' : forall sz w, exists k, wordToNat (natToWord sz w) + k * pow2 sz = w.
  induction sz; simpl; intuition; repeat rewrite untimes2.

  exists w; intuition.

  case_eq (mod2 w); intro Hmw.

  specialize (IHsz (div2 w)); firstorder.
  rewrite wordToNat_wordToNat' in *.
  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.
  exists x; intuition.
  rewrite mult_assoc.
  rewrite (mult_comm x 2).
  rewrite <- mult_assoc.
  rewrite mult_comm.
  rewrite <- mult_plus_distr_l.
  rewrite H; clear H.
  symmetry; apply div2_even; auto.
Qed.

Theorem wordToNat_natToWord : forall sz w, exists k, wordToNat (natToWord sz w) = w - k * pow2 sz /\ k * pow2 sz <= w.
  intros; destruct (wordToNat_natToWord' sz w) as [k]; exists k; intuition.
Qed.

Definition wone sz := natToWord sz 1.

Fixpoint wones (sz : nat) : word sz :=
  match sz with
    | O => WO
    | S sz' => WS true (wones sz')
  end.

(** Comparisons *)

Fixpoint wmsb sz (w : word sz) (a : bool) : bool :=
  match w with
    | WO => a
    | WS b _ x => wmsb x b
  end.

Definition whd sz (w : word (S sz)) : bool :=
  match w in word sz' return match sz' with
                               | O => unit
                               | S _ => bool
                             end with
    | WO => tt
    | WS b _ _ => b
  end.

Definition wtl sz (w : word (S sz)) : word sz :=
  match w in word sz' return match sz' with
                               | O => unit
                               | S sz'' => word sz''
                             end with
    | WO => tt
    | WS _ _ w' => w'
  end.

Theorem WS_neq : forall b1 b2 sz (w1 w2 : word sz),
  (b1 <> b2 \/ w1 <> w2)
  -> WS b1 w1 <> WS b2 w2.
  intuition.
  apply (f_equal (@whd _)) in H0; tauto.
  apply (f_equal (@wtl _)) in H0; tauto.
Qed.

(** Shattering **)

Lemma shatter_word : forall n (a : word n),
  match n return word n -> Prop with
    | O => fun a => a = WO
    | S _ => fun a => a = WS (whd a) (wtl a)
  end a.
  destruct a; eauto.
Qed.

Lemma shatter_word_S : forall n (a : word (S n)),
  exists b, exists c, a = WS b c.
Proof.
  intros; repeat eexists; apply (shatter_word a).
Qed.
Lemma shatter_word_0 : forall a : word 0,
  a = WO.
Proof.
  intros; apply (shatter_word a).
Qed.

Hint Resolve shatter_word_0.

Require Import Coq.Logic.Eqdep_dec.

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 y)).

  abstract (rewrite (shatter_word y); simpl; intro; injection H; intros;
    apply _H0; apply inj_pair2_eq_dec in H0; [ auto | apply eq_nat_dec ]).

  abstract (rewrite (shatter_word y); simpl; intro; apply _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.

Theorem weqb_true_iff : forall sz x y,
  @weqb sz x y = true <-> x = y.
Proof.
  induction x; simpl; intros.
  { split; auto. }
  { rewrite (shatter_word y) in *. simpl in *.
    case_eq (eqb b (whd y)); intros.
    case_eq (weqb x (wtl y)); intros.
    split; auto; intros. rewrite eqb_true_iff in H. f_equal; eauto. eapply IHx; eauto.
    split; intros; try congruence. inversion H1; clear H1; subst.
    eapply inj_pair2_eq_dec in H4. eapply IHx in H4. congruence.
    eapply Peano_dec.eq_nat_dec.
    split; intros; try congruence.
    inversion H0. apply eqb_false_iff in H. congruence. }
Qed.

(** * 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.

Ltac shatterer := simpl; intuition;
  match goal with
    | [ w : _ |- _ ] => rewrite (shatter_word w); simpl
  end; f_equal; auto.

Theorem combine_split : forall sz1 sz2 (w : word (sz1 + sz2)),
  combine (split1 sz1 sz2 w) (split2 sz1 sz2 w) = w.
  induction sz1; shatterer.
Qed.

Theorem split1_combine : forall sz1 sz2 (w : word sz1) (z : word sz2),
  split1 sz1 sz2 (combine w z) = w.
  induction sz1; shatterer.
Qed.

Theorem split2_combine : forall sz1 sz2 (w : word sz1) (z : word sz2),
  split2 sz1 sz2 (combine w z) = z.
  induction sz1; shatterer.
Qed.

Require Import Coq.Logic.Eqdep_dec.

Theorem combine_assoc : forall n1 (w1 : word n1) n2 n3 (w2 : word n2) (w3 : word n3) Heq,
  combine (combine w1 w2) w3
  = match Heq in _ = N return word N with
      | refl_equal => combine w1 (combine w2 w3)
    end.
  induction w1; simpl; 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.
  rewrite (UIP_dec eq_nat_dec e (refl_equal _)).
  rewrite (UIP_dec eq_nat_dec Heq0 (refl_equal _)).
  reflexivity.
Qed.

Theorem split2_iter : forall n1 n2 n3 Heq w,
  split2 n2 n3 (split2 n1 (n2 + n3) w)
  = split2 (n1 + n2) n3 (match Heq in _ = N return word N with
                           | refl_equal => w
                         end).
  induction n1; simpl; intuition.

  rewrite (UIP_dec eq_nat_dec Heq (refl_equal _)); reflexivity.

  rewrite (IHn1 _ _ (plus_assoc _ _ _)).
  f_equal.
  repeat match goal with
           | [ |- context[match ?pf with refl_equal => _ end] ] => generalize pf
         end.
  generalize dependent w.
  simpl.
  fold plus.
  generalize (n1 + (n2 + n3)); clear.
  intros.
  generalize Heq e.
  subst.
  intros.
  rewrite (UIP_dec eq_nat_dec e (refl_equal _)).
  rewrite (UIP_dec eq_nat_dec Heq0 (refl_equal _)).
  reflexivity.
Qed.

Theorem combine_end : forall n1 n2 n3 Heq w,
  combine (split1 n2 n3 (split2 n1 (n2 + n3) w))
  (split2 (n1 + n2) n3 (match Heq in _ = N return word N with
                          | refl_equal => w
                        end))
  = split2 n1 (n2 + n3) w.
  induction n1; simpl; intros.

  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.

(** * 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 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).

(** * Notations *)

Delimit Scope word_scope with word.
Bind Scope word_scope with word.

Notation "w ~ 1" := (WS true w)
 (at level 7, left associativity, format "w '~' '1'") : word_scope.
Notation "w ~ 0" := (WS false w)
 (at level 7, left associativity, format "w '~' '0'") : word_scope.

Notation "^~" := wneg.
Notation "l ^+ r" := (@wplus _ l%word r%word) (at level 50, left associativity).
Notation "l ^* r" := (@wmult _ l%word r%word) (at level 40, left associativity).
Notation "l ^- r" := (@wminus _ l%word r%word) (at level 50, left associativity).

Theorem wordToN_nat : forall sz (w : word sz), wordToN w = N_of_nat (wordToNat w).
  induction w; intuition.
  destruct b; unfold wordToN, wordToNat; fold wordToN; fold wordToNat.

  rewrite N_of_S.
  rewrite N_of_mult.
  rewrite <- IHw.
  rewrite Nmult_comm.
  reflexivity.

  rewrite N_of_mult.
  rewrite <- IHw.
  rewrite Nmult_comm.
  reflexivity.
Qed.

Theorem mod2_S : forall n k,
  2 * k = S n
  -> mod2 n = true.
  induction n using strong; intros.
  destruct n; simpl in *.
  elimtype False; omega.
  destruct n; simpl in *; auto.
  destruct k; simpl in *.
  discriminate.
  apply H with k; auto.
Qed.

Theorem wzero'_def : forall sz, wzero' sz = wzero sz.
  unfold wzero; induction sz; simpl; intuition.
  congruence.
Qed.

Theorem posToWord_nat : forall p sz, posToWord sz p = natToWord sz (nat_of_P p).
  induction p; destruct sz; simpl; intuition; f_equal; try rewrite wzero'_def in *.

  rewrite ZL6.
  destruct (ZL4 p) as [? 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.

Theorem NToWord_nat : forall sz n, NToWord sz n = natToWord sz (nat_of_N n).
  destruct n; simpl; intuition; try rewrite wzero'_def in *.
  auto.
  apply posToWord_nat.
Qed.

Theorem wplus_alt : forall sz (x y : word sz), wplus x y = wplusN x y.
  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.

Theorem wmult_alt : forall sz (x y : word sz), wmult x y = wmultN x y.
  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.

Theorem Npow2_nat : forall n, nat_of_N (Npow2 n) = pow2 n.
  induction n; simpl; intuition.
  rewrite <- IHn; clear IHn.
  case_eq (Npow2 n); intuition.
  rewrite untimes2.
  replace (Npos p~0) with (Ndouble (Npos p)) by reflexivity.
  apply nat_of_Ndouble.
Qed.

Theorem wneg_alt : forall sz (x : word sz), wneg x = wnegN x.
  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.

Theorem wminus_Alt : forall sz (x y : word sz), wminus x y = wminusN x y.
  intros; unfold wminusN, wminus; rewrite wneg_alt; apply wplus_alt.
Qed.

Theorem wplus_unit : forall sz (x : word sz), natToWord sz 0 ^+ x = x.
  intros; rewrite wplus_alt; unfold wplusN, wordBinN; intros.
  rewrite roundTrip_0; apply natToWord_wordToNat.
Qed.

Theorem wplus_comm : forall sz (x y : word sz), x ^+ y = y ^+ x.
  intros; repeat rewrite wplus_alt; unfold wplusN, wordBinN; f_equal; auto.
Qed.

Theorem drop_mod2 : forall n k,
  2 * k <= n
  -> mod2 (n - 2 * k) = mod2 n.
  induction n using strong; intros.

  do 2 (destruct n; simpl in *; repeat rewrite untimes2 in *; intuition).

  destruct k; simpl in *; intuition.

  destruct k; simpl; intuition.
  rewrite <- plus_n_Sm.
  repeat rewrite untimes2 in *.
  simpl; auto.
  apply H; omega.
Qed.

Theorem div2_minus_2 : forall n k,
  2 * k <= n
  -> div2 (n - 2 * k) = div2 n - k.
  induction n using strong; intros.

  do 2 (destruct n; simpl in *; intuition; repeat rewrite untimes2 in *).
  destruct k; simpl in *; intuition.

  destruct k; simpl in *; intuition.
  rewrite <- plus_n_Sm.
  apply H; omega.
Qed.

Theorem div2_bound : forall k n,
  2 * k <= n
  -> k <= div2 n.
  intros; case_eq (mod2 n); intro Heq.

  rewrite (div2_odd _ Heq) in H.
  omega.

  rewrite (div2_even _ Heq) in H.
  omega.
Qed.

Theorem drop_sub : forall sz n k,
  k * pow2 sz <= n
  -> natToWord sz (n - k * pow2 sz) = natToWord sz n.
  induction sz; simpl; intuition; repeat rewrite untimes2 in *; f_equal.

  rewrite mult_assoc.
  rewrite (mult_comm k).
  rewrite <- mult_assoc.
  apply drop_mod2.
  rewrite mult_assoc.
  rewrite (mult_comm 2).
  rewrite <- mult_assoc.
  auto.

  rewrite <- (IHsz (div2 n) k).
  rewrite mult_assoc.
  rewrite (mult_comm k).
  rewrite <- mult_assoc.
  rewrite div2_minus_2.
  reflexivity.
  rewrite mult_assoc.
  rewrite (mult_comm 2).
  rewrite <- mult_assoc.
  auto.

  apply div2_bound.
  rewrite mult_assoc.
  rewrite (mult_comm 2).
  rewrite <- mult_assoc.
  auto.
Qed.

Local Hint Extern 1 (_ <= _) => omega.

Theorem wplus_assoc : forall sz (x y z : word sz), x ^+ (y ^+ z) = x ^+ y ^+ z.
  intros; 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.

  replace (wordToNat x + wordToNat y - x1 * pow2 sz + wordToNat z)
    with (wordToNat x + wordToNat y + wordToNat z - x1 * pow2 sz) by auto.
  replace (wordToNat x + (wordToNat y + wordToNat z - x0 * pow2 sz))
    with (wordToNat x + wordToNat y + wordToNat z - x0 * pow2 sz) by auto.
  repeat rewrite drop_sub; auto.
Qed.

Theorem roundTrip_1 : forall sz, wordToNat (natToWord (S sz) 1) = 1.
  induction sz; simpl in *; intuition.
Qed.

Theorem mod2_WS : forall sz (x : word sz) b, mod2 (wordToNat (WS b x)) = b.
  intros. 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.

Theorem div2_WS : forall sz (x : word sz) b, div2 (wordToNat (WS b x)) = wordToNat x.
  destruct b; rewrite wordToNat_wordToNat'; unfold wordToNat'; fold wordToNat'.
  apply div2_S_double.
  apply div2_double.
Qed.

Theorem wmult_unit : forall sz (x : word sz), natToWord sz 1 ^* x = x.
  intros; 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.

Theorem wmult_comm : forall sz (x y : word sz), x ^* y = y ^* x.
  intros; repeat rewrite wmult_alt; unfold wmultN, wordBinN; auto with arith.
Qed.

Theorem wmult_assoc : forall sz (x y z : word sz), x ^* (y ^* z) = x ^* y ^* z.
  intros; 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.
  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.

Theorem wmult_plus_distr : forall sz (x y z : word sz), (x ^+ y) ^* z = (x ^* z) ^+ (y ^* z).
  intros; 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.
  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.

Theorem wminus_def : forall sz (x y : word sz), x ^- y = x ^+ ^~ y.
  reflexivity.
Qed.

Theorem wordToNat_bound : forall sz (w : word sz), wordToNat w < pow2 sz.
  induction w; simpl; intuition.
  destruct b; simpl; omega.
Qed.

Theorem natToWord_pow2 : forall sz, natToWord sz (pow2 sz) = natToWord sz 0.
  induction 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.

Theorem wminus_inv : forall sz (x : word sz), x ^+ ^~ x = wzero sz.
  intros; 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.

  replace (wordToNat x + (pow2 sz - wordToNat x - x0 * pow2 sz))
    with (pow2 sz - x0 * pow2 sz).
  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 _).

Theorem weqb_sound : forall sz (x y : word sz), weqb x y = true -> x = y.
Proof.
  eapply weqb_true_iff.
Qed.

Implicit Arguments weqb_sound [].

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
    | _ => 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]).
*)

(** * 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 wor := bitwp orb.
Definition wand := bitwp andb.
Definition wxor := bitwp xorb.

Notation "l ^| r" := (@wor _ l%word r%word) (at level 50, left associativity).
Notation "l ^& r" := (@wand _ l%word r%word) (at level 40, left associativity).

Theorem wor_unit : forall sz (x : word sz), wzero sz ^| x = x.
  unfold wzero, wor; induction x; simpl; intuition congruence.
Qed.

Theorem wor_comm : forall sz (x y : word sz), x ^| y = y ^| x.
  unfold wor; induction x; intro y; rewrite (shatter_word y); simpl; intuition; f_equal; auto with bool.
Qed.

Theorem wor_assoc : forall sz (x y z : word sz), x ^| (y ^| z) = x ^| y ^| z.
  unfold wor; induction x; intro y; rewrite (shatter_word y); simpl; intuition; f_equal; auto with bool.
Qed.

Theorem wand_unit : forall sz (x : word sz), wones sz ^& x = x.
  unfold wand; induction x; simpl; intuition congruence.
Qed.

Theorem wand_kill : forall sz (x : word sz), wzero sz ^& x = wzero sz.
  unfold wzero, wand; induction x; simpl; intuition congruence.
Qed.

Theorem wand_comm : forall sz (x y : word sz), x ^& y = y ^& x.
  unfold wand; induction x; intro y; rewrite (shatter_word y); simpl; intuition; f_equal; auto with bool.
Qed.

Theorem wand_assoc : forall sz (x y z : word sz), x ^& (y ^& z) = x ^& y ^& z.
  unfold wand; induction x; intro y; rewrite (shatter_word y); simpl; intuition; f_equal; auto with bool.
Qed.

Theorem wand_or_distr : forall sz (x y z : word sz), (x ^| y) ^& z = (x ^& z) ^| (y ^& z).
  unfold wand, wor; induction x; intro y; rewrite (shatter_word y); intro z; rewrite (shatter_word z); simpl; intuition; f_equal; auto with bool.
  destruct (whd y); destruct (whd z); destruct b; reflexivity.
Qed.

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.

Theorem word_neq : forall sz (w1 w2 : word sz),
  w1 ^- w2 <> wzero sz
  -> w1 <> w2.
  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.

Open Scope word_scope.

(** * Signed Logic **)
Fixpoint wordToZ sz (w : word sz) : Z :=
  if wmsb w true 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.

(** * Comparison Predicates and Deciders **)
Definition wlt sz (l r : word sz) : Prop :=
  Nlt (wordToN l) (wordToN r).
Definition wslt sz (l r : word sz) : Prop :=
  Zlt (wordToZ l) (wordToZ r).

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) (at level 70) : word_scope.
Notation "w1 '>s=' w2" := (~(@wslt _ w1%word w2%word)) (at level 70) : word_scope.
Notation "w1 '<s' w2" := (@wslt _ w1%word w2%word) (at level 70) : word_scope.
Notation "w1 '<s=' w2" := (~(@wslt _ w2%word w1%word)) (at level 70) : word_scope.

Definition wlt_dec : forall sz (l r : word sz), {l < r} + {l >= r}.
  refine (fun sz l r =>
    match Ncompare (wordToN l) (wordToN r) as k return Ncompare (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 Zcompare (wordToZ l) (wordToZ r) as c return Zcompare (wordToZ l) (wordToZ r) = c -> _ with
      | Lt => fun pf => left _ _
      | _ => fun pf => right _ _
    end (refl_equal _));
  abstract congruence.
Defined.

(* Ordering Lemmas **)
Lemma lt_le : forall sz (a b : word sz),
  a < b -> a <= b.
Proof.
  unfold wlt, Nlt. intros. intro. rewrite <- Ncompare_antisym in H0. rewrite H in H0. simpl in *. congruence.
Qed.
Lemma eq_le : forall sz (a b : word sz),
  a = b -> a <= b.
Proof.
  intros; subst. unfold wlt, Nlt. rewrite Ncompare_refl. congruence.
Qed.
Lemma wordToN_inj : forall sz (a b : word sz),
  wordToN a = wordToN b -> a = b.
Proof.
  induction a; intro b0; rewrite (shatter_word b0); intuition.
  simpl in H.
  destruct b; destruct (whd b0); intros.
  f_equal. eapply IHa. eapply Nsucc_inj in H.
  destruct (wordToN a); destruct (wordToN (wtl b0)); try congruence.
  destruct (wordToN (wtl b0)); destruct (wordToN a); inversion H.
  destruct (wordToN (wtl b0)); destruct (wordToN a); inversion H.
  f_equal. eapply IHa.
  destruct (wordToN a); destruct (wordToN (wtl b0)); try congruence.
Qed.
Lemma unique_inverse : forall sz (a b1 b2 : word sz),
  a ^+ b1 = wzero _ ->
  a ^+ b2 = wzero _ ->
  b1 = b2.
Proof.
  intros.
  transitivity (b1 ^+ wzero _).
  rewrite wplus_comm. rewrite wplus_unit. auto.
  transitivity (b1 ^+ (a ^+ b2)). congruence.
  rewrite wplus_assoc.
  rewrite (wplus_comm b1). rewrite H. rewrite wplus_unit. auto.
Qed.
Lemma sub_0_eq : forall sz (a b : word sz),
  a ^- b = wzero _ -> a = b.
Proof.
  intros. destruct (weq (wneg b) (wneg a)).
  transitivity (a ^+ (^~ b ^+ b)).
  rewrite (wplus_comm (^~ b)). rewrite wminus_inv.
  rewrite wplus_comm. rewrite wplus_unit. auto.
  rewrite e. rewrite wplus_assoc. rewrite wminus_inv. rewrite wplus_unit. auto.
  unfold wminus in H.
  generalize (unique_inverse a (wneg a) (^~ b)).
  intros. elimtype False. apply n. symmetry; apply H0.
  apply wminus_inv.
  auto.
Qed.

Lemma le_neq_lt : forall sz (a b : word sz),
  b <= a -> a <> b -> b < a.
Proof.
  intros; destruct (wlt_dec b a); auto.
  elimtype False. apply H0. unfold wlt, Nlt in *.
  eapply wordToN_inj. eapply Ncompare_eq_correct.
  case_eq ((wordToN a ?= wordToN b)%N); auto; try congruence.
  intros. rewrite <- Ncompare_antisym in n. rewrite H1 in n. simpl in *. congruence.
Qed.

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.

(** Uniqueness of equality proofs **)
Lemma rewrite_weq : forall sz (a b : word sz)
  (pf : a = b),
  weq a b = left _ pf.
Proof.
  intros; destruct (weq a b); try solve [ elimtype False; auto ].
  f_equal.
  eapply UIP_dec. eapply weq.
Qed.

(** * Some more useful derived facts *)

Lemma natToWord_plus : forall sz n m, natToWord sz (n + m) = natToWord _ n ^+ natToWord _ m.
  destruct sz; intuition.
  rewrite wplus_alt.
  unfold wplusN, wordBinN.
  destruct (wordToNat_natToWord (S sz) n); intuition.
  destruct (wordToNat_natToWord (S sz) m); intuition.
  rewrite H0; rewrite H2; clear H0 H2.
  replace (n - x * pow2 (S sz) + (m - x0 * pow2 (S sz))) with (n + m - x * pow2 (S sz) - x0 * pow2 (S sz))
    by omega.
  repeat rewrite drop_sub; auto; omega.
Qed.

Lemma natToWord_S : forall sz n, natToWord sz (S n) = natToWord _ 1 ^+ natToWord _ n.
  intros; change (S n) with (1 + n); apply natToWord_plus.
Qed.

Theorem natToWord_inj : forall sz n m, natToWord sz n = natToWord sz m
  -> (n < pow2 sz)%nat
  -> (m < pow2 sz)%nat
  -> n = m.
  intros.
  apply (f_equal (@wordToNat _)) in H.
  destruct (wordToNat_natToWord sz n).
  destruct (wordToNat_natToWord sz m).
  intuition.
  rewrite H4 in H; rewrite H2 in H; clear H4 H2.
  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.

Lemma wordToNat_natToWord_idempotent : forall sz n,
  (N.of_nat n < Npow2 sz)%N
  -> wordToNat (natToWord sz n) = n.
  intros.
  destruct (wordToNat_natToWord sz n); intuition.
  destruct 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.

Lemma wplus_cancel : forall sz (a b c : word sz),
  a ^+ c = b ^+ c
  -> a = b.
  intros.
  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.


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

(******************************************************************************)
(* This file deals with divisibility for natural numbers.                     *)
(* It contains the definitions of:                                            *)
(*      edivn m d   == the pair composed of the quotient and remainder        *)
(*                     of the Euclidean division of m by d.                   *)
(*          m %/ d  == quotient of the Euclidean division of m by d.          *)
(*          m %% d  == remainder of the Euclidean division of m by d.         *)
(*  m = n %[mod d]  <-> m equals n modulo d.                                  *)
(*  m == n %[mod d] <=> m equals n modulo d (boolean version).                *)
(*  m <> n %[mod d] <-> m differs from n modulo d.                            *)
(*  m != n %[mod d] <=> m differs from n modulo d (boolean version).          *)
(*           d %| m <=> d divides m.                                          *)
(*         gcdn m n == the GCD of m and n.                                    *)
(*        egcdn m n == the extended GCD (Bezout coefficient pair) of m and n. *)
(*                     If egcdn m n = (u, v), then gcdn m n = m * u - n * v.  *)
(*         lcmn m n == the LCM of m and n.                                    *)
(*      coprime m n <=> m and n are coprime (:= gcdn m n == 1).               *)
(*  chinese m n r s == witness of the chinese remainder theorem.              *)
(* We adjoin an m to operator suffixes to indicate a nested %% (modn), as in  *)
(*   modnDml : m %% d + n = m + n %[mod d].                                   *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** Euclidean division *)

Definition edivn_rec d :=
  fix loop m q := if m - d is m'.+1 then loop m' q.+1 else (q, m).

Definition edivn m d := if d > 0 then edivn_rec d.-1 m 0 else (0, m).

Variant edivn_spec m d : nat * nat -> Type :=
  EdivnSpec q r of m = q * d + r & (d > 0) ==> (r < d) : edivn_spec m d (q, r).

Lemma edivnP m d : edivn_spec m d (edivn m d).
Proof.
rewrite -[m in edivn_spec m]/(0 * d + m) /edivn; case: d => //= d.
elim/ltn_ind: m 0 => -[|m] IHm q //=; rewrite subn_if_gt.
case: ltnP => // le_dm; rewrite -[in m.+1](subnKC le_dm) -addSn.
by rewrite addnA -mulSnr; apply/IHm/leq_subr.
Qed.

Lemma edivn_eq d q r : r < d -> edivn (q * d + r) d = (q, r).
Proof.
move=> lt_rd; have d_gt0: 0 < d by apply: leq_trans lt_rd.
case: edivnP lt_rd => q' r'; rewrite d_gt0 /=.
wlog: q q' r r' / q <= q' by case/orP: (leq_total q q'); last symmetry; eauto.
have [||-> _ /addnI ->] //= := ltngtP q q'.
rewrite -(leq_pmul2r d_gt0) => /leq_add lt_qr _ eq_qr _ /lt_qr {lt_qr}.
by rewrite addnS ltnNge mulSn -addnA eq_qr addnCA addnA leq_addr.
Qed.

Definition divn m d := (edivn m d).1.

Notation "m %/ d" := (divn m d) : nat_scope.

(* We redefine modn so that it is structurally decreasing. *)

Definition modn_rec d := fix loop m := if m - d is m'.+1 then loop m' else m.

Definition modn m d := if d > 0 then modn_rec d.-1 m else m.

Notation "m %% d" := (modn m d) : nat_scope.
Notation "m = n %[mod d ]" := (m %% d = n %% d) : nat_scope.
Notation "m == n %[mod d ]" := (m %% d == n %% d) : nat_scope.
Notation "m <> n %[mod d ]" := (m %% d <> n %% d) : nat_scope.
Notation "m != n %[mod d ]" := (m %% d != n %% d) : nat_scope.

Lemma modn_def m d : m %% d = (edivn m d).2.
Proof.
case: d => //= d; rewrite /modn /edivn /=; elim/ltn_ind: m 0 => -[|m] IHm q //=.
by rewrite !subn_if_gt; case: (d <= m) => //; apply/IHm/leq_subr.
Qed.

Lemma edivn_def m d : edivn m d = (m %/ d, m %% d).
Proof. by rewrite /divn modn_def; case: (edivn m d). Qed.

Lemma divn_eq m d : m = m %/ d * d + m %% d.
Proof. by rewrite /divn modn_def; case: edivnP. Qed.

Lemma div0n d : 0 %/ d = 0. Proof. by case: d. Qed.
Lemma divn0 m : m %/ 0 = 0. Proof. by []. Qed.
Lemma mod0n d : 0 %% d = 0. Proof. by case: d. Qed.
Lemma modn0 m : m %% 0 = m. Proof. by []. Qed.

Lemma divn_small m d : m < d -> m %/ d = 0.
Proof. by move=> lt_md; rewrite /divn (edivn_eq 0). Qed.

Lemma divnMDl q m d : 0 < d -> (q * d + m) %/ d = q + m %/ d.
Proof.
move=> d_gt0; rewrite [in LHS](divn_eq m d) addnA -mulnDl.
by rewrite /divn edivn_eq // modn_def; case: edivnP; rewrite d_gt0.
Qed.

Lemma mulnK m d : 0 < d -> m * d %/ d = m.
Proof. by move=> d_gt0; rewrite -[m * d]addn0 divnMDl // div0n addn0. Qed.

Lemma mulKn m d : 0 < d -> d * m %/ d = m.
Proof. by move=> d_gt0; rewrite mulnC mulnK. Qed.

Lemma expnB p m n : p > 0 -> m >= n -> p ^ (m - n) = p ^ m %/ p ^ n.
Proof.
by move=> p_gt0 /subnK-Dm; rewrite -[in RHS]Dm expnD mulnK // expn_gt0 p_gt0.
Qed.

Lemma modn1 m : m %% 1 = 0.
Proof. by rewrite modn_def; case: edivnP => ? []. Qed.

Lemma divn1 m : m %/ 1 = m.
Proof. by rewrite [RHS](@divn_eq m 1) // modn1 addn0 muln1. Qed.

Lemma divnn d : d %/ d = (0 < d).
Proof. by case: d => // d; rewrite -[n in n %/ _]muln1 mulKn. Qed.

Lemma divnMl p m d : p > 0 -> p * m %/ (p * d) = m %/ d.
Proof.
move=> p_gt0; have [->|d_gt0] := posnP d; first by rewrite muln0.
rewrite [RHS]/divn; case: edivnP; rewrite d_gt0 /= => q r ->{m} lt_rd.
rewrite mulnDr mulnCA divnMDl; last by rewrite muln_gt0 p_gt0.
by rewrite addnC divn_small // ltn_pmul2l.
Qed.
Arguments divnMl [p m d].

Lemma divnMr p m d : p > 0 -> m * p %/ (d * p) = m %/ d.
Proof. by move=> p_gt0; rewrite -!(mulnC p) divnMl. Qed.
Arguments divnMr [p m d].

Lemma ltn_mod m d : (m %% d < d) = (0 < d).
Proof. by case: d => // d; rewrite modn_def; case: edivnP. Qed.

Lemma ltn_pmod m d : 0 < d -> m %% d < d.
Proof. by rewrite ltn_mod. Qed.

Lemma leq_trunc_div m d : m %/ d * d <= m.
Proof. by rewrite [leqRHS](divn_eq m d) leq_addr. Qed.

Lemma leq_mod m d : m %% d <= m.
Proof. by rewrite [leqRHS](divn_eq m d) leq_addl. Qed.

Lemma leq_div m d : m %/ d <= m.
Proof.
by case: d => // d; apply: leq_trans (leq_pmulr _ _) (leq_trunc_div _ _).
Qed.

Lemma ltn_ceil m d : 0 < d -> m < (m %/ d).+1 * d.
Proof.
by move=> d_gt0; rewrite [in m.+1](divn_eq m d) -addnS mulSnr leq_add2l ltn_mod.
Qed.

Lemma ltn_divLR m n d : d > 0 -> (m %/ d < n) = (m < n * d).
Proof.
move=> d_gt0; apply/idP/idP.
  by rewrite -(leq_pmul2r d_gt0); apply: leq_trans (ltn_ceil _ _).
rewrite !ltnNge -(@leq_pmul2r d n) //; apply: contra => le_nd_floor.
exact: leq_trans le_nd_floor (leq_trunc_div _ _).
Qed.

Lemma leq_divRL m n d : d > 0 -> (m <= n %/ d) = (m * d <= n).
Proof. by move=> d_gt0; rewrite leqNgt ltn_divLR // -leqNgt. Qed.

Lemma ltn_Pdiv m d : 1 < d -> 0 < m -> m %/ d < m.
Proof. by move=> d_gt1 m_gt0; rewrite ltn_divLR ?ltn_Pmulr // ltnW. Qed.

Lemma divn_gt0 d m : 0 < d -> (0 < m %/ d) = (d <= m).
Proof. by move=> d_gt0; rewrite leq_divRL ?mul1n. Qed.

Lemma leq_div2r d m n : m <= n -> m %/ d <= n %/ d.
Proof.
have [-> //| d_gt0 le_mn] := posnP d.
by rewrite leq_divRL // (leq_trans _ le_mn) -?leq_divRL.
Qed.

Lemma leq_div2l m d e : 0 < d -> d <= e -> m %/ e <= m %/ d.
Proof.
move/leq_divRL=> -> le_de.
by apply: leq_trans (leq_trunc_div m e); apply: leq_mul.
Qed.

Lemma edivnD m n d (offset := m %% d + n %% d >= d) : 0 < d ->
   edivn (m + n) d = (m %/ d + n %/ d + offset, m %% d + n %% d - offset * d).
Proof.
rewrite {}/offset; case: d => // d _; rewrite /divn !modn_def.
case: (edivnP m d.+1) (edivnP n d.+1) => [/= q r -> r_lt] [/= p s -> s_lt].
rewrite addnACA -mulnDl; have [r_le s_le] := (ltnW r_lt, ltnW s_lt).
have [d_ge|d_lt] := leqP; first by rewrite addn0 mul0n subn0 edivn_eq.
rewrite addn1 mul1n -[in LHS](subnKC d_lt) addnA -mulSnr edivn_eq//.
by rewrite ltn_subLR// -addnS leq_add.
Qed.

Lemma divnD m n d : 0 < d ->
  (m + n) %/ d = (m %/ d) + (n %/ d) + (m %% d + n %% d >= d).
Proof. by move=> /(@edivnD m n); rewrite edivn_def => -[]. Qed.

Lemma modnD m n d : 0 < d ->
  (m + n) %% d = m %% d + n %% d - (m %% d + n %% d >= d) * d.
Proof. by move=> /(@edivnD m n); rewrite edivn_def => -[]. Qed.

Lemma leqDmod m n d : 0 < d ->
  (d <= m %% d + n %% d) = ((m + n) %% d < n %% d).
Proof.
move=> d_gt0; rewrite modnD//.
have [d_le|_] := leqP d; last by rewrite subn0 ltnNge leq_addl.
by rewrite -(ltn_add2r d) mul1n (subnK d_le) addnC ltn_add2l ltn_pmod.
Qed.

Lemma divnB n m d : 0 < d ->
  (m - n) %/ d = (m %/ d) - (n %/ d) - (m %% d < n %% d).
Proof.
move=> d_gt0; have [mn|/ltnW nm] := leqP m n.
  by rewrite (eqP mn) (eqP (leq_div2r _ _)) ?div0n.
by rewrite -[in m %/ d](subnK nm) divnD// addnAC addnK leqDmod ?subnK ?addnK.
Qed.

Lemma modnB m n d : 0 < d -> n <= m ->
  (m - n) %% d = (m %% d < n %% d) * d + m %% d - n %% d.
Proof.
move=> d_gt0 nm; rewrite -[in m %% _](subnK nm) -leqDmod// modnD//.
have [d_le|_] := leqP d; last by rewrite mul0n add0n subn0 addnK.
by rewrite mul1n addnBA// addnC !addnK.
Qed.

Lemma edivnB m n d (offset := m %% d < n %% d) : 0 < d -> n <= m ->
   edivn (m - n) d = (m %/ d - n %/ d - offset, offset * d + m %% d - n %% d).
Proof. by move=> d_gt0 le_nm; rewrite edivn_def divnB// modnB. Qed.

Lemma leq_divDl p m n : (m + n) %/ p <= m %/ p + n %/ p + 1.
Proof. by have [->//|p_gt0] := posnP p; rewrite divnD// !leq_add// leq_b1. Qed.

Lemma geq_divBl k m p : k %/ p - m %/ p <= (k - m) %/ p + 1.
Proof.
rewrite leq_subLR addnA; apply: leq_trans (leq_divDl _ _ _).
by rewrite -maxnE leq_div2r ?leq_maxr.
Qed.

Lemma divnMA m n p : m %/ (n * p) = m %/ n %/ p.
Proof.
case: n p => [|n] [|p]; rewrite ?muln0 ?div0n //.
rewrite [in RHS](divn_eq m (n.+1 * p.+1)) mulnA mulnAC !divnMDl //.
by rewrite [_ %/ p.+1]divn_small ?addn0 // ltn_divLR // mulnC ltn_mod.
Qed.

Lemma divnAC m n p : m %/ n %/ p =  m %/ p %/ n.
Proof. by rewrite -!divnMA mulnC. Qed.

Lemma modn_small m d : m < d -> m %% d = m.
Proof. by move=> lt_md; rewrite [RHS](divn_eq m d) divn_small. Qed.

Lemma modn_mod m d : m %% d = m %[mod d].
Proof. by case: d => // d; apply: modn_small; rewrite ltn_mod. Qed.

Lemma modnMDl p m d : p * d + m = m %[mod d].
Proof.
have [->|d_gt0] := posnP d; first by rewrite muln0.
by rewrite [in LHS](divn_eq m d) addnA -mulnDl modn_def edivn_eq // ltn_mod.
Qed.

Lemma muln_modr p m d : p * (m %% d) = (p * m) %% (p * d).
Proof.
have [->//|p_gt0] := posnP p; apply: (@addnI (p * (m %/ d * d))).
by rewrite -mulnDr -divn_eq mulnCA -(divnMl p_gt0) -divn_eq.
Qed.

Lemma muln_modl p m d : (m %% d) * p = (m * p) %% (d * p).
Proof. by rewrite -!(mulnC p); apply: muln_modr. Qed.

Lemma modn_divl m n d : (m %/ d) %% n = m %% (n * d) %/ d.
Proof.
case: d n => [|d] [|n] //; rewrite [in LHS]/divn [in LHS]modn_def.
case: (edivnP m d.+1) edivnP => [/= _ r -> le_rd] [/= q s -> le_sn].
rewrite mulnDl -mulnA -addnA modnMDl modn_small ?divnMDl ?divn_small ?addn0//.
by rewrite mulSnr -addnS leq_add ?leq_mul2r.
Qed.

Lemma modnDl m d : d + m = m %[mod d].
Proof. by rewrite -[m %% _](modnMDl 1) mul1n. Qed.

Lemma modnDr m d : m + d = m %[mod d]. Proof. by rewrite addnC modnDl. Qed.

Lemma modnn d : d %% d = 0. Proof. by rewrite [d %% d](modnDr 0) mod0n. Qed.

Lemma modnMl p d : p * d %% d = 0.
Proof. by rewrite -[p * d]addn0 modnMDl mod0n. Qed.

Lemma modnMr p d : d * p %% d = 0. Proof. by rewrite mulnC modnMl. Qed.

Lemma modnDml m n d : m %% d + n = m + n %[mod d].
Proof. by rewrite [in RHS](divn_eq m d) -addnA modnMDl. Qed.

Lemma modnDmr m n d : m + n %% d = m + n %[mod d].
Proof. by rewrite !(addnC m) modnDml. Qed.

Lemma modnDm m n d : m %% d + n %% d = m + n %[mod d].
Proof. by rewrite modnDml modnDmr. Qed.

Lemma eqn_modDl p m n d : (p + m == p + n %[mod d]) = (m == n %[mod d]).
Proof.
case: d => [|d]; first by rewrite !modn0 eqn_add2l.
apply/eqP/eqP=> eq_mn; last by rewrite -modnDmr eq_mn modnDmr.
rewrite -(modnMDl p m) -(modnMDl p n) !mulnSr -!addnA.
by rewrite -modnDmr eq_mn modnDmr.
Qed.

Lemma eqn_modDr p m n d : (m + p == n + p %[mod d]) = (m == n %[mod d]).
Proof. by rewrite -!(addnC p) eqn_modDl. Qed.

Lemma modnMml m n d : m %% d * n = m * n %[mod d].
Proof. by rewrite [in RHS](divn_eq m d) mulnDl mulnAC modnMDl. Qed.

Lemma modnMmr m n d : m * (n %% d) = m * n %[mod d].
Proof. by rewrite !(mulnC m) modnMml. Qed.

Lemma modnMm m n d : m %% d * (n %% d) = m * n %[mod d].
Proof. by rewrite modnMml modnMmr. Qed.

Lemma modn2 m : m %% 2 = odd m.
Proof. by elim: m => //= m IHm; rewrite -addn1 -modnDml IHm; case odd. Qed.

Lemma divn2 m : m %/ 2 = m./2.
Proof. by rewrite [in RHS](divn_eq m 2) modn2 muln2 addnC half_bit_double. Qed.

Lemma odd_mod m d : odd d = false -> odd (m %% d) = odd m.
Proof.
by move=> d_even; rewrite [in RHS](divn_eq m d) oddD oddM d_even andbF.
Qed.

Lemma modnXm m n a : (a %% n) ^ m = a ^ m %[mod n].
Proof. by elim: m => // m IHm; rewrite !expnS -modnMmr IHm modnMml modnMmr. Qed.

(** Divisibility **)

Definition dvdn d m := m %% d == 0.

Notation "m %| d" := (dvdn m d) : nat_scope.

Lemma dvdnP d m : reflect (exists k, m = k * d) (d %| m).
Proof.
apply: (iffP eqP) => [md0 | [k ->]]; last by rewrite modnMl.
by exists (m %/ d); rewrite [LHS](divn_eq m d) md0 addn0.
Qed.
Arguments dvdnP {d m}.

Lemma dvdn0 d : d %| 0.
Proof. by case: d. Qed.

Lemma dvd0n n : (0 %| n) = (n == 0).
Proof. by case: n. Qed.

Lemma dvdn1 d : (d %| 1) = (d == 1).
Proof. by case: d => [|[|d]] //; rewrite /dvdn modn_small. Qed.

Lemma dvd1n m : 1 %| m.
Proof. by rewrite /dvdn modn1. Qed.

Lemma dvdn_gt0 d m : m > 0 -> d %| m -> d > 0.
Proof. by case: d => // /prednK <-. Qed.

Lemma dvdnn m : m %| m.
Proof. by rewrite /dvdn modnn. Qed.

Lemma dvdn_mull d m n : d %| n -> d %| m * n.
Proof. by case/dvdnP=> n' ->; rewrite /dvdn mulnA modnMl. Qed.

Lemma dvdn_mulr d m n : d %| m -> d %| m * n.
Proof. by move=> d_m; rewrite mulnC dvdn_mull. Qed.
#[global] Hint Resolve dvdn0 dvd1n dvdnn dvdn_mull dvdn_mulr : core.

Lemma dvdn_mul d1 d2 m1 m2 : d1 %| m1 -> d2 %| m2 -> d1 * d2 %| m1 * m2.
Proof.
by move=> /dvdnP[q1 ->] /dvdnP[q2 ->]; rewrite mulnCA -mulnA 2?dvdn_mull.
Qed.

Lemma dvdn_trans n d m : d %| n -> n %| m -> d %| m.
Proof. by move=> d_dv_n /dvdnP[n1 ->]; apply: dvdn_mull. Qed.

Lemma dvdn_eq d m : (d %| m) = (m %/ d * d == m).
Proof.
apply/eqP/eqP=> [modm0 | <-]; last exact: modnMl.
by rewrite [RHS](divn_eq m d) modm0 addn0.
Qed.

Lemma dvdn2 n : (2 %| n) = ~~ odd n.
Proof. by rewrite /dvdn modn2; case (odd n). Qed.

Lemma dvdn_odd m n : m %| n -> odd n -> odd m.
Proof. by move=> m_dv_n; apply: contraTT; rewrite -!dvdn2 => /dvdn_trans->. Qed.

Lemma divnK d m : d %| m -> m %/ d * d = m.
Proof. by rewrite dvdn_eq; move/eqP. Qed.

Lemma leq_divLR d m n : d %| m -> (m %/ d <= n) = (m <= n * d).
Proof. by case: d m => [|d] [|m] ///divnK=> {2}<-; rewrite leq_pmul2r. Qed.

Lemma ltn_divRL d m n : d %| m -> (n < m %/ d) = (n * d < m).
Proof. by move=> dv_d_m; rewrite !ltnNge leq_divLR. Qed.

Lemma eqn_div d m n : d > 0 -> d %| m -> (n == m %/ d) = (n * d == m).
Proof. by move=> d_gt0 dv_d_m; rewrite -(eqn_pmul2r d_gt0) divnK. Qed.

Lemma eqn_mul d m n : d > 0 -> d %| m -> (m == n * d) = (m %/ d == n).
Proof. by move=> d_gt0 dv_d_m; rewrite eq_sym -eqn_div // eq_sym. Qed.

Lemma divn_mulAC d m n : d %| m -> m %/ d * n = m * n %/ d.
Proof.
case: d m => [[] //| d m] dv_d_m; apply/eqP.
by rewrite eqn_div ?dvdn_mulr // mulnAC divnK.
Qed.

Lemma muln_divA d m n : d %| n -> m * (n %/ d) = m * n %/ d.
Proof. by move=> dv_d_m; rewrite !(mulnC m) divn_mulAC. Qed.

Lemma muln_divCA d m n : d %| m -> d %| n -> m * (n %/ d) = n * (m %/ d).
Proof. by move=> dv_d_m dv_d_n; rewrite mulnC divn_mulAC ?muln_divA. Qed.

Lemma divnA m n p : p %| n -> m %/ (n %/ p) = m * p %/ n.
Proof. by case: p => [|p] dv_n; rewrite -[in RHS](divnK dv_n) // divnMr. Qed.

Lemma modn_dvdm m n d : d %| m -> n %% m = n %[mod d].
Proof.
by case/dvdnP=> q def_m; rewrite [in RHS](divn_eq n m) def_m mulnA modnMDl.
Qed.

Lemma dvdn_leq d m : 0 < m -> d %| m -> d <= m.
Proof. by move=> m_gt0 /dvdnP[[|k] Dm]; rewrite Dm // leq_addr in m_gt0 *. Qed.

Lemma gtnNdvd n d : 0 < n -> n < d -> (d %| n) = false.
Proof. by move=> n_gt0 lt_nd; rewrite /dvdn eqn0Ngt modn_small ?n_gt0. Qed.

Lemma eqn_dvd m n : (m == n) = (m %| n) && (n %| m).
Proof.
case: m n => [|m] [|n] //; apply/idP/andP => [/eqP -> //| []].
by rewrite eqn_leq => Hmn Hnm; do 2 rewrite dvdn_leq //.
Qed.

Lemma dvdn_pmul2l p d m : 0 < p -> (p * d %| p * m) = (d %| m).
Proof. by case: p => // p _; rewrite /dvdn -muln_modr // muln_eq0. Qed.
Arguments dvdn_pmul2l [p d m].

Lemma dvdn_pmul2r p d m : 0 < p -> (d * p %| m * p) = (d %| m).
Proof. by move=> p_gt0; rewrite -!(mulnC p) dvdn_pmul2l. Qed.
Arguments dvdn_pmul2r [p d m].

Lemma dvdn_divLR p d m : 0 < p -> p %| d -> (d %/ p %| m) = (d %| m * p).
Proof. by move=> /(@dvdn_pmul2r p _ m) <- /divnK->. Qed.

Lemma dvdn_divRL p d m : p %| m -> (d %| m %/ p) = (d * p %| m).
Proof.
have [-> | /(@dvdn_pmul2r p d) <- /divnK-> //] := posnP p.
by rewrite divn0 muln0 dvdn0.
Qed.

Lemma dvdn_div d m : d %| m -> m %/ d %| m.
Proof. by move/divnK=> {2}<-; apply: dvdn_mulr. Qed.

Lemma dvdn_exp2l p m n : m <= n -> p ^ m %| p ^ n.
Proof. by move/subnK <-; rewrite expnD dvdn_mull. Qed.

Lemma dvdn_Pexp2l p m n : p > 1 -> (p ^ m %| p ^ n) = (m <= n).
Proof.
move=> p_gt1; case: leqP => [|gt_n_m]; first exact: dvdn_exp2l.
by rewrite gtnNdvd ?ltn_exp2l ?expn_gt0 // ltnW.
Qed.

Lemma dvdn_exp2r m n k : m %| n -> m ^ k %| n ^ k.
Proof. by case/dvdnP=> q ->; rewrite expnMn dvdn_mull. Qed.

Lemma divn_modl m n d : d %| n -> (m %% n) %/ d = (m %/ d) %% (n %/ d).
Proof. by move=> dvd_dn; rewrite modn_divl divnK. Qed.

Lemma dvdn_addr m d n : d %| m -> (d %| m + n) = (d %| n).
Proof. by case/dvdnP=> q ->; rewrite /dvdn modnMDl. Qed.

Lemma dvdn_addl n d m : d %| n -> (d %| m + n) = (d %| m).
Proof. by rewrite addnC; apply: dvdn_addr. Qed.

Lemma dvdn_add d m n : d %| m -> d %| n -> d %| m + n.
Proof. by move/dvdn_addr->. Qed.

Lemma dvdn_add_eq d m n : d %| m + n -> (d %| m) = (d %| n).
Proof. by move=> dv_d_mn; apply/idP/idP => [/dvdn_addr | /dvdn_addl] <-. Qed.

Lemma dvdn_subr d m n : n <= m -> d %| m -> (d %| m - n) = (d %| n).
Proof. by move=> le_n_m dv_d_m; apply: dvdn_add_eq; rewrite subnK. Qed.

Lemma dvdn_subl d m n : n <= m -> d %| n -> (d %| m - n) = (d %| m).
Proof. by move=> le_n_m dv_d_m; rewrite -(dvdn_addl _ dv_d_m) subnK. Qed.

Lemma dvdn_sub d m n : d %| m -> d %| n -> d %| m - n.
Proof.
by case: (leqP n m) => [le_nm /dvdn_subr <- // | /ltnW/eqnP ->]; rewrite dvdn0.
Qed.

Lemma dvdn_exp k d m : 0 < k -> d %| m -> d %| (m ^ k).
Proof. by case: k => // k _ d_dv_m; rewrite expnS dvdn_mulr. Qed.

Lemma dvdn_fact m n : 0 < m <= n -> m %| n`!.
Proof.
case: m => //= m; elim: n => //= n IHn; rewrite ltnS.
have [/IHn/dvdn_mull->||-> _] // := ltngtP m n; exact: dvdn_mulr.
Qed.

#[global] Hint Resolve dvdn_add dvdn_sub dvdn_exp : core.

Lemma eqn_mod_dvd d m n : n <= m -> (m == n %[mod d]) = (d %| m - n).
Proof.
by move/subnK=> Dm; rewrite -[n in LHS]add0n -[in LHS]Dm eqn_modDr mod0n.
Qed.

Lemma divnDMl q m d : 0 < d -> (m + q * d) %/ d = (m %/ d) + q.
Proof. by move=> d_gt0; rewrite addnC divnMDl// addnC. Qed.

Lemma divnMBl q m d : 0 < d -> (q * d - m) %/ d = q - (m %/ d) - (~~ (d %| m)).
Proof. by move=> d_gt0; rewrite divnB// mulnK// modnMl lt0n. Qed.

Lemma divnBMl q m d : (m - q * d) %/ d = (m %/ d) - q.
Proof. by case: d => [|d]//=; rewrite divnB// mulnK// modnMl ltn0 subn0. Qed.

Lemma divnDl m n d : d %| m -> (m + n) %/ d = m %/ d + n %/ d.
Proof. by case: d => // d /divnK-Dm; rewrite -[in LHS]Dm divnMDl. Qed.

Lemma divnDr m n d : d %| n -> (m + n) %/ d = m %/ d + n %/ d.
Proof. by move=> dv_n; rewrite addnC divnDl // addnC. Qed.

Lemma divnBl m n d : d %| m -> (m - n) %/ d = m %/ d - (n %/ d) - (~~ (d %| n)).
Proof. by case: d => [|d] // /divnK-Dm; rewrite -[in LHS]Dm divnMBl. Qed.

Lemma divnBr m n d : d %| n -> (m - n) %/ d = m %/ d - n %/ d.
Proof. by case: d => [|d]// /divnK-Dm; rewrite -[in LHS]Dm divnBMl. Qed.

Lemma edivnS m d : 0 < d -> edivn m.+1 d =
  if d %| m.+1 then ((m %/ d).+1, 0) else (m %/ d, (m %% d).+1).
Proof.
case: d => [|[|d]] //= _; first by rewrite edivn_def modn1 dvd1n !divn1.
rewrite -addn1 /dvdn modn_def edivnD//= (@modn_small 1)// (@divn_small 1)//.
rewrite addn1 addn0 ltnS; have [||<-] := ltngtP d.+1.
- by rewrite ltnNge -ltnS ltn_pmod.
- by rewrite addn0 mul0n subn0.
- by rewrite addn1 mul1n subnn.
Qed.

Lemma modnS m d : m.+1 %% d = if d %| m.+1 then 0 else (m %% d).+1.
Proof. by case: d => [|d]//; rewrite modn_def edivnS//; case: ifP. Qed.

Lemma divnS m d : 0 < d -> m.+1 %/ d = (d %| m.+1) + m %/ d.
Proof. by move=> d_gt0; rewrite /divn edivnS//; case: ifP. Qed.

Lemma divn_pred m d : m.-1 %/ d = (m %/ d) - (d %| m).
Proof.
by case: d m => [|d] [|m]; rewrite ?divn1 ?dvd1n ?subn1//= divnS// addnC addnK.
Qed.

Lemma modn_pred m d : d != 1 -> 0 < m ->
  m.-1 %% d = if d %| m then d.-1 else (m %% d).-1.
Proof.
rewrite -subn1; case: d m => [|[|d]] [|m]//= _ _.
  by rewrite ?modn1 ?dvd1n ?modn0 ?subn1.
rewrite modnB// (@modn_small 1)// [_ < _]leqn0 /dvdn mulnbl/= subn1.
by case: eqP => // ->; rewrite addn0.
Qed.

Lemma edivn_pred m d : d != 1 -> 0 < m ->
  edivn m.-1 d = if d %| m then ((m %/ d).-1, d.-1) else (m %/ d, (m %% d).-1).
Proof.
move=> d_neq1 m_gt0; rewrite edivn_def divn_pred modn_pred//.
by case: ifP; rewrite ?subn0 ?subn1.
Qed.

(***********************************************************************)
(*   A function that computes the gcd of 2 numbers                     *)
(***********************************************************************)

Fixpoint gcdn_rec m n :=
  let n' := n %% m in if n' is 0 then m else
  if m - n'.-1 is m'.+1 then gcdn_rec (m' %% n') n' else n'.

Definition gcdn := nosimpl gcdn_rec.

Lemma gcdnE m n : gcdn m n = if m == 0 then n else gcdn (n %% m) m.
Proof.
rewrite /gcdn; elim/ltn_ind: m n => -[|m] IHm [|n] //=.
case def_p: (_ %% _) => // [p].
have{def_p} lt_pm: p.+1 < m.+1 by rewrite -def_p ltn_pmod.
rewrite {}IHm // subn_if_gt ltnW //=; congr gcdn_rec.
by rewrite -(subnK (ltnW lt_pm)) modnDr.
Qed.

Lemma gcdnn : idempotent gcdn.
Proof. by case=> // n; rewrite gcdnE modnn. Qed.

Lemma gcdnC : commutative gcdn.
Proof.
move=> m n; wlog lt_nm: m n / n < m by have [? ->|? <-|-> //] := ltngtP n m.
by rewrite gcdnE -[in m == 0](ltn_predK lt_nm) modn_small.
Qed.

Lemma gcd0n : left_id 0 gcdn. Proof. by case. Qed.
Lemma gcdn0 : right_id 0 gcdn. Proof. by case. Qed.

Lemma gcd1n : left_zero 1 gcdn.
Proof. by move=> n; rewrite gcdnE modn1. Qed.

Lemma gcdn1 : right_zero 1 gcdn.
Proof. by move=> n; rewrite gcdnC gcd1n. Qed.

Lemma dvdn_gcdr m n : gcdn m n %| n.
Proof.
elim/ltn_ind: m n => -[|m] IHm [|n] //=.
rewrite gcdnE; case def_p: (_ %% _) => [|p]; first by rewrite /dvdn def_p.
have lt_pm: p < m by rewrite -ltnS -def_p ltn_pmod.
rewrite /= (divn_eq n.+1 m.+1) def_p dvdn_addr ?dvdn_mull //; last exact: IHm.
by rewrite gcdnE /= IHm // (ltn_trans (ltn_pmod _ _)).
Qed.

Lemma dvdn_gcdl m n : gcdn m n %| m.
Proof. by rewrite gcdnC dvdn_gcdr. Qed.

Lemma gcdn_gt0 m n : (0 < gcdn m n) = (0 < m) || (0 < n).
Proof.
by case: m n => [|m] [|n] //; apply: (@dvdn_gt0 _ m.+1) => //; apply: dvdn_gcdl.
Qed.

Lemma gcdnMDl k m n : gcdn m (k * m + n) = gcdn m n.
Proof. by rewrite !(gcdnE m) modnMDl mulnC; case: m. Qed.

Lemma gcdnDl m n : gcdn m (m + n) = gcdn m n.
Proof. by rewrite -[m in m + n]mul1n gcdnMDl. Qed.

Lemma gcdnDr m n : gcdn m (n + m) = gcdn m n.
Proof. by rewrite addnC gcdnDl. Qed.

Lemma gcdnMl n m : gcdn n (m * n) = n.
Proof. by case: n => [|n]; rewrite gcdnE modnMl // muln0. Qed.

Lemma gcdnMr n m : gcdn n (n * m) = n.
Proof. by rewrite mulnC gcdnMl. Qed.

Lemma gcdn_idPl {m n} : reflect (gcdn m n = m) (m %| n).
Proof.
by apply: (iffP idP) => [/dvdnP[q ->] | <-]; rewrite (gcdnMl, dvdn_gcdr).
Qed.

Lemma gcdn_idPr {m n} : reflect (gcdn m n = n) (n %| m).
Proof. by rewrite gcdnC; apply: gcdn_idPl. Qed.

Lemma expn_min e m n : e ^ minn m n = gcdn (e ^ m) (e ^ n).
Proof. by case: leqP => [|/ltnW] /(dvdn_exp2l e) /gcdn_idPl; rewrite gcdnC. Qed.

Lemma gcdn_modr m n : gcdn m (n %% m) = gcdn m n.
Proof. by rewrite [in RHS](divn_eq n m) gcdnMDl. Qed.

Lemma gcdn_modl m n : gcdn (m %% n) n = gcdn m n.
Proof. by rewrite !(gcdnC _ n) gcdn_modr. Qed.

(* Extended gcd, which computes Bezout coefficients. *)

Fixpoint Bezout_rec km kn qs :=
  if qs is q :: qs' then Bezout_rec kn (NatTrec.add_mul q kn km) qs'
  else (km, kn).

Fixpoint egcdn_rec m n s qs :=
  if s is s'.+1 then
    let: (q, r) := edivn m n in
    if r > 0 then egcdn_rec n r s' (q :: qs) else
    if odd (size qs) then qs else q.-1 :: qs
  else [::0].

Definition egcdn m n := Bezout_rec 0 1 (egcdn_rec m n n [::]).

Variant egcdn_spec m n : nat * nat -> Type :=
  EgcdnSpec km kn of km * m = kn * n + gcdn m n & kn * gcdn m n < m :
    egcdn_spec m n (km, kn).

Lemma egcd0n n : egcdn 0 n = (1, 0).
Proof. by case: n. Qed.

Lemma egcdnP m n : m > 0 -> egcdn_spec m n (egcdn m n).
Proof.
have [-> /= | n_gt0 m_gt0] := posnP n; first by split; rewrite // mul1n gcdn0.
rewrite /egcdn; set s := (s in egcdn_rec _ _ s); pose bz := Bezout_rec n m [::].
have: n < s.+1 by []; move defSpec: (egcdn_spec bz.2 bz.1) s => Spec s.
elim: s => [[]|s IHs] //= in n m (qs := [::]) bz defSpec n_gt0 m_gt0 *.
case: edivnP => q r def_m; rewrite n_gt0 ltnS /= => lt_rn le_ns1.
case: posnP => [r0 {s le_ns1 IHs lt_rn}|r_gt0]; last first.
  by apply: IHs => //=; [rewrite natTrecE -def_m | rewrite (leq_trans lt_rn)].
rewrite {r}r0 addn0 in def_m; set b := odd _; pose d := gcdn m n.
pose km := ~~ b : nat; pose kn := if b then 1 else q.-1.
rewrite [bz in Spec bz](_ : _ = Bezout_rec km kn qs); last first.
  by rewrite /kn /km; case: (b) => //=; rewrite natTrecE addn0 muln1.
have def_d: d = n by rewrite /d def_m gcdnC gcdnE modnMl gcd0n -[n]prednK.
have: km * m + 2 * b * d = kn * n + d.
  rewrite {}/kn {}/km def_m def_d -mulSnr; case: b; rewrite //= addn0 mul1n.
  by rewrite prednK //; apply: dvdn_gt0 m_gt0 _; rewrite def_m dvdn_mulr.
have{def_m}: kn * d <= m.
  have q_gt0 : 0 < q by rewrite def_m muln_gt0 n_gt0 ?andbT in m_gt0.
  by rewrite /kn; case b; rewrite def_d def_m leq_pmul2r // leq_pred.
have{def_d}: km * d <= n by rewrite -[n]mul1n def_d leq_pmul2r // leq_b1.
move: km {q}kn m_gt0 n_gt0 defSpec; rewrite {}/b {}/d {}/bz.
elim: qs m n => [|q qs IHq] n r kn kr n_gt0 r_gt0 /=.
  set d := gcdn n r; rewrite mul0n addn0 => <- le_kn_r _ def_d; split=> //.
  have d_gt0: 0 < d by rewrite gcdn_gt0 n_gt0.
  have /ltn_pmul2l<-: 0 < kn by rewrite -(ltn_pmul2r n_gt0) def_d ltn_addl.
  by rewrite def_d -addn1 leq_add // mulnCA leq_mul2l le_kn_r orbT.
rewrite !natTrecE; set m := _ + r; set km := _ + kn; pose d := gcdn m n.
have ->: gcdn n r = d by rewrite [d]gcdnC gcdnMDl.
have m_gt0: 0 < m by rewrite addn_gt0 r_gt0 orbT.
have d_gt0: 0 < d by rewrite gcdn_gt0 m_gt0.
move=> {}/IHq IHq le_kn_r le_kr_n def_d; apply: IHq => //; rewrite -/d.
  by rewrite mulnDl leq_add // -mulnA leq_mul2l le_kr_n orbT.
apply: (@addIn d); rewrite mulnDr -addnA addnACA -def_d addnACA mulnA.
rewrite -!mulnDl -mulnDr -addnA [kr * _]mulnC; congr addn.
by rewrite addnC addn_negb muln1 mul2n addnn.
Qed.

Lemma Bezoutl m n : m > 0 -> {a | a < m & m %| gcdn m n + a * n}.
Proof.
move=> m_gt0; case: (egcdnP n m_gt0) => km kn def_d lt_kn_m.
exists kn; last by rewrite addnC -def_d dvdn_mull.
apply: leq_ltn_trans lt_kn_m.
by rewrite -{1}[kn]muln1 leq_mul2l gcdn_gt0 m_gt0 orbT.
Qed.

Lemma Bezoutr m n : n > 0 -> {a | a < n & n %| gcdn m n + a * m}.
Proof. by rewrite gcdnC; apply: Bezoutl. Qed.

(* Back to the gcd. *)

Lemma dvdn_gcd p m n : p %| gcdn m n = (p %| m) && (p %| n).
Proof.
apply/idP/andP=> [dv_pmn | [dv_pm dv_pn]].
  by rewrite !(dvdn_trans dv_pmn) ?dvdn_gcdl ?dvdn_gcdr.
have [->|n_gt0] := posnP n; first by rewrite gcdn0.
case: (Bezoutr m n_gt0) => // km _ /(dvdn_trans dv_pn).
by rewrite dvdn_addl // dvdn_mull.
Qed.

Lemma gcdnAC : right_commutative gcdn.
Proof.
suffices dvd m n p: gcdn (gcdn m n) p %| gcdn (gcdn m p) n.
  by move=> m n p; apply/eqP; rewrite eqn_dvd !dvd.
rewrite !dvdn_gcd dvdn_gcdr.
by rewrite !(dvdn_trans (dvdn_gcdl _ p)) ?dvdn_gcdl ?dvdn_gcdr.
Qed.

Lemma gcdnA : associative gcdn.
Proof. by move=> m n p; rewrite !(gcdnC m) gcdnAC. Qed.

Lemma gcdnCA : left_commutative gcdn.
Proof. by move=> m n p; rewrite !gcdnA (gcdnC m). Qed.

Lemma gcdnACA : interchange gcdn gcdn.
Proof. by move=> m n p q; rewrite -!gcdnA (gcdnCA n). Qed.

Lemma muln_gcdr : right_distributive muln gcdn.
Proof.
move=> p m n; have [-> //|p_gt0] := posnP p.
elim/ltn_ind: m n => m IHm n; rewrite gcdnE [RHS]gcdnE muln_eq0 (gtn_eqF p_gt0).
by case: posnP => // m_gt0; rewrite -muln_modr //=; apply/IHm/ltn_pmod.
Qed.

Lemma muln_gcdl : left_distributive muln gcdn.
Proof. by move=> m n p; rewrite -!(mulnC p) muln_gcdr. Qed.

Lemma gcdn_def d m n :
    d %| m -> d %| n -> (forall d', d' %| m -> d' %| n -> d' %| d) ->
  gcdn m n = d.
Proof.
move=> dv_dm dv_dn gdv_d; apply/eqP.
by rewrite eqn_dvd dvdn_gcd dv_dm dv_dn gdv_d ?dvdn_gcdl ?dvdn_gcdr.
Qed.

Lemma muln_divCA_gcd n m : n * (m %/ gcdn n m)  = m * (n %/ gcdn n m).
Proof. by rewrite muln_divCA ?dvdn_gcdl ?dvdn_gcdr. Qed.

(* We derive the lcm directly. *)

Definition lcmn m n := m * n %/ gcdn m n.

Lemma lcmnC : commutative lcmn.
Proof. by move=> m n; rewrite /lcmn mulnC gcdnC. Qed.

Lemma lcm0n : left_zero 0 lcmn.  Proof. by move=> n; apply: div0n. Qed.
Lemma lcmn0 : right_zero 0 lcmn. Proof. by move=> n; rewrite lcmnC lcm0n. Qed.

Lemma lcm1n : left_id 1 lcmn.
Proof. by move=> n; rewrite /lcmn gcd1n mul1n divn1. Qed.

Lemma lcmn1 : right_id 1 lcmn.
Proof. by move=> n; rewrite lcmnC lcm1n. Qed.

Lemma muln_lcm_gcd m n : lcmn m n * gcdn m n = m * n.
Proof. by apply/eqP; rewrite divnK ?dvdn_mull ?dvdn_gcdr. Qed.

Lemma lcmn_gt0 m n : (0 < lcmn m n) = (0 < m) && (0 < n).
Proof. by rewrite -muln_gt0 ltn_divRL ?dvdn_mull ?dvdn_gcdr. Qed.

Lemma muln_lcmr : right_distributive muln lcmn.
Proof.
case=> // m n p; rewrite /lcmn -muln_gcdr -!mulnA divnMl // mulnCA.
by rewrite muln_divA ?dvdn_mull ?dvdn_gcdr.
Qed.

Lemma muln_lcml : left_distributive muln lcmn.
Proof. by move=> m n p; rewrite -!(mulnC p) muln_lcmr. Qed.

Lemma lcmnA : associative lcmn.
Proof.
move=> m n p; rewrite [LHS]/lcmn [RHS]/lcmn mulnC.
rewrite !divn_mulAC ?dvdn_mull ?dvdn_gcdr // -!divnMA ?dvdn_mulr ?dvdn_gcdl //.
rewrite mulnC mulnA !muln_gcdr; congr (_ %/ _).
by rewrite ![_ * lcmn _ _]mulnC !muln_lcm_gcd !muln_gcdl -!(mulnC m) gcdnA.
Qed.

Lemma lcmnCA : left_commutative lcmn.
Proof. by move=> m n p; rewrite !lcmnA (lcmnC m). Qed.

Lemma lcmnAC : right_commutative lcmn.
Proof. by move=> m n p; rewrite -!lcmnA (lcmnC n). Qed.

Lemma lcmnACA : interchange lcmn lcmn.
Proof. by move=> m n p q; rewrite -!lcmnA (lcmnCA n). Qed.

Lemma dvdn_lcml d1 d2 : d1 %| lcmn d1 d2.
Proof. by rewrite /lcmn -muln_divA ?dvdn_gcdr ?dvdn_mulr. Qed.

Lemma dvdn_lcmr d1 d2 : d2 %| lcmn d1 d2.
Proof. by rewrite lcmnC dvdn_lcml. Qed.

Lemma dvdn_lcm d1 d2 m : lcmn d1 d2 %| m = (d1 %| m) && (d2 %| m).
Proof.
case: d1 d2 => [|d1] [|d2]; try by case: m => [|m]; rewrite ?lcmn0 ?andbF.
rewrite -(@dvdn_pmul2r (gcdn d1.+1 d2.+1)) ?gcdn_gt0 // muln_lcm_gcd.
by rewrite muln_gcdr dvdn_gcd {1}mulnC andbC !dvdn_pmul2r.
Qed.

Lemma lcmnMl m n : lcmn m (m * n) = m * n.
Proof. by case: m => // m; rewrite /lcmn gcdnMr mulKn. Qed.

Lemma lcmnMr m n : lcmn n (m * n) = m * n.
Proof. by rewrite mulnC lcmnMl. Qed.

Lemma lcmn_idPr {m n} : reflect (lcmn m n = n) (m %| n).
Proof.
by apply: (iffP idP) => [/dvdnP[q ->] | <-]; rewrite (lcmnMr, dvdn_lcml).
Qed.

Lemma lcmn_idPl {m n} : reflect (lcmn m n = m) (n %| m).
Proof. by rewrite lcmnC; apply: lcmn_idPr. Qed.

Lemma expn_max e m n : e ^ maxn m n = lcmn (e ^ m) (e ^ n).
Proof. by case: leqP => [|/ltnW] /(dvdn_exp2l e) /lcmn_idPl; rewrite lcmnC. Qed.

(* Coprime factors *)

Definition coprime m n := gcdn m n == 1.

Lemma coprime1n n : coprime 1 n.
Proof. by rewrite /coprime gcd1n. Qed.

Lemma coprimen1 n : coprime n 1.
Proof. by rewrite /coprime gcdn1. Qed.

Lemma coprime_sym m n : coprime m n = coprime n m.
Proof. by rewrite /coprime gcdnC. Qed.

Lemma coprime_modl m n : coprime (m %% n) n = coprime m n.
Proof. by rewrite /coprime gcdn_modl. Qed.

Lemma coprime_modr m n : coprime m (n %% m) = coprime m n.
Proof. by rewrite /coprime gcdn_modr. Qed.

Lemma coprime2n n : coprime 2 n = odd n.
Proof. by rewrite -coprime_modr modn2; case: (odd n). Qed.

Lemma coprimen2 n : coprime n 2 = odd n.
Proof. by rewrite coprime_sym coprime2n. Qed.

Lemma coprimeSn n : coprime n.+1 n.
Proof. by rewrite -coprime_modl (modnDr 1) coprime_modl coprime1n. Qed.

Lemma coprimenS n : coprime n n.+1.
Proof. by rewrite coprime_sym coprimeSn. Qed.

Lemma coprimePn n : n > 0 -> coprime n.-1 n.
Proof. by case: n => // n _; rewrite coprimenS. Qed.

Lemma coprimenP n : n > 0 -> coprime n n.-1.
Proof. by case: n => // n _; rewrite coprimeSn. Qed.

Lemma coprimeP n m :
  n > 0 -> reflect (exists u, u.1 * n - u.2 * m = 1) (coprime n m).
Proof.
move=> n_gt0; apply: (iffP eqP) => [<-| [[kn km] /= kn_km_1]].
  by have [kn km kg _] := egcdnP m n_gt0; exists (kn, km); rewrite kg addKn.
apply gcdn_def; rewrite ?dvd1n // => d dv_d_n dv_d_m.
by rewrite -kn_km_1 dvdn_subr ?dvdn_mull // ltnW // -subn_gt0 kn_km_1.
Qed.

Lemma modn_coprime k n : 0 < k -> (exists u, (k * u) %% n = 1) -> coprime k n.
Proof.
move=> k_gt0 [u Hu]; apply/coprimeP=> //.
by exists (u, k * u %/ n); rewrite /= mulnC {1}(divn_eq (k * u) n) addKn.
Qed.

Lemma Gauss_dvd m n p : coprime m n -> (m * n %| p) = (m %| p) && (n %| p).
Proof. by move=> co_mn; rewrite -muln_lcm_gcd (eqnP co_mn) muln1 dvdn_lcm. Qed.

Lemma Gauss_dvdr m n p : coprime m n -> (m %| n * p) = (m %| p).
Proof.
case: n => [|n] co_mn; first by case: m co_mn => [|[]] // _; rewrite !dvd1n.
by symmetry; rewrite mulnC -(@dvdn_pmul2r n.+1) ?Gauss_dvd // andbC dvdn_mull.
Qed.

Lemma Gauss_dvdl m n p : coprime m p -> (m %| n * p) = (m %| n).
Proof. by rewrite mulnC; apply: Gauss_dvdr. Qed.

Lemma dvdn_double_leq m n : m %| n -> odd m -> ~~ odd n -> 0 < n -> m.*2 <= n.
Proof.
move=> m_dv_n odd_m even_n n_gt0.
by rewrite -muln2 dvdn_leq // Gauss_dvd ?coprimen2 ?m_dv_n ?dvdn2.
Qed.

Lemma dvdn_double_ltn m n : m %| n.-1 -> odd m -> odd n -> 1 < n -> m.*2 < n.
Proof. by case: n => //; apply: dvdn_double_leq. Qed.

Lemma Gauss_gcdr p m n : coprime p m -> gcdn p (m * n) = gcdn p n.
Proof.
move=> co_pm; apply/eqP; rewrite eqn_dvd !dvdn_gcd !dvdn_gcdl /=.
rewrite andbC dvdn_mull ?dvdn_gcdr //= -(@Gauss_dvdr _ m) ?dvdn_gcdr //.
by rewrite /coprime gcdnAC (eqnP co_pm) gcd1n.
Qed.

Lemma Gauss_gcdl p m n : coprime p n -> gcdn p (m * n) = gcdn p m.
Proof. by move=> co_pn; rewrite mulnC Gauss_gcdr. Qed.

Lemma coprimeMr p m n : coprime p (m * n) = coprime p m && coprime p n.
Proof.
case co_pm: (coprime p m) => /=; first by rewrite /coprime Gauss_gcdr.
apply/eqP=> co_p_mn; case/eqnP: co_pm; apply gcdn_def => // d dv_dp dv_dm.
by rewrite -co_p_mn dvdn_gcd dv_dp dvdn_mulr.
Qed.

Lemma coprimeMl p m n : coprime (m * n) p = coprime m p && coprime n p.
Proof. by rewrite -!(coprime_sym p) coprimeMr. Qed.

Lemma coprime_pexpl k m n : 0 < k -> coprime (m ^ k) n = coprime m n.
Proof.
case: k => // k _; elim: k => [|k IHk]; first by rewrite expn1.
by rewrite expnS coprimeMl -IHk; case coprime.
Qed.

Lemma coprime_pexpr k m n : 0 < k -> coprime m (n ^ k) = coprime m n.
Proof. by move=> k_gt0; rewrite !(coprime_sym m) coprime_pexpl. Qed.

Lemma coprimeXl k m n : coprime m n -> coprime (m ^ k) n.
Proof. by case: k => [|k] co_pm; rewrite ?coprime1n // coprime_pexpl. Qed.

Lemma coprimeXr k m n : coprime m n -> coprime m (n ^ k).
Proof. by rewrite !(coprime_sym m); apply: coprimeXl. Qed.

Lemma coprime_dvdl m n p : m %| n -> coprime n p -> coprime m p.
Proof. by case/dvdnP=> d ->; rewrite coprimeMl => /andP[]. Qed.

Lemma coprime_dvdr m n p : m %| n -> coprime p n -> coprime p m.
Proof. by rewrite !(coprime_sym p); apply: coprime_dvdl. Qed.

Lemma coprime_egcdn n m : n > 0 -> coprime (egcdn n m).1 (egcdn n m).2.
Proof.
move=> n_gt0; case: (egcdnP m n_gt0) => kn km /= /eqP.
have [/dvdnP[u defn] /dvdnP[v defm]] := (dvdn_gcdl n m, dvdn_gcdr n m).
rewrite -[gcdn n m]mul1n {1}defm {1}defn !mulnA -mulnDl addnC.
rewrite eqn_pmul2r ?gcdn_gt0 ?n_gt0 //; case: kn => // kn /eqP def_knu _.
by apply/coprimeP=> //; exists (u, v); rewrite mulnC def_knu mulnC addnK.
Qed.

Lemma dvdn_pexp2r m n k : k > 0 -> (m ^ k %| n ^ k) = (m %| n).
Proof.
move=> k_gt0; apply/idP/idP=> [dv_mn_k|]; last exact: dvdn_exp2r.
have [->|n_gt0] := posnP n; first by rewrite dvdn0.
have [n' def_n] := dvdnP (dvdn_gcdr m n); set d := gcdn m n in def_n.
have [m' def_m] := dvdnP (dvdn_gcdl m n); rewrite -/d in def_m.
have d_gt0: d > 0 by rewrite gcdn_gt0 n_gt0 orbT.
rewrite def_m def_n !expnMn dvdn_pmul2r ?expn_gt0 ?d_gt0 // in dv_mn_k.
have: coprime (m' ^ k) (n' ^ k).
  rewrite coprime_pexpl // coprime_pexpr // /coprime -(eqn_pmul2r d_gt0) mul1n.
  by rewrite muln_gcdl -def_m -def_n.
rewrite /coprime -gcdn_modr (eqnP dv_mn_k) gcdn0 -(exp1n k).
by rewrite (inj_eq (expIn k_gt0)) def_m; move/eqP->; rewrite mul1n dvdn_gcdr.
Qed.

Section Chinese.

(***********************************************************************)
(*   The chinese remainder theorem                                     *)
(***********************************************************************)

Variables m1 m2 : nat.
Hypothesis co_m12 : coprime m1 m2.

Lemma chinese_remainder x y :
  (x == y %[mod m1 * m2]) = (x == y %[mod m1]) && (x == y %[mod m2]).
Proof.
wlog le_yx : x y / y <= x; last by rewrite !eqn_mod_dvd // Gauss_dvd.
by have [?|/ltnW ?] := leqP y x; last rewrite !(eq_sym (x %% _)); apply.
Qed.

(***********************************************************************)
(*   A function that solves the chinese remainder problem              *)
(***********************************************************************)

Definition chinese r1 r2 :=
  r1 * m2 * (egcdn m2 m1).1 + r2 * m1 * (egcdn m1 m2).1.

Lemma chinese_modl r1 r2 : chinese r1 r2 = r1 %[mod m1].
Proof.
rewrite /chinese; case: (posnP m2) co_m12 => [-> /eqnP | m2_gt0 _].
  by rewrite gcdn0 => ->; rewrite !modn1.
case: egcdnP => // k2 k1 def_m1 _.
rewrite mulnAC -mulnA def_m1 gcdnC (eqnP co_m12) mulnDr mulnA muln1.
by rewrite addnAC (mulnAC _ m1) -mulnDl modnMDl.
Qed.

Lemma chinese_modr r1 r2 : chinese r1 r2 = r2 %[mod m2].
Proof.
rewrite /chinese; case: (posnP m1) co_m12 => [-> /eqnP | m1_gt0 _].
  by rewrite gcd0n => ->; rewrite !modn1.
case: (egcdnP m2) => // k1 k2 def_m2 _.
rewrite addnC mulnAC -mulnA def_m2 (eqnP co_m12) mulnDr mulnA muln1.
by rewrite addnAC (mulnAC _ m2) -mulnDl modnMDl.
Qed.

Lemma chinese_mod x : x = chinese (x %% m1) (x %% m2) %[mod m1 * m2].
Proof.
apply/eqP; rewrite chinese_remainder //.
by rewrite chinese_modl chinese_modr !modn_mod !eqxx.
Qed.

End Chinese.


(* Arithmetic expressions *)

Require Import imports.
Require Import String.
Local Open Scope Z_scope.

Definition vname := string.
Definition val := Z.

Inductive aexpr :=
| Anum : val -> aexpr
| Avar : vname -> aexpr
| Aplus : aexpr -> aexpr -> aexpr.

Definition state := vname -> val.

Fixpoint aval (s : state) (e : aexpr) :=
  match e with
  | Anum n => n
  | Avar x => s x
  | Aplus x y => aval s x + aval s y
  end.

Fixpoint asimp_const (e : aexpr) :=
  match e with
  | Anum n => Anum n
  | Avar x => Avar x
  | Aplus e1 e2 =>
    match asimp_const e1, asimp_const e2 with
    | Anum n1, Anum n2 => Anum (n1 + n2)
    | e1', e2' => Aplus e1' e2'
    end
  end.

Lemma lem_aval_asimp_const : forall s e, aval s (asimp_const e) = aval s e.
Proof.
  induction e; sauto.
Qed.

Fixpoint plus (e1 e2 : aexpr) :=
  match e1, e2 with
  | Anum n1, Anum n2 => Anum (n1 + n2)
  | Anum 0, _ => e2
  | _, Anum 0 => e1
  | _, _ => Aplus e1 e2
  end.

Lemma lem_aval_plus : forall s e1 e2, aval s (plus e1 e2) = aval s e1 + aval s e2.
Proof.
  Reconstr.scrush (** hammer *).
Qed.

Fixpoint asimp (e : aexpr) :=
  match e with
  | Aplus x y => plus (asimp x) (asimp y)
  | _ => e
  end.

Lemma lem_aval_asimp : forall s e, aval s (asimp e) = aval s e.
Proof.
  induction e; sauto.
  Reconstr.htrivial Reconstr.AllHyps
                    (@lem_aval_plus)
                    Reconstr.Empty.
Qed.


Require Import Frap.

(* Levels of verification *)
Fixpoint my_reverse (A: Type) (l: list A): list A :=
  match l with
  | nil => nil
  | cons head tail => app (my_reverse A tail) (cons head nil)
  end.

Arguments my_reverse [A].

Theorem my_reverse_correct1: forall (A: Type) (l: list A),
  length l = length (my_reverse l).
Proof.
  simplify.
  induct l.
  + simplify. trivial.
  + simplify.
    rewrite IHl.
    Search (length (_ ++ _) = length _ + length _).
    (* https://coq.inria.fr/library/Coq.Lists.List.html *)
    rewrite app_length.
    simplify.
    linear_arithmetic.
Qed.

Theorem my_reverse_correct2: forall (A: Type) (l: list A),
  length l = length (my_reverse l) /\
  (forall (e: A), (In e l) -> In e (my_reverse l)) /\
  (forall (e: A), (In e (my_reverse l)) -> In e l).
Proof.
  simplify.
  propositional.
  + apply my_reverse_correct1.
  + induct l.
    - simplify. trivial.
    - simplify.
      Locate "\/".
      Print or.
      destruct H. (* alternatively invert from Frap *)
      *
        Search (In _ _ \/ In _ _ -> In _ (_ ++ _)).
        apply in_or_app.
        simplify.
        propositional.
      * apply in_or_app.
        (* version 1: natural-deduction like *)
        apply or_introl.
        apply IHl.
        assumption.
        (* alternatively:
         apply IHl in H. propositional *)
  + induct l.
    - simplify. trivial.
    - simplify.
      Search (In _ (_ ++ _) -> In _ _ \/ In _ _).
      apply in_app_or in H.
      destruct H.
      * apply or_intror.
        apply IHl.
        assumption.
      * simplify.
        propositional.
Qed.

Theorem my_reverse_correct3: forall (A: Type) (l: list A),
  length l = length (my_reverse l) /\
  (forall (a: A), my_reverse [a] = [a]) /\
  forall (l1 l2: list A) (a1 a2: A),
    (my_reverse (l1 ++ [a1; a2] ++ l2)) = (my_reverse l2) ++ [a2; a1] ++ (my_reverse l1).
Proof.
  pose my_reverse_correct1.
  simplify.
  propositional.
  + apply e.
  + induct l1; induct l2; simplify.
    - equality.
    - Search ((_ ++ _) ++ _ = _ ++ (_ ++ _)).
      rewrite app_assoc_reverse.
      simplify.
      equality.
    - specialize IHl1 with (l2 := nil) (a1 := a1) (a2 := a2).
      rewrite IHl1.
      simplify.
      equality.
    - specialize IHl1 with (l2 := a0 :: l2).
      rewrite IHl1.
      simplify.
      rewrite app_assoc_reverse.
      simplify.
      equality.
Qed.

Search (nat -> list _ ->  _).
Search (list _ ->  nat -> _).
Theorem my_reverse_really_correct: forall (A: Type) (l: list A),
    length l = length (my_reverse l) /\
    forall (i: nat), i < length l -> nth_error l i = nth_error (my_reverse l) (length l - i - 1).
Proof.
  pose my_reverse_correct1.
  simplify.
  propositional.
  - apply e.
  - induct l.
    + simplify. linear_arithmetic.
    + cases i.
      -- simplify.
         rewrite nth_error_app2.
         ++ rewrite e with A l.
            assert (length (my_reverse l) - 0 - length (my_reverse l) = 0) by linear_arithmetic.
            rewrite H0.
            simplify.
            equality.
         ++ specialize e with A l.
            linear_arithmetic.
      -- simplify.
         rewrite nth_error_app1.
         ++ apply IHl. linear_arithmetic.
         ++ specialize e with A l.
            linear_arithmetic.
Qed.


From mathcomp.ssreflect
Require Import ssreflect ssrbool.
From mathcomp.ssreflect
Require Import ssrnat.
From mathcomp.ssreflect
Require Import seq.

(* Recap: we can define simple inductive types as seen before
Inductive unit : Set := it.
*)

(* seemingly, types of symbols are inferred to be elements
* i.e it : unit
*)

(* Inductive types can be empty *)
Inductive empty: Set := .

(* Recap: Types can hold multiple values
    Inductive bool : Set := true : bool | false : bool.
*)

(* Recap: quick example of a simple
*  non-recursive function
    Definition negate b :=
        match b with
        | true => false
        | false => true
        end.
*)

(* A simple custom add operation:
*    add n m:
*       if n == 0:
*           return m
*       else:
*           return (add (n-1) m) + 1
*)
Fixpoint custom_plus n m :=
    match n with
    | 0 => m
(* New: we haven't used temporary variables before - looks like they act like haskell. *)
    | n'.+1 => let tmp := custom_plus n' m in tmp.+1
    end.

(*
* ssreflect provides a couple of utility constructs that can make proofs faster.
* specifically, the if-is notation
* which is exactly rust's if-let construct.
*)
Fixpoint custom_plus' (n m: nat) :=
    if n is n'.+1 then (custom_plus' n' m).+1
                  else m.

(* COOL stuff: now we're cooking with functionals!
* we're going to use the recursion principle
* to implement custom_plus
*)
Definition custom_plus'' (n m: nat) :=
    nat_rec (fun _ => nat) m (fun n' m' => m'.+1) n.
(*
* All values of P n are natural numbers
* f (base of the recursion is m)
* f0 n' m' returns m'.+1
* and then is applied to n.
*
* so once executed, it becomes
* f0 (m-1) (f0 (m-2) (f0 (m-3) .... (f0 1 0) ..)
* which evaluates to
*  0.+1.+1.+1 ... .+1 = result
*)

Example plus_works: custom_plus'' 2 3 = 5.
simpl.
reflexivity.
Qed.

(* Note how Coq's compile time restrictions allows for dependantly typed functions
* to illustrate the point, we'll implement a complex one
*)
Definition sum_no_zero n :=
    (* P is a function that return the unit type if input is 0 else the natural type *)
    let: P := (fun n => if n is 0 then unit else nat) in
    (* our type generator function is P, our initial element is the only element in unit
    * tt, our combiner function *)
    nat_rec P tt (fun n' m =>
        match n' return P n' -> _ with (* Note: the return construct is a type annotation *)
        | 0 => fun _ => 1  (* maps from unit to nat - is the first function in the
                sequence  *)
        | n''.+1 => fun m => custom_plus'' m (n'.+1) (* maps from nat to nat *)
        end m) n.

(* Having looked at the definition of empty_rect, we can see that it's type signiture:
* (P: empty -> Type) -> (e: empty) -> P e
* i.e given a mapping from empty to a type, and given an element of empty, we can construct
* a member of any type
*
* This is a vacuous truth - much like false -> anything, we can never get an element of empty
* so this would never apply.
*)

(*
* However, a type with no elements is not the only way we can construct an
* un-instantiateable type.
*
* for example:
*)

Inductive strange : Set := cs : strange -> strange.

(*
* The definition of strange_rect is as follows:
*strange_rect
*    : forall P : strange -> Type,
*      (forall s : strange, P s -> P (cs s)) -> forall s : strange, P s
* i.e,  given a mapping from strange to type = P,
*       and a mapping from P s to P (cs s)
*       we can get P s
*)

(*
* Now consider the definition of prod - coq's equivalent of a pair type.
*
* Inductive prod (A B : Type) : Type := A -> B -> A * B
*
*  This becomes clearer when you look at how  a pair is constructed.
*
*  Check pair 1 tt.
*
* (1, tt)
*      : nat * unit
*
*  which can be corroborated by considering the type of the type prod
*
* Check prod.
*
* prod
*     : Type -> Type -> Type
*
* I.e, like in Haskell, the prod takes in two arguments and produces a type.
*
* We can manually specify the type (rather than allowing it to be inferred) using @:
*
* Check @pair nat unit 1 tt.
*
*)

(*
*
* Now, finally, to include some bread-and-butter functional programming utilities,
*  let's consider the union and list types - sum and seq.
* Sum : (A B : Type) : Type = inl : A -> A + B
*                           | inr : B -> A + B.
*
* seq : (A : Type) : Type := nil : seq A
*                           | cons: A -> seq A -> seq A
*
* We can also do nifty typedefs as follows:
*)
Notation seq := list.

(*
*
* Let's try using this stuff out by implementing an alternate function, which alternates the elements of two lists.
*
*)

(* This is how we'd implement it in Haskell,
*  However, this is not permitted by the coq language
*  as it has no clear recursive variant - no parameter is always decreasing
Fixpoint alternate (a : seq nat) (b : seq nat) : seq nat :=
    match a return seq nat with
    | nil => b
    | cons head' tail' => cons head' (alternate b tail)
    end.
*  we can implement it as follows:
*)

Fixpoint alternate (a b : seq nat) : seq nat :=
        match a return seq nat with
                | nil => b
                | cons head_a tail_a => match b with
                                    | nil => cons head_a tail_a
                                    | cons head_b tail_b => cons head_a (cons head_b
                                            (alternate
                                            tail_a tail_b))
                                    end
                end.

(*
*
* Now we will consider how we can use ssreflect to speed up our proofs
*  here we'll consider a shorter way to define pairs
*)

Inductive custom_prod (A B : Type) : Type := custom_pair of A & B.

(*
* Here, we will use of & structure to allow A and B to be the parameters of the type as well a the constructor.
*
* However with this format, we need to provide the types explicitly.
* We can work around this using the Implicit arguments of coq.
*)

Implicit Arguments custom_pair [A B].

(*
*
* Alongside implicit arguments, coq provides additional utilities is the form of
* custom notation to represent our own types for ease of reading.
*)

Notation "X ** Y" := (custom_prod X Y) (at level 2).
Notation "( X ,, Y )" := (custom_pair X Y).

(*
*
* You can see this notation in action by running Check (1 ,, 3).
*)


Require Export P02.

Theorem S_injective : forall (n m : nat),
  S n = S m ->
  n = m.
Proof.
  intros n m H. inversion H. reflexivity.
Qed.

Theorem plus_comm : forall n m : nat,
  n + m = m + n.
Proof.
  intros n m. induction n as [| n' IHn'].
  - simpl. rewrite <- plus_n_O. reflexivity.
  - rewrite <- plus_n_Sm. rewrite <- IHn'. reflexivity.
Qed.

Theorem plus_n_Sm : forall n m : nat,
  S (n + m) = n + (S m).
Proof.
  intros n m. induction n as [| n' IHn'].
  - reflexivity.
  - simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem plus_n_n_injective : forall n m,
     n + n = m + m ->
     n = m.
Proof.
  intros n. induction n as [| n'].
  - intros m H. simpl in H. destruct m.
    + reflexivity.
    + inversion H.
  - intros m H. simpl in H. destruct m.
    + inversion H.
    + symmetry in H. rewrite <- plus_n_Sm in H. apply S_injective in H.
      rewrite <- plus_n_Sm in H. rewrite -> plus_comm in H. rewrite <- plus_n_Sm in H.
      apply S_injective in H. symmetry in H. apply IHn' in H. rewrite H. reflexivity.
Qed.


Require Import Omega List.
Require Import List.
Print list.
Print nil.
Require Setoid.
Require Import PeanoNat Le Gt Minus Bool Lt.
Open Scope list_scope.

Definition szam(k:option(nat)):nat:=
  match k with
  | None => 0
  | Some k => k
  end.

Fixpoint listaszum(k:list(option(nat))):nat:=
  match k with
  | nil => 0
  | cons x l' => szam x+ listaszum l'
  end.

Eval compute in listaszum (Some(2)::None::Some(4)::nil).

Require Import NAxioms NProperties OrdersFacts.

Print min_l.

Eval compute in Init.Nat.min 5 6.

Fixpoint listakicsi(k:list(option(nat))):nat:=
  match k with
  | nil => 0
  | cons x l' => Init.Nat.min (szam x) (listakicsi l')
  end.

Eval compute in listakicsi (Some(2)::None::Some(4)::nil).

Print Init.Nat.

Eval compute in (Init.Nat.eqb(Init.Nat.min 5 6)  (5)).

Definition MinPairTwo(x y : option (nat*nat)) : nat :=
  match x, y with
    | None, None => 0
    | None, Some (b,m) => b
    | Some (a,n), None => a
    | Some (a, n), Some (b, m) =>  match (Init.Nat.eqb(Init.Nat.min n m)(n)) with
          |true => a
          |_ => b
          end
  end.

Definition MinPairTwoVege(x y : option (nat*nat)) : option(nat*nat) :=
  match x, y with
    | None, None => None
    | None, Some (b,m) => Some(b,m)
    | Some (a,n), None => Some(a,n)
    | Some (a, n), Some (b, m) =>  match (Init.Nat.eqb(Init.Nat.min n m)(n)) with
          |true => Some(a,n)
          |_ => Some(b,m)
          end
  end.

Definition elsokinyer (x:option(nat*nat)):option(nat):=
  match x with
  |None => None
  |Some(a,b)=>Some(a)
  end.

Eval compute in MinPairTwoVege (Some(2,3)) (Some (1,4)).

Fixpoint listaminpar(k:list(option(nat*nat))):option(nat*nat):=
  match k with
  | nil => None
  | cons x l' => MinPairTwoVege(x) (listaminpar l')
  end.

Definition legkisebbpar (k:list(option(nat*nat))):option(nat):=
  elsokinyer (listaminpar k).

Eval compute in legkisebbpar (Some(2,3)::None::Some(4,1)::Some(88,0)::nil).