Require Import Bool String List Lia.
Require Import Lib.CommonTactics Lib.NatLib Lib.Indexer
        Lib.Struct Lib.DepEq Lib.Word Lib.FMap Lib.Reflection.
Require Import Kami.Syntax Kami.Notations Kami.Semantics Kami.SemFacts Kami.Tactics.

Require Import ZArith Eqdep Program.Equality.

Set Implicit Arguments.
Open Scope string.

(* Some useful facts about [word], only for the multiplier implementation. *)
Section WordEx.

  Definition rtrunc1 sz (w: word (S sz)): word sz:=
    match w with
    | WO => idProp
    | WS _ w' => w'
    end.

  Definition rtrunc2 sz (w: word (S (S sz))): word sz :=
    match w with
    | WO => idProp
    | WS _ w' =>
      match w' with
      | WO => idProp
      | WS _ w'' => w''
      end
    end.

  Lemma wordToNat_rtrunc1:
    forall sz (w: word (S sz)),
      wordToNat (rtrunc1 w) = wordToNat w / 2.
  Proof.
    dependent destruction w.
    unfold rtrunc1, wordToNat; fold wordToNat.
    destruct b.
    - change (S (wordToNat w * 2)) with (1 + wordToNat w * 2).
      rewrite Nat.div_add by discriminate.
      reflexivity.
    - apply eq_sym, Nat.div_mul; discriminate.
  Qed.

  Lemma combine_wrshifta_rtrunc1_sext:
    forall s (w: word s) sl (wl: word (S (S sl))) su (wu: word (S su)),
      existT word s w =
      existT word ((S (S sl)) + S su) (combine wl wu) ->
      existT word s (wrshifta w 1) =
      existT word ((S sl) + (S su + 1)) (combine (rtrunc1 wl) (sext wu 1)).
  Proof.
    intros.
    pose proof (eq_sigT_fst H); subst.
    destruct_existT.
    apply wordToNat_existT; [lia|].

    rewrite wordToNat_wrshifta.
    change (pow2 1) with 2.
    rewrite wordToNat_combine.
    pose proof (combine_sext wl wu 1).
    apply existT_wordToNat in H; rewrite <-H.
    rewrite wordToNat_combine.
    change (pow2 (S (S sl))) with (2 * pow2 (S sl)).
    rewrite <-Nat.mul_assoc.
    rewrite Nat.mul_comm with (n:= 2).
    rewrite Nat.div_add by discriminate.
    rewrite wordToNat_rtrunc1.
    reflexivity.
  Qed.

  Lemma wordToNat_rtrunc2:
    forall sz (w: word (S (S sz))),
      wordToNat (rtrunc2 w) = wordToNat w / 4.
  Proof.
    do 2 dependent destruction w.
    unfold rtrunc2, wordToNat; fold wordToNat.
    destruct b, b0.
    - replace (S (S (wordToNat w * 2) * 2))
        with (3 + wordToNat w * 4) by lia.
      rewrite Nat.div_add by discriminate.
      reflexivity.
    - replace (S (wordToNat w * 2 * 2))
        with (1 + wordToNat w * 4) by lia.
      rewrite Nat.div_add by discriminate.
      reflexivity.
    - replace (S (wordToNat w * 2) * 2)
        with (2 + wordToNat w * 4) by lia.
      rewrite Nat.div_add by discriminate.
      reflexivity.
    - replace (wordToNat w * 2 * 2)
        with (wordToNat w * 4) by lia.
      apply eq_sym, Nat.div_mul; discriminate.
  Qed.

  Lemma combine_wrshifta_rtrunc2_sext:
    forall s (w: word s) sl (wl: word (S (S (S sl)))) su (wu: word (S su)),
      existT word s w =
      existT word ((S (S (S sl))) + S su) (combine wl wu) ->
      existT word s (wrshifta w 2) =
      existT word ((S sl) + (S su + 2)) (combine (rtrunc2 wl) (sext wu 2)).
  Proof.
    intros.
    pose proof (eq_sigT_fst H); subst.
    destruct_existT.
    apply wordToNat_existT; [lia|].

    rewrite wordToNat_wrshifta.
    change (pow2 2) with 4.
    rewrite wordToNat_combine.
    pose proof (combine_sext wl wu 2).
    apply existT_wordToNat in H; rewrite <-H.
    rewrite wordToNat_combine.
    replace (pow2 (S (S (S sl)))) with (4 * pow2 (S sl)) by (simpl; lia).
    rewrite <-Nat.mul_assoc.
    rewrite Nat.mul_comm with (n:= 4).
    rewrite Nat.div_add by discriminate.
    rewrite wordToNat_rtrunc2.
    reflexivity.
  Qed.

End WordEx.

(** A radix-4 Booth Multiplier.*)

(* Note that the Booth multiplication algorithm is naturally designed
 * for signed integers, so we need to add sign bits (0) for unsigned integers
 * and their multiplication. It means we have to deal with 65 bits for 64-bit
 * unsigned multiplication.
 *
 * Here we assume the multiplier always takes _65-bit signed integers_ as
 * arguments.
 *)
Section Multiplier32.
  (* NOTE: it's hard to declare [LogNumPhases] and [NumBitsPerPhase] as
   * variables, since truncation and extension require certain equation
   * w.r.t. bit-lengths.
   *)
  (* Variable MultLogNumPhases MultNumStepsPerPhase: nat. *)
  Definition MultLogNumPhases := 2.
  Definition MultNumStepsPerPhase := 4.
  (* 2*4 = 8 bits are calculated per a phase. *)
  Definition MultNumBitsPerPhase := 2 * MultNumStepsPerPhase.

  Definition MultNumPhases := wordToNat (wones MultLogNumPhases) + 1. (* 2^2 = 4 *)
  Definition MultNumBits := MultNumPhases * MultNumBitsPerPhase. (* 4*8 = 32 *)
  Definition MultNumBitsExt := MultNumBits + 1. (* 4*8 + 1 = 33 *)
  Definition MultBits := 2 * MultNumBitsExt + 2.

  Definition MultInStr := STRUCT { "multiplicand" :: Bit MultNumBitsExt;
                                   "multiplier" :: Bit MultNumBitsExt }.
  Definition MultOutStr := STRUCT { "high" :: Bit MultNumBits;
                                    "low" :: Bit MultNumBits }.

  (* NOTE: must use shirt-right-arithmetic to preserve the sign bit. *)
  Definition boothStep' {ty}
             (m_pos m_neg: fullType ty (SyntaxKind (Bit MultBits)))
             (p: Expr ty (SyntaxKind (Bit MultBits)))
             (pr: Expr ty (SyntaxKind (Bit 2))) :=
    let pSra := (p ~>> $$(WO~1))%kami_expr in
    (IF (pr == $$(WO~0~1)) then pSra + (#m_pos ~>> $$(WO~1))
     else IF (pr == $$(WO~1~0)) then pSra + (#m_neg ~>> $$(WO~1))
     else pSra)%kami_expr.

  Definition boothStep {ty}
             (m_pos m_neg: fullType ty (SyntaxKind (Bit MultBits)))
             (p: Expr ty (SyntaxKind (Bit ((MultBits - 2) + 2))))
    : Expr ty (SyntaxKind (Bit MultBits)) :=
    (boothStep' m_pos m_neg p (UniBit (Trunc 2 _) p))%kami_expr.

  Lemma boothStep'_eval:
    forall m_pos m_neg p pr,
      evalExpr (boothStep' m_pos m_neg p pr) =
      if weq (evalExpr pr) WO~0~1 then (wrshifta (evalExpr p) 1) ^+ (wrshifta m_pos 1)
      else if weq (evalExpr pr) WO~1~0 then (wrshifta (evalExpr p) 1) ^+ (wrshifta m_neg 1)
           else wrshifta (evalExpr p) 1.
  Proof.
    intros; simpl.
    destruct (weq _ _); try reflexivity.
    destruct (weq _ _); reflexivity.
  Qed.

  Definition boothStepEvalM (m_pos m_neg: word MultBits)
             (p: Expr type (SyntaxKind (Bit (MultBits - 2 + 2)))) :=
    wrshifta
      (if weq (split1 2 (MultBits - 2) (evalExpr p)) WO~0~1
       then m_pos
       else
         if weq (split1 2 (MultBits - 2) (evalExpr p)) WO~1~0
         then m_neg
         else $0) 1.

  Lemma boothStep_eval:
    forall m_pos m_neg p,
      evalExpr (boothStep m_pos m_neg p) =
      wrshifta (evalExpr p) 1 ^+ boothStepEvalM m_pos m_neg p.
  Proof.
    intros; unfold boothStep, boothStepEvalM.
    rewrite boothStep'_eval.
    repeat destruct (weq _ _); try reflexivity.
    rewrite wrshifta_wzero, wplus_comm, wplus_unit; reflexivity.
  Qed.

  Opaque boothStep.

  Definition booth4Step' {ty}
             (m_pos m_neg: fullType ty (SyntaxKind (Bit MultBits)))
             (p: Expr ty (SyntaxKind (Bit MultBits)))
             (pr: Expr ty (SyntaxKind (Bit 3))) :=
    let pSra := (p ~>> $$(WO~1~0))%kami_expr in
    (IF (pr == $$(WO~0~0~1)) then pSra + (#m_pos ~>> $$(WO~1~0))
     else IF (pr == $$(WO~0~1~0)) then pSra + (#m_pos ~>> $$(WO~1~0))
     else IF (pr == $$(WO~0~1~1)) then pSra + ((#m_pos << $$(WO~1)) ~>> $$(WO~1~0))
     else IF (pr == $$(WO~1~0~0)) then pSra + ((#m_neg << $$(WO~1)) ~>> $$(WO~1~0))
     else IF (pr == $$(WO~1~0~1)) then pSra + (#m_neg ~>> $$(WO~1~0))
     else IF (pr == $$(WO~1~1~0)) then pSra + (#m_neg ~>> $$(WO~1~0))
     else pSra)%kami_expr.

  (* NOTE: must use shirt-right-arithmetic to preserve the sign bit. *)
  Definition booth4Step {ty}
             (m_pos m_neg: fullType ty (SyntaxKind (Bit MultBits)))
             (p: Expr ty (SyntaxKind (Bit ((MultBits - 3) + 3))))
    : Expr ty (SyntaxKind (Bit MultBits)) :=
    (booth4Step' m_pos m_neg p (UniBit (Trunc 3 _) p))%kami_expr.

  Lemma booth4Step'_eval:
    forall m_pos m_neg p pr,
      evalExpr (booth4Step' m_pos m_neg p pr) =
      if weq (evalExpr pr) WO~0~0~1 then wrshifta (evalExpr p) 2 ^+ wrshifta m_pos 2
      else if weq (evalExpr pr) WO~0~1~0 then wrshifta (evalExpr p) 2 ^+ wrshifta m_pos 2
      else if weq (evalExpr pr) WO~0~1~1 then wrshifta (evalExpr p) 2 ^+ wrshifta (wlshift m_pos 1) 2
      else if weq (evalExpr pr) WO~1~0~0 then wrshifta (evalExpr p) 2 ^+ wrshifta (wlshift m_neg 1) 2
      else if weq (evalExpr pr) WO~1~0~1 then wrshifta (evalExpr p) 2 ^+ wrshifta m_neg 2
      else if weq (evalExpr pr) WO~1~1~0 then wrshifta (evalExpr p) 2 ^+ wrshifta m_neg 2
      else wrshifta (evalExpr p) 2.
  Proof.
    intros; simpl.
    repeat destruct (weq _ _); reflexivity.
  Qed.

  Definition booth4StepEvalM (m_pos m_neg: word MultBits)
             (p: Expr type (SyntaxKind (Bit (MultBits - 3 + 3)))) :=
    wrshifta
      (if weq (split1 3 (MultBits - 3) (evalExpr p)) WO~0~0~1
       then m_pos
       else
         if weq (split1 3 (MultBits - 3) (evalExpr p)) WO~0~1~0
         then m_pos
         else
           if weq (split1 3 (MultBits - 3) (evalExpr p)) WO~0~1~1
           then (wlshift m_pos 1)
           else
             if weq (split1 3 (MultBits - 3) (evalExpr p)) WO~1~0~0
             then (wlshift m_neg 1)
             else
               if weq (split1 3 (MultBits - 3) (evalExpr p)) WO~1~0~1
               then m_neg
               else
                 if weq (split1 3 (MultBits - 3) (evalExpr p)) WO~1~1~0
                 then m_neg
                 else $0) 2.

  Lemma booth4Step_eval:
    forall m_pos m_neg p,
      evalExpr (booth4Step m_pos m_neg p) =
      wrshifta (evalExpr p) 2 ^+ (booth4StepEvalM m_pos m_neg p).
  Proof.
    intros; unfold booth4Step, booth4StepEvalM.
    rewrite booth4Step'_eval.

    repeat destruct (weq _ _); try reflexivity.
    rewrite wrshifta_wzero, wplus_comm, wplus_unit; reflexivity.
  Qed.

  Opaque booth4Step.

  Fixpoint booth4Steps (cnt: nat)
           {ty} (m_pos m_neg: fullType ty (SyntaxKind (Bit MultBits)))
           (p: fullType ty (SyntaxKind (Bit ((MultBits - 3) + 3))))
           (cont: fullType ty (SyntaxKind (Bit ((MultBits - 3) + 3))) ->
                  ActionT ty Void)
    : ActionT ty Void :=
    match cnt with
    | O => (cont p)%kami_action
    | S n => (LET np <- booth4Step m_pos m_neg #p;
              booth4Steps n m_pos m_neg np cont)%kami_action
    end.

  Definition multPull := MethodSig "multPull"(): Struct MultInStr.
  Definition multPush := MethodSig "multPush"(Struct MultOutStr): Void.

  Definition boothMultiplierImpl :=
    MODULE {
      Register "m_pos" : Bit MultBits <- Default
      with Register "m_neg" : Bit MultBits <- Default
      with Register "p" : Bit MultBits <- Default
      with Register "m" : Bit MultNumBitsExt <- Default
      with Register "r" : Bit MultNumBitsExt <- Default
      with Register "cnt" : Bit (S MultLogNumPhases) <- Default

      with Rule "boothMultRegister" :=
        Call src <- multPull();

        LET m : Bit (pred MultNumBitsExt + 1) <- #src!MultInStr@."multiplicand";

        (* Make sure msb(m) = 0 *)
        Assert (UniBit (TruncLsb _ 1) #m == $0);

        LET m_neg <- UniBit (Neg _) #m;

        LET m_pos : Bit MultBits <-
          BinBit (Concat _ (S MultNumBitsExt))
                 (UniBit (SignExtendTrunc _ (S MultNumBitsExt)) #m) $0;
        LET m_neg : Bit MultBits <-
          BinBit (Concat _ (S MultNumBitsExt))
                 (UniBit (SignExtendTrunc _ (S MultNumBitsExt)) #m_neg) $0;

        Write "m_pos" <- #m_pos;
        Write "m_neg" <- #m_neg;
        Write "m" <- #m;

        LET r <- #src!MultInStr@."multiplier";
        Write "r" <- #r;

        LET p : Bit MultBits <-
          BinBit (Concat (S MultNumBitsExt) _) $0 (BinBit (Concat _ 1) #r $0);

        (* Handle one bit in advance, in order to deal with other 64 bits
         * consistently in a rule [boothStep].
         *)
        LET np : Bit MultBits <- boothStep m_pos m_neg #p;
        Write "p" <- #np;

        Write "cnt" : Bit (S MultLogNumPhases) <- $(MultNumPhases);
        Retv

      with Rule "boothMultGetResult" :=
        Read cnt : Bit (S MultLogNumPhases) <- "cnt";
        Assert (#cnt == $0);

        Read p : Bit MultBits <- "p";
        LET highlowe : Bit (2 * MultNumBitsExt) <-
          UniBit (ConstExtract 1 (2 * MultNumBitsExt) 1) #p;
        LET highlow : Bit (2 * MultNumBits) <-
          UniBit (SignExtendTrunc _ _) #highlowe;

        LET high : Bit MultNumBits <- UniBit (TruncLsb _ _) #highlow;
        LET low : Bit MultNumBits <- UniBit (Trunc _ _) #highlow;

        Call multPush(STRUCT { "high" ::= #high; "low" ::= #low });

        Retv

      with Rule "boothStep" :=
        Read cnt : Bit (S MultLogNumPhases) <- "cnt";
        Assert (#cnt != $0);

        Read m_pos : Bit MultBits <- "m_pos";
        Read m_neg : Bit MultBits <- "m_neg";
        Read p : Bit MultBits <- "p";

        Write "cnt" <- #cnt - $1;

        booth4Steps
          MultNumStepsPerPhase m_pos m_neg p
          (fun np => Write "p" <- #np; Retv)
    }.

  Definition multiplierSpec :=
    MODULE {
      Register "m" : Bit MultNumBitsExt <- Default
      with Register "r" : Bit MultNumBitsExt <- Default

      with Rule "multRegister" :=
        Call src <- multPull();
        LET m : Bit MultNumBitsExt <- #src!MultInStr@."multiplicand";
        LET r : Bit MultNumBitsExt <- #src!MultInStr@."multiplier";

        Write "m" <- #m;
        Write "r" <- #r;
        Retv

      with Rule "multGetResult" :=
        Read m : Bit MultNumBitsExt <- "m";
        LET m_ext : Bit (2 * MultNumBitsExt) <- UniBit (SignExtendTrunc _ _) #m;
        Read r : Bit MultNumBitsExt <- "r";
        LET r_ext : Bit (2 * MultNumBitsExt) <- UniBit (SignExtendTrunc _ _) #r;

        LET p : Bit (2 * MultNumBitsExt) <- #m_ext *s #r_ext;
        LET highlow : Bit (2 * MultNumBits) <- UniBit (SignExtendTrunc _ _) #p;

        LET high : Bit MultNumBits <- UniBit (TruncLsb _ _) #highlow;
        LET low : Bit MultNumBits <- UniBit (Trunc _ _) #highlow;

        Call multPush(STRUCT { "high" ::= #high; "low" ::= #low });

        Retv
    }.

  (*! Correctness of the multiplier *)

  Section BoothEncoding.

    Inductive Booth := BZero | BPlus | BMinus.

    Definition boothToZ (b: Booth): Z :=
      match b with
      | BZero => 0
      | BPlus => 1
      | BMinus => -1
      end.

    Definition bbToZ (bb: Booth * Booth): Z :=
      match bb with
      | (BZero, b) => boothToZ b
      | (BPlus, b) => boothToZ b + 2
      | (BMinus, b) => boothToZ b - 2
      end.

    Inductive bword: nat -> Set :=
    | BWO: bword 0
    | BWS: Booth -> forall n, bword n -> bword (S n).

    Fixpoint bwordToZ sz (bw: bword sz): Z :=
      match bw with
      | BWO => 0
      | BWS BZero bw' => bwordToZ bw' * 2
      | BWS BPlus bw' => (bwordToZ bw' * 2) + 1
      | BWS BMinus bw' => (bwordToZ bw' * 2) - 1
      end.

    Declare Scope bword_scope.
    Notation "w ~ 0" := (BWS BZero w) (at level 7, left associativity,
                                       format "w '~' '0'"): bword_scope.
    Notation "w ~ 'P'" := (BWS BPlus w) (at level 7, left associativity,
                                         format "w '~' 'P'"): bword_scope.
    Notation "w ~ 'N'" := (BWS BMinus w) (at level 7, left associativity,
                                          format "w '~' 'N'"): bword_scope.
    Delimit Scope bword_scope with bword.

    Definition encodeB2 (mst lst: bool) :=
      match mst, lst with
      | false, true => BPlus
      | true, false => BMinus
      | _, _ => BZero
      end.

    Definition wencodeB2 (w: word 2): Booth.
    Proof.
      dependent destruction w.
      dependent destruction w.
      exact (encodeB2 b0 b).
    Defined.

    Fixpoint wordToB2' sz (w: word sz) (p: bool): bword sz :=
      match w with
      | WO => BWO
      | WS b w' => BWS (encodeB2 b p) (wordToB2' w' b)
      end.

    Lemma wordToB2'_rtrunc1_wlsb:
      forall sz (w: word (S sz)) p,
        wordToB2' w p = BWS (encodeB2 (wlsb w) p) (wordToB2' (rtrunc1 w) (wlsb w)).
    Proof.
      intros; dependent destruction w; simpl; reflexivity.
    Qed.

    Definition wordToB2 sz (w: word (S sz)): bword sz :=
      match w with
      | WO => idProp
      | WS b w' => wordToB2' w' b
      end.

    Lemma wordToB2_one:
      forall (w: word 1), bwordToZ (wordToB2 w) = 0%Z.
    Proof.
      dependent destruction w.
      dependent destruction w.
      simpl; reflexivity.
    Qed.

    Lemma wordToB2_bwordToZ':
      forall sz (w: word (S sz)) b,
        bwordToZ (wordToB2 (WS b w)) = (wordToZ w + (if b then 1 else 0))%Z.
    Proof.
      dependent induction w; simpl; intros.
      dependent destruction w.
      - destruct b, b0; cbn; reflexivity.
      - specialize (IHw _ _ eq_refl JMeq_refl).
        unfold wordToB2 in IHw; rewrite IHw; clear IHw.
        destruct b, b1, b0; cbn;
          repeat (rewrite wordToZ_WS_0 || rewrite wordToZ_WS_1); lia.
    Qed.

    Lemma wordToB2_bwordToZ:
      forall sz (w: word sz),
        bwordToZ (wordToB2 w~0) = wordToZ w.
    Proof.
      dependent destruction w; [reflexivity|].
      rewrite wordToB2_bwordToZ'; lia.
    Qed.

    Lemma wordToB2_bwordToZ_step:
      forall sz (w: word (S (S sz))),
        bwordToZ (wordToB2 w) =
        (2 * bwordToZ (wordToB2 (rtrunc1 w)) +
         boothToZ (wencodeB2 (split1 2 _ w)))%Z.
    Proof.
      do 2 dependent destruction w; cbn.
      remember (bwordToZ (wordToB2' w b0)) as ww; clear Heqww.
      destruct ww.
      - destruct b, b0; cbn; reflexivity.
      - rewrite Pos2Z.inj_xO with (p:= p).
        rewrite Z.mul_comm; remember (2 * Z.pos p)%Z as tp; clear Heqtp.
        destruct b, b0; cbn; lia.
      - rewrite Pos2Z.neg_xO with (p:= p).
        rewrite Z.mul_comm; remember (2 * Z.neg p)%Z as tp; clear Heqtp.
        destruct b, b0; cbn; lia.
    Qed.

    Definition encodeB4 (b1 b2 b3: bool) :=
      match b1, b2, b3 with
      | false, false, true
      | false, true, false => (BZero, BPlus)
      | false, true, true => (BPlus, BZero)
      | true, false, false => (BMinus, BZero)
      | true, false, true
      | true, true, false => (BZero, BMinus)
      | _, _, _ => (BZero, BZero)
      end.

    Definition wencodeB4 (w: word 3): Booth * Booth.
    Proof.
      dependent destruction w.
      dependent destruction w.
      dependent destruction w.
      exact (encodeB4 b1 b0 b).
    Defined.

    Fixpoint wordToB4' sz (w: word sz) (p1 p2: bool): bword (S sz).
    Proof.
      dependent destruction w.
      - exact (BWS (encodeB2 p1 p2) BWO).
      - dependent destruction w.
        + exact (BWS (snd (encodeB4 b p1 p2)) (BWS (fst (encodeB4 b p1 p2)) BWO)).
        + refine (BWS (snd (encodeB4 b p1 p2)) (BWS (fst (encodeB4 b p1 p2)) _)).
          exact (wordToB4' _ w b0 b).
    Defined.

    Definition wordToB4 sz (w: word (S sz)): bword sz.
    Proof.
      dependent destruction w.
      dependent destruction w.
      - exact BWO.
      - exact (wordToB4' w b0 b).
    Defined.

    Lemma wordToB2_wordToB4:
      forall sz (w: word (S sz)),
        bwordToZ (wordToB2 w) = bwordToZ (wordToB4 w).
    Proof.
      dependent destruction w.
      move b at bottom.
      dependent induction w; [reflexivity|].
      cbn; cbn in IHw; rewrite IHw; clear IHw.
      move b at bottom.
      dependent induction w.
      - destruct b, b0; cbn; reflexivity.
      - rewrite <-IHw; clear IHw.
        dependent destruction w.
        + destruct b, b0, b1; cbn; reflexivity.
        + cbn; remember (bwordToZ (wordToB4' w b0 b)) as ww; clear Heqww.
          destruct b, b0, b1, b2; cbn; lia.
    Qed.

    Lemma wordToB4_bwordToZ_step:
      forall sz (w: word (S (S (S sz)))),
        bwordToZ (wordToB4 w) =
        (4 * bwordToZ (wordToB4 (rtrunc2 w)) +
         bbToZ (wencodeB4 (split1 3 _ w)))%Z.
    Proof.
      do 3 dependent destruction w; cbn.
      dependent destruction w.
      - destruct b, b0, b1; cbn; reflexivity.
      - cbn; remember (bwordToZ (wordToB4' w b2 b1)) as ww; clear Heqww.
        destruct ww.
        + destruct b, b0, b1; cbn; reflexivity.
        + rewrite Pos2Z.inj_xO with (p:= (p~0)%positive).
          rewrite Pos2Z.inj_xO with (p:= p).
          rewrite Z.mul_comm with (n:= Z.pos p); remember (2 * Z.pos p)%Z as tp; clear Heqtp.
          Opaque Z.mul.
          destruct b, b0, b1; cbn; lia.
          Transparent Z.mul.
        + rewrite Pos2Z.neg_xO with (p:= (p~0)%positive).
          rewrite Pos2Z.neg_xO with (p:= p).
          rewrite Z.mul_comm with (n:= Z.neg p); remember (2 * Z.neg p)%Z as tp; clear Heqtp.
          Opaque Z.mul.
          destruct b, b0, b1; cbn; lia.
          Transparent Z.mul.
    Qed.

  End BoothEncoding.

  Inductive BoothStepInv {sz} (m p: word sz)
    : forall sl, word sl -> forall su, word su -> Prop :=
  | BSInv: forall sl su (wl: word (S sl)) (wu: word su) u,
      (sl = 0 -> exists tsu (twu: word tsu), existT word _ wu = existT word _ (sext twu 1)) ->
      wordToZ wu = (wordToZ m * u)%Z ->
      (u + bwordToZ (wordToB2 wl) * Z.of_nat (pow2 (su - sz - 1)))%Z = wordToZ p ->
      BoothStepInv m p wl wu.

  Lemma boothStepInv_inv:
    forall {sz} (m p: word sz) sl su (wl: word (S sl)) (wu: word su),
      BoothStepInv m p wl wu ->
      (sl = 0 -> exists tsu (twu: word tsu), existT word _ wu = existT word _ (sext twu 1)) /\
      exists u,
        wordToZ wu = (wordToZ m * u)%Z /\
        (u + bwordToZ (wordToB2 wl) * Z.of_nat (pow2 (su - sz - 1)))%Z = wordToZ p.
  Proof.
    intros.
    inv H; destruct_existT.
    split; auto.
    eexists; repeat (split; try eassumption).
  Qed.

  Lemma natToWord_ZToWord_zero:
    forall sz, natToWord sz 0 = ZToWord sz 0%Z.
  Proof.
    intros; simpl.
    induction sz; simpl; auto.
    rewrite IHsz; reflexivity.
  Qed.

  Lemma wmsb_wzero'_false:
    forall sz, wmsb (wzero' sz) false = false.
  Proof.
    induction sz; simpl; intros; auto.
  Qed.

  Lemma boothStepInv_init:
    forall sz m p,
      BoothStepInv m (p: word sz)
                   (combine (natToWord 1 0) p)
                   (natToWord (S sz) 0).
  Proof.
    intros; econstructor; try reflexivity.
    - intros; subst.
      eexists; exists WO.
      reflexivity.
    - instantiate (1:= 0%Z).
      rewrite <-Zmult_0_r_reverse.
      rewrite natToWord_ZToWord_zero.
      rewrite wordToZ_wzero'.
      reflexivity.
    - rewrite Z.add_0_l.
      replace (S sz - sz - 1) with 0 by lia.
      simpl; rewrite <-wordToB2_bwordToZ.
      rewrite Z.mul_1_r.
      reflexivity.
  Qed.

  Lemma boothStepInv_finish:
    forall {sz} (m p: word sz) (wl: word 1) su (wu: word su),
      BoothStepInv m p wl wu ->
      exists tsu (twu: word tsu),
        existT word _ wu = existT word _ (sext twu 1) /\
        wordToZ wu = (wordToZ m * wordToZ p)%Z.
  Proof.
    intros.
    apply boothStepInv_inv in H; dest.
    specialize (H eq_refl); destruct H as [tsu [twu ?]].
    rewrite wordToB2_one in H1.
    rewrite Z.add_0_r in H1; subst.
    repeat eexists; eassumption.
  Qed.

  Definition booth2AddM (m: word MultNumBitsExt) (wl: word 2) {sus}
    : word (S sus + MultNumBitsExt).
  Proof.
    assert (Hsu: sus + MultNumBitsExt + 1 = S sus + MultNumBitsExt)
      by (abstract lia).
    refine (if weq wl WO~0~1 then _
            else if weq wl WO~1~0 then _
                 else _).
    - exact (eq_rect _ word (sext (extz m sus) 1) _ Hsu).
    - exact (eq_rect _ word (sext (extz (wneg m) sus) 1) _ Hsu).
    - exact $0.
  Defined.

  Definition booth4AddM (m: word MultNumBitsExt) (wl: word 3) {sus}
    : word (S sus + MultNumBitsExt).
  Proof.
    assert (Hsu: sus + (MultNumBitsExt + 1) = S sus + MultNumBitsExt)
      by (abstract lia).
    refine (if weq wl WO~0~0~1 then _
            else if weq wl WO~0~1~0 then _
                 else if weq wl WO~0~1~1 then _
                      else if weq wl WO~1~0~0 then _
                           else if weq wl WO~1~0~1 then _
                                else if weq wl WO~1~1~0 then _
                                     else _).
    - exact (eq_rect _ word (extz (sext m 1) sus) _ Hsu).
    - exact (eq_rect _ word (extz (sext m 1) sus) _ Hsu).
    - exact (extz m (S sus)).
    - exact (extz (wneg m) (S sus)).
    - exact (eq_rect _ word (extz (sext (wneg m) 1) sus) _ Hsu).
    - exact (eq_rect _ word (extz (sext (wneg m) 1) sus) _ Hsu).
    - exact $0.
  Defined.

  Definition booth2AddU (wl: word 2) (sus: nat) :=
    (if weq wl WO~0~1 then (Z.of_nat (pow2 sus))
     else if weq wl WO~1~0 then -(Z.of_nat (pow2 sus))
          else 0)%Z.

  Definition booth4AddU (wl: word 3) (sus: nat) :=
    (if weq wl WO~0~0~1 then (Z.of_nat (pow2 sus))
     else if weq wl WO~0~1~0 then (Z.of_nat (pow2 sus))
          else if weq wl WO~0~1~1 then (Z.of_nat (pow2 (S sus)))
               else if weq wl WO~1~0~0 then -(Z.of_nat (pow2 (S sus)))
                    else if weq wl WO~1~0~1 then -(Z.of_nat (pow2 sus))
                         else if weq wl WO~1~1~0 then -(Z.of_nat (pow2 sus))
                              else 0)%Z.

  Lemma wencodeB2_zero:
    forall (wl: word 2),
      wl <> WO~0~1 -> wl <> WO~1~0 ->
      wencodeB2 wl = BZero.
  Proof.
    intros.
    dependent destruction wl.
    dependent destruction wl.
    dependent destruction wl.
    destruct b, b0; intuition idtac.
  Qed.

  Lemma wencodeB4_zero:
    forall (wl: word 3),
      wl <> WO~0~0~1 -> wl <> WO~0~1~0 -> wl <> WO~0~1~1 ->
      wl <> WO~1~0~0 -> wl <> WO~1~0~1 -> wl <> WO~1~1~0 ->
      wencodeB4 wl = (BZero, BZero).
  Proof.
    intros.
    dependent destruction wl.
    dependent destruction wl.
    dependent destruction wl.
    dependent destruction wl.
    destruct b, b0, b1; intuition idtac.
  Qed.

  Ltac wordToZ_red :=
    repeat (first [rewrite extz_pow2_wordToZ
                  |rewrite sext_wordToZ
                  |rewrite wordToZ_eq_rect]).

  Lemma boothStepEvalM_booth2AddM:
    forall (m: word MultNumBitsExt) we sl sus,
      MultBits - 2 + 2 = S (S sl) + (S sus + MultNumBitsExt) ->
      existT word (1 + S MultNumBitsExt + MultNumBitsExt)
             (boothStepEvalM
                (extz (sext m 1) (S MultNumBitsExt))
                (extz (sext (^~ m) 1) (S MultNumBitsExt)) we) =
      existT word (S sl + (S sus + MultNumBitsExt + 1))
             (extz (sext (booth2AddM m (split1 2 (MultBits - 2) (evalExpr we))) 1)
                   (S sl)).
  Proof.
    unfold boothStepEvalM, booth2AddM; intros.
    repeat destruct (weq _ _).

    - change (1 + S MultNumBitsExt + MultNumBitsExt)
        with (1 + MultNumBitsExt + S MultNumBitsExt).
      rewrite wrshifta_extz_sext.
      apply wordToZ_existT; [cbn; cbn in H; lia|].
      wordToZ_red.
      rewrite <-Z.mul_assoc, <-Nat2Z.inj_mul.
      rewrite <-pow2_add_mul.
      replace MultNumBitsExt with (sus + S sl) at 2 by (cbn; cbn in H; lia).
      reflexivity.
    - change (1 + S MultNumBitsExt + MultNumBitsExt)
        with (1 + MultNumBitsExt + S MultNumBitsExt).
      rewrite wrshifta_extz_sext.
      apply wordToZ_existT; [cbn; cbn in H; lia|].
      wordToZ_red.
      rewrite <-Z.mul_assoc, <-Nat2Z.inj_mul.
      rewrite <-pow2_add_mul.
      replace MultNumBitsExt with (sus + S sl) at 3 by (cbn; cbn in H; lia).
      reflexivity.

    - rewrite wrshifta_wzero, sext_wzero, extz_zero.
      replace (S sl + (S sus + MultNumBitsExt + 1)) with MultBits by lia.
      reflexivity.
  Qed.

  Lemma booth4StepEvalM_booth4AddM:
    forall (m: word MultNumBitsExt) we sl sus,
      MultBits - 3 + 3 = S (S (S sl)) + (S sus + MultNumBitsExt) ->
      existT word (2 + (MultNumBitsExt - 1) + S MultNumBitsExt)
             (booth4StepEvalM (extz (sext m 1) (S MultNumBitsExt))
                              (extz (sext (^~ m) 1) (S MultNumBitsExt)) we) =
      existT word (S sl + (S sus + MultNumBitsExt + 2))
             (extz (sext (booth4AddM m (split1 3 (MultBits - 3) (evalExpr we))) 2) (S sl)).
  Proof.
    unfold booth4StepEvalM, booth4AddM; intros.
    repeat destruct (weq _ _).

    - rewrite wrshifta_extz_sext.
      apply wordToZ_existT; [cbn; cbn in H; lia|].
      wordToZ_red.
      rewrite <-Z.mul_assoc, <-Nat2Z.inj_mul.
      rewrite <-pow2_add_mul.
      replace (MultNumBitsExt - 1) with (sus + S sl) by (cbn; cbn in H; lia).
      reflexivity.
    - rewrite wrshifta_extz_sext.
      apply wordToZ_existT; [cbn; cbn in H; lia|].
      wordToZ_red.
      rewrite <-Z.mul_assoc, <-Nat2Z.inj_mul.
      rewrite <-pow2_add_mul.
      replace (MultNumBitsExt - 1) with (sus + S sl) by (cbn; cbn in H; lia).
      reflexivity.

    - erewrite existT_wrshifta
        by (erewrite existT_wlshift
             by (change MultBits with ((S MultNumBitsExt) + (MultNumBitsExt + 1));
                 apply extz_sext);
            apply wlshift_sext_extz).
      erewrite existT_wrshifta by apply extz_extz.
      change (1 + S MultNumBitsExt) with (2 + MultNumBitsExt).
      rewrite wrshifta_extz_sext.
      rewrite extz_sext.
      apply existT_sext.
      rewrite extz_extz.
      replace (S sl + S sus) with MultNumBitsExt by (cbn; cbn in H; lia).
      reflexivity.
    - erewrite existT_wrshifta
        by (erewrite existT_wlshift
             by (change MultBits with ((S MultNumBitsExt) + (MultNumBitsExt + 1));
                 apply extz_sext);
            apply wlshift_sext_extz).
      erewrite existT_wrshifta by apply extz_extz.
      change (1 + S MultNumBitsExt) with (2 + MultNumBitsExt).
      rewrite wrshifta_extz_sext.
      rewrite extz_sext.
      apply existT_sext.
      rewrite extz_extz.
      replace (S sl + S sus) with MultNumBitsExt by (cbn; cbn in H; lia).
      reflexivity.

    - rewrite wrshifta_extz_sext.
      apply wordToZ_existT; [cbn; cbn in H; lia|].
      wordToZ_red.
      rewrite <-Z.mul_assoc, <-Nat2Z.inj_mul.
      rewrite <-pow2_add_mul.
      replace (MultNumBitsExt - 1) with (sus + S sl) by (cbn; cbn in H; lia).
      reflexivity.
    - rewrite wrshifta_extz_sext.
      apply wordToZ_existT; [cbn; cbn in H; lia|].
      wordToZ_red.
      rewrite <-Z.mul_assoc, <-Nat2Z.inj_mul.
      rewrite <-pow2_add_mul.
      replace (MultNumBitsExt - 1) with (sus + S sl) by (cbn; cbn in H; lia).
      reflexivity.

    - rewrite wrshifta_wzero, sext_wzero, extz_zero.
      replace (S sl + (S sus + MultNumBitsExt + 2)) with MultBits by lia.
      reflexivity.
  Qed.

  Lemma booth2AddM_booth2AddU:
    forall sus (m: word MultNumBitsExt) (Hm: m <> wpow2 MultNumBits)
           wu w,
      wordToZ (sext wu 1 ^+ sext (booth2AddM (sus:= sus) m (split1 2 (MultBits - 2) w)) 1) =
      (wordToZ wu + wordToZ m * booth2AddU (split1 2 (MultBits - 2) w) sus)%Z.
  Proof.
    unfold booth2AddM, booth2AddU; intros.
    repeat destruct (weq _ _).
    - rewrite sext_wplus_wordToZ_distr by discriminate.
      do 2 rewrite sext_wordToZ.
      rewrite wordToZ_eq_rect.
      rewrite sext_wordToZ.
      rewrite extz_pow2_wordToZ.
      reflexivity.
    - rewrite sext_wplus_wordToZ_distr by discriminate.
      do 2 rewrite sext_wordToZ.
      rewrite wordToZ_eq_rect.
      rewrite sext_wordToZ.
      rewrite extz_pow2_wordToZ.
      change MultNumBitsExt with (S MultNumBits).
      rewrite wneg_wordToZ by assumption.
      ring.
    - rewrite sext_wzero, wplus_wzero_1.
      rewrite Z.mul_0_r.
      rewrite sext_wordToZ.
      lia.
  Qed.

  Lemma booth4AddM_booth4AddU:
    forall sus (m: word MultNumBitsExt) (Hm: m <> wpow2 MultNumBits)
           wu w,
      wordToZ (sext wu 2 ^+ sext (booth4AddM (sus:= sus) m (split1 3 (MultBits - 3) w)) 2) =
      (wordToZ wu + wordToZ m * booth4AddU (split1 3 (MultBits - 3) w) sus)%Z.
  Proof.
    unfold booth4AddM, booth4AddU; intros.
    repeat destruct (weq _ _).

    - rewrite sext_wplus_wordToZ_distr by discriminate.
      do 2 rewrite sext_wordToZ.
      rewrite wordToZ_eq_rect.
      rewrite extz_pow2_wordToZ.
      rewrite sext_wordToZ.
      reflexivity.
    - rewrite sext_wplus_wordToZ_distr by discriminate.
      do 2 rewrite sext_wordToZ.
      rewrite wordToZ_eq_rect.
      rewrite extz_pow2_wordToZ.
      rewrite sext_wordToZ.
      reflexivity.

    - rewrite sext_wplus_wordToZ_distr by discriminate.
      do 2 rewrite sext_wordToZ.
      rewrite extz_pow2_wordToZ.
      reflexivity.
    - rewrite sext_wplus_wordToZ_distr by discriminate.
      do 2 rewrite sext_wordToZ.
      rewrite extz_pow2_wordToZ.
      change MultNumBitsExt with (S MultNumBits).
      rewrite wneg_wordToZ by assumption.
      ring.

    - rewrite sext_wplus_wordToZ_distr by discriminate.
      do 2 rewrite sext_wordToZ.
      rewrite wordToZ_eq_rect.
      rewrite extz_pow2_wordToZ.
      rewrite sext_wordToZ.
      change MultNumBitsExt with (S MultNumBits).
      rewrite wneg_wordToZ by assumption.
      ring.
    - rewrite sext_wplus_wordToZ_distr by discriminate.
      do 2 rewrite sext_wordToZ.
      rewrite wordToZ_eq_rect.
      rewrite extz_pow2_wordToZ.
      rewrite sext_wordToZ.
      change MultNumBitsExt with (S MultNumBits).
      rewrite wneg_wordToZ by assumption.
      ring.
    - rewrite sext_wzero.
      rewrite wplus_comm, wplus_unit.
      rewrite sext_wordToZ.
      rewrite Z.mul_0_r.
      ring.
  Qed.

  Lemma booth2AddU_boothToZ:
    forall wl n,
      booth2AddU wl n =
      (boothToZ (wencodeB2 wl) * Z.of_nat (pow2 n))%Z.
  Proof.
    unfold booth2AddU, boothToZ; intros.
    repeat destruct (weq _ _); subst.
    - simpl; destruct (Z.of_nat (pow2 n)); reflexivity.
    - simpl; destruct (Z.of_nat (pow2 n)); reflexivity.
    - rewrite wencodeB2_zero by assumption.
      reflexivity.
  Qed.

  Lemma booth4AddU_bbToZ:
    forall wl n,
      booth4AddU wl n =
      (bbToZ (wencodeB4 wl) * Z.of_nat (pow2 n))%Z.
  Proof.
    unfold booth4AddU, bbToZ; intros.
    repeat destruct (weq _ _); subst.
    - simpl; destruct (Z.of_nat (pow2 n)); reflexivity.
    - simpl; destruct (Z.of_nat (pow2 n)); reflexivity.
    - rewrite pow2_S_z; simpl; reflexivity.
    - rewrite pow2_S_z; simpl.
      destruct (Z.of_nat (pow2 n)); reflexivity.
    - simpl; destruct (Z.of_nat (pow2 n)); reflexivity.
    - simpl; destruct (Z.of_nat (pow2 n)); reflexivity.
    - rewrite wencodeB4_zero by assumption.
      reflexivity.
  Qed.

  Lemma wordToZ_sext_wplus_distr:
    forall (sz: nat) (w1 w2: word (S sz)) n,
      (- Z.of_nat (pow2 sz) <= wordToZ w1 + wordToZ w2 < Z.of_nat (pow2 sz))%Z ->
      wordToZ (sext (w1 ^+ w2) n) = wordToZ (sext w1 n ^+ sext w2 n).
  Proof.
    intros.
    rewrite sext_wordToZ.
    rewrite <-wordToZ_wplus_bound by assumption.
    change (S sz + n) with (S (sz + n)).
    rewrite <-wordToZ_wplus_bound; change (S (sz + n)) with (S sz + n).
    - do 2 rewrite sext_wordToZ.
      reflexivity.
    - do 2 rewrite sext_wordToZ.
      destruct H; split.
      + etransitivity; [|eassumption].
        rewrite <-Z.opp_le_mono.
        apply Nat2Z.inj_le.
        rewrite pow2_add_mul.
        pose proof (zero_lt_pow2 n).
        replace (pow2 sz) with (pow2 sz * 1)%nat at 1 by lia.
        apply mult_le_compat_l; lia.
      + eapply Z.lt_le_trans; [eassumption|].
        apply Nat2Z.inj_le.
        rewrite pow2_add_mul.
        pose proof (zero_lt_pow2 n).
        replace (pow2 sz) with (pow2 sz * 1)%nat at 1 by lia.
        apply mult_le_compat_l; lia.
  Qed.

  Lemma boothStepInv_booth4Step:
    forall (m: word MultNumBitsExt) (Hm: m <> wpow2 MultNumBits)
           mp mn p we nwe,
      mp = extz (sext m 1) (S MultNumBitsExt) ->
      mn = extz (sext (wneg m) 1) (S MultNumBitsExt) ->
      booth4Step mp mn we = nwe ->
      forall sl su (wl: word (S (S (S sl)))) (wu: word su) sus,
        (S sus) + MultNumBitsExt = su ->
        existT word _ (evalExpr we) = existT word _ (combine wl wu) ->
        BoothStepInv m p wl wu ->
        exists (nwl: word (S sl)) (nwu: word (su + 2)),
          existT word _ (evalExpr nwe) = existT word _ (combine nwl nwu) /\
          BoothStepInv m p nwl nwu.
  Proof.
    intros; subst.
    apply boothStepInv_inv in H4; destruct H4 as [_ H4].
    rewrite wordToB2_wordToB4 in H4.
    destruct H4 as [u ?]; dest.

    exists (rtrunc2 wl).
    exists (sext wu 2 ^+ sext (booth4AddM m (split1 3 (MultBits - 3) (evalExpr we))) 2).
    split.

    - rewrite booth4Step_eval.
      rewrite combine_wplus_1.
      apply existT_wplus.
      + apply combine_wrshifta_rtrunc2_sext; assumption.
      + apply booth4StepEvalM_booth4AddM.
        apply eq_sigT_fst in H3; assumption.

    - pose proof (sext_wplus_exist wu (booth4AddM m (split1 3 (MultBits - 3) (evalExpr we))) 1).
      destruct H1 as [twu ?].
      eapply @BSInv
        with (u:= (u + booth4AddU (split1 3 (MultBits - 3) (evalExpr we)) sus)%Z).
      + intros; rewrite H1; do 2 eexists; reflexivity.
      + rewrite Z.mul_add_distr_l, <-H.
        apply booth4AddM_booth4AddU; assumption.
      + rewrite wordToB2_wordToB4.
        rewrite <-H0, <-Z.add_assoc.
        replace (S sus + MultNumBitsExt + 2 - MultNumBitsExt - 1)
          with (S (S sus)) by lia.
        apply Z.add_cancel_l.
        replace (S sus + MultNumBitsExt - MultNumBitsExt - 1) with sus by lia.
        rewrite wordToB4_bwordToZ_step.
        rewrite Z.mul_add_distr_r.
        rewrite Z.add_comm.
        f_equal.
        * replace (Z.of_nat (pow2 (S (S sus)))) with (4 * Z.of_nat (pow2 sus))%Z
            by (do 2 rewrite pow2_S_z; ring).
          rewrite Z.mul_assoc; f_equal; lia.
        * replace (split1 3 (MultBits - 3) (evalExpr we)) with (split1 3 sl wl)
            by (apply eq_sym; eauto using split1_combine_existT).
          apply booth4AddU_bbToZ.
  Qed.

  Lemma boothStepInv_boothStep:
    forall (m: word MultNumBitsExt) (Hm: m <> wpow2 MultNumBits)
           mp mn p we nwe,
      mp = extz (sext m 1) (S MultNumBitsExt) ->
      mn = extz (sext (wneg m) 1) (S MultNumBitsExt) ->
      boothStep mp mn we = nwe ->
      forall sl su (wl: word (S (S sl))) (wu: word su) sus,
        sl <> 0 ->
        (S sus) + MultNumBitsExt = su ->
        existT word _ (evalExpr we) = existT word _ (combine wl wu) ->
        BoothStepInv m p wl wu ->
        exists (nwl: word (S sl)) (nwu: word (su + 1)),
          existT word _ (evalExpr nwe) = existT word _ (combine nwl nwu) /\
          BoothStepInv m p nwl nwu.
  Proof.
    intros; subst.
    apply boothStepInv_inv in H5; destruct H5 as [_ H5].
    destruct H5 as [u ?]; dest.

    exists (rtrunc1 wl).
    exists (sext wu 1 ^+ sext (booth2AddM m (split1 2 (MultBits - 2) (evalExpr we))) 1).
    split.

    - rewrite boothStep_eval.
      rewrite combine_wplus_1.
      apply existT_wplus.
      + apply combine_wrshifta_rtrunc1_sext; assumption.
      + apply boothStepEvalM_booth2AddM.
        apply eq_sigT_fst in H4; assumption.

    - eapply @BSInv
        with (u:= (u + booth2AddU (split1 2 (MultBits - 2) (evalExpr we)) sus)%Z).
      + intros; subst.
        elim H2; reflexivity.
      + rewrite Z.mul_add_distr_l, <-H.
        apply booth2AddM_booth2AddU; assumption.
      + rewrite <-H0, <-Z.add_assoc.
        replace (S sus + MultNumBitsExt + 1 - MultNumBitsExt - 1) with (S sus) by lia.
        apply Z.add_cancel_l.
        replace (S sus + MultNumBitsExt - MultNumBitsExt - 1) with sus by lia.
        rewrite wordToB2_bwordToZ_step.
        rewrite Z.mul_add_distr_r.
        rewrite Z.add_comm.
        f_equal.
        * replace (Z.of_nat (pow2 (S sus))) with (2 * Z.of_nat (pow2 sus))%Z
            by (rewrite pow2_S_z; ring).
          rewrite Z.mul_assoc; f_equal; lia.
        * replace (split1 2 (MultBits - 2) (evalExpr we)) with (split1 2 sl wl)
            by (apply eq_sym; eauto using split1_combine_existT).
          apply booth2AddU_boothToZ.
  Qed.

  Lemma booth4Step_evalExpr_var:
    forall m_pos m_neg e,
      evalExpr (booth4Step m_pos m_neg (Var _ _ (evalExpr e))) =
      evalExpr (booth4Step m_pos m_neg e).
  Proof.
    intros; do 2 rewrite booth4Step_eval; reflexivity.
  Qed.

  Record BoothMultiplierInv (o: RegsT): Prop :=
    { bsiM : fullType type (SyntaxKind (Bit MultNumBitsExt));
      HbsiM : M.find "m" o = Some (existT _ _ bsiM);
      bsiR : fullType type (SyntaxKind (Bit MultNumBitsExt));
      HbsiR : M.find "r" o = Some (existT _ _ bsiR);

      bsiMp : fullType type (SyntaxKind (Bit MultBits));
      HbsiMp : M.find "m_pos" o = Some (existT _ _ bsiMp);
      bsiMn : fullType type (SyntaxKind (Bit MultBits));
      HbsiMn : M.find "m_neg" o = Some (existT _ _ bsiMn);

      bsiP : fullType type (SyntaxKind (Bit MultBits));
      HbsiP : M.find "p" o = Some (existT _ _ bsiP);

      bsiCnt : fullType type (SyntaxKind (Bit (S MultLogNumPhases)));
      HbsiCnt : M.find "cnt" o = Some (existT _ _ bsiCnt);

      HbsiMmp : bsiMp = extz (sext bsiM 1) (S MultNumBitsExt);
      HbsiMmn : bsiMn = extz (sext (wneg bsiM) 1) (S MultNumBitsExt);

      HmInv : bsiM <> wpow2 MultNumBits;
      HbsiInv :
        exists sl (wl: word sl) sus su (wu: word su),
          sl = 8 * (wordToNat bsiCnt) + 1 /\
          su = S sus + MultNumBitsExt /\
          existT word _ bsiP = existT word _ (combine wl wu) /\
          BoothStepInv bsiM bsiR wl wu
    }.

  Ltac boothMultiplierInv_old :=
    repeat match goal with
           | [H: BoothMultiplierInv _ |- _] => destruct H
           end;
    kinv_red.

  Ltac boothMultiplierInv_new :=
    econstructor; (* let's prove that the invariant holds for the next state *)
    try (findReify; (reflexivity || eassumption); fail);
    kinv_red; (* unfolding invariant definitions *)
    repeat (* cheaper than "intuition" *)
      (match goal with
       | [ |- _ /\ _ ] => split
       end);
    try eassumption; intros; try reflexivity;
    intuition kinv_simpl; intuition idtac.

  Variable n: nat.

  Lemma boothMultiplierInv_ok':
    forall init n ll,
      init = initRegs (getRegInits boothMultiplierImpl) ->
      Multistep boothMultiplierImpl init n ll ->
      BoothMultiplierInv n.
  Proof.
    induction 2; intros.

    - boothMultiplierInv_old.
      unfold getRegInits, fst, boothMultiplierImpl, projT1.
      boothMultiplierInv_new; [discriminate|].
      eexists; exists (natToWord 1 0).
      eexists; eexists; exists (natToWord (2 * MultNumBitsExt + 1) 0).
      split; [|split; [|split]].
      + reflexivity.
      + instantiate (1:= MultNumBitsExt); reflexivity.
      + reflexivity.
      + econstructor.
        * intros.
          eexists; exists (wzero (2 * MultNumBitsExt)).
          reflexivity.
        * instantiate (1:= 0%Z); reflexivity.
        * reflexivity.

    - kinvert; [mred|mred| | |].
      + (* boothMultRegister *)
        Opaque natToWord evalExpr combine.
        kinv_action_dest.
        Transparent natToWord evalExpr.
        kinv_custom boothMultiplierInv_old.
        boothMultiplierInv_new.

        * cbn; unfold eq_rec; eq_rect_simpl.
          reflexivity.
        * cbn; unfold eq_rec; eq_rect_simpl.
          reflexivity.
        * clear -H4 H12.
          Opaque split2.
          simpl in *.
          Transparent split2.
          find_if_inside; [|discriminate].
          assert (wmsb (x Fin.F1) false = true) by (rewrite H12; reflexivity).
          remember (x Fin.F1) as x1; simpl in x1; clear Heqx1 x.
          change MultNumBitsExt with (MultNumBits + 1) in *.
          rewrite wmsb_split2 in H.
          find_if_inside; [discriminate|].
          elim n; assumption.

        * simpl; unfold eq_rec; eq_rect_simpl.

          assert (Hx1: x Fin.F1 <> wpow2 MultNumBits).
          { intro Hx.
            clear -Hx H4.
            Opaque split2.
            simpl in H4.
            Transparent split2.
            find_if_inside; [|discriminate].
            assert (wmsb (x Fin.F1) false = true) by (rewrite Hx; reflexivity).
            remember (x Fin.F1) as x1; simpl in x1; clear Heqx1 x.
            change MultNumBitsExt with (MultNumBits + 1) in *.
            rewrite wmsb_split2 in H.
            find_if_inside; [discriminate|].
            elim n; assumption.
          }

          set (extz (combine (x (Fin.FS Fin.F1)) (natToWord (MultNumBitsExt + 1) 0)) 1) as ww.
          pose proof (boothStepInv_init (x Fin.F1) (x (Fin.FS Fin.F1))) as Hinv0.

          assert (pred MultNumBitsExt <> 0) by (cbn; lia).
          eapply (boothStepInv_boothStep
                    (we:= Var type (SyntaxKind (Bit MultBits)) ww) (sus:= O)
                    Hx1 eq_refl eq_refl eq_refl H12 eq_refl) in Hinv0; [|reflexivity].
          simpl in Hinv0.
          destruct Hinv0 as [nwl [nwu [? ?]]].

          eexists; exists nwl.
          exists 1; eexists; exists nwu.

          repeat split.
          { subst ww.
            cbv [evalSignExtendTrunc].
            simpl; unfold eq_rec; eq_rect_simpl.
            rewrite <-H13.
            reflexivity.
          }
          { assumption. }

      + (* boothMultGetResult *)
        Opaque MultNumBits.
        kinv_action_dest.
        mred.
        Transparent MultNumBits.

      + (* boothStep *)
        kinv_action_dest.
        kinv_custom boothMultiplierInv_old.
        boothMultiplierInv_new.

        remember (8 * wordToNat x + 1) as psl.
        assert (psl >= 9)%nat.
        { subst; clear -n1.
          unfold type in x.
          do 4 (dependent destruction x).
          destruct b, b0, b1; cbn; try lia.
          elim n1; reflexivity.
        }
        do 9 (destruct psl as [|psl]; [lia|]); clear H.

        rename H12 into Hinv0.
        eapply (boothStepInv_booth4Step
                  (we:= Var type (SyntaxKind (Bit MultBits)) x2)
                  HmInv eq_refl eq_refl eq_refl eq_refl) in Hinv0; [|eassumption].
        replace (S x5 + MultNumBitsExt + 2)
          with ((S (S (S x5))) + MultNumBitsExt) in Hinv0 by lia.
        destruct Hinv0 as [nwl1 [nwu1 [Heq1 Hinv1]]].

        eapply (boothStepInv_booth4Step
                  HmInv eq_refl eq_refl eq_refl eq_refl) in Hinv1; [|eassumption].
        replace (S (S (S x5)) + MultNumBitsExt + 2)
          with (S (S (S (S (S x5)))) + MultNumBitsExt) in Hinv1 by lia.
        destruct Hinv1 as [nwl2 [nwu2 [Heq2 Hinv2]]].

        eapply (boothStepInv_booth4Step
                  HmInv eq_refl eq_refl eq_refl eq_refl) in Hinv2; [|eassumption].
        replace (S (S (S (S (S x5)))) + MultNumBitsExt + 2)
          with (S (S (S (S (S (S (S x5)))))) + MultNumBitsExt) in Hinv2 by lia.
        destruct Hinv2 as [nwl3 [nwu3 [Heq3 Hinv3]]].

        eapply (boothStepInv_booth4Step
                  HmInv eq_refl eq_refl eq_refl eq_refl) in Hinv3; [|eassumption].
        replace (S (S (S (S (S (S (S x5)))))) + MultNumBitsExt + 2)
          with (S (S (S (S (S (S (S (S (S x5)))))))) + MultNumBitsExt) in Hinv3 by lia.
        destruct Hinv3 as [nwl4 [nwu4 [Heq4 Hinv4]]].

        eexists; exists nwl4.
        eexists; eexists; exists nwu4.

        repeat split.
        * intros.
          match goal with
          | [ |- context [_ ^- ?w] ] =>
            replace w with (natToWord (S MultLogNumPhases) 1) by reflexivity
          end.
          rewrite <-wordToNat_natToWord_pred by assumption.
          lia.
        * rewrite booth4Step_evalExpr_var with (e:= booth4Step _ _ (#x2)%kami_expr).
          rewrite booth4Step_evalExpr_var with (e:= booth4Step _ _ (booth4Step _ _ _)).
          rewrite booth4Step_evalExpr_var.
          assumption.
        * assumption.

  Qed.

  Lemma boothMultiplierInv_ok:
    forall o,
      reachable o boothMultiplierImpl ->
      BoothMultiplierInv o.
  Proof.
    intros; inv H; inv H0.
    eapply boothMultiplierInv_ok'; eauto.
  Qed.

  Local Definition thetaR (ir sr: RegsT): Prop.
  Proof.
    kexistv "m_pos" m_pos ir (Bit MultBits).
    kexistv "m_neg" m_neg ir (Bit MultBits).
    kexistv "p" p ir (Bit MultBits).
    kexistv "m" m ir (Bit MultNumBitsExt).
    kexistv "r" r ir (Bit MultNumBitsExt).
    kexistv "cnt" cnt ir (Bit (S MultLogNumPhases)).

    exact (sr = ["r" <- existT _ _ r]
                +["m" <- existT _ _ m])%fmap.
  Defined.
  #[local] Hint Unfold thetaR: MapDefs.

  Local Definition ruleMap (o: RegsT): string -> option string :=
    "boothMultRegister" |-> "multRegister";
      "boothMultGetResult" |-> "multGetResult"; ||.
  #[local] Hint Unfold ruleMap: MethDefs.

  Theorem multiplier_ok: boothMultiplierImpl <<== multiplierSpec.
  Proof.
    kdecomposeR_nodefs thetaR ruleMap.
    kinv_add boothMultiplierInv_ok.
    kinvert.

    - (* "boothMultRegister" |-> "multRegister" *)
      Opaque natToWord evalExpr combine.
      kinv_action_dest.
      kinv_custom boothMultiplierInv_old.
      kinv_regmap_red.
      eexists; split; kinv_constr.
      kinv_eq.
      Transparent natToWord evalExpr combine.

    - (* "boothMultGetResult" |-> "multGetResult" *)
      Opaque MultNumBits.
      kinv_action_dest.
      kinv_custom boothMultiplierInv_old.
      kinv_regmap_red.
      Transparent MultNumBits.

      eexists; split; kinv_constr.
      apply boothStepInv_finish in H7; dest.
      assert (x3 = MultNumBitsExt) by (apply eq_sigT_fst in H6; cbn; cbn in H6; lia).
      subst; destruct_existT.
      rewrite idElementwiseId; unfold id.
      do 3 f_equal.
      fin_func_eq.

      + Opaque split1 split2 wordToZ.
        simpl.
        unfold eq_rec_r, eq_rec; repeat rewrite <-eq_rect_eq.
        unfold ilist.ilist_to_fun_m; simpl.
        repeat f_equal.
        rewrite wtl_combine.
        unfold wmultZ, wordBinZ.
        pose proof (sext_wordToZ 33 bsiM).
        cbv [evalSignExtendTrunc]; cbn.
        unfold eq_rec; eq_rect_simpl.
        cbn in H1; rewrite H1.
        pose proof (sext_wordToZ 33 bsiR).
        cbn; cbn in H2; rewrite H2.
        cbn in H0; rewrite <-H0.
        assert (x = 2 * MultNumBitsExt) by (apply eq_sigT_fst in H; lia); subst.
        destruct_existT.
        pose proof (sext_wordToZ 1 x4); cbn; cbn in H; rewrite H.
        rewrite sext_split1.
        rewrite ZToWord_wordToZ.
        reflexivity.
        Transparent split1 split2 wordToZ.

      + Opaque split1 split2 wordToZ.
        simpl.
        unfold eq_rec_r, eq_rec; repeat rewrite <-eq_rect_eq.
        unfold ilist.ilist_to_fun_m; simpl.
        repeat f_equal.
        rewrite wtl_combine.
        unfold wmultZ, wordBinZ.
        pose proof (sext_wordToZ 33 bsiM).
        cbv [evalSignExtendTrunc]; cbn.
        unfold eq_rec; eq_rect_simpl.
        cbn in H1; rewrite H1.
        pose proof (sext_wordToZ 33 bsiR).
        cbn; cbn in H2; rewrite H2.
        cbn in H0; rewrite <-H0.
        assert (x = 2 * MultNumBitsExt) by (apply eq_sigT_fst in H; lia); subst.
        destruct_existT.
        pose proof (sext_wordToZ 1 x4); cbn; cbn in H; rewrite H.
        rewrite sext_split1.
        rewrite ZToWord_wordToZ.
        reflexivity.
        Transparent split1 split2 wordToZ.

    - (* "boothStep" |-> . *)
      kinv_action_dest.
      kinv_custom boothMultiplierInv_old.
      kinv_regmap_red.
      eexists; split; kinv_constr.

  Qed.

End Multiplier32.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e512m569_25limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Require Import Coq.Lists.List.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Common.List.ListFacts.

Lemma disjoint_nil_l {A} beq (ls : list A)
  : disjoint beq nil ls = true.
Proof. reflexivity. Qed.
Lemma disjoint_nil_r {A} beq (ls : list A)
  : disjoint beq ls nil = true.
Proof. rewrite disjoint_comm, disjoint_nil_l; reflexivity. Qed.
Lemma disjoint_cons_l {A} beq x (xs ls : list A)
  : disjoint beq (x::xs) ls = (negb (Equality.list_bin beq x ls) && disjoint beq xs ls)%bool.
Proof. reflexivity. Qed.
Lemma disjoint_cons_r {A} beq x (xs ls : list A)
  : disjoint beq ls (x::xs) = (negb (Equality.list_bin (fun a b => beq b a) x ls) && disjoint beq ls xs)%bool.
Proof. rewrite disjoint_comm, disjoint_cons_l, <- disjoint_comm; reflexivity. Qed.
Lemma disjoint_uniquize {A} beq
      (bl : forall x y, beq x y = true -> x = y)
      (lb : forall x y, x = y -> beq x y = true)
      (ls1 ls2 : list A)
  : disjoint beq ls1 ls2 = disjoint beq (uniquize beq ls1) (uniquize beq ls2).
Proof.
  revert ls2; induction ls1 as [|l ls1 IHls1]; simpl; intro ls2.
  { rewrite !disjoint_nil_l; reflexivity. }
  { repeat match goal with
           | _ => reflexivity
           | _ => rewrite !disjoint_cons_l
           | [ IH : forall ls, disjoint _ _ _ = disjoint _ _ _ |- _ ]
             => rewrite IH; clear IH
           | [ |- andb _ _ = andb _ _ ] => apply f_equal2
           | _ => progress unfold negb
           | _ => progress simpl
           | [ |- context[if ?b then _ else _] ]
             => destruct b eqn:?
           | [ H : Equality.list_bin _ _ _ = true |- _ ]
             => apply (@Equality.list_in_bl _ _ bl) in H
           | [ H : List.In _ (uniquize _ _) |- _ ]
             => apply ListFacts.uniquize_In in H
           | [ |- context[disjoint ?beq ?ls1 ?ls2] ]
             => destruct (disjoint beq ls1 ls2) eqn:?
           | [ H : disjoint _ _ _ = true |- _ ]
             => pose proof (@disjoint_bl _ _ lb _ _ H); clear H
           | [ H : Equality.list_bin _ _ _ = false |- _ ]
             => apply Equality.list_in_bl_false in H; [ | assumption.. ]
           | [ |- false = true ] => exfalso
           | [ |- true = false ] => exfalso
           | _ => solve [ eauto using uniquize_In_refl ]
           | [ H : _ |- _ ] => solve [ eapply H; eauto using uniquize_In_refl ]
           end. }
Qed.


From Hammer Require Import Hammer.

Require Import ZArith.
Require Import Zquot.
From compcert Require Import Zaux.

Fixpoint digits2_Pnat (n : positive) : nat :=
match n with
| xH => O
| xO p => S (digits2_Pnat p)
| xI p => S (digits2_Pnat p)
end.

Theorem digits2_Pnat_correct :
forall n,
let d := digits2_Pnat n in
(Zpower_nat 2 d <= Zpos n < Zpower_nat 2 (S d))%Z.
Proof. hammer_hook "Digits" "Digits.digits2_Pnat_correct".
intros n d. unfold d. clear.
assert (Hp: forall m, (Zpower_nat 2 (S m) = 2 * Zpower_nat 2 m)%Z) by easy.
induction n ; simpl digits2_Pnat.
rewrite Zpos_xI, 2!Hp.
omega.
rewrite (Zpos_xO n), 2!Hp.
omega.
now split.
Qed.

Section Fcore_digits.

Variable beta : radix.

Definition Zdigit n k := Z.rem (Z.quot n (Zpower beta k)) beta.

Theorem Zdigit_lt :
forall n k,
(k < 0)%Z ->
Zdigit n k = Z0.
Proof. hammer_hook "Digits" "Digits.Zdigit_lt".
intros n [|k|k] Hk ; try easy.
now case n.
Qed.

Theorem Zdigit_0 :
forall k, Zdigit 0 k = Z0.
Proof. hammer_hook "Digits" "Digits.Zdigit_0".
intros k.
unfold Zdigit.
rewrite Zquot_0_l.
apply Zrem_0_l.
Qed.

Theorem Zdigit_opp :
forall n k,
Zdigit (-n) k = Z.opp (Zdigit n k).
Proof. hammer_hook "Digits" "Digits.Zdigit_opp".
intros n k.
unfold Zdigit.
rewrite Zquot_opp_l.
apply Zrem_opp_l.
Qed.

Theorem Zdigit_ge_Zpower_pos :
forall e n,
(0 <= n < Zpower beta e)%Z ->
forall k, (e <= k)%Z -> Zdigit n k = Z0.
Proof. hammer_hook "Digits" "Digits.Zdigit_ge_Zpower_pos".
intros e n Hn k Hk.
unfold Zdigit.
rewrite Z.quot_small.
apply Zrem_0_l.
split.
apply Hn.
apply Z.lt_le_trans with (1 := proj2 Hn).
replace k with (e + (k - e))%Z by ring.
rewrite Zpower_plus.
rewrite <- (Zmult_1_r (beta ^ e)) at 1.
apply Zmult_le_compat_l.
apply (Zlt_le_succ 0).
apply Zpower_gt_0.
now apply Zle_minus_le_0.
apply Zlt_le_weak.
now apply Z.le_lt_trans with n.
generalize (Z.le_lt_trans _ _ _ (proj1 Hn) (proj2 Hn)).
clear.
now destruct e as [|e|e].
now apply Zle_minus_le_0.
Qed.

Theorem Zdigit_ge_Zpower :
forall e n,
(Z.abs n < Zpower beta e)%Z ->
forall k, (e <= k)%Z -> Zdigit n k = Z0.
Proof. hammer_hook "Digits" "Digits.Zdigit_ge_Zpower".
intros e [|n|n] Hn k.
easy.
apply Zdigit_ge_Zpower_pos.
now split.
intros He.
change (Zneg n) with (Z.opp (Zpos n)).
rewrite Zdigit_opp.
rewrite Zdigit_ge_Zpower_pos with (2 := He).
apply Z.opp_0.
now split.
Qed.

Theorem Zdigit_not_0_pos :
forall e n, (0 <= e)%Z ->
(Zpower beta e <= n < Zpower beta (e + 1))%Z ->
Zdigit n e <> Z0.
Proof. hammer_hook "Digits" "Digits.Zdigit_not_0_pos".
intros e n He (Hn1,Hn2).
unfold Zdigit.
rewrite <- ZOdiv_mod_mult.
rewrite Z.rem_small.
intros H.
apply Zle_not_lt with (1 := Hn1).
rewrite (Z.quot_rem' n (beta ^ e)).
rewrite H, Zmult_0_r, Zplus_0_l.
apply Zrem_lt_pos_pos.
apply Z.le_trans with (2 := Hn1).
apply Zpower_ge_0.
now apply Zpower_gt_0.
split.
apply Z.le_trans with (2 := Hn1).
apply Zpower_ge_0.
replace (beta ^ e * beta)%Z with (beta ^ (e + 1))%Z.
exact Hn2.
rewrite <- (Zmult_1_r beta) at 3.
now apply (Zpower_plus beta e 1).
Qed.

Theorem Zdigit_not_0 :
forall e n, (0 <= e)%Z ->
(Zpower beta e <= Z.abs n < Zpower beta (e + 1))%Z ->
Zdigit n e <> Z0.
Proof. hammer_hook "Digits" "Digits.Zdigit_not_0".
intros e n He Hn.
destruct (Zle_or_lt 0 n) as [Hn'|Hn'].
rewrite (Z.abs_eq _ Hn') in Hn.
now apply Zdigit_not_0_pos.
intros H.
rewrite (Zabs_non_eq n) in Hn by now apply Zlt_le_weak.
apply (Zdigit_not_0_pos _ _ He Hn).
now rewrite Zdigit_opp, H.
Qed.

Theorem Zdigit_mul_pow :
forall n k k', (0 <= k')%Z ->
Zdigit (n * Zpower beta k') k = Zdigit n (k - k').
Proof. hammer_hook "Digits" "Digits.Zdigit_mul_pow".
intros n k k' Hk'.
destruct (Zle_or_lt k' k) as [H|H].
revert k H.
pattern k' ; apply Zlt_0_ind with (2 := Hk').
clear k' Hk'.
intros k' IHk' Hk' k H.
unfold Zdigit.
apply (f_equal (fun x => Z.rem x beta)).
pattern k at 1 ; replace k with (k - k' + k')%Z by ring.
rewrite Zpower_plus with (2 := Hk').
apply Zquot_mult_cancel_r.
apply Zgt_not_eq.
now apply Zpower_gt_0.
now apply Zle_minus_le_0.
destruct (Zle_or_lt 0 k) as [H0|H0].
rewrite (Zdigit_lt n) by omega.
unfold Zdigit.
replace k' with (k' - k + k)%Z by ring.
rewrite Zpower_plus with (2 := H0).
rewrite Zmult_assoc, Z_quot_mult.
replace (k' - k)%Z with (k' - k - 1 + 1)%Z by ring.
rewrite Zpower_exp by omega.
rewrite Zmult_assoc.
change (Zpower beta 1) with (beta * 1)%Z.
rewrite Zmult_1_r.
apply Z_rem_mult.
apply Zgt_not_eq.
now apply Zpower_gt_0.
apply Zle_minus_le_0.
now apply Zlt_le_weak.
rewrite Zdigit_lt with (1 := H0).
apply sym_eq.
apply Zdigit_lt.
omega.
Qed.

Theorem Zdigit_div_pow :
forall n k k', (0 <= k)%Z -> (0 <= k')%Z ->
Zdigit (Z.quot n (Zpower beta k')) k = Zdigit n (k + k').
Proof. hammer_hook "Digits" "Digits.Zdigit_div_pow".
intros n k k' Hk Hk'.
unfold Zdigit.
rewrite Zquot_Zquot.
rewrite Zplus_comm.
now rewrite Zpower_plus.
Qed.

Theorem Zdigit_mod_pow :
forall n k k', (k < k')%Z ->
Zdigit (Z.rem n (Zpower beta k')) k = Zdigit n k.
Proof. hammer_hook "Digits" "Digits.Zdigit_mod_pow".
intros n k k' Hk.
destruct (Zle_or_lt 0 k) as [H|H].
unfold Zdigit.
rewrite <- 2!ZOdiv_mod_mult.
apply (f_equal (fun x => Z.quot x (beta ^ k))).
replace k' with (k + 1 + (k' - (k + 1)))%Z by ring.
rewrite Zpower_exp by omega.
rewrite Zmult_comm.
rewrite Zpower_plus by easy.
change (Zpower beta 1) with (beta * 1)%Z.
rewrite Zmult_1_r.
apply ZOmod_mod_mult.
now rewrite 2!Zdigit_lt.
Qed.

Theorem Zdigit_mod_pow_out :
forall n k k', (0 <= k' <= k)%Z ->
Zdigit (Z.rem n (Zpower beta k')) k = Z0.
Proof. hammer_hook "Digits" "Digits.Zdigit_mod_pow_out".
intros n k k' Hk.
unfold Zdigit.
rewrite ZOdiv_small_abs.
apply Zrem_0_l.
apply Z.lt_le_trans with (Zpower beta k').
rewrite <- (Z.abs_eq (beta ^ k')) at 2 by apply Zpower_ge_0.
apply Zrem_lt.
apply Zgt_not_eq.
now apply Zpower_gt_0.
now apply Zpower_le.
Qed.

Fixpoint Zsum_digit f k :=
match k with
| O => Z0
| S k => (Zsum_digit f k + f (Z_of_nat k) * Zpower beta (Z_of_nat k))%Z
end.

Theorem Zsum_digit_digit :
forall n k,
Zsum_digit (Zdigit n) k = Z.rem n (Zpower beta (Z_of_nat k)).
Proof. hammer_hook "Digits" "Digits.Zsum_digit_digit".
intros n.
induction k.
apply sym_eq.
apply Z.rem_1_r.
simpl Zsum_digit.
rewrite IHk.
unfold Zdigit.
rewrite <- ZOdiv_mod_mult.
rewrite <- (ZOmod_mod_mult n beta).
rewrite Zmult_comm.
replace (beta ^ Z_of_nat k * beta)%Z with (Zpower beta (Z_of_nat (S k))).
rewrite Zplus_comm, Zmult_comm.
apply sym_eq.
apply Z.quot_rem'.
rewrite inj_S.
rewrite <- (Zmult_1_r beta) at 3.
apply Zpower_plus.
apply Zle_0_nat.
easy.
Qed.

Theorem Zdigit_ext :
forall n1 n2,
(forall k, (0 <= k)%Z -> Zdigit n1 k = Zdigit n2 k) ->
n1 = n2.
Proof. hammer_hook "Digits" "Digits.Zdigit_ext".
intros n1 n2 H.
rewrite <- (ZOmod_small_abs n1 (Zpower beta (Z.max (Z.abs n1) (Z.abs n2)))).
rewrite <- (ZOmod_small_abs n2 (Zpower beta (Z.max (Z.abs n1) (Z.abs n2)))) at 2.
replace (Z.max (Z.abs n1) (Z.abs n2)) with (Z_of_nat (Z.abs_nat (Z.max (Z.abs n1) (Z.abs n2)))).
rewrite <- 2!Zsum_digit_digit.
induction (Z.abs_nat (Z.max (Z.abs n1) (Z.abs n2))).
easy.
simpl.
rewrite H, IHn.
apply refl_equal.
apply Zle_0_nat.
rewrite inj_Zabs_nat.
apply Z.abs_eq.
apply Z.le_trans with (Z.abs n1).
apply Zabs_pos.
apply Z.le_max_l.
apply Z.lt_le_trans with (Zpower beta (Z.abs n2)).
apply Zpower_gt_id.
apply Zpower_le.
apply Z.le_max_r.
apply Z.lt_le_trans with (Zpower beta (Z.abs n1)).
apply Zpower_gt_id.
apply Zpower_le.
apply Z.le_max_l.
Qed.

Theorem ZOmod_plus_pow_digit :
forall u v n, (0 <= u * v)%Z ->
(forall k, (0 <= k < n)%Z -> Zdigit u k = Z0 \/ Zdigit v k = Z0) ->
Z.rem (u + v) (Zpower beta n) = (Z.rem u (Zpower beta n) + Z.rem v (Zpower beta n))%Z.
Proof. hammer_hook "Digits" "Digits.ZOmod_plus_pow_digit".
intros u v n Huv Hd.
destruct (Zle_or_lt 0 n) as [Hn|Hn].
rewrite Zplus_rem with (1 := Huv).
apply ZOmod_small_abs.
generalize (Z.le_refl n).
pattern n at -2 ; rewrite <- Z.abs_eq with (1 := Hn).
rewrite <- (inj_Zabs_nat n).
induction (Z.abs_nat n) as [|p IHp].
now rewrite 2!Z.rem_1_r.
rewrite <- 2!Zsum_digit_digit.
simpl Zsum_digit.
rewrite inj_S.
intros Hn'.
replace (Zsum_digit (Zdigit u) p + Zdigit u (Z_of_nat p) * beta ^ Z_of_nat p +
(Zsum_digit (Zdigit v) p + Zdigit v (Z_of_nat p) * beta ^ Z_of_nat p))%Z with
(Zsum_digit (Zdigit u) p + Zsum_digit (Zdigit v) p +
(Zdigit u (Z_of_nat p) + Zdigit v (Z_of_nat p)) * beta ^ Z_of_nat p)%Z by ring.
apply (Z.le_lt_trans _ _ _ (Z.abs_triangle _ _)).
replace (beta ^ Z.succ (Z_of_nat p))%Z with (beta ^ Z_of_nat p + (beta - 1) * beta ^ Z_of_nat p)%Z.
apply Zplus_lt_le_compat.
rewrite 2!Zsum_digit_digit.
apply IHp.
now apply Zle_succ_le.
rewrite Zabs_Zmult.
rewrite (Z.abs_eq (beta ^ Z_of_nat p)) by apply Zpower_ge_0.
apply Zmult_le_compat_r. 2: apply Zpower_ge_0.
apply Zlt_succ_le.
assert (forall u v, Z.abs (Zdigit u v) < Z.succ (beta -  1))%Z.
clear ; intros n k.
assert (0 < beta)%Z.
apply Z.lt_le_trans with 2%Z.
apply refl_equal.
apply Zle_bool_imp_le.
apply beta.
replace (Z.succ (beta - 1)) with (Z.abs beta).
apply Zrem_lt.
now apply Zgt_not_eq.
rewrite Z.abs_eq.
apply Zsucc_pred.
now apply Zlt_le_weak.
assert (0 <= Z_of_nat p < n)%Z.
split.
apply Zle_0_nat.
apply Z.gt_lt.
now apply Zle_succ_gt.
destruct (Hd (Z_of_nat p) H0) as [K|K] ; rewrite K.
apply H.
rewrite Zplus_0_r.
apply H.
unfold Z.succ.
ring_simplify.
rewrite Zpower_plus.
change (beta ^1)%Z with (beta * 1)%Z.
now rewrite Zmult_1_r.
apply Zle_0_nat.
easy.
destruct n as [|n|n] ; try easy.
now rewrite 3!Zrem_0_r.
Qed.

Theorem ZOdiv_plus_pow_digit :
forall u v n, (0 <= u * v)%Z ->
(forall k, (0 <= k < n)%Z -> Zdigit u k = Z0 \/ Zdigit v k = Z0) ->
Z.quot (u + v) (Zpower beta n) = (Z.quot u (Zpower beta n) + Z.quot v (Zpower beta n))%Z.
Proof. hammer_hook "Digits" "Digits.ZOdiv_plus_pow_digit".
intros u v n Huv Hd.
rewrite <- (Zplus_0_r (Z.quot u (Zpower beta n) + Z.quot v (Zpower beta n))).
rewrite ZOdiv_plus with (1 := Huv).
rewrite <- ZOmod_plus_pow_digit by assumption.
apply f_equal.
destruct (Zle_or_lt 0 n) as [Hn|Hn].
apply ZOdiv_small_abs.
rewrite <- Z.abs_eq.
apply Zrem_lt.
apply Zgt_not_eq.
now apply Zpower_gt_0.
apply Zpower_ge_0.
clear -Hn.
destruct n as [|n|n] ; try easy.
apply Zquot_0_r.
Qed.

Theorem Zdigit_plus :
forall u v, (0 <= u * v)%Z ->
(forall k, (0 <= k)%Z -> Zdigit u k = Z0 \/ Zdigit v k = Z0) ->
forall k,
Zdigit (u + v) k = (Zdigit u k + Zdigit v k)%Z.
Proof. hammer_hook "Digits" "Digits.Zdigit_plus".
intros u v Huv Hd k.
destruct (Zle_or_lt 0 k) as [Hk|Hk].
unfold Zdigit.
rewrite ZOdiv_plus_pow_digit with (1 := Huv).
rewrite <- (Zmult_1_r beta) at 3 5 7.
change (beta * 1)%Z with (beta ^1)%Z.
apply ZOmod_plus_pow_digit.
apply Zsame_sign_trans_weak with v.
intros Zv ; rewrite Zv.
apply Zquot_0_l.
rewrite Zmult_comm.
apply Zsame_sign_trans_weak with u.
intros Zu ; rewrite Zu.
apply Zquot_0_l.
now rewrite Zmult_comm.
apply Zsame_sign_odiv.
apply Zpower_ge_0.
apply Zsame_sign_odiv.
apply Zpower_ge_0.
intros k' (Hk1,Hk2).
rewrite 2!Zdigit_div_pow by assumption.
apply Hd.
now apply Zplus_le_0_compat.
intros k' (Hk1,Hk2).
now apply Hd.
now rewrite 3!Zdigit_lt.
Qed.

Definition Zscale n k :=
if Zle_bool 0 k then (n * Zpower beta k)%Z else Z.quot n (Zpower beta (-k)).

Theorem Zdigit_scale :
forall n k k', (0 <= k')%Z ->
Zdigit (Zscale n k) k' = Zdigit n (k' - k).
Proof. hammer_hook "Digits" "Digits.Zdigit_scale".
intros n k k' Hk'.
unfold Zscale.
case Zle_bool_spec ; intros Hk.
now apply Zdigit_mul_pow.
apply Zdigit_div_pow with (1 := Hk').
omega.
Qed.

Theorem Zscale_0 :
forall k,
Zscale 0 k = Z0.
Proof. hammer_hook "Digits" "Digits.Zscale_0".
intros k.
unfold Zscale.
case Zle_bool.
apply Zmult_0_l.
apply Zquot_0_l.
Qed.

Theorem Zsame_sign_scale :
forall n k,
(0 <= n * Zscale n k)%Z.
Proof. hammer_hook "Digits" "Digits.Zsame_sign_scale".
intros n k.
unfold Zscale.
case Zle_bool_spec ; intros Hk.
rewrite Zmult_assoc.
apply Zmult_le_0_compat.
apply Zsame_sign_imp ; apply Zlt_le_weak.
apply Zpower_ge_0.
apply Zsame_sign_odiv.
apply Zpower_ge_0.
Qed.

Theorem Zscale_mul_pow :
forall n k k', (0 <= k)%Z ->
Zscale (n * Zpower beta k) k' = Zscale n (k + k').
Proof. hammer_hook "Digits" "Digits.Zscale_mul_pow".
intros n k k' Hk.
unfold Zscale.
case Zle_bool_spec ; intros Hk'.
rewrite Zle_bool_true.
rewrite <- Zmult_assoc.
apply f_equal.
now rewrite Zpower_plus.
now apply Zplus_le_0_compat.
case Zle_bool_spec ; intros Hk''.
pattern k at 1 ; replace k with (k + k' + -k')%Z by ring.
assert (0 <= -k')%Z by omega.
rewrite Zpower_plus by easy.
rewrite Zmult_assoc, Z_quot_mult.
apply refl_equal.
apply Zgt_not_eq.
now apply Zpower_gt_0.
replace (-k')%Z with (-(k+k') + k)%Z by ring.
rewrite Zpower_plus with (2 := Hk).
apply Zquot_mult_cancel_r.
apply Zgt_not_eq.
now apply Zpower_gt_0.
omega.
Qed.

Theorem Zscale_scale :
forall n k k', (0 <= k)%Z ->
Zscale (Zscale n k) k' = Zscale n (k + k').
Proof. hammer_hook "Digits" "Digits.Zscale_scale".
intros n k k' Hk.
unfold Zscale at 2.
rewrite Zle_bool_true with (1 := Hk).
now apply Zscale_mul_pow.
Qed.

Definition Zslice n k1 k2 :=
if Zle_bool 0 k2 then Z.rem (Zscale n (-k1)) (Zpower beta k2) else Z0.

Theorem Zdigit_slice :
forall n k1 k2 k, (0 <= k < k2)%Z ->
Zdigit (Zslice n k1 k2) k = Zdigit n (k1 + k).
Proof. hammer_hook "Digits" "Digits.Zdigit_slice".
intros n k1 k2 k Hk.
unfold Zslice.
rewrite Zle_bool_true.
rewrite Zdigit_mod_pow by apply Hk.
rewrite Zdigit_scale by apply Hk.
unfold Zminus.
now rewrite Z.opp_involutive, Zplus_comm.
omega.
Qed.

Theorem Zdigit_slice_out :
forall n k1 k2 k, (k2 <= k)%Z ->
Zdigit (Zslice n k1 k2) k = Z0.
Proof. hammer_hook "Digits" "Digits.Zdigit_slice_out".
intros n k1 k2 k Hk.
unfold Zslice.
case Zle_bool_spec ; intros Hk2.
apply Zdigit_mod_pow_out.
now split.
apply Zdigit_0.
Qed.

Theorem Zslice_0 :
forall k k',
Zslice 0 k k' = Z0.
Proof. hammer_hook "Digits" "Digits.Zslice_0".
intros k k'.
unfold Zslice.
case Zle_bool.
rewrite Zscale_0.
apply Zrem_0_l.
apply refl_equal.
Qed.

Theorem Zsame_sign_slice :
forall n k k',
(0 <= n * Zslice n k k')%Z.
Proof. hammer_hook "Digits" "Digits.Zsame_sign_slice".
intros n k k'.
unfold Zslice.
case Zle_bool.
apply Zsame_sign_trans_weak with (Zscale n (-k)).
intros H ; rewrite H.
apply Zrem_0_l.
apply Zsame_sign_scale.
rewrite Zmult_comm.
apply Zrem_sgn2.
now rewrite Zmult_0_r.
Qed.

Theorem Zslice_slice :
forall n k1 k2 k1' k2', (0 <= k1' <= k2)%Z ->
Zslice (Zslice n k1 k2) k1' k2' = Zslice n (k1 + k1') (Z.min (k2 - k1') k2').
Proof. hammer_hook "Digits" "Digits.Zslice_slice".
intros n k1 k2 k1' k2' Hk1'.
destruct (Zle_or_lt 0 k2') as [Hk2'|Hk2'].
apply Zdigit_ext.
intros k Hk.
destruct (Zle_or_lt (Z.min (k2 - k1') k2') k) as [Hk'|Hk'].
rewrite (Zdigit_slice_out n (k1 + k1')) with (1 := Hk').
destruct (Zle_or_lt k2' k) as [Hk''|Hk''].
now apply Zdigit_slice_out.
rewrite Zdigit_slice by now split.
apply Zdigit_slice_out.
zify ; omega.
rewrite Zdigit_slice by (zify ; omega).
rewrite (Zdigit_slice n (k1 + k1')) by now split.
rewrite Zdigit_slice.
now rewrite Zplus_assoc.
zify ; omega.
unfold Zslice.
rewrite Z.min_r.
now rewrite Zle_bool_false.
omega.
Qed.

Theorem Zslice_mul_pow :
forall n k k1 k2, (0 <= k)%Z ->
Zslice (n * Zpower beta k) k1 k2 = Zslice n (k1 - k) k2.
Proof. hammer_hook "Digits" "Digits.Zslice_mul_pow".
intros n k k1 k2 Hk.
unfold Zslice.
case Zle_bool_spec ; intros Hk2.
2: apply refl_equal.
rewrite Zscale_mul_pow with (1 := Hk).
now replace (- (k1 - k))%Z with (k + -k1)%Z by ring.
Qed.

Theorem Zslice_div_pow :
forall n k k1 k2, (0 <= k)%Z -> (0 <= k1)%Z ->
Zslice (Z.quot n (Zpower beta k)) k1 k2 = Zslice n (k1 + k) k2.
Proof. hammer_hook "Digits" "Digits.Zslice_div_pow".
intros n k k1 k2 Hk Hk1.
unfold Zslice.
case Zle_bool_spec ; intros Hk2.
2: apply refl_equal.
apply (f_equal (fun x => Z.rem x (beta ^ k2))).
unfold Zscale.
case Zle_bool_spec ; intros Hk1'.
replace k1 with Z0 by omega.
case Zle_bool_spec ; intros Hk'.
replace k with Z0 by omega.
simpl.
now rewrite Z.quot_1_r.
rewrite Z.opp_involutive.
apply Zmult_1_r.
rewrite Zle_bool_false by omega.
rewrite 2!Z.opp_involutive, Zplus_comm.
rewrite Zpower_plus by assumption.
apply Zquot_Zquot.
Qed.

Theorem Zslice_scale :
forall n k k1 k2, (0 <= k1)%Z ->
Zslice (Zscale n k) k1 k2 = Zslice n (k1 - k) k2.
Proof. hammer_hook "Digits" "Digits.Zslice_scale".
intros n k k1 k2 Hk1.
unfold Zscale.
case Zle_bool_spec; intros Hk.
now apply Zslice_mul_pow.
apply Zslice_div_pow with (2 := Hk1).
omega.
Qed.

Theorem Zslice_div_pow_scale :
forall n k k1 k2, (0 <= k)%Z ->
Zslice (Z.quot n (Zpower beta k)) k1 k2 = Zscale (Zslice n k (k1 + k2)) (-k1).
Proof. hammer_hook "Digits" "Digits.Zslice_div_pow_scale".
intros n k k1 k2 Hk.
apply Zdigit_ext.
intros k' Hk'.
rewrite Zdigit_scale with (1 := Hk').
unfold Zminus.
rewrite (Zplus_comm k'), Z.opp_involutive.
destruct (Zle_or_lt k2 k') as [Hk2|Hk2].
rewrite Zdigit_slice_out with (1 := Hk2).
apply sym_eq.
apply Zdigit_slice_out.
now apply Zplus_le_compat_l.
rewrite Zdigit_slice by now split.
destruct (Zle_or_lt 0 (k1 + k')) as [Hk1'|Hk1'].
rewrite Zdigit_slice by omega.
rewrite Zdigit_div_pow by assumption.
apply f_equal.
ring.
now rewrite 2!Zdigit_lt.
Qed.

Theorem Zplus_slice :
forall n k l1 l2, (0 <= l1)%Z -> (0 <= l2)%Z ->
(Zslice n k l1 + Zscale (Zslice n (k + l1) l2) l1)%Z = Zslice n k (l1 + l2).
Proof. hammer_hook "Digits" "Digits.Zplus_slice".
intros n k1 l1 l2 Hl1 Hl2.
clear Hl1.
apply Zdigit_ext.
intros k Hk.
rewrite Zdigit_plus.
rewrite Zdigit_scale with (1 := Hk).
destruct (Zle_or_lt (l1 + l2) k) as [Hk2|Hk2].
rewrite Zdigit_slice_out with (1 := Hk2).
now rewrite 2!Zdigit_slice_out by omega.
rewrite Zdigit_slice with (1 := conj Hk Hk2).
destruct (Zle_or_lt l1 k) as [Hk1|Hk1].
rewrite Zdigit_slice_out with (1 := Hk1).
rewrite Zdigit_slice by omega.
simpl ; apply f_equal.
ring.
rewrite Zdigit_slice with (1 := conj Hk Hk1).
rewrite (Zdigit_lt _ (k - l1)) by omega.
apply Zplus_0_r.
rewrite Zmult_comm.
apply Zsame_sign_trans_weak with n.
intros H ; rewrite H.
apply Zslice_0.
rewrite Zmult_comm.
apply Zsame_sign_trans_weak with (Zslice n (k1 + l1) l2).
intros H ; rewrite H.
apply Zscale_0.
apply Zsame_sign_slice.
apply Zsame_sign_scale.
apply Zsame_sign_slice.
clear k Hk ; intros k Hk.
rewrite Zdigit_scale with (1 := Hk).
destruct (Zle_or_lt l1 k) as [Hk1|Hk1].
left.
now apply Zdigit_slice_out.
right.
apply Zdigit_lt.
omega.
Qed.

Section digits_aux.

Variable p : Z.

Fixpoint Zdigits_aux (nb pow : Z) (n : nat) { struct n } : Z :=
match n with
| O => nb
| S n => if Zlt_bool p pow then nb else Zdigits_aux (nb + 1) (Zmult beta pow) n
end.

End digits_aux.

Definition Zdigits n :=
match n with
| Z0 => Z0
| Zneg p => Zdigits_aux (Zpos p) 1 beta (digits2_Pnat p)
| Zpos p => Zdigits_aux n 1 beta (digits2_Pnat p)
end.

Theorem Zdigits_correct :
forall n,
(Zpower beta (Zdigits n - 1) <= Z.abs n < Zpower beta (Zdigits n))%Z.
Proof. hammer_hook "Digits" "Digits.Zdigits_correct".
cut (forall p, Zpower beta (Zdigits (Zpos p) - 1) <= Zpos p < Zpower beta (Zdigits (Zpos p)))%Z.
intros H [|n|n] ; try exact (H n).
now split.
intros n.
simpl.

assert (U: (Zpos n < Zpower beta (Z_of_nat (S (digits2_Pnat n))))%Z).
apply Z.lt_le_trans with (1 := proj2 (digits2_Pnat_correct n)).
rewrite Zpower_Zpower_nat.
rewrite Zabs_nat_Z_of_nat.
induction (S (digits2_Pnat n)).
easy.
rewrite 2!(Zpower_nat_S).
apply Zmult_le_compat with (2 := IHn0).
apply Zle_bool_imp_le.
apply beta.
easy.
rewrite <- (Zabs_nat_Z_of_nat n0).
rewrite <- Zpower_Zpower_nat.
apply (Zpower_ge_0 (Build_radix 2 (refl_equal true))).
apply Zle_0_nat.
apply Zle_0_nat.

revert U.
rewrite inj_S.
unfold Z.succ.
generalize (digits2_Pnat n).
intros u U.
pattern (radix_val beta) at 2 4 ; replace (radix_val beta) with (Zpower beta 1) by apply Zmult_1_r.
assert (V: (Zpower beta (1 - 1) <= Zpos n)%Z).
now apply (Zlt_le_succ 0).
generalize (conj V U).
clear.
generalize (Z.le_refl 1).
generalize 1%Z at 2 3 5 6 7 9 10.

induction u.
easy.
rewrite inj_S; unfold Z.succ.
simpl Zdigits_aux.
intros v Hv U.
case Zlt_bool_spec ; intros K.
now split.
pattern (radix_val beta) at 2 5 ; replace (radix_val beta) with (Zpower beta 1) by apply Zmult_1_r.
rewrite <- Zpower_plus.
rewrite Zplus_comm.
apply IHu.
clear -Hv ; omega.
split.
now ring_simplify (1 + v - 1)%Z.
now rewrite Zplus_assoc.
easy.
apply Zle_succ_le with (1 := Hv).
Qed.

Theorem Zdigits_unique :
forall n d,
(Zpower beta (d - 1) <= Z.abs n < Zpower beta d)%Z ->
Zdigits n = d.
Proof. hammer_hook "Digits" "Digits.Zdigits_unique".
intros n d Hd.
assert (Hd' := Zdigits_correct n).
apply Zle_antisym.
apply (Zpower_lt_Zpower beta).
now apply Z.le_lt_trans with (Z.abs n).
apply (Zpower_lt_Zpower beta).
now apply Z.le_lt_trans with (Z.abs n).
Qed.

Theorem Zdigits_abs :
forall n, Zdigits (Z.abs n) = Zdigits n.
Proof. hammer_hook "Digits" "Digits.Zdigits_abs".
now intros [|n|n].
Qed.

Theorem Zdigits_gt_0 :
forall n, n <> Z0 -> (0 < Zdigits n)%Z.
Proof. hammer_hook "Digits" "Digits.Zdigits_gt_0".
intros n Zn.
rewrite <- (Zdigits_abs n).
assert (Hn: (0 < Z.abs n)%Z).
destruct n ; [|easy|easy].
now elim Zn.
destruct (Z.abs n) as [|p|p] ; try easy ; clear.
simpl.
generalize 1%Z (radix_val beta) (refl_equal Lt : (0 < 1)%Z).
induction (digits2_Pnat p).
easy.
simpl.
intros.
case Zlt_bool.
exact H.
apply IHn.
now apply Zlt_lt_succ.
Qed.

Theorem Zdigits_ge_0 :
forall n, (0 <= Zdigits n)%Z.
Proof. hammer_hook "Digits" "Digits.Zdigits_ge_0".
intros n.
destruct (Z.eq_dec n 0) as [H|H].
now rewrite H.
apply Zlt_le_weak.
now apply Zdigits_gt_0.
Qed.

Theorem Zdigit_out :
forall n k, (Zdigits n <= k)%Z ->
Zdigit n k = Z0.
Proof. hammer_hook "Digits" "Digits.Zdigit_out".
intros n k Hk.
apply Zdigit_ge_Zpower with (2 := Hk).
apply Zdigits_correct.
Qed.

Theorem Zdigit_digits :
forall n, n <> Z0 ->
Zdigit n (Zdigits n - 1) <> Z0.
Proof. hammer_hook "Digits" "Digits.Zdigit_digits".
intros n Zn.
apply Zdigit_not_0.
apply Zlt_0_le_0_pred.
now apply Zdigits_gt_0.
ring_simplify (Zdigits n - 1 + 1)%Z.
apply Zdigits_correct.
Qed.

Theorem Zdigits_slice :
forall n k l, (0 <= l)%Z ->
(Zdigits (Zslice n k l) <= l)%Z.
Proof. hammer_hook "Digits" "Digits.Zdigits_slice".
intros n k l Hl.
unfold Zslice.
rewrite Zle_bool_true with (1 := Hl).
destruct (Zdigits_correct (Z.rem (Zscale n (- k)) (Zpower beta l))) as (H1,H2).
apply Zpower_lt_Zpower with beta.
apply Z.le_lt_trans with (1 := H1).
rewrite <- (Z.abs_eq (beta ^ l)) at 2 by apply Zpower_ge_0.
apply Zrem_lt.
apply Zgt_not_eq.
now apply Zpower_gt_0.
Qed.

Theorem Zdigits_mult_Zpower :
forall m e,
m <> Z0 -> (0 <= e)%Z ->
Zdigits (m * Zpower beta e) = (Zdigits m + e)%Z.
Proof. hammer_hook "Digits" "Digits.Zdigits_mult_Zpower".
intros m e Hm He.
assert (H := Zdigits_correct m).
apply Zdigits_unique.
rewrite Z.abs_mul, Z.abs_pow, (Z.abs_eq beta).
2: now apply Zlt_le_weak, radix_gt_0.
split.
replace (Zdigits m + e - 1)%Z with (Zdigits m - 1 + e)%Z by ring.
rewrite Zpower_plus with (2 := He).
apply Zmult_le_compat_r.
apply H.
apply Zpower_ge_0.
now apply Zlt_0_le_0_pred, Zdigits_gt_0.
rewrite Zpower_plus with (2 := He).
apply Zmult_lt_compat_r.
now apply Zpower_gt_0.
apply H.
now apply Zlt_le_weak, Zdigits_gt_0.
Qed.

Theorem Zdigits_Zpower :
forall e,
(0 <= e)%Z ->
Zdigits (Zpower beta e) = (e + 1)%Z.
Proof. hammer_hook "Digits" "Digits.Zdigits_Zpower".
intros e He.
rewrite <- (Zmult_1_l (Zpower beta e)).
rewrite Zdigits_mult_Zpower ; try easy.
apply Zplus_comm.
Qed.

Theorem Zdigits_le :
forall x y,
(0 <= x)%Z -> (x <= y)%Z ->
(Zdigits x <= Zdigits y)%Z.
Proof. hammer_hook "Digits" "Digits.Zdigits_le".
intros x y Zx Hxy.
assert (Hx := Zdigits_correct x).
assert (Hy := Zdigits_correct y).
apply (Zpower_lt_Zpower beta).
zify ; omega.
Qed.

Theorem lt_Zdigits :
forall x y,
(0 <= y)%Z ->
(Zdigits x < Zdigits y)%Z ->
(x < y)%Z.
Proof. hammer_hook "Digits" "Digits.lt_Zdigits".
intros x y Hy.
cut (y <= x -> Zdigits y <= Zdigits x)%Z. omega.
now apply Zdigits_le.
Qed.

Theorem Zpower_le_Zdigits :
forall e x,
(e < Zdigits x)%Z ->
(Zpower beta e <= Z.abs x)%Z.
Proof. hammer_hook "Digits" "Digits.Zpower_le_Zdigits".
intros e x Hex.
destruct (Zdigits_correct x) as [H1 H2].
apply Z.le_trans with (2 := H1).
apply Zpower_le.
clear -Hex ; omega.
Qed.

Theorem Zdigits_le_Zpower :
forall e x,
(Z.abs x < Zpower beta e)%Z ->
(Zdigits x <= e)%Z.
Proof. hammer_hook "Digits" "Digits.Zdigits_le_Zpower".
intros e x.
generalize (Zpower_le_Zdigits e x).
omega.
Qed.

Theorem Zpower_gt_Zdigits :
forall e x,
(Zdigits x <= e)%Z ->
(Z.abs x < Zpower beta e)%Z.
Proof. hammer_hook "Digits" "Digits.Zpower_gt_Zdigits".
intros e x Hex.
destruct (Zdigits_correct x) as [H1 H2].
apply Z.lt_le_trans with (1 := H2).
now apply Zpower_le.
Qed.

Theorem Zdigits_gt_Zpower :
forall e x,
(Zpower beta e <= Z.abs x)%Z ->
(e < Zdigits x)%Z.
Proof. hammer_hook "Digits" "Digits.Zdigits_gt_Zpower".
intros e x Hex.
generalize (Zpower_gt_Zdigits e x).
omega.
Qed.

Theorem Zdigits_mult_strong :
forall x y,
(0 <= x)%Z -> (0 <= y)%Z ->
(Zdigits (x + y + x * y) <= Zdigits x + Zdigits y)%Z.
Proof. hammer_hook "Digits" "Digits.Zdigits_mult_strong".
intros x y Hx Hy.
apply Zdigits_le_Zpower.
rewrite Z.abs_eq.
apply Z.lt_le_trans with ((x + 1) * (y + 1))%Z.
ring_simplify.
apply Zle_lt_succ, Z.le_refl.
rewrite Zpower_plus by apply Zdigits_ge_0.
apply Zmult_le_compat.
apply Zlt_le_succ.
rewrite <- (Z.abs_eq x) at 1 by easy.
apply Zdigits_correct.
apply Zlt_le_succ.
rewrite <- (Z.abs_eq y) at 1 by easy.
apply Zdigits_correct.
clear -Hx ; omega.
clear -Hy ; omega.
change Z0 with (0 + 0 + 0)%Z.
apply Zplus_le_compat.
now apply Zplus_le_compat.
now apply Zmult_le_0_compat.
Qed.

Theorem Zdigits_mult :
forall x y,
(Zdigits (x * y) <= Zdigits x + Zdigits y)%Z.
Proof. hammer_hook "Digits" "Digits.Zdigits_mult".
intros x y.
rewrite <- Zdigits_abs.
rewrite <- (Zdigits_abs x).
rewrite <- (Zdigits_abs y).
apply Z.le_trans with (Zdigits (Z.abs x + Z.abs y + Z.abs x * Z.abs y)).
apply Zdigits_le.
apply Zabs_pos.
rewrite Zabs_Zmult.
generalize (Zabs_pos x) (Zabs_pos y).
omega.
apply Zdigits_mult_strong ; apply Zabs_pos.
Qed.

Theorem Zdigits_mult_ge :
forall x y,
(x <> 0)%Z -> (y <> 0)%Z ->
(Zdigits x + Zdigits y - 1 <= Zdigits (x * y))%Z.
Proof. hammer_hook "Digits" "Digits.Zdigits_mult_ge".
intros x y Zx Zy.
cut ((Zdigits x - 1) + (Zdigits y - 1) < Zdigits (x * y))%Z. omega.
apply Zdigits_gt_Zpower.
rewrite Zabs_Zmult.
rewrite Zpower_exp.
apply Zmult_le_compat.
apply Zpower_le_Zdigits.
apply Zlt_pred.
apply Zpower_le_Zdigits.
apply Zlt_pred.
apply Zpower_ge_0.
apply Zpower_ge_0.
generalize (Zdigits_gt_0 x). omega.
generalize (Zdigits_gt_0 y). omega.
Qed.

Theorem Zdigits_div_Zpower :
forall m e,
(0 <= m)%Z ->
(0 <= e <= Zdigits m)%Z ->
Zdigits (m / Zpower beta e) = (Zdigits m - e)%Z.
Proof. hammer_hook "Digits" "Digits.Zdigits_div_Zpower".
intros m e Hm He.
assert (H := Zdigits_correct m).
apply Zdigits_unique.
destruct (Zle_lt_or_eq _ _ (proj2 He)) as [He'|He'].
rewrite Z.abs_eq in H by easy.
destruct H as [H1 H2].
rewrite Z.abs_eq.
split.
replace (Zdigits m - e - 1)%Z with (Zdigits m - 1 - e)%Z by ring.
rewrite Z.pow_sub_r.
2: apply Zgt_not_eq, radix_gt_0.
2: clear -He He' ; omega.
apply Z_div_le with (2 := H1).
now apply Z.lt_gt, Zpower_gt_0.
apply Zmult_lt_reg_r with (Zpower beta e).
now apply Zpower_gt_0.
apply Z.le_lt_trans with m.
rewrite Zmult_comm.
apply Z_mult_div_ge.
now apply Z.lt_gt, Zpower_gt_0.
rewrite <- Zpower_plus.
now replace (Zdigits m - e + e)%Z with (Zdigits m) by ring.
now apply Zle_minus_le_0.
apply He.
apply Z_div_pos with (2 := Hm).
now apply Z.lt_gt, Zpower_gt_0.
rewrite He'.
rewrite (Zeq_minus _ (Zdigits m)) by reflexivity.
simpl.
rewrite Zdiv_small.
easy.
split.
exact Hm.
now rewrite <- (Z.abs_eq m) at 1.
Qed.

End Fcore_digits.

Section Zdigits2.

Theorem Z_of_nat_S_digits2_Pnat :
forall m : positive,
Z_of_nat (S (digits2_Pnat m)) = Zdigits radix2 (Zpos m).
Proof. hammer_hook "Digits" "Digits.Z_of_nat_S_digits2_Pnat".
intros m.
apply eq_sym, Zdigits_unique.
rewrite <- Zpower_nat_Z.
rewrite Nat2Z.inj_succ.
change (_ - 1)%Z with (Z.pred (Z.succ (Z.of_nat (digits2_Pnat m)))).
rewrite <- Zpred_succ.
rewrite <- Zpower_nat_Z.
apply digits2_Pnat_correct.
Qed.

Fixpoint digits2_pos (n : positive) : positive :=
match n with
| xH => xH
| xO p => Pos.succ (digits2_pos p)
| xI p => Pos.succ (digits2_pos p)
end.

Theorem Zpos_digits2_pos :
forall m : positive,
Zpos (digits2_pos m) = Zdigits radix2 (Zpos m).
Proof. hammer_hook "Digits" "Digits.Zpos_digits2_pos".
intros m.
rewrite <- Z_of_nat_S_digits2_Pnat.
unfold Z.of_nat.
apply f_equal.
induction m ; simpl ; try easy ;
apply f_equal, IHm.
Qed.

Definition Zdigits2 n :=
match n with
| Z0 => n
| Zpos p => Zpos (digits2_pos p)
| Zneg p => Zpos (digits2_pos p)
end.

Lemma Zdigits2_Zdigits :
forall n, Zdigits2 n = Zdigits radix2 n.
Proof. hammer_hook "Digits" "Digits.Zdigits2_Zdigits".
intros [|p|p] ; try easy ;
apply Zpos_digits2_pos.
Qed.

End Zdigits2.


Require Import Undecidability.PCP.Definitions.

(** * PCP to CFP *)

Section PCP_CFP.

  Variable P : SRS.

  Definition Sigma := sym P.
  Notation "#" := (fresh Sigma).

  Definition gamma (A : SRS) := map (fun '(x,y) => (x, rev y)) A.

  Lemma sigma_gamma a A :
    sigma a (gamma A) = tau1 A ++ a ++ rev (tau2 A).
  Proof.
    induction A as [ | (x & y) ]; unfold gamma in *; cbn.
    - reflexivity.
    - rewrite IHA.  now simpl_list.
  Qed.

  Definition palin X (A : list X) := A = rev A.

  Lemma tau_eq_iff A a :
    ~ a el sym A ->
    tau1 A = tau2 A <-> palin (sigma a (gamma A)).
  Proof.
    rewrite sigma_gamma. unfold palin.
    simpl_list. intuition.
    - now rewrite H0.
    - eapply list_prefix_inv in H0; firstorder using tau1_sym, tau2_sym.
  Qed.

  Lemma gamma_invol A :
    gamma (gamma A) = A.
  Proof.
    induction A as [ | (x,y) ]; cbn.
    - reflexivity.
    - simpl_list. now rewrite <- IHA at 2.
  Qed.

  Lemma gamma_mono A B :
    A <<= gamma B -> gamma A <<= B.
  Proof.
    induction A as [ | (x,y) ]; cbn; intros.
    - firstorder.
    - intros ? [ <- | ].
      + assert ( x/y el gamma B) by firstorder.
        unfold gamma in H0. eapply in_map_iff in H0 as ((x',y') & ? & ?).
        inv H0. now simpl_list.
      + firstorder.
  Qed.

End PCP_CFP.

Theorem PCP_CFP :
  PCP ⪯ CFP.
Proof.
  exists (fun P => (gamma P, fresh (sym P))).
  intros P. split; intros.
  - destruct H as (A & Hi & He & H).
    exists (gamma A). repeat split.
    + eapply gamma_mono. now rewrite gamma_invol.
    + destruct A; cbn in *; congruence.
    + eapply tau_eq_iff. intros F % (sym_mono (P := P)) % fresh_spec; now try eapply F. eauto.
  - destruct H as (B & Hi & He & H).
    exists (gamma B). repeat split.
    + now eapply gamma_mono.
    + destruct B; cbn in *; congruence.
    + eapply tau_eq_iff with (a := fresh (sym P)).
      * intros F % (sym_mono (P := P)) % fresh_spec.  now eapply F. now eapply gamma_mono.
      * rewrite gamma_invol. eassumption.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
(************************************************************************)

(** * Signature and specification of a bounded integer structure *)

(** This file specifies how to represent [Z/nZ] when [n=2^d],
    [d] being the number of digits of these bounded integers. *)

Set Implicit Arguments.

Require Import ZArith.
Require Import Znumtheory.
Require Import BigNumPrelude.
Require Import DoubleType.

Local Open Scope Z_scope.

(** First, a description via an operator record and a spec record. *)

Module ZnZ.

 Class Ops (t:Type) := MkOps {

    (* Conversion functions with Z *)
    digits : positive;
    zdigits: t;
    to_Z   : t -> Z;
    of_pos : positive -> N * t; (* Euclidean division by [2^digits] *)
    head0  : t -> t; (* number of digits 0 in front of the number *)
    tail0  : t -> t; (* number of digits 0 at the bottom of the number *)

    (* Basic numbers *)
    zero : t;
    one  : t;
    minus_one : t;  (* [2^digits-1], which is equivalent to [-1] *)

    (* Comparison *)
    compare     : t -> t -> comparison;
    eq0         : t -> bool;

    (* Basic arithmetic operations *)
    opp_c       : t -> carry t;
    opp         : t -> t;
    opp_carry   : t -> t; (* the carry is known to be -1 *)

    succ_c      : t -> carry t;
    add_c       : t -> t -> carry t;
    add_carry_c : t -> t -> carry t;
    succ        : t -> t;
    add         : t -> t -> t;
    add_carry   : t -> t -> t;

    pred_c      : t -> carry t;
    sub_c       : t -> t -> carry t;
    sub_carry_c : t -> t -> carry t;
    pred        : t -> t;
    sub         : t -> t -> t;
    sub_carry   : t -> t -> t;

    mul_c       : t -> t -> zn2z t;
    mul         : t -> t -> t;
    square_c    : t -> zn2z t;

    (* Special divisions operations *)
    div21       : t -> t -> t -> t*t;
    div_gt      : t -> t -> t * t; (* specialized version of [div] *)
    div         : t -> t -> t * t;

    modulo_gt   : t -> t -> t; (* specialized version of [mod] *)
    modulo      : t -> t -> t;

    gcd_gt      : t -> t -> t; (* specialized version of [gcd] *)
    gcd         : t -> t -> t;
    (* [add_mul_div p i j] is a combination of the [(digits-p)]
       low bits of [i] above the [p] high bits of [j]:
       [add_mul_div p i j = i*2^p+j/2^(digits-p)] *)
    add_mul_div : t -> t -> t -> t;
    (* [pos_mod p i] is [i mod 2^p] *)
    pos_mod     : t -> t -> t;

    is_even     : t -> bool;
    (* square root *)
    sqrt2       : t -> t -> t * carry t;
    sqrt        : t -> t  }.

 Section Specs.
 Context {t : Type}{ops : Ops t}.

 Notation "[| x |]" := (to_Z x)  (at level 0, x at level 99).

 Let wB := base digits.

 Notation "[+| c |]" :=
   (interp_carry 1 wB to_Z c)  (at level 0, x at level 99).

 Notation "[-| c |]" :=
   (interp_carry (-1) wB to_Z c)  (at level 0, x at level 99).

 Notation "[|| x ||]" :=
   (zn2z_to_Z wB to_Z x)  (at level 0, x at level 99).

 Class Specs := MkSpecs {

    (* Conversion functions with Z *)
    spec_to_Z   : forall x, 0 <= [| x |] < wB;
    spec_of_pos : forall p,
           Zpos p = (Z_of_N (fst (of_pos p)))*wB + [|(snd (of_pos p))|];
    spec_zdigits : [| zdigits |] = Zpos digits;
    spec_more_than_1_digit: 1 < Zpos digits;

    (* Basic numbers *)
    spec_0   : [|zero|] = 0;
    spec_1   : [|one|] = 1;
    spec_m1 : [|minus_one|] = wB - 1;

    (* Comparison *)
    spec_compare : forall x y, compare x y = ([|x|] ?= [|y|]);
    (* NB: the spec of [eq0] is deliberately partial,
       see DoubleCyclic where [eq0 x = true <-> x = W0] *)
    spec_eq0 : forall x, eq0 x = true -> [|x|] = 0;
    (* Basic arithmetic operations *)
    spec_opp_c : forall x, [-|opp_c x|] = -[|x|];
    spec_opp : forall x, [|opp x|] = (-[|x|]) mod wB;
    spec_opp_carry : forall x, [|opp_carry x|] = wB - [|x|] - 1;

    spec_succ_c : forall x, [+|succ_c x|] = [|x|] + 1;
    spec_add_c  : forall x y, [+|add_c x y|] = [|x|] + [|y|];
    spec_add_carry_c : forall x y, [+|add_carry_c x y|] = [|x|] + [|y|] + 1;
    spec_succ : forall x, [|succ x|] = ([|x|] + 1) mod wB;
    spec_add : forall x y, [|add x y|] = ([|x|] + [|y|]) mod wB;
    spec_add_carry :
	 forall x y, [|add_carry x y|] = ([|x|] + [|y|] + 1) mod wB;

    spec_pred_c : forall x, [-|pred_c x|] = [|x|] - 1;
    spec_sub_c : forall x y, [-|sub_c x y|] = [|x|] - [|y|];
    spec_sub_carry_c : forall x y, [-|sub_carry_c x y|] = [|x|] - [|y|] - 1;
    spec_pred : forall x, [|pred x|] = ([|x|] - 1) mod wB;
    spec_sub : forall x y, [|sub x y|] = ([|x|] - [|y|]) mod wB;
    spec_sub_carry :
	 forall x y, [|sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB;

    spec_mul_c : forall x y, [|| mul_c x y ||] = [|x|] * [|y|];
    spec_mul : forall x y, [|mul x y|] = ([|x|] * [|y|]) mod wB;
    spec_square_c : forall x, [|| square_c x||] = [|x|] * [|x|];

    (* Special divisions operations *)
    spec_div21 : forall a1 a2 b,
      wB/2 <= [|b|] ->
      [|a1|] < [|b|] ->
      let (q,r) := div21 a1 a2 b in
      [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\
      0 <= [|r|] < [|b|];
    spec_div_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] ->
      let (q,r) := div_gt a b in
      [|a|] = [|q|] * [|b|] + [|r|] /\
      0 <= [|r|] < [|b|];
    spec_div : forall a b, 0 < [|b|] ->
      let (q,r) := div a b in
      [|a|] = [|q|] * [|b|] + [|r|] /\
      0 <= [|r|] < [|b|];

    spec_modulo_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] ->
      [|modulo_gt a b|] = [|a|] mod [|b|];
    spec_modulo :  forall a b, 0 < [|b|] ->
      [|modulo a b|] = [|a|] mod [|b|];

    spec_gcd_gt : forall a b, [|a|] > [|b|] ->
      Zis_gcd [|a|] [|b|] [|gcd_gt a b|];
    spec_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|];

    (* shift operations *)
    spec_head00:  forall x, [|x|] = 0 -> [|head0 x|] = Zpos digits;
    spec_head0  : forall x,  0 < [|x|] ->
	 wB/ 2 <= 2 ^ ([|head0 x|]) * [|x|] < wB;
    spec_tail00:  forall x, [|x|] = 0 -> [|tail0 x|] = Zpos digits;
    spec_tail0  : forall x, 0 < [|x|] ->
         exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|tail0 x|]) ;
    spec_add_mul_div : forall x y p,
       [|p|] <= Zpos digits ->
       [| add_mul_div p x y |] =
         ([|x|] * (2 ^ [|p|]) +
          [|y|] / (2 ^ ((Zpos digits) - [|p|]))) mod wB;
    spec_pos_mod : forall w p,
       [|pos_mod p w|] = [|w|] mod (2 ^ [|p|]);
    (* sqrt *)
    spec_is_even : forall x,
      if is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1;
    spec_sqrt2 : forall x y,
       wB/ 4 <= [|x|] ->
       let (s,r) := sqrt2 x y in
          [||WW x y||] = [|s|] ^ 2 + [+|r|] /\
          [+|r|] <= 2 * [|s|];
    spec_sqrt : forall x,
       [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2
  }.

 End Specs.

 Implicit Arguments Specs [[t]].

 (** Generic construction of double words *)

 Section WW.

 Context {t : Type}{ops : Ops t}{specs : Specs ops}.

 Let wB := base digits.

 Definition WO' (eq0:t->bool) zero h :=
  if eq0 h then W0 else WW h zero.

 Definition WO := Eval lazy beta delta [WO'] in
   let eq0 := ZnZ.eq0 in
   let zero := ZnZ.zero in
   WO' eq0 zero.

 Definition OW' (eq0:t->bool) zero l :=
  if eq0 l then W0 else WW zero l.

 Definition OW := Eval lazy beta delta [OW'] in
   let eq0 := ZnZ.eq0 in
   let zero := ZnZ.zero in
   OW' eq0 zero.

 Definition WW'  (eq0:t->bool) zero h l :=
  if eq0 h then OW' eq0 zero l else WW h l.

 Definition WW := Eval lazy beta delta [WW' OW'] in
   let eq0 := ZnZ.eq0 in
   let zero := ZnZ.zero in
   WW' eq0 zero.

 Lemma spec_WO : forall h,
   zn2z_to_Z wB to_Z (WO h) = (to_Z h)*wB.
 Proof.
 unfold zn2z_to_Z, WO; simpl; intros.
 case_eq (eq0 h); intros.
 rewrite (spec_eq0 _ H); auto.
 rewrite spec_0; auto with zarith.
 Qed.

 Lemma spec_OW : forall l,
   zn2z_to_Z wB to_Z (OW l) = to_Z l.
 Proof.
 unfold zn2z_to_Z, OW; simpl; intros.
 case_eq (eq0 l); intros.
 rewrite (spec_eq0 _ H); auto.
 rewrite spec_0; auto with zarith.
 Qed.

 Lemma spec_WW : forall h l,
  zn2z_to_Z wB to_Z (WW h l) = (to_Z h)*wB + to_Z l.
 Proof.
 unfold WW; simpl; intros.
 case_eq (eq0 h); intros.
 rewrite (spec_eq0 _ H); auto.
 fold (OW l).
 rewrite spec_OW; auto.
 simpl; auto.
 Qed.

 End WW.

 (** Injecting [Z] numbers into a cyclic structure *)

 Section Of_Z.

 Context {t : Type}{ops : Ops t}{specs : Specs ops}.

 Notation "[| x |]" := (to_Z x)  (at level 0, x at level 99).

 Theorem of_pos_correct:
   forall p, Zpos p < base digits -> [|(snd (of_pos p))|] = Zpos p.
 Proof.
 intros p Hp.
 generalize (spec_of_pos p).
 case (of_pos p); intros n w1; simpl.
 case n; simpl Npos; auto with zarith.
 intros p1 Hp1; contradict Hp; apply Zle_not_lt.
 replace (base digits) with (1 * base digits + 0) by ring.
 rewrite Hp1.
 apply Zplus_le_compat.
 apply Zmult_le_compat; auto with zarith.
 case p1; simpl; intros; red; simpl; intros; discriminate.
 unfold base; auto with zarith.
 case (spec_to_Z w1); auto with zarith.
 Qed.

 Definition of_Z z :=
 match z with
 | Zpos p => snd (of_pos p)
 | _ => zero
 end.

 Theorem of_Z_correct:
   forall p, 0 <= p < base digits -> [|of_Z p|] = p.
 Proof.
 intros p; case p; simpl; try rewrite spec_0; auto.
 intros; rewrite of_pos_correct; auto with zarith.
 intros p1 (H1, _); contradict H1; apply Zlt_not_le; red; simpl; auto.
 Qed.

 End Of_Z.

End ZnZ.

(** A modular specification grouping the earlier records. *)

Module Type CyclicType.
 Parameter t : Type.
 Declare Instance ops : ZnZ.Ops t.
 Declare Instance specs : ZnZ.Specs ops.
End CyclicType.

(** A Cyclic structure can be seen as a ring *)

Module CyclicRing (Import Cyclic : CyclicType).

Local Notation "[| x |]" := (ZnZ.to_Z x) (at level 0, x at level 99).

Definition eq (n m : t) := [| n |] = [| m |].

Local Infix "=="  := eq (at level 70).
Local Notation "0" := ZnZ.zero.
Local Notation "1" := ZnZ.one.
Local Infix "+" := ZnZ.add.
Local Infix "-" := ZnZ.sub.
Local Notation "- x" := (ZnZ.opp x).
Local Infix "*" := ZnZ.mul.
Local Notation wB := (base ZnZ.digits).

Hint Rewrite ZnZ.spec_0 ZnZ.spec_1 ZnZ.spec_add ZnZ.spec_mul
 ZnZ.spec_opp ZnZ.spec_sub
 : cyclic.

Ltac zify := unfold eq in *; autorewrite with cyclic.

Lemma add_0_l : forall x, 0 + x == x.
Proof.
intros. zify. rewrite Zplus_0_l.
apply Zmod_small. apply ZnZ.spec_to_Z.
Qed.

Lemma add_comm : forall x y, x + y == y + x.
Proof.
intros. zify. now rewrite Zplus_comm.
Qed.

Lemma add_assoc : forall x y z, x + (y + z) == x + y + z.
Proof.
intros. zify. now rewrite Zplus_mod_idemp_r, Zplus_mod_idemp_l, Zplus_assoc.
Qed.

Lemma mul_1_l : forall x, 1 * x == x.
Proof.
intros. zify. rewrite Zmult_1_l.
apply Zmod_small. apply ZnZ.spec_to_Z.
Qed.

Lemma mul_comm : forall x y, x * y == y * x.
Proof.
intros. zify. now rewrite Zmult_comm.
Qed.

Lemma mul_assoc : forall x y z, x * (y * z) == x * y * z.
Proof.
intros. zify. now rewrite Zmult_mod_idemp_r, Zmult_mod_idemp_l, Zmult_assoc.
Qed.

Lemma mul_add_distr_r : forall x y z, (x+y)*z == x*z + y*z.
Proof.
intros. zify. now rewrite <- Zplus_mod, Zmult_mod_idemp_l, Zmult_plus_distr_l.
Qed.

Lemma add_opp_r : forall x y, x + - y == x-y.
Proof.
intros. zify. rewrite <- Zminus_mod_idemp_r. unfold Zminus.
destruct (Z_eq_dec ([|y|] mod wB) 0) as [EQ|NEQ].
rewrite Z_mod_zero_opp_full, EQ, 2 Zplus_0_r; auto.
rewrite Z_mod_nz_opp_full by auto.
rewrite <- Zplus_mod_idemp_r, <- Zminus_mod_idemp_l.
rewrite Z_mod_same_full. simpl. now rewrite Zplus_mod_idemp_r.
Qed.

Lemma add_opp_diag_r : forall x, x + - x == 0.
Proof.
intros. red. rewrite add_opp_r. zify. now rewrite Zminus_diag, Zmod_0_l.
Qed.

Lemma CyclicRing : ring_theory 0 1 ZnZ.add ZnZ.mul ZnZ.sub ZnZ.opp eq.
Proof.
constructor.
exact add_0_l. exact add_comm. exact add_assoc.
exact mul_1_l. exact mul_comm. exact mul_assoc.
exact mul_add_distr_r.
symmetry. apply add_opp_r.
exact add_opp_diag_r.
Qed.

Definition eqb x y :=
 match ZnZ.compare x y with Eq => true | _ => false end.

Lemma eqb_eq : forall x y, eqb x y = true <-> x == y.
Proof.
 intros. unfold eqb, eq.
 rewrite ZnZ.spec_compare.
 case Zcompare_spec; intuition; try discriminate.
Qed.

(* POUR HUGO:
Lemma eqb_eq : forall x y, eqb x y = true <-> x == y.
Proof.
 intros. unfold eqb, eq. generalize (ZnZ.spec_compare x y).
 case (ZnZ.compare x y); intuition; try discriminate.
 (* BUG ?! using destruct instead of case won't work:
   it gives 3 subcases, but ZnZ.compare x y is still there in them! *)
Qed.
*)

Lemma eqb_correct : forall x y, eqb x y = true -> x==y.
Proof. now apply eqb_eq. Qed.

End CyclicRing.