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

(** * Efficient arbitrary large natural numbers in base 2^63 *)

(** Initial Author: Arnaud Spiwack *)

Require Import Lia CyclicAxioms Ring63 NSig NSigNAxioms NMake
  NProperties GenericMinMax.
Import Cyclic63.

(** The following [BigN] module regroups both the operations and
    all the abstract properties:

    - [NMake.Make Int63Cyclic] provides the operations and basic specs
       w.r.t. ZArith
    - [NTypeIsNAxioms] shows (mainly) that these operations implement
      the interface [NAxioms]
    - [NProp] adds all generic properties derived from [NAxioms]
    - [MinMax*Properties] provides properties of [min] and [max].

*)

Delimit Scope bigN_scope with bigN.

Module BigN <: NType <: OrderedTypeFull <: TotalOrder :=
  NMake.Make Uint63Cyclic
  <+ NTypeIsNAxioms
  <+ NBasicProp [no inline] <+ NExtraProp [no inline]
  <+ HasEqBool2Dec [no inline]
  <+ MinMaxLogicalProperties [no inline]
  <+ MinMaxDecProperties [no inline].

(** Notations about [BigN] *)

Local Open Scope bigN_scope.

Notation bigN := BigN.t.
Bind Scope bigN_scope with bigN.
Bind Scope bigN_scope with BigN.t.
Bind Scope bigN_scope with BigN.t'.
Arguments BigN.N0 _%int63.
Local Notation "0" := BigN.zero : bigN_scope. (* temporary notation *)
Local Notation "1" := BigN.one : bigN_scope. (* temporary notation *)
Local Notation "2" := BigN.two : bigN_scope. (* temporary notation *)
Infix "+" := BigN.add : bigN_scope.
Infix "-" := BigN.sub : bigN_scope.
Infix "*" := BigN.mul : bigN_scope.
Infix "/" := BigN.div : bigN_scope.
Infix "^" := BigN.pow : bigN_scope.
Infix "?=" := BigN.compare : bigN_scope.
Infix "=?" := BigN.eqb (at level 70, no associativity) : bigN_scope.
Infix "<=?" := BigN.leb (at level 70, no associativity) : bigN_scope.
Infix "<?" := BigN.ltb (at level 70, no associativity) : bigN_scope.
Infix "==" := BigN.eq (at level 70, no associativity) : bigN_scope.
Notation "x != y" := (~x==y) (at level 70, no associativity) : bigN_scope.
Infix "<" := BigN.lt : bigN_scope.
Infix "<=" := BigN.le : bigN_scope.
Notation "x > y" := (y < x) (only parsing) : bigN_scope.
Notation "x >= y" := (y <= x) (only parsing) : bigN_scope.
Notation "x < y < z" := (x<y /\ y<z) : bigN_scope.
Notation "x < y <= z" := (x<y /\ y<=z) : bigN_scope.
Notation "x <= y < z" := (x<=y /\ y<z) : bigN_scope.
Notation "x <= y <= z" := (x<=y /\ y<=z) : bigN_scope.
Infix "mod" := BigN.modulo (at level 40, no associativity) : bigN_scope.

(** Example of reasoning about [BigN] *)

Theorem succ_pred: forall q : bigN,
  0 < q -> BigN.succ (BigN.pred q) == q.
Proof.
intros; apply BigN.succ_pred.
intro H'; rewrite H' in H; discriminate.
Qed.

(** [BigN] is a semi-ring *)

Lemma BigNring : semi_ring_theory 0 1 BigN.add BigN.mul BigN.eq.
Proof.
constructor.
exact BigN.add_0_l. exact BigN.add_comm. exact BigN.add_assoc.
exact BigN.mul_1_l. exact BigN.mul_0_l. exact BigN.mul_comm.
exact BigN.mul_assoc. exact BigN.mul_add_distr_r.
Qed.

Lemma BigNeqb_correct : forall x y, (x =? y) = true -> x==y.
Proof. now apply BigN.eqb_eq. Qed.

Lemma BigNpower : power_theory 1 BigN.mul BigN.eq BigN.of_N BigN.pow.
Proof.
constructor.
intros. red. rewrite BigN.spec_pow, BigN.spec_of_N.
rewrite Zpower_theory.(rpow_pow_N).
destruct n; simpl. reflexivity.
induction p; simpl; intros; BigN.zify; rewrite ?IHp; auto.
Qed.

Lemma BigNdiv : div_theory BigN.eq BigN.add BigN.mul (@id _)
 (fun a b => if b =? 0 then (0,a) else BigN.div_eucl a b).
Proof.
constructor. unfold id. intros a b.
BigN.zify.
case Z.eqb_spec.
BigN.zify. auto with zarith.
intros NEQ.
generalize (BigN.spec_div_eucl a b).
generalize (Z_div_mod_full (BigN.to_Z a) (BigN.to_Z b) NEQ).
destruct BigN.div_eucl as (q,r), Z.div_eucl as (q',r').
intros (EQ,_). injection 1 as EQr EQq.
BigN.zify. rewrite EQr, EQq; auto.
Qed.

(** Detection of constants *)

Ltac isStaticWordCst t :=
 match t with
 | W0 => constr:(true)
 | WW ?t1 ?t2 =>
   match isStaticWordCst t1 with
   | false => constr:(false)
   | true => isStaticWordCst t2
   end
 | _ => isUint63cst t
 end.

Ltac isBigNcst t :=
 match t with
 | BigN.N0 ?t => isStaticWordCst t
 | BigN.N1 ?t => isStaticWordCst t
 | BigN.N2 ?t => isStaticWordCst t
 | BigN.N3 ?t => isStaticWordCst t
 | BigN.N4 ?t => isStaticWordCst t
 | BigN.N5 ?t => isStaticWordCst t
 | BigN.N6 ?t => isStaticWordCst t
 | BigN.Nn ?n ?t => match isnatcst n with
   | true => isStaticWordCst t
   | false => constr:(false)
   end
 | BigN.zero => constr:(true)
 | BigN.one => constr:(true)
 | BigN.two => constr:(true)
 | _ => constr:(false)
 end.

Ltac BigNcst t :=
 match isBigNcst t with
 | true => constr:(t)
 | false => constr:(NotConstant)
 end.

Ltac BigN_to_N t :=
 match isBigNcst t with
 | true => eval vm_compute in (BigN.to_N t)
 | false => constr:(NotConstant)
 end.

Ltac Ncst t :=
 match isNcst t with
 | true => constr:(t)
 | false => constr:(NotConstant)
 end.

(** Registration for the "ring" tactic *)

Add Ring BigNr : BigNring
 (decidable BigNeqb_correct,
  constants [BigNcst],
  power_tac BigNpower [BigN_to_N],
  div BigNdiv).

Section TestRing.
Let test : forall x y, 1 + x*y^1 + x^2 + 1 == 1*1 + 1 + y*x + 1*x*x.
intros. ring_simplify. reflexivity.
Qed.
End TestRing.

(** We benefit also from an "order" tactic *)

Ltac bigN_order := BigN.order.

Section TestOrder.
Let test : forall x y : bigN, x<=y -> y<=x -> x==y.
Proof. bigN_order. Qed.
End TestOrder.

(** We can use at least a bit of lia by translating to [Z]. *)

Section TestLia.
Let test : forall x y : bigN, x<=y -> y<=x -> x==y.
Proof. intros x y. BigN.zify. lia. Qed.
End TestLia.


Require Export SystemFR.ErasedPrimitive.
Require Import Coq.Strings.String.

Lemma reducible_values_primitive_EqEquiv1:
  forall v1 v2,
    cbv_value v1 ->
    cbv_value v2 ->
    [ binary_primitive Eq v1 v2 ≡ ttrue ] ->
    [ v1 ≡ v2 ].
Proof.
  unfold reduces_to; intros; repeat simp_red; repeat is_nat_value_buildable; steps.
  apply_anywhere equivalent_true. last_step_binary_primitive.
   rewrite PeanoNat.Nat.eqb_eq in *; subst.
  unfold equivalent_terms; steps; eauto with erased values wf fv.
Qed.

Opaque Coq.Init.Wf.Fix_F.
Opaque  Subterm.FixWf.

Lemma reducible_primitive_EqEquiv1:
  forall t1 t2,
    [ binary_primitive Eq t1 t2 ≡ ttrue ] ->
    [ t1 ≡ t2 ].
Proof.
  steps.
  pose proof H.
  apply_anywhere equivalent_true.
  t_invert_star; eauto with values. steps.
  eapply equivalent_trans; [ top_level_unfold equivalent_terms;
    apply equivalent_star; eauto with erased wf fv; t_closer | idtac].
  eapply equivalent_sym, equivalent_trans; [equivalent_star | idtac].
  apply equivalent_sym.
  eapply reducible_values_primitive_EqEquiv1; unfold reduces_to; steps;
    autorewrite with reducible_values; eauto with cbvlemmas values reducible_values.
  eapply equivalent_trans; [idtac | eauto using equivalent_refl with fv erased values].
  apply equivalent_sym, equivalent_star;
    repeat steps || list_utils || top_level_unfold equivalent_terms ; eauto with wf erased fv.
  apply star_smallstep_binary_primitive; eauto with values.
Qed.

Lemma open_reducible_primitive_EqEquiv1:
  forall Θ Γ t1 t2,
    [Θ; Γ ⊨ binary_primitive Eq t1 t2 ≡ ttrue ] ->
    [Θ; Γ ⊨ t1 ≡ t2].
Proof. unfold open_reducible, open_equivalent; steps;
         eauto using reducible_primitive_EqEquiv1.
Qed.

#[export]
Hint Resolve open_reducible_primitive_EqEquiv1: primitives.

Lemma equivalent_build_nat:
  forall n1 n2,
    [build_nat n1 ≡ build_nat n2] ->
    n1 = n2.
Proof.
  unfold equivalent_terms; steps.
  specialize (H6 (binary_primitive Eq (lvar 0 term_var) (build_nat n2))); steps.
  repeat (rewrite open_none in H6; eauto with wf).
  assert (binary_primitive Eq (build_nat n1) (build_nat n2) ~> ttrue). {
    apply last_step_binary_primitive; eauto with values.
    apply H6; try Psatz.lia; eauto with wf smallstep.
    apply star_one. pose proof (SPBetaEq _ _ n2 n2 eq_refl eq_refl); steps.
    rewrite PeanoNat.Nat.eqb_neq in *; steps.
    }
  t_invert_step; repeat steps || rewrite PeanoNat.Nat.eqb_eq in * || build_nat_inj.
Qed.

Ltac equivalent_build_nat :=
  match goal with
  | H: [ build_nat ?n1 ≡ build_nat ?n2 ] |- _ => apply equivalent_build_nat in H; subst
  end.

Lemma reducible_values_primitive_EqEquiv2:
  forall ρ v1 v2,
    [ ρ ⊨ v1 : T_nat ]v ->
    [ ρ ⊨ v2 : T_nat ]v ->
    [ v1 ≡ v2 ] ->
    [ binary_primitive Eq v1 v2 ≡ ttrue ].
Proof.
  unfold reduces_to; repeat simp_red || is_nat_value_buildable || steps || equivalent_build_nat.
  eapply equivalent_star; repeat steps || list_utils; eauto with smallstep wf fv erased.
  apply star_one. epose proof (SPBetaEq _ _ n0 n0); repeat rewrite PeanoNat.Nat.eqb_neq in * || steps.
Qed.

Lemma reducible_primitive_EqEquiv2:
  forall ρ t1 t2,
    (valid_interpretation ρ) ->
    [ ρ ⊨ t1 : T_nat ] ->
    [ ρ ⊨ t2 : T_nat ] ->
    [ t1 ≡ t2 ] ->
    [ binary_primitive Eq t1 t2 ≡ ttrue ].
Proof.
  intros;
    repeat steps || simp_red || is_nat_value_buildable || unfold closed_term in * || top_level_unfold reduces_to ; eauto with erased wf.

  eapply equivalent_trans.
  apply equivalent_star; repeat steps || list_utils ; eauto with erased wf fv.
  apply star_smallstep_binary_primitive; eauto using cbv_value_build_nat.
  unshelve eapply reducible_values_primitive_EqEquiv2; unfold reduces_to; steps;
    autorewrite with reducible_values; eauto with cbvlemmas values reducible_values.
  eapply equivalent_trans. apply equivalent_sym. equivalent_star.
  eapply equivalent_trans; eauto. equivalent_star.
Qed.

Lemma open_reducible_primitive_EqEquiv2:
  forall Θ Γ t1 t2,
    [Θ; Γ ⊨ t1 : T_nat] ->
    [Θ; Γ ⊨ t2 : T_nat] ->
    [Θ; Γ ⊨ t1 ≡ t2] ->
    [Θ; Γ ⊨ binary_primitive Eq t1 t2 ≡ ttrue ].
Proof. unfold open_reducible, open_equivalent; steps;
         eauto using reducible_primitive_EqEquiv2.
Qed.
#[export]
Hint Resolve open_reducible_primitive_EqEquiv2: primitives.

Lemma open_reducible_primitive_Eq_args:
  forall Θ Γ t1 t2,
    [Θ; Γ ⊨ binary_primitive Eq t1 t2 ≡ ttrue ] ->
    [Θ; Γ ⊨ t1 : T_nat] /\ [Θ; Γ ⊨ t2 : T_nat].
Proof.
  intros. unfold open_equivalent, open_reducible in *; steps; specialize (H ρ lterms); intuition auto;
  assert (closed_term (psubstitute t2 lterms term_var)) by
      (unfold equivalent_terms, closed_term, open_equivalent, open_reducible in *; repeat steps || list_utils);
  assert (closed_term (psubstitute t1 lterms term_var)) by
      (unfold equivalent_terms, closed_term, open_equivalent, open_reducible in *; repeat steps || list_utils);
  apply_anywhere equivalent_true;
  eapply_anywhere star_smallstep_binary_primitive_inv; eauto with values; steps;
  step_inversion scbv_step; steps;
  unfold reduces_to; steps; eauto with values smallstep;
  eexists; split; eauto;
  rewrite reducible_values_equation_4; apply is_nat_value_build_nat.
Qed.

Lemma open_reducible_primitive_EqSym:
  forall Θ Γ t1 t2,
    [Θ; Γ ⊨ binary_primitive Eq t1 t2 ≡ ttrue ] ->
    [Θ; Γ ⊨ binary_primitive Eq t2 t1 ≡ ttrue ].
Proof.
  steps.
  apply open_reducible_primitive_EqEquiv2;
    try solve [
          apply_anywhere open_reducible_primitive_Eq_args; steps].
  assert ([Θ; Γ ⊨ t1 ≡ t2]). apply open_reducible_primitive_EqEquiv1; eauto.
  unfold open_equivalent in * ; steps ; eauto using equivalent_sym.
Qed.
#[export]
Hint Resolve open_reducible_primitive_EqSym: primitives.

Lemma reducible_values_primitive_Lt_sound:
  forall a b, cbv_value a ->
         cbv_value b ->
         [ binary_primitive Lt a b ≡ ttrue] ->
         tree_size a < tree_size b.
Proof.
  intros.
  apply_anywhere equivalent_true. last_step_binary_primitive.
  repeat rewrite tree_size_build_nat; steps. Psatz.lia.
Qed.

Ltac reducible_values_primitive_Lt_sound :=
  match goal with
  | H: binary_primitive Lt ?a ?b ~>* ttrue |- _ =>
    cbv_value a; cbv_value b;
    poseNew (Mark (a,b) "reducible_values_primitive_Lt_sound");
    unshelve epose proof (reducible_values_primitive_Lt_sound a b _ _ H)
  | H: [ binary_primitive Lt ?a ?b ≡ ttrue ] |- _ =>
    cbv_value a; cbv_value b;
    poseNew (Mark (a,b) "reducible_values_primitive_Lt_sound");
    unshelve epose proof (reducible_values_primitive_Lt_sound a b _ _ _)
  end.


From Coq Require Import ZArith Arith List Decidable Lia.
From mathcomp Require Import ssreflect eqtype ssrbool ssrnat ssrfun seq div.
From nbits Require Import NBitsDef AuxLemmas Compatibility NBitsOp.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Section Test.

  Local Open Scope bits_scope.

  (*---------------------------------------------------------------------------
    Preparation of implementation of Karatsuba algorithm
    ---------------------------------------------------------------------------*)

  (* 原本有subB_addB，此處新增addB_subB *)

  Lemma addB_subB bs1 bs2: size bs1 == size bs2 -> bs1 +# bs2 -# bs2 = bs1.
  Proof.
    intros. set bs:= bs1 +# bs2. have H1: size bs2 == size bs2 by done. have HaddBsz: size bs == size bs2 by rewrite size_addB minnE (eqP H) subnn subn0.
    rewrite (eqP (subB_equiv_addB_negB HaddBsz)) /bs -addBA -(eqP (subB_equiv_addB_negB H1)) subB_same -(eqP H) addB0 unzip1_zip; [by done|by rewrite size_zeros].
  Qed.

  (* 想要直接用addB_subB去證明沒有size bs1 > 0此限制的subB_addB，需要先證明 bs1 -# -# bs2 = bs1 +# bs2 *)

  Lemma subB_negB bs1 bs2: size bs1 == size bs2 -> bs1 -# -# bs2 = bs1 +# bs2.
  Proof.
    set bs:= -# bs2. have Hbs: bs2 = -# bs by rewrite negB_involutive. rewrite Hbs size_negB.
    intros.
    exact: (eqP (subB_equiv_addB_negB H)).
  Qed.

  Lemma subB_addB_generalize bs1 bs2: size bs1 == size bs2 -> bs1 -# bs2 +# bs2 = bs1.
  Proof.
    set bs:= -# bs2. have Hbs: bs2 = -# bs by rewrite negB_involutive. rewrite Hbs size_negB.
    move => H. have Hsz: size bs == size bs by done. rewrite (subB_negB H) -addBA. move /eqP in H.
    rewrite -(eqP (subB_equiv_addB_negB Hsz)) subB_same -H addB0 unzip1_zip; [by done| by rewrite size_zeros].
  Qed.

  (* bs1 = bs1 +# bs2 可以直接看成 bs2 = zeros (size bs2) *)

  Lemma addB_zero bs1 bs2: size bs1 == size bs2 -> bs1 = bs1 +# bs2 <-> bs2 = zeros (size bs2).
  Proof.
    move => Hsz. split.
    - move => H. rewrite addBC in H. rewrite eq_sym in Hsz. by rewrite (eqP Hsz) -subB_same {1}H (addB_subB Hsz).
    - move ->. rewrite addB0 unzip1_zip; [by done|by rewrite size_zeros (eqP Hsz)].
  Qed.

  (* 若是bs a b 長度都相同且轉換到nat後有加法的關係，則在原本的bits中也有加法addB的關係 *)

  Lemma to_nat_add_addB bs a b:
    size a == size b -> size a == size bs -> to_nat bs == to_nat a + to_nat b -> bs = a +# b.
  Proof.
    move => Hszb Hszbs. rewrite -(eqP (to_nat_addB_zext1 Hszb)). set addBab := zext 1 a +# zext 1 b.
    have HaddBsz: size addBab == (size bs).+1 by rewrite /addBab size_addB !size_zext -(eqP Hszb) minnE subnn subn0 (eqP Hszbs) addn1.
    have HaddBsz': size bs <= size addBab by rewrite (eqP HaddBsz) leqnSn.
    rewrite (to_nat_inj_rl HaddBsz') (eqP HaddBsz) subSnn /addBab => Hzextbs.
    by rewrite -(addB_zext1_lown (eqP Hszb)) -(eqP Hzextbs) (eqP Hszbs) low_zext.
  Qed.

  (* 如果a和b長度相同且轉換成nat後相加並未超過該長度的bits所能表示的nat範圍，則to_nat (a +# b) = to_nat a + to_nat b *)

  Lemma to_nat_add_addB_bounded a b:
    size a == size b -> to_nat a + to_nat b < 2 ^ (size a) -> to_nat (a +# b) = to_nat a + to_nat b.
  Proof.
    move => Hsz Hto_nat. pose proof (to_nat_from_nat_bounded Hto_nat) as H. move /eqP in H. set bs := (size a) -bits of (to_nat a + to_nat b).
    have Hbssz: size a == size bs by rewrite size_from_nat.
    by rewrite -(to_nat_add_addB Hsz Hbssz H) /bs (eqP H).
  Qed.

  (* 上述的關係在減法需要多加一個條件，那就是to_nat a <= to_nat b，當初真不應該用to_nat，直接用to_Zpos不是更好嗎... *)

  Lemma leB_to_nat_subB a b: size a == size b -> b <=# a -> to_nat (a -# b) = to_nat a - to_nat b.
  Proof.
    move => Hsz Hblea. rewrite (to_nat_Zpos (a -# b)) (to_Zpos_subB' (eqP Hsz)). assert (Hblea_to_Zpos := Hblea). rewrite eq_sym in Hsz. rewrite (to_Zpos_leB_eqn (eqP Hsz)) -(eqb_id (to_Zpos b <=? to_Zpos a)%Z) in Hblea_to_Zpos.
    move /eqP in Hblea_to_Zpos. apply (Z.leb_le (to_Zpos b) (to_Zpos a)) in Hblea_to_Zpos. apply (Z.le_sub_0 (to_Zpos b) (to_Zpos a)) in Hblea_to_Zpos.
    rewrite -(Z.add_opp_l (to_Zpos b) (to_Zpos a)) -(Z.opp_sub_distr (to_Zpos a) (to_Zpos b)) Z.opp_nonpos_nonneg in Hblea_to_Zpos.
    have Hzmod: (0 <= to_Zpos a - to_Zpos b < 2 ^ Z.of_nat (size a))%Z.
    - split; first by done. have Hsub: (0 <= to_Zpos b)%Z by apply to_Zpos_ge0. apply (Z.le_sub_nonneg (to_Zpos a) (to_Zpos b)) in Hsub. exact: (Z.le_lt_trans (to_Zpos a - to_Zpos b) (to_Zpos a) (2 ^ Z.of_nat (size a)) Hsub (to_Zpos_bounded a)).
    - rewrite (Z.mod_small (to_Zpos a - to_Zpos b) (2 ^ Z.of_nat (size a)) Hzmod) Z2Nat.inj_sub; last by apply to_Zpos_ge0. by rewrite -!to_nat_Zpos.
  Qed.

  Lemma leB_to_nat_sub_subB bs a b:
    size a == size b -> b <=# a -> size a == size bs -> to_nat bs == to_nat a - to_nat b -> bs = a -# b.
  Proof.
    move => Hsz Hblea Hszbs. rewrite -(leB_to_nat_subB Hsz Hblea). rewrite to_nat_inj_ss; first by move /eqP => H.
    by rewrite size_subB minnE -(eqP Hsz) subnn subn0 (eqP Hszbs).
  Qed.

  (* 若是bs1 bs2長度相同且carry_addB bs1 bs2 == [:: false]，則bs1和bs2 先相加再轉換成nat 跟 先轉換成nat再相加 所得到的結果會相同 *)

  Lemma carry_addB_msb_zext a b:
    size a == size b -> carry_addB a b == msb ((zext 1 a) +# (zext 1 b)).
  Proof.
    move => Hsz. pose proof (addB_zext1_high1 (eqP Hsz)) as HaddB_zext1_high1. rewrite high1_msb /from_bool /from_nat /joinlsb oddb in HaddB_zext1_high1.
    by rewrite -(to_bool_bit (carry_addB a b)) -(to_bool_bit (msb (zext 1 a +# zext 1 b))) HaddB_zext1_high1.
  Qed.

  Lemma joinmsb_dropmsb bs:
    0 < size bs -> joinmsb (dropmsb bs) (msb bs) = bs.
  Proof.
    case/lastP: bs; first by done. move => s x Hsz. by rewrite msb_rcons dropmsb_rcons /joinmsb.
  Qed.

  Lemma zext1 bs:
    zext 1 bs == rcons bs b0.
  Proof.
    rewrite /zext cats1 //=.
  Qed.

  Lemma carry_addB_to_nat_add bs1 bs2:
    size bs1 == size bs2 -> ~~(carry_addB bs1 bs2) -> to_nat (bs1 +# bs2) = (to_nat bs1) + (to_nat bs2).
  Proof.
    move => Hsz. rewrite (eqP (carry_addB_msb_zext Hsz)) => Hmsb_zext_false.
    have Hsize_zext: size (zext 1 bs1 +# zext 1 bs2) == (size bs1).+1 by rewrite size_addB !size_zext -(eqP Hsz) minnE subnn subn0 addn1.
    rewrite -(addB_zext1_lown (eqP Hsz)) -(eqP (to_nat_addB_zext1 Hsz)) -dropmsb_low -(eqP Hsize_zext) low_size.
    have Hsize_zext': 0 < size (zext 1 bs1 +# zext 1 bs2) by rewrite (eqP Hsize_zext); exact: (leq_ltn_trans (leq0n (size bs1)) (ltnSn (size bs1))).
    by rewrite -{2}(joinmsb_dropmsb Hsize_zext') (negbTE Hmsb_zext_false) /joinmsb -(eqP (zext1 (dropmsb (zext 1 bs1 +# zext 1 bs2)))) to_nat_zext.
  Qed.

  (* 另外一個確認to_nat (a +# b) = (to_nat a) + (to_nat b)的條件是 a <=# a +# b && b <=# a +# b *)

  Lemma leB_leB_addB_to_nat_add bs a b:
    size a == size b -> a <=# bs -> b <=# bs -> bs == a +# b -> to_nat bs = (to_nat a) + (to_nat b).
  Proof.
    move=> Hsz Hale Hble /eqP HaddBeq. have Hszbsa: size a == size bs by rewrite HaddBeq size_addB minnE -(eqP Hsz) subnn subn0. have Hszbsb: size b == size bs by rewrite -(eqP Hsz).
    rewrite (to_nat_leB (eqP Hszbsa)) in Hale. rewrite (to_nat_leB (eqP Hszbsb)) in Hble.
    case (msb (zext 1 a +# zext 1 b)) eqn: Hmsb_zext_bs.
    - rewrite -(eqP (to_nat_addB_zext1 Hsz)). pose proof (to_nat_addB_zext1 Hsz) as Hzext; move: Hzext Hmsb_zext_bs; set zext_bs := zext 1 a +# zext 1 b; move => Hzext Hmsb_zext_bs.
      have Hsz_zext_bs: size zext_bs == (size a).+1 by rewrite size_addB !size_zext -(eqP Hsz) minnE subnn subn0 addn1.
      have Hsz_zext_bs': 0 < size zext_bs by rewrite (eqP Hsz_zext_bs); exact: (leq_ltn_trans (leq0n (size a)) (ltnSn (size a))).
      rewrite -(joinmsb_dropmsb Hsz_zext_bs') -{1}(low_size zext_bs) (eqP Hsz_zext_bs) dropmsb_low (addB_zext1_lown (eqP Hsz)) -HaddBeq to_nat_joinmsb Hmsb_zext_bs //= mul1n in Hzext.
      pose proof(leq_add Hale Hble) as H. rewrite -(eqP Hzext) leq_add2r in H. pose proof (leq_ltn_trans H (to_nat_bounded bs)) as H'. by rewrite ltnn in H'.
    - move: Hmsb_zext_bs; rewrite HaddBeq. rewrite -(eqP (carry_addB_msb_zext Hsz)) => H. apply (carry_addB_to_nat_add Hsz (negbT H)).
  Qed.

  (* Karatsuba algorithm在conquer階段可能會把不同長度的bits相加，因此額外定義long_addB和long_carry_addB. *)
  (* 此外，為了避免Karatsuba在計算(a+b)*(c+d)時的overflow，需要額外定義zext_addB *)
  Definition long_addB (bs1 bs2 : bits) : bits := (adcB false (zext (size bs2 - size bs1) bs1) (zext (size bs1 - size bs2) bs2)).2.
  Definition long_carry_addB (bs1 bs2 : bits) : bool := (adcB false (zext (size bs2 - size bs1) bs1) (zext (size bs1 - size bs2) bs2)).1.
  Definition zext_addB (bs1 bs2 : bits) : bits := (zext 1 bs1) +# (zext 1 bs2).

  Definition long_subB (bs1 bs2 : bits) : bits := (sbbB false (zext (size bs2 - size bs1) bs1) (zext (size bs1 - size bs2) bs2)).2.
  Definition long_borrow_subB (bs1 bs2 : bits) : bool := (sbbB false (zext (size bs2 - size bs1) bs1) (zext (size bs1 - size bs2) bs2)).1.

  Notation "bs1 ++# bs2" := (long_addB bs1 bs2) (at level 40, left associativity) : bits_scope.
  Notation "bs1 0+# bs2" := (zext_addB bs1 bs2) (at level 40, left associativity) : bits_scope.
  Notation "bs1 --# bs2" := (long_subB bs1 bs2) (at level 40, left associativity) : bits_scope.

  (* add zero to the end *)
  Definition zend (n : nat) (bs : bits) : bits := zeros n ++ bs.

  (* high half and low half *)
  Definition low_half (bs : bits) : bits := low (size bs)./2 bs.
  Definition high_half (bs : bits) : bits := high (size bs)./2 bs.

  Notation "bs <<<# n" := (zend n bs) (at level 40, left associativity) : bits_scope.

  (*---------------------------------------------------------------------------
    Definition of multiplication based on Karatsuba algorithm
    ---------------------------------------------------------------------------*)

  Fixpoint Karatsuba_fullmul' (n : nat) (bs1' bs2' : bits) : bits :=
    match n with
    | 0 => full_mul bs1' bs2'
    | m.+1 => if (size bs1' <= 64) then full_mul bs1' bs2' else
                let bs1 := if odd (size bs1') then (zext 1 bs1') else bs1' in
                let bs2 := if odd (size bs2') then (zext 1 bs2') else bs2' in
                let bs1_high := high_half bs1 in
                let bs1_low := low_half bs1 in
                let bs2_high := high_half bs2 in
                let bs2_low := low_half bs2 in
                let hi_hi := low (size bs1_high).*2 (Karatsuba_fullmul' m bs1_high bs2_high) in
                let cross_term := low (size (bs1_high 0+# bs1_low)).*2 (Karatsuba_fullmul' m (bs1_high 0+# bs1_low) (bs2_high 0+# bs2_low)) in
                let lo_lo := low (size bs1_low).*2 (Karatsuba_fullmul' m bs1_low bs2_low) in
                lo_lo ++# ((cross_term --# (hi_hi 0+# lo_lo)) <<<# (size bs1)./2) ++# (hi_hi <<<# size bs1)
    end.

  Definition Karatsuba_fullmul (bs1 bs2 : bits) : bits := low (size bs1).*2 (Karatsuba_fullmul' (Nat.log2_up (size bs1)) bs1 bs2).

  Fixpoint General_Karatsuba_fullmul' (n : nat) (n' : nat) (bs1' bs2' : bits) : bits :=
    match n with
    | 0 => full_mul bs1' bs2'
    | m.+1 => if (size bs1' <= n') then full_mul bs1' bs2' else
                let bs1 := if odd (size bs1') then (zext 1 bs1') else bs1' in
                let bs2 := if odd (size bs2') then (zext 1 bs2') else bs2' in
                let bs1_high := high_half bs1 in
                let bs1_low := low_half bs1 in
                let bs2_high := high_half bs2 in
                let bs2_low := low_half bs2 in
                let hi_hi := low (size bs1_high).*2 (General_Karatsuba_fullmul' m n' bs1_high bs2_high) in
                let cross_term := low (size (bs1_high 0+# bs1_low)).*2 (General_Karatsuba_fullmul' m n' (bs1_high 0+# bs1_low) (bs2_high 0+# bs2_low)) in
                let lo_lo := low (size bs1_low).*2 (General_Karatsuba_fullmul' m n' bs1_low bs2_low) in
                lo_lo ++# ((cross_term --# (hi_hi 0+# lo_lo)) <<<# (size bs1)./2) ++# (hi_hi <<<# size bs1)
    end.

  Definition General_Karatsuba_fullmul (n' : nat) (bs1 bs2 : bits) : bits := low (size bs1).*2 (General_Karatsuba_fullmul' (Nat.log2_up (size bs1)) n' bs1 bs2).

  (* Just a simple test
  Compute to_Zpos (full_mul (from_Zpos 8192 546464946494564165146496446494654616649466446546541646495464649464945641651464964464946546166494664465465416464954646494649456416514649644649465461664946644654654164649) (from_Zpos 8192 165416541644964516515646464694654165516155464649464945641651464964464946546166494664465465416464954646494649456416514649644649465461664946644654654164649)).
  Compute to_Zpos (Karatsuba_fullmul (from_Zpos 8192 546464946494564165146496446494654616649466446546541646495464649464945641651464964464946546166494664465465416464954646494649456416514649644649465461664946644654654164649) (from_Zpos 8192 165416541644964516515646464694654165516155464649464945641651464964464946546166494664465465416464954646494649456416514649644649465461664946644654654164649)). *)
  Lemma low_fullmul bs1 bs2: size bs1 == size bs2 -> low (size bs1).*2 (full_mul bs1 bs2) == full_mul bs1 bs2.
  Proof.
    move => Hsz. have Hsz_fullmul: (size bs1).*2 = size (full_mul bs1 bs2) by rewrite size_full_mul -(eqP Hsz) addnn.
    by rewrite Hsz_fullmul low_size.
  Qed.

  (* about long_addB *)

  Lemma size_long_addB bs1 bs2: size (bs1 ++# bs2) = maxn (size bs1) (size bs2).
  Proof.
    rewrite /long_addB size_adcB. rewrite !size_zext. pose proof (orP (ltn_geq_total (size bs1) (size bs2))). case: H.
    - move => H. pose proof (ltnW H). rewrite -(subn_eq0 (size bs1) (size bs2)) in H0. by rewrite maxnE addnBn !(eqP H0) add0n addn0 minnE subnn subn0.
    - rewrite -(subn_eq0 (size bs2) (size bs1)) => H0. by rewrite maxnE !(eqP H0) addnBn (eqP H0) !addn0 add0n minnE subnn subn0.
  Qed.

  Lemma long_addB_addB bs1 bs2: bs1 ++# bs2 == (zext (size bs2 - size bs1) bs1) +# (zext (size bs1 - size bs2) bs2).
  Proof. by rewrite /long_addB /addB. Qed.

  Lemma long_addB_addB_nn bs1 bs2: size bs1 == size bs2 -> bs1 ++# bs2 == bs1 +# bs2.
  Proof. move => H. by rewrite (eqP (long_addB_addB bs1 bs2)) !(eqP H) subnn !zext0. Qed.

  Lemma long_addB_addB_rl bs1 bs2: size bs1 <= size bs2 -> bs1 ++# bs2 == (zext (size bs2 - size bs1)bs1) +# bs2.
  Proof. rewrite -(subn_eq0 (size bs1) (size bs2)) => H. by rewrite (eqP (long_addB_addB bs1 bs2)) (eqP H) zext0. Qed.

  Lemma long_addB_addB_ll bs1 bs2: size bs2 <= size bs1 -> bs1 ++# bs2 == bs1 +# (zext (size bs1 - size bs2) bs2).
  Proof. rewrite -(subn_eq0 (size bs2) (size bs1)) => H. by rewrite (eqP (long_addB_addB bs1 bs2)) (eqP H) zext0. Qed.

  (* 若是bs1 a b 長度都相同且轉換到nat後有加法的關係，則在原本的bits中也有加法long_addB的關係 *)

  Lemma to_nat_add_long_addB bs a b:
    size bs == size (a ++# b) -> to_nat bs == to_nat a + to_nat b -> bs = a ++# b.
  Proof.
    rewrite (eqP (long_addB_addB a b)) -(to_nat_zext (size b - size a) a) -(to_nat_zext (size a - size b) b).
    set a' := zext (size b - size a) a. set b' := zext (size a - size b) b.
    have Hsz: size a' == size b'.
    - rewrite /a' /b' !size_zext. pose proof (orP (ltn_geq_total (size a) (size b))). case: H => H.
      - pose proof (ltnW H). rewrite (subnKC H0).  rewrite -(subn_eq0 (size a) (size b)) in H0. by rewrite (eqP H0) addn0.
      - rewrite (subnKC H). rewrite -(subn_eq0 (size b) (size a)) in H. by rewrite (eqP H) addn0.
    - move => Hsz_addB Hto_nat. have Hszbs: size a' == size bs by rewrite (eqP Hsz_addB) size_addB minnE -(eqP Hsz) subnn subn0.
      exact: (to_nat_add_addB Hsz Hszbs Hto_nat).
  Qed.

  (* 如果a和b轉換成nat後相加並未超過長度為 size (a ++# b) 的bits所能表示的nat範圍，則to_nat (a ++# b) = to_nat a + to_nat b *)

  Lemma to_nat_add_long_addB_bounded a b:
    to_nat a + to_nat b < 2 ^ maxn (size a) (size b) -> to_nat (a ++# b) == to_nat a + to_nat b.
  Proof.
    move => Hto_nat.  pose proof (to_nat_from_nat_bounded Hto_nat) as H. move /eqP in H. set bs := (maxn (size a) (size b)) -bits of (to_nat a + to_nat b). rewrite (eqP (long_addB_addB a b)).
    set a' := zext (size b - size a) a. set b' := zext (size a - size b) b.
    have Hsz': size a' == size b'.
    - rewrite /a' /b' !size_zext. pose proof (orP (ltn_geq_total (size a) (size b))) as Htemp. case: Htemp => Htemp.
      + pose proof (ltnW Htemp). rewrite -(subn_eq0 (size a) (size b)) in H0. by rewrite addnBn (eqP H0) add0n addn0.
      + assert (H0 := Htemp). rewrite -(subn_eq0 (size b) (size a)) in H0. by rewrite -(maxnE (size b) (size a)) (maxn_idPr Htemp) (eqP H0) addn0.
    - have Hbssz: size a' == size bs by rewrite /a' /bs size_zext size_from_nat maxnE.
      rewrite -(to_nat_add_addB Hsz' Hbssz) to_nat_from_nat; first by rewrite (modn_small Hto_nat).
      by rewrite /a' /b' !to_nat_zext (modn_small Hto_nat).
  Qed.

  (* about long_carry_addB *)

  Lemma long_carry_carry bs1 bs2: long_carry_addB bs1 bs2 == carry_addB (zext (size bs2 - size bs1) bs1) (zext (size bs1 - size bs2) bs2).
  Proof. by rewrite /long_carry_addB /carry_addB. Qed.

  Lemma long_carry_carry_nn bs1 bs2: size bs1 == size bs2 -> long_carry_addB bs1 bs2 = carry_addB bs1 bs2.
  Proof. move => /eqP H. by rewrite (eqP (long_carry_carry bs1 bs2)) !H subnn !zext0. Qed.

  (* about zend *)

  Lemma zend0 bs: bs <<<# 0 == bs.
  Proof. by rewrite /zend zeros0. Qed.

  Lemma zend1 bs: bs <<<# 1 == joinlsb false bs.
  Proof. by rewrite /zend /zeros. Qed.

  Lemma zend_shlB_zextB bs n: bs <<<# n == (zext n bs) <<# n.
  Proof.
    set bs' := zext n bs. have Hsz: n <= size bs' by rewrite /bs' size_cat size_zeros leq_addl.
    rewrite (shlB_cat Hsz) /zend !/bs' size_cat size_zeros -subnBA; last by done. by rewrite (subnn n) subn0 low_zext.
  Qed.

  Lemma addC m n: m + n = n + m.
  Proof. induction m; [by rewrite add0n addn0 | by rewrite addSn addnS IHm]. Qed.

  Lemma size_zend bs n: size (bs <<<# n) = size bs + n.
  Proof. by rewrite /zend size_cat size_zeros addC. Qed.

  (* about zext_addB *)

  Lemma size_zext_addB bs1 bs2: size (bs1 0+# bs2) = minn (size bs1).+1 (size bs2).+1.
  Proof. by rewrite /zext_addB size_addB !size_zext !addn1. Qed.

  Lemma zext_addB_addB bs1 bs2: bs1 0+# bs2 == (zext 1 bs1) +# (zext 1 bs2).
  Proof. by rewrite /zext_addB /addB. Qed.

  Lemma to_nat_zext_addB bs1 bs2: size bs1 == size bs2 -> to_nat (bs1 0+# bs2) = to_nat bs1 + to_nat bs2.
  Proof. move => Hsz. by rewrite (eqP (zext_addB_addB bs1 bs2)) (eqP (to_nat_addB_zext1 Hsz)). Qed.

  (* about long_subB *)
  Lemma size_long_subB bs1 bs2: size (bs1 --# bs2) = maxn (size bs1) (size bs2).
  Proof.
    rewrite /long_subB size_sbbB !size_zext. pose proof (orP (ltn_geq_total (size bs1) (size bs2))). case: H => H.
    - pose proof (ltnW H). rewrite -(subn_eq0 (size bs1) (size bs2)) in H0. by rewrite maxnE addnBn !(eqP H0) add0n addn0 minnE subnn subn0.
    - rewrite -(subn_eq0 (size bs2) (size bs1)) in H. by rewrite maxnE !(eqP H) addnBn (eqP H) !addn0 add0n minnE subnn subn0.
  Qed.

  Lemma long_subB_subB bs1 bs2: bs1 --# bs2 == (zext (size bs2 - size bs1) bs1) -# (zext (size bs1 - size bs2) bs2).
  Proof. by rewrite /long_subB /subB. Qed.

  Lemma long_subB_subB_ss bs1 bs2: size bs1 == size bs2 -> bs1 --# bs2 == bs1 -# bs2.
  Proof. move => H. by rewrite (eqP (long_subB_subB bs1 bs2)) !(eqP H) subnn !zext0. Qed.

  Lemma long_subB_subB_rl bs1 bs2: size bs1 <= size bs2 -> bs1 --# bs2 == (zext (size bs2 - size bs1)bs1) -# bs2.
  Proof. rewrite -(subn_eq0 (size bs1) (size bs2)) => H. by rewrite (eqP (long_subB_subB bs1 bs2)) (eqP H) zext0. Qed.

  Lemma long_subB_subB_ll bs1 bs2: size bs2 <= size bs1 -> bs1 --# bs2 == bs1 -# (zext (size bs1 - size bs2) bs2).
  Proof. rewrite -(subn_eq0 (size bs2) (size bs1)) => H. by rewrite (eqP (long_subB_subB bs1 bs2)) (eqP H) zext0. Qed.

  Lemma to_nat_sub_long_subB bs1 bs2: to_nat bs2 <= to_nat bs1 -> to_nat (bs1 --# bs2) == to_nat bs1 - to_nat bs2.
  Proof.
    rewrite (eqP (long_subB_subB bs1 bs2)). set a := zext (size bs2 - size bs1) bs1. set b := zext (size bs1 - size bs2) bs2. move => HleB.
    have Hsz: size a == size b.
    - rewrite /a /b !size_zext. pose proof (orP (ltn_geq_total (size bs1) (size bs2))). case: H => H.
      + pose proof (ltnW H). rewrite -(subn_eq0 (size bs1) (size bs2)) in H0. by rewrite (eqP H0) -maxnE (maxn_idPr (ltnW H)) addn0.
      + assert (H0 := H). rewrite -(subn_eq0 (size bs2) (size bs1)) in H0. by rewrite (eqP H0) -maxnE (maxn_idPr H) addn0.
    - rewrite leB_to_nat_subB; [by rewrite /a /b !to_nat_zext | by done |]. rewrite eq_sym in Hsz. by rewrite (to_nat_leB (eqP Hsz)) /a /b !to_nat_zext.
  Qed.

  (* about zend *)
  Lemma to_nat_zend bs n: to_nat(bs <<<# n) == to_nat bs * 2 ^ n.
  Proof.
    rewrite (eqP (zend_shlB_zextB bs n)) to_nat_shlBnm to_nat_zext size_zext expnD.
    have Hbounded: to_nat bs * 2 ^ n < 2 ^ size bs * 2 ^ n by rewrite ltn_mul2r exp2n_gt0  to_nat_bounded.
    by rewrite (modn_small Hbounded).
  Qed.

  Lemma size_low_half bs: size (low_half bs) = (size bs)./2.
  Proof. by rewrite /low_half size_low. Qed.

  Lemma size_high_half bs: size (high_half bs) = (size bs)./2.
  Proof. by rewrite /high_half size_high. Qed.

  Lemma high_low_half bs: ~~ odd (size bs) -> low_half bs ++ high_half bs == bs.
  Proof.
    move => Hodd. rewrite /low_half /high_half cat_low_high; first by done.
    rewrite addnn -{2}(odd_double_half (size bs)). by rewrite (negbTE Hodd).
  Qed.

  Lemma to_nat_high_low_half bs:
    ~~ odd (size bs) -> to_nat (low_half bs) + to_nat ((high_half bs) <<<# (size bs)./2) == to_nat bs.
  Proof.
    move => Hodd. rewrite -{4}(eqP (high_low_half Hodd)) (to_nat_cat (low_half bs) (high_half bs)) (eqP (to_nat_zend (high_half bs) (size bs)./2)).
    by rewrite {3}/low_half size_low.
  Qed.

  Lemma addB_high_low_half bs:
    ~~ odd (size bs) -> zext (size bs)./2 (low_half bs) +# ((high_half bs) <<<# (size bs)./2) == bs.
  Proof.
    move => Hodd.
    have Hto_nat: to_nat bs == to_nat(zext (size bs)./2 (low_half bs)) + to_nat (high_half bs <<<# (size bs)./2) by rewrite to_nat_zext (eqP (to_nat_high_low_half Hodd)).
    have Hsz_even: (size bs)./2.*2 = size bs by rewrite -{2}(odd_double_half (size bs)) (negbTE Hodd).
    have Hsz: size (zext (size bs)./2 (low_half bs)) == size (high_half bs <<<# (size bs)./2) by rewrite size_zext (size_low_half bs) size_zend (size_high_half bs) !addnn !Hsz_even.
    have Hsz_addB: size (zext (size bs)./2 (low_half bs)) == size bs by rewrite size_zext (size_low_half bs) addnn Hsz_even.
    by rewrite {5}(to_nat_add_addB Hsz Hsz_addB Hto_nat).
  Qed.

  Lemma long_addB_high_low_half bs:
    ~~ odd (size bs) -> (low_half bs) ++# ((high_half bs) <<<# (size bs)./2) == bs.
  Proof.
    move => Hodd. set lo := low_half bs. set hi := high_half bs <<<# (size bs)./2.
    have Hszleq: size lo <= size hi by rewrite /lo /hi (size_low_half bs) size_zend (size_high_half bs) leq_addr.
    have Hsz: size hi == size lo + (size bs)./2 by rewrite /lo /hi (size_low_half bs) size_zend (size_high_half bs).
    rewrite (eqP (long_addB_addB_rl Hszleq)) (eqP Hsz) (size_low_half bs) -addnBA; last by done. rewrite (subnn (size bs)./2) addn0.
    exact: (addB_high_low_half Hodd).
  Qed.

  (* 剛剛才發現nat居然沒有乘法對加法的分配律......只好把上面一些有關to_nat的證明，通通改成to_Zpos了...... *)
  (* 重點是原來有些上面證明的東西，其實在NBitsOP已經證過了...... *)

  Lemma size_addB_ss a b: size a = size b -> size (a +# b) = size a.
  Proof. move => Hsz. by rewrite size_addB minnE -Hsz subnn subn0. Qed.

  Lemma size_subB_ss a b: size a = size b -> size (a -# b) = size a.
  Proof. move => Hsz. by rewrite size_subB minnE -Hsz subnn subn0. Qed.

  Lemma minn_sym n m: minn n m = minn m n.
  Proof.
    pose proof (orP (ltn_geq_total n m)). case: H => H.
    - by rewrite (minn_idPl (ltnW H)) (minn_idPr (ltnW H)).
    - by rewrite (minn_idPl H) (minn_idPr H).
  Qed.

  Lemma maxn_sym n m: maxn n m = maxn m n.
  Proof.
    pose proof (orP (ltn_geq_total n m)). case: H => H.
    - by rewrite (maxn_idPl (ltnW H)) (maxn_idPr (ltnW H)).
    - by rewrite (maxn_idPl H) (maxn_idPr H).
  Qed.

  Lemma to_Zpos_add_addB bs a b:
    size a == size b -> size a == size bs -> to_Zpos bs = (to_Zpos a + to_Zpos b)%Z -> bs = a +# b.
  Proof.
    move => Hszb Hszbs Hbs.
    have Hto_Zpos: to_Zpos (a +# b) = (to_Zpos a + to_Zpos b)%Z. rewrite (to_Zpos_addB' (eqP Hszb)) -!Hbs (eqP Hszbs) Zmod_small; first by done.
    - split; [by apply to_Zpos_ge0| exact: to_Zpos_bounded].
    - rewrite -Hto_Zpos in Hbs. have HszaddB: size bs = size (a +# b) by rewrite size_addB -(eqP Hszb) minnE subnn subn0 (eqP Hszbs). by rewrite (to_Zpos_inj_ss HszaddB Hbs).
  Qed.

  Lemma to_Zpos_add_addB_bounded a b:
    size a == size b -> (to_Zpos a + to_Zpos b < 2 ^ Z.of_nat (size a))%Z -> to_Zpos (a +# b) = (to_Zpos a + to_Zpos b)%Z.
  Proof.
    move => Hsz Hto_Zpos. rewrite (to_Zpos_addB' (eqP Hsz)) Zmod_small; first by done.
    split; last by done. apply Z.add_nonneg_nonneg; by apply to_Zpos_ge0.
  Qed.

  Lemma leB_to_Zpos_subB a b: size a == size b -> b <=# a -> to_Zpos (a -# b) = (to_Zpos a - to_Zpos b)%Z.
  Proof.
    move => Hsz Hblea. rewrite (to_Zpos_subB' (eqP Hsz)) Zmod_small; first by done. split.
    - assert (Hblea_to_Zpos := Hblea). rewrite eq_sym in Hsz. rewrite (to_Zpos_leB_eqn (eqP Hsz)) -(eqb_id (to_Zpos b <=? to_Zpos a)%Z) in Hblea_to_Zpos.
      move /eqP in Hblea_to_Zpos. apply (Z.leb_le (to_Zpos b) (to_Zpos a)) in Hblea_to_Zpos. apply (Z.le_sub_0 (to_Zpos b) (to_Zpos a)) in Hblea_to_Zpos.
      rewrite -(Z.add_opp_l (to_Zpos b) (to_Zpos a)) -(Z.opp_sub_distr (to_Zpos a) (to_Zpos b)) Z.opp_nonpos_nonneg in Hblea_to_Zpos. exact: Hblea_to_Zpos.
    - have Hsub: (0 <= to_Zpos b)%Z by apply to_Zpos_ge0. apply (Z.le_sub_nonneg (to_Zpos a) (to_Zpos b)) in Hsub. exact: (Z.le_lt_trans (to_Zpos a - to_Zpos b) (to_Zpos a) (2 ^ Z.of_nat (size a)) Hsub (to_Zpos_bounded a)).
  Qed.

  Lemma to_Zpos_sub_subB bs a b:
    size a == size b -> size a == size bs -> to_Zpos bs = (to_Zpos a - to_Zpos b)%Z -> bs = a -# b.
  Proof.
    move => Hsz Hszbs Hto_Zpos. have Hblea: b <=# a.
    - rewrite eq_sym in Hsz. rewrite (to_Zpos_leB_eqn (eqP Hsz)) -(eqb_id (to_Zpos b <=? to_Zpos a)%Z). apply /eqP. apply (Z.leb_le (to_Zpos b) (to_Zpos a)). apply (Z.le_sub_0 (to_Zpos b) (to_Zpos a)).
      rewrite -(Z.add_opp_l (to_Zpos b) (to_Zpos a)) -(Z.opp_sub_distr (to_Zpos a) (to_Zpos b)) Z.opp_nonpos_nonneg -Hto_Zpos. apply to_Zpos_ge0.
    - rewrite -(leB_to_Zpos_subB Hsz Hblea) in Hto_Zpos. apply to_Zpos_inj_ss; last by done. by rewrite (size_subB_ss (eqP Hsz)) (eqP Hszbs).
  Qed.

  (* carry_addB_to_nat_add 的Zpos版本，其實就是 bv2z_add_unsigned *)

  Lemma leB_leB_addB_to_Zpos_add bs a b:
    size a == size b -> a <=# bs -> b <=# bs -> bs == a +# b -> to_Zpos bs = (to_Zpos a + to_Zpos b)%Z.
  Proof.
    move=> Hsz Hale Hble /eqP HaddBeq. have Hszbsa: size a == size bs by rewrite HaddBeq size_addB minnE -(eqP Hsz) subnn subn0. have Hszbsb: size b == size bs by rewrite -(eqP Hsz).
    rewrite (to_Zpos_leB (eqP Hszbsa)) in Hale. rewrite (to_Zpos_leB (eqP Hszbsb)) in Hble.
    case Hcarry: (carry_addB a b).
    - have H: (to_Zpos a + to_Zpos b < to_Zpos bs + 2 ^ Z.of_nat (size bs))%Z. apply Z.add_le_lt_mono; [ exact: Hale | rewrite -(eqP Hszbsb); apply to_Zpos_bounded].
      rewrite -(to_Zpos_addB (eqP Hsz)) Hcarry -HaddBeq -(eqP Hszbsa) in H. have H0: (true * 2 ^ Z.of_nat (size a) = 2 ^ Z.of_nat (size a))%Z by case (2 ^ Z.of_nat (size a))%Z. rewrite H0 in H. by apply Z.lt_irrefl in H.
    - by rewrite -(to_Zpos_addB (eqP Hsz)) Hcarry //= Z.add_0_r HaddBeq.
  Qed.

  Lemma to_Zpos_add_long_addB bs a b:
    size bs == size (a ++# b) -> to_Zpos bs = (to_Zpos a + to_Zpos b)%Z -> bs = a ++# b.
  Proof.
    rewrite (eqP (long_addB_addB a b)) -(to_Zpos_zext a (size b - size a)) -(to_Zpos_zext b (size a - size b)).
    set a' := zext (size b - size a) a. set b' := zext (size a - size b) b.
    have Hsz: size a' == size b'.
    - rewrite /a' /b' !size_zext. pose proof (orP (ltn_geq_total (size a) (size b))). case: H => H.
      - pose proof (ltnW H). rewrite (subnKC H0).  rewrite -(subn_eq0 (size a) (size b)) in H0. by rewrite (eqP H0) addn0.
      - rewrite (subnKC H). rewrite -(subn_eq0 (size b) (size a)) in H. by rewrite (eqP H) addn0.
    - rewrite (size_addB_ss (eqP Hsz)) eq_sym; exact: (to_Zpos_add_addB Hsz).
  Qed.

  Lemma to_Zpos_add_long_addB_bounded a b:
    (to_Zpos a + to_Zpos b < 2 ^ Z.of_nat (maxn (size a) (size b)))%Z -> to_Zpos (a ++# b) = (to_Zpos a + to_Zpos b)%Z.
  Proof.
    rewrite (eqP (long_addB_addB a b)) -(to_Zpos_zext a (size b - size a)) -(to_Zpos_zext b (size a - size b)).
    have Hsz: size (zext (size b - size a) a) = maxn (size a) (size b) by rewrite size_zext maxnE. rewrite -Hsz. apply to_Zpos_add_addB_bounded.
    by rewrite Hsz size_zext -maxnE maxn_sym.
  Qed.

  Lemma to_Zpos_zext_addB bs1 bs2: size bs1 == size bs2 -> to_Zpos (bs1 0+# bs2) = (to_Zpos bs1 + to_Zpos bs2)%Z.
  Proof. move => Hsz. rewrite (eqP (zext_addB_addB bs1 bs2)). pose proof (eqP (to_nat_addB_zext1 Hsz)). by rewrite !to_Zpos_nat H Nat2Z.inj_add. Qed.

  Lemma to_Zpos_sub_long_subB bs1 bs2: (to_Zpos bs2 <= to_Zpos bs1)%Z -> to_Zpos (bs1 --# bs2) = (to_Zpos bs1 - to_Zpos bs2)%Z.
  Proof.
    rewrite (eqP (long_subB_subB bs1 bs2)). set a := zext (size bs2 - size bs1) bs1. set b := zext (size bs1 - size bs2) bs2. move => HleB.
    have Hsz: size a == size b.
    - by rewrite /a /b !size_zext -!maxnE maxn_sym.
    - rewrite leB_to_Zpos_subB; [by rewrite /a /b !to_Zpos_zext | by done |]. rewrite eq_sym in Hsz. by rewrite (to_Zpos_leB (eqP Hsz)) /a /b !to_Zpos_zext.
  Qed.

  Lemma to_Zpos_zend bs n: to_Zpos (bs <<<# n) = (to_Zpos bs * 2 ^ Z.of_nat n)%Z.
  Proof.
    rewrite (eqP (zend_shlB_zextB bs n)) to_Zpos_shlB to_Zpos_zext size_zext Zmod_small; first by done.
    split. apply Z.mul_nonneg_nonneg. apply to_Zpos_ge0. apply (Z.pow_nonneg 2 (Z.of_nat n)); done.
    rewrite -(Zpower_nat_Z 2 (size bs + n)) Zpower_nat_is_exp !Zpower_nat_Z. apply Zmult_lt_compat_r; [apply pow2_nat2z_gt0 | apply to_Zpos_bounded].
  Qed.

  Lemma to_Zpos_high_low_half bs:
    ~~ odd (size bs) -> (to_Zpos (low_half bs) + to_Zpos ((high_half bs) <<<# (size bs)./2))%Z = to_Zpos bs.
  Proof.
    move => Hodd. rewrite -{4}(eqP (high_low_half Hodd)) (to_Zpos_cat (low_half bs) (high_half bs)) (to_Zpos_zend (high_half bs) (size bs)./2).
    by rewrite {3}/low_half size_low.
  Qed.

  Lemma Zexp_distr a b m n p: (0 <= m)%Z -> (0 <= n)%Z -> (a * p ^ m * (b * p ^ n))%Z = (a * b * p ^ (m + n))%Z.
  Proof. move => Hm Hn; rewrite Z.pow_add_r; [apply Z.mul_shuffle1 | exact: Hm | exact: Hn]. Qed.

  Lemma Zmul_cross a b c d: ((a+b)*(c+d) - a * c - b * d)%Z = (a*d+b*c)%Z.
  Proof. by rewrite Z.mul_add_distr_r !Z.mul_add_distr_l Zplus_assoc_reverse Z.add_simpl_l Zplus_assoc Z.add_simpl_r. Qed.

(* 關鍵是這個Lemma，只要證出來，Karatsuba_fullmul就可以等價於full_mul *)
  Lemma Karatsuba_eq a b:
    size a == size b -> 64 < (size a) -> ~~ odd (size a) ->
      (full_mul (low_half a) (low_half b) ++#
      (full_mul (high_half a 0+# low_half a) (high_half b 0+# low_half b) --# (full_mul (high_half a) (high_half b) 0+# full_mul (low_half a) (low_half b)) <<<# (size a)./2) ++#
      (full_mul (high_half a) (high_half b) <<<# size a))
    = full_mul a b.
  Proof.
    move => Hsz Hsz64 Ha_odd. have Hb_odd: ~~ odd (size b) by rewrite -(eqP Hsz) Ha_odd. rewrite -{9}(eqP (high_low_half Ha_odd)) -{7}(eqP (high_low_half Hb_odd)).
    set hia := high_half a; set hib := high_half b; set loa := low_half a; set lob := low_half b.
    assert (Hsz_all: maxn (maxn (size loa + size lob) (maxn (minn (size hia).+1 (size loa).+1 + minn (size hib).+1 (size lob).+1) (minn (size hia + size hib).+1 (size loa + size lob).+1) + (size a)./2)) (size hia + size hib + size a) = size loa + size hia + (size lob + size hib)).
    {
      rewrite !(size_high_half a) !(size_high_half b) !(size_low_half a) !(size_low_half b) -!(eqP Hsz) !addnn.
      have Hsza: ((size a)./2).*2 = size a by rewrite -{2}(odd_double_half (size a)) (negbTE Ha_odd). rewrite Hsza !minnE !subnn !subn0 doubleS Hsza.
      have H: (size a).+1 <= (size a).+2 by done. rewrite (maxn_idPl H). rewrite -add2n addnCAC addnACl add2n.
      have H0: (size a)./2.+2 <= size a. rewrite -{2}Hsza -addnn -addn2 (leq_add2l (size a)./2 2 (size a)./2) -ltn_double Hsza -muln2. have H1: 1 * 2 < 64 by done. by rewrite (ltn_trans H1 Hsz64).
      rewrite -(leq_add2l (size a) (size a)./2.+2 (size a)) in H0. by rewrite (maxn_idPr (leq_addr (size a)./2.+2 (size a))) (maxn_idPr H0) addnn.
    }
    apply to_Zpos_inj_ss; first by rewrite !size_long_addB !size_zend (size_long_subB (full_mul (hia 0+# loa) (hib 0+# lob)) (full_mul hia hib 0+# full_mul loa lob)) !size_full_mul !size_zext_addB !size_full_mul (size_cat loa hia) (size_cat lob hib); apply Hsz_all. rewrite to_Zpos_full_mul 2!to_Zpos_cat Z.mul_add_distr_r !Z.mul_add_distr_l !size_low_half -!(eqP Hsz).
    set Zpos_hia := (to_Zpos hia * 2 ^ Z.of_nat (size a)./2)%Z; set Zpos_hib := (to_Zpos hib * 2 ^ Z.of_nat (size a)./2)%Z; set Zpos_loa := to_Zpos loa; set Zpos_lob := to_Zpos lob.
    have Hsza_half: Z.of_nat (size a) = (Z.of_nat (size a)./2 + Z.of_nat (size a)./2)%Z by rewrite -Nat2Z.inj_add -{1}(odd_double_half (size a)) (negbTE Ha_odd) /= add0n -addnn.
    have loa_bounded: (Zpos_loa < 2 ^ Z.of_nat (size a)./2)%Z by rewrite -size_low_half; apply to_Zpos_bounded.
    have lob_bounded: (Zpos_lob < 2 ^ Z.of_nat (size a)./2)%Z by rewrite (eqP Hsz) -size_low_half; apply to_Zpos_bounded.
    have hia_bounded: (Zpos_hia < 2 ^ Z.of_nat (size a))%Z. rewrite Hsza_half /Zpos_hia Z.pow_add_r; [| apply Zle_0_nat | apply Zle_0_nat]. apply Zmult_gt_0_lt_compat_r; [|rewrite -size_high_half /hia; apply to_Zpos_bounded]. apply Z.lt_gt. apply pow2_nat2z_gt0.
    have hib_bounded: (Zpos_hib < 2 ^ Z.of_nat (size a))%Z. rewrite Hsza_half {1}(eqP Hsz) /Zpos_hia Z.pow_add_r; [| apply Zle_0_nat | apply Zle_0_nat]. apply Zmult_gt_0_lt_compat_r; [|rewrite -size_high_half /hia; apply to_Zpos_bounded]. apply Z.lt_gt. apply pow2_nat2z_gt0.
    have loalob_bounded: (Zpos_loa * Zpos_lob < 2 ^ Z.of_nat (size a))%Z. rewrite Hsza_half Z.pow_add_r; [| apply Zle_0_nat | apply Zle_0_nat]. apply Z.mul_lt_mono_nonneg; [apply to_Zpos_ge0 | apply loa_bounded| apply to_Zpos_ge0 | apply lob_bounded].
    have hialob_bounded: (Zpos_hia * Zpos_lob < 2 ^ (Z.of_nat (size a) + Z.of_nat (size a)./2))%Z. rewrite Z.pow_add_r; [| apply Zle_0_nat | apply Zle_0_nat]. apply Z.mul_lt_mono_nonneg; [ apply Z.mul_nonneg_nonneg; [apply to_Zpos_ge0 |apply Z.lt_le_incl; apply pow2_nat2z_gt0]| apply hia_bounded| apply to_Zpos_ge0 | apply lob_bounded].
    have hibloa_bounded: (Zpos_hib * Zpos_loa < 2 ^ (Z.of_nat (size a) + Z.of_nat (size a)./2))%Z. rewrite Z.pow_add_r; [| apply Zle_0_nat | apply Zle_0_nat]. apply Z.mul_lt_mono_nonneg; [ apply Z.mul_nonneg_nonneg; [apply to_Zpos_ge0 |apply Z.lt_le_incl; apply pow2_nat2z_gt0]| apply hib_bounded| apply to_Zpos_ge0 | apply loa_bounded].
    have hiahib_bounded: (Zpos_hia * Zpos_hib < 2 ^ (Z.of_nat (size a) + Z.of_nat (size a)))%Z. rewrite Z.pow_add_r; [| apply Zle_0_nat | apply Zle_0_nat]. apply Z.mul_lt_mono_nonneg; [apply Z.mul_nonneg_nonneg; [apply to_Zpos_ge0 |apply Z.lt_le_incl; apply pow2_nat2z_gt0]| apply hia_bounded| apply Z.mul_nonneg_nonneg; [apply to_Zpos_ge0 |apply Z.lt_le_incl; apply pow2_nat2z_gt0] | apply hib_bounded].
    pose proof (to_Zpos_full_mul loa lob) as Zpos_lolo.
    have Zpos_hihi: to_Zpos (full_mul hia hib <<<# size a) = (Zpos_hia * Zpos_hib)%Z. rewrite to_Zpos_zend to_Zpos_full_mul /Zpos_hia /Zpos_hib Zexp_distr. rewrite -Nat2Z.inj_add -{1}(odd_double_half (size a)) -addnn (negbTE Ha_odd) //=. apply Zle_0_nat. apply Zle_0_nat.
    have Zpos_cross: to_Zpos (full_mul (hia 0+# loa) (hib 0+# lob) --# (full_mul hia hib 0+# full_mul loa lob) <<<# (size a)./2) = (Zpos_hia * Zpos_lob + Zpos_hib * Zpos_loa)%Z.
    {
      rewrite to_Zpos_zend to_Zpos_sub_long_subB !to_Zpos_full_mul !to_Zpos_zext_addB. rewrite 2!to_Zpos_full_mul Z.sub_add_distr Zmul_cross Z.mul_add_distr_r {1}Z.mul_shuffle0; apply Z.add_cancel_l; by rewrite Zmult_assoc_reverse Z.mul_comm /Zpos_hib.
      by rewrite !size_full_mul !size_low_half !size_high_half. by rewrite size_low_half size_high_half. by rewrite size_low_half size_high_half.
      rewrite !to_Zpos_full_mul Z.mul_add_distr_r !Z.mul_add_distr_l Zplus_assoc_reverse. apply (Zplus_le_compat_l _ _ (to_Zpos hia * to_Zpos hib)). rewrite Z.add_assoc -{1}(Z.add_0_l (to_Zpos loa * to_Zpos lob)). apply Z.add_le_mono.
      apply Z.add_nonneg_nonneg; apply Z.mul_nonneg_nonneg; apply to_Zpos_ge0. by apply Z.eq_le_incl. by rewrite size_low_half size_high_half. by rewrite size_low_half size_high_half. by rewrite !size_full_mul !size_low_half !size_high_half.
    }
    have Hgoal: (to_Zpos loa * to_Zpos lob + to_Zpos (full_mul (hia 0+# loa) (hib 0+# lob) --# (full_mul hia hib 0+# full_mul loa lob) <<<# (size a)./2) < 2 ^ Z.of_nat (maxn (size (full_mul loa lob)) (size (full_mul (hia 0+# loa) (hib 0+# lob) --# (full_mul hia hib 0+# full_mul loa lob) <<<# (size a)./2))))%Z.
    {
      rewrite Zpos_cross size_zend size_long_subB !size_full_mul !size_zext_addB !size_full_mul !size_low_half !size_high_half -!(eqP Hsz) !minnE !subnn !subn0 !addnn.
      have Hsza: ((size a)./2).*2 = size a by rewrite -{2}(odd_double_half (size a)) (negbTE Ha_odd). rewrite doubleS !Hsza. have Hadd2: (size a).+1 <= (size a).+2 by done. rewrite (maxn_idPl Hadd2).
      have H0: size a <= (size a).+2 + (size a)./2 by rewrite -add2n addnACl leq_addr. rewrite (maxn_idPr H0) -addn2 addnACl addC {1}Nat2Z.inj_add //= addC Zpower_exp; last by done.
      pose proof (Z.add_lt_mono _ _ _ _ hialob_bounded hibloa_bounded) as H1. pose proof (Z.add_lt_mono _ _ _ _ loalob_bounded H1) as H2.
      have H3: (2 ^ Z.of_nat (size a) + (2 ^ (Z.of_nat (size a) + Z.of_nat (size a)./2) + 2 ^ (Z.of_nat (size a) + Z.of_nat (size a)./2)) < 2 ^ Z.of_nat (size a + (size a)./2) * 2 ^ 2)%Z.
      {
        rewrite Zred_factor1 Z.pow_2_r Zmult_assoc -(Zred_factor1 (2 ^ Z.of_nat (size a + (size a)./2) * 2)) Nat2Z.inj_add; apply Z.add_lt_mono_r.
        rewrite Zpower_exp; [| apply Z.le_ge; apply Zle_0_nat | apply Z.le_ge; apply Zle_0_nat]. rewrite {1}(Zred_factor0 (2 ^ Z.of_nat (size a))) Zmult_assoc_reverse.
        apply Zmult_lt_compat_l; [ apply pow2_nat2z_gt0 |]. rewrite Z.mul_comm; apply Z.lt_1_mul_pos; [done | apply pow2_nat2z_gt0].
      }
      apply (Z.lt_trans _ _ _ H2 H3). apply Z.le_ge; apply Zle_0_nat.
    }
    rewrite !to_Zpos_add_long_addB_bounded Zpos_lolo. rewrite 2!Zplus_assoc_reverse; apply Z.add_cancel_l. rewrite Zplus_assoc Zpos_hihi; apply Z.add_cancel_r. rewrite Zpos_cross Z.add_comm; apply Z.add_cancel_r. apply Z.mul_comm.
    apply Hgoal. 2 :{ apply Hgoal. }

    rewrite Zpos_cross Z.add_assoc Zpos_hihi (Z.mul_comm Zpos_hib Zpos_loa) -Z.mul_add_distr_r Zplus_assoc_reverse -Z.mul_add_distr_r -Z.mul_add_distr_l.
    rewrite /Zpos_hia -(to_Zpos_zend hia (size a)./2) (to_Zpos_high_low_half Ha_odd) /Zpos_hib -(to_Zpos_zend hib (size a)./2) {1}(eqP Hsz) (to_Zpos_high_low_half Hb_odd) -(to_Zpos_full_mul a b).
    rewrite !size_long_addB !size_zend (size_long_subB (full_mul (hia 0+# loa) (hib 0+# lob)) (full_mul hia hib 0+# full_mul loa lob)) !size_full_mul !size_zext_addB !size_full_mul Hsz_all.
    rewrite -(size_cat loa hia) -(size_cat lob hib) (eqP (high_low_half Ha_odd)) (eqP (high_low_half Hb_odd)) -(size_full_mul a b); apply to_Zpos_bounded.
  Qed.

  Lemma General_Karatsuba_eq n a b:
    size a == size b -> n > 2 -> n < (size a) -> ~~ odd (size a) ->
      (full_mul (low_half a) (low_half b) ++#
      (full_mul (high_half a 0+# low_half a) (high_half b 0+# low_half b) --# (full_mul (high_half a) (high_half b) 0+# full_mul (low_half a) (low_half b)) <<<# (size a)./2) ++#
      (full_mul (high_half a) (high_half b) <<<# size a))
    = full_mul a b.
  Proof.
    move => Hsz Hnge2 Hszn Ha_odd. have Hb_odd: ~~ odd (size b) by rewrite -(eqP Hsz) Ha_odd. rewrite -{9}(eqP (high_low_half Ha_odd)) -{7}(eqP (high_low_half Hb_odd)).
    set hia := high_half a; set hib := high_half b; set loa := low_half a; set lob := low_half b.
    assert (Hsz_all: maxn (maxn (size loa + size lob) (maxn (minn (size hia).+1 (size loa).+1 + minn (size hib).+1 (size lob).+1) (minn (size hia + size hib).+1 (size loa + size lob).+1) + (size a)./2)) (size hia + size hib + size a) = size loa + size hia + (size lob + size hib)).
    {
      rewrite !(size_high_half a) !(size_high_half b) !(size_low_half a) !(size_low_half b) -!(eqP Hsz) !addnn.
      have Hsza: ((size a)./2).*2 = size a by rewrite -{2}(odd_double_half (size a)) (negbTE Ha_odd). rewrite Hsza !minnE !subnn !subn0 doubleS Hsza.
      have H: (size a).+1 <= (size a).+2 by done. rewrite (maxn_idPl H). rewrite -add2n addnCAC addnACl add2n.
      have H0: (size a)./2.+2 <= size a. rewrite -{2}Hsza -addnn -addn2 (leq_add2l (size a)./2 2 (size a)./2) -ltn_double Hsza -muln2. have H1: 1 * 2 < n by done. by rewrite (ltn_trans H1 Hszn).
      rewrite -(leq_add2l (size a) (size a)./2.+2 (size a)) in H0. by rewrite (maxn_idPr (leq_addr (size a)./2.+2 (size a))) (maxn_idPr H0) addnn.
    }
    apply to_Zpos_inj_ss; first by rewrite !size_long_addB !size_zend (size_long_subB (full_mul (hia 0+# loa) (hib 0+# lob)) (full_mul hia hib 0+# full_mul loa lob)) !size_full_mul !size_zext_addB !size_full_mul (size_cat loa hia) (size_cat lob hib); apply Hsz_all. rewrite to_Zpos_full_mul 2!to_Zpos_cat Z.mul_add_distr_r !Z.mul_add_distr_l !size_low_half -!(eqP Hsz).
    set Zpos_hia := (to_Zpos hia * 2 ^ Z.of_nat (size a)./2)%Z; set Zpos_hib := (to_Zpos hib * 2 ^ Z.of_nat (size a)./2)%Z; set Zpos_loa := to_Zpos loa; set Zpos_lob := to_Zpos lob.
    have Hsza_half: Z.of_nat (size a) = (Z.of_nat (size a)./2 + Z.of_nat (size a)./2)%Z by rewrite -Nat2Z.inj_add -{1}(odd_double_half (size a)) (negbTE Ha_odd) /= add0n -addnn.
    have loa_bounded: (Zpos_loa < 2 ^ Z.of_nat (size a)./2)%Z by rewrite -size_low_half; apply to_Zpos_bounded.
    have lob_bounded: (Zpos_lob < 2 ^ Z.of_nat (size a)./2)%Z by rewrite (eqP Hsz) -size_low_half; apply to_Zpos_bounded.
    have hia_bounded: (Zpos_hia < 2 ^ Z.of_nat (size a))%Z. rewrite Hsza_half /Zpos_hia Z.pow_add_r; [| apply Zle_0_nat | apply Zle_0_nat]. apply Zmult_gt_0_lt_compat_r; [|rewrite -size_high_half /hia; apply to_Zpos_bounded]. apply Z.lt_gt. apply pow2_nat2z_gt0.
    have hib_bounded: (Zpos_hib < 2 ^ Z.of_nat (size a))%Z. rewrite Hsza_half {1}(eqP Hsz) /Zpos_hia Z.pow_add_r; [| apply Zle_0_nat | apply Zle_0_nat]. apply Zmult_gt_0_lt_compat_r; [|rewrite -size_high_half /hia; apply to_Zpos_bounded]. apply Z.lt_gt. apply pow2_nat2z_gt0.
    have loalob_bounded: (Zpos_loa * Zpos_lob < 2 ^ Z.of_nat (size a))%Z. rewrite Hsza_half Z.pow_add_r; [| apply Zle_0_nat | apply Zle_0_nat]. apply Z.mul_lt_mono_nonneg; [apply to_Zpos_ge0 | apply loa_bounded| apply to_Zpos_ge0 | apply lob_bounded].
    have hialob_bounded: (Zpos_hia * Zpos_lob < 2 ^ (Z.of_nat (size a) + Z.of_nat (size a)./2))%Z. rewrite Z.pow_add_r; [| apply Zle_0_nat | apply Zle_0_nat]. apply Z.mul_lt_mono_nonneg; [ apply Z.mul_nonneg_nonneg; [apply to_Zpos_ge0 |apply Z.lt_le_incl; apply pow2_nat2z_gt0]| apply hia_bounded| apply to_Zpos_ge0 | apply lob_bounded].
    have hibloa_bounded: (Zpos_hib * Zpos_loa < 2 ^ (Z.of_nat (size a) + Z.of_nat (size a)./2))%Z. rewrite Z.pow_add_r; [| apply Zle_0_nat | apply Zle_0_nat]. apply Z.mul_lt_mono_nonneg; [ apply Z.mul_nonneg_nonneg; [apply to_Zpos_ge0 |apply Z.lt_le_incl; apply pow2_nat2z_gt0]| apply hib_bounded| apply to_Zpos_ge0 | apply loa_bounded].
    have hiahib_bounded: (Zpos_hia * Zpos_hib < 2 ^ (Z.of_nat (size a) + Z.of_nat (size a)))%Z. rewrite Z.pow_add_r; [| apply Zle_0_nat | apply Zle_0_nat]. apply Z.mul_lt_mono_nonneg; [apply Z.mul_nonneg_nonneg; [apply to_Zpos_ge0 |apply Z.lt_le_incl; apply pow2_nat2z_gt0]| apply hia_bounded| apply Z.mul_nonneg_nonneg; [apply to_Zpos_ge0 |apply Z.lt_le_incl; apply pow2_nat2z_gt0] | apply hib_bounded].
    pose proof (to_Zpos_full_mul loa lob) as Zpos_lolo.
    have Zpos_hihi: to_Zpos (full_mul hia hib <<<# size a) = (Zpos_hia * Zpos_hib)%Z. rewrite to_Zpos_zend to_Zpos_full_mul /Zpos_hia /Zpos_hib Zexp_distr. rewrite -Nat2Z.inj_add -{1}(odd_double_half (size a)) -addnn (negbTE Ha_odd) //=. apply Zle_0_nat. apply Zle_0_nat.
    have Zpos_cross: to_Zpos (full_mul (hia 0+# loa) (hib 0+# lob) --# (full_mul hia hib 0+# full_mul loa lob) <<<# (size a)./2) = (Zpos_hia * Zpos_lob + Zpos_hib * Zpos_loa)%Z.
    {
      rewrite to_Zpos_zend to_Zpos_sub_long_subB !to_Zpos_full_mul !to_Zpos_zext_addB. rewrite 2!to_Zpos_full_mul Z.sub_add_distr Zmul_cross Z.mul_add_distr_r {1}Z.mul_shuffle0; apply Z.add_cancel_l; by rewrite Zmult_assoc_reverse Z.mul_comm /Zpos_hib.
      by rewrite !size_full_mul !size_low_half !size_high_half. by rewrite size_low_half size_high_half. by rewrite size_low_half size_high_half.
      rewrite !to_Zpos_full_mul Z.mul_add_distr_r !Z.mul_add_distr_l Zplus_assoc_reverse. apply (Zplus_le_compat_l _ _ (to_Zpos hia * to_Zpos hib)). rewrite Z.add_assoc -{1}(Z.add_0_l (to_Zpos loa * to_Zpos lob)). apply Z.add_le_mono.
      apply Z.add_nonneg_nonneg; apply Z.mul_nonneg_nonneg; apply to_Zpos_ge0. by apply Z.eq_le_incl. by rewrite size_low_half size_high_half. by rewrite size_low_half size_high_half. by rewrite !size_full_mul !size_low_half !size_high_half.
    }
    have Hgoal: (to_Zpos loa * to_Zpos lob + to_Zpos (full_mul (hia 0+# loa) (hib 0+# lob) --# (full_mul hia hib 0+# full_mul loa lob) <<<# (size a)./2) < 2 ^ Z.of_nat (maxn (size (full_mul loa lob)) (size (full_mul (hia 0+# loa) (hib 0+# lob) --# (full_mul hia hib 0+# full_mul loa lob) <<<# (size a)./2))))%Z.
    {
      rewrite Zpos_cross size_zend size_long_subB !size_full_mul !size_zext_addB !size_full_mul !size_low_half !size_high_half -!(eqP Hsz) !minnE !subnn !subn0 !addnn.
      have Hsza: ((size a)./2).*2 = size a by rewrite -{2}(odd_double_half (size a)) (negbTE Ha_odd). rewrite doubleS !Hsza. have Hadd2: (size a).+1 <= (size a).+2 by done. rewrite (maxn_idPl Hadd2).
      have H0: size a <= (size a).+2 + (size a)./2 by rewrite -add2n addnACl leq_addr. rewrite (maxn_idPr H0) -addn2 addnACl addC {1}Nat2Z.inj_add //= addC Zpower_exp; last by done.
      pose proof (Z.add_lt_mono _ _ _ _ hialob_bounded hibloa_bounded) as H1. pose proof (Z.add_lt_mono _ _ _ _ loalob_bounded H1) as H2.
      have H3: (2 ^ Z.of_nat (size a) + (2 ^ (Z.of_nat (size a) + Z.of_nat (size a)./2) + 2 ^ (Z.of_nat (size a) + Z.of_nat (size a)./2)) < 2 ^ Z.of_nat (size a + (size a)./2) * 2 ^ 2)%Z.
      {
        rewrite Zred_factor1 Z.pow_2_r Zmult_assoc -(Zred_factor1 (2 ^ Z.of_nat (size a + (size a)./2) * 2)) Nat2Z.inj_add; apply Z.add_lt_mono_r.
        rewrite Zpower_exp; [| apply Z.le_ge; apply Zle_0_nat | apply Z.le_ge; apply Zle_0_nat]. rewrite {1}(Zred_factor0 (2 ^ Z.of_nat (size a))) Zmult_assoc_reverse.
        apply Zmult_lt_compat_l; [ apply pow2_nat2z_gt0 |]. rewrite Z.mul_comm; apply Z.lt_1_mul_pos; [done | apply pow2_nat2z_gt0].
      }
      apply (Z.lt_trans _ _ _ H2 H3). apply Z.le_ge; apply Zle_0_nat.
    }
    rewrite !to_Zpos_add_long_addB_bounded Zpos_lolo. rewrite 2!Zplus_assoc_reverse; apply Z.add_cancel_l. rewrite Zplus_assoc Zpos_hihi; apply Z.add_cancel_r. rewrite Zpos_cross Z.add_comm; apply Z.add_cancel_r. apply Z.mul_comm.
    apply Hgoal. 2 :{ apply Hgoal. }

    rewrite Zpos_cross Z.add_assoc Zpos_hihi (Z.mul_comm Zpos_hib Zpos_loa) -Z.mul_add_distr_r Zplus_assoc_reverse -Z.mul_add_distr_r -Z.mul_add_distr_l.
    rewrite /Zpos_hia -(to_Zpos_zend hia (size a)./2) (to_Zpos_high_low_half Ha_odd) /Zpos_hib -(to_Zpos_zend hib (size a)./2) {1}(eqP Hsz) (to_Zpos_high_low_half Hb_odd) -(to_Zpos_full_mul a b).
    rewrite !size_long_addB !size_zend (size_long_subB (full_mul (hia 0+# loa) (hib 0+# lob)) (full_mul hia hib 0+# full_mul loa lob)) !size_full_mul !size_zext_addB !size_full_mul Hsz_all.
    rewrite -(size_cat loa hia) -(size_cat lob hib) (eqP (high_low_half Ha_odd)) (eqP (high_low_half Hb_odd)) -(size_full_mul a b); apply to_Zpos_bounded.
  Qed.

  (*---------------------------------------------------------------------------
    Properties of multiplication based on Karatsuba algorithm
    ---------------------------------------------------------------------------*)

  Lemma General_Karatsuba'_full_mul n n' a b: n' > 2 -> size a == size b -> low (size a).*2 (General_Karatsuba_fullmul' n n' a b) == full_mul a b.
  Proof.
    move: a b. induction n.
    - move => a b Hn' Hsz. exact: low_fullmul Hsz.
    - move => a b Hn' Hsz.
      pose proof (orP (leq_gtn_total (size a) n')) as Hszn'. elim: Hszn' => Hszn'.
      + rewrite /General_Karatsuba_fullmul' Hszn'. exact: low_fullmul Hsz.
      + rewrite ltnNge in Hszn'. rewrite /General_Karatsuba_fullmul' (negbTE Hszn'). rewrite -ltnNge in Hszn'.
        pose proof (orP (orbN (odd (size a)))) as Ha_odd. elim: Ha_odd => Ha_odd.
        2 :{
          have Hb_odd: ~~ odd (size b) by rewrite -(eqP Hsz) Ha_odd. rewrite (negbTE Ha_odd) (negbTE Hb_odd).
          have Hlo_lo: size (low_half a) == size (low_half b) by rewrite (size_low_half a) (size_low_half b) (eqP Hsz).
          have Hhi_hi: size (high_half a) == size (high_half b) by rewrite (size_high_half a) (size_high_half b) (eqP Hsz).
          have Hcross: size (high_half a 0+# low_half a) == size (high_half b 0+# low_half b) by rewrite !size_zext_addB (eqP Hlo_lo) (eqP Hhi_hi).
          rewrite (eqP (IHn (low_half a) (low_half b) Hn' Hlo_lo)) (eqP (IHn (high_half a) (high_half b) Hn' Hhi_hi)) (eqP (IHn (high_half a 0+# low_half a) (high_half b 0+# low_half b) Hn' Hcross)).
          rewrite (General_Karatsuba_eq Hsz Hn' Hszn' Ha_odd). exact: (low_fullmul Hsz).
        }
        have Hb_odd: odd (size b) by rewrite -(eqP Hsz) Ha_odd. rewrite Ha_odd Hb_odd.
        set a' := zext 1 a. set b' := zext 1 b.
        have Hsz': size a' == size b' by rewrite /a' /b' !size_zext !addn1.
        have Hszn'': n' < size a' by rewrite /a' size_zext addn1 ltnS (ltnW Hszn').
        have Ha_odd': ~~ odd(size a') by rewrite /a' size_zext addn1 oddS Bool.negb_involutive.
        have Hlo_lo: size (low_half a') == size (low_half b') by rewrite (size_low_half a') (size_low_half b') (eqP Hsz').
        have Hhi_hi: size (high_half a') == size (high_half b') by rewrite (size_high_half a') (size_high_half b') (eqP Hsz').
        have Hcross: size (high_half a' 0+# low_half a') == size (high_half b' 0+# low_half b') by rewrite !size_zext_addB (eqP Hlo_lo) (eqP Hhi_hi).
        rewrite (eqP (IHn (low_half a') (low_half b') Hn' Hlo_lo)) (eqP (IHn (high_half a') (high_half b') Hn' Hhi_hi)) (eqP (IHn (high_half a' 0+# low_half a') (high_half b' 0+# low_half b') Hn' Hcross)).
        rewrite (General_Karatsuba_eq Hsz' Hn' Hszn'' Ha_odd').
        have Hfull_mul: full_mul a' b' == (zext 2 (full_mul a b)). rewrite -to_nat_inj_ss; [by rewrite to_nat_zext !to_nat_full_mul' /a' /b' !to_nat_zext | by rewrite /a' /b' size_zext !size_full_mul !size_zext !addn1 addSnnS -addn2 (addC (size a) (size b)) addnCAC -addnACl].
        by rewrite (eqP Hfull_mul) -addnn {2}(eqP Hsz) -size_full_mul low_zext.
  Qed.

  Lemma General_Karatsuba_full_mul n' a b: n' > 2 -> size a == size b -> General_Karatsuba_fullmul n' a b == full_mul a b.
  Proof. rewrite /General_Karatsuba_fullmul; apply General_Karatsuba'_full_mul. Qed.

  Lemma test n a b: size a == size b -> (Karatsuba_fullmul' n a b) == (General_Karatsuba_fullmul' n 64 a b).
  Proof.
    move: a b; induction n; first by done. move => a b Hsz; rewrite /General_Karatsuba_fullmul' /Karatsuba_fullmul'.
    pose proof (orP (leq_gtn_total (size a) 64)) as Hsz64. elim: Hsz64 => Hsz64; first by rewrite Hsz64.
    rewrite ltnNge in Hsz64. rewrite (negbTE Hsz64). fold Karatsuba_fullmul' General_Karatsuba_fullmul'.
    rewrite -!(eqP Hsz). pose proof (orP (orbN (odd (size a)))) as Ha_odd. elim: Ha_odd => Ha_odd.
    2:{
      rewrite (negbTE Ha_odd).
      have Hlo_lo: size (low_half a) == size (low_half b) by rewrite (size_low_half a) (size_low_half b) (eqP Hsz).
      have Hhi_hi: size (high_half a) == size (high_half b) by rewrite (size_high_half a) (size_high_half b) (eqP Hsz).
      have Hcross: size (high_half a 0+# low_half a) == size (high_half b 0+# low_half b) by rewrite !size_zext_addB (eqP Hlo_lo) (eqP Hhi_hi).
      by rewrite (eqP (IHn (low_half a) (low_half b) Hlo_lo)) (eqP (IHn (high_half a) (high_half b) Hhi_hi)) (eqP (IHn (high_half a 0+# low_half a) (high_half b 0+# low_half b) Hcross)).
    }
    rewrite Ha_odd.
    set a' := zext 1 a. set b' := zext 1 b.
    have Hsz': size a' == size b' by rewrite /a' /b' !size_zext !addn1.
    have Ha_odd': ~~ odd(size a') by rewrite /a' size_zext addn1 oddS Bool.negb_involutive.
    have Hlo_lo: size (low_half a') == size (low_half b') by rewrite (size_low_half a') (size_low_half b') (eqP Hsz').
    have Hhi_hi: size (high_half a') == size (high_half b') by rewrite (size_high_half a') (size_high_half b') (eqP Hsz').
    have Hcross: size (high_half a' 0+# low_half a') == size (high_half b' 0+# low_half b') by rewrite !size_zext_addB (eqP Hlo_lo) (eqP Hhi_hi).
    by rewrite (eqP (IHn (low_half a') (low_half b') Hlo_lo)) (eqP (IHn (high_half a') (high_half b') Hhi_hi)) (eqP (IHn (high_half a' 0+# low_half a') (high_half b' 0+# low_half b') Hcross)).
  Qed.

  Lemma test2 a b: size a == size b -> Karatsuba_fullmul a b == General_Karatsuba_fullmul 64 a b.
  Proof.
    move => Hsz; rewrite /General_Karatsuba_fullmul /Karatsuba_fullmul.
    pose proof (eqP (test (Nat.log2_up (size a)) Hsz)); by rewrite H.
  Qed.

  Lemma Karatsuba'_full_mul n a b: size a == size b -> low (size a).*2 (Karatsuba_fullmul' n a b) == full_mul a b.
  Proof.
    move: a b. induction n.
    - move => a b Hsz. exact: low_fullmul Hsz.
    - move => a b Hsz. pose proof (orP (leq_gtn_total (size a) 64)) as Hsz64. elim: Hsz64 => Hsz64.
      + rewrite /Karatsuba_fullmul' Hsz64. exact: low_fullmul Hsz.
      + rewrite ltnNge in Hsz64. rewrite /Karatsuba_fullmul' (negbTE Hsz64). rewrite -ltnNge in Hsz64.
        pose proof (orP (orbN (odd (size a)))) as Ha_odd. elim: Ha_odd => Ha_odd.
        2 :{
          have Hb_odd: ~~ odd (size b) by rewrite -(eqP Hsz) Ha_odd. rewrite (negbTE Ha_odd) (negbTE Hb_odd).
          have Hlo_lo: size (low_half a) == size (low_half b) by rewrite (size_low_half a) (size_low_half b) (eqP Hsz).
          have Hhi_hi: size (high_half a) == size (high_half b) by rewrite (size_high_half a) (size_high_half b) (eqP Hsz).
          have Hcross: size (high_half a 0+# low_half a) == size (high_half b 0+# low_half b) by rewrite !size_zext_addB (eqP Hlo_lo) (eqP Hhi_hi).
          rewrite (eqP (IHn (low_half a) (low_half b) Hlo_lo)) (eqP (IHn (high_half a) (high_half b) Hhi_hi)) (eqP (IHn (high_half a 0+# low_half a) (high_half b 0+# low_half b) Hcross)).
          rewrite (Karatsuba_eq Hsz Hsz64 Ha_odd). exact: (low_fullmul Hsz).
        }
        have Hb_odd: odd (size b) by rewrite -(eqP Hsz) Ha_odd. rewrite Ha_odd Hb_odd.
        set a' := zext 1 a. set b' := zext 1 b.
        have Hsz': size a' == size b' by rewrite /a' /b' !size_zext !addn1.
        have Hsz64': 64 < size a' by rewrite /a' size_zext addn1 ltnS (ltnW Hsz64).
        have Ha_odd': ~~ odd(size a') by rewrite /a' size_zext addn1 oddS Bool.negb_involutive.
        have Hlo_lo: size (low_half a') == size (low_half b') by rewrite (size_low_half a') (size_low_half b') (eqP Hsz').
        have Hhi_hi: size (high_half a') == size (high_half b') by rewrite (size_high_half a') (size_high_half b') (eqP Hsz').
        have Hcross: size (high_half a' 0+# low_half a') == size (high_half b' 0+# low_half b') by rewrite !size_zext_addB (eqP Hlo_lo) (eqP Hhi_hi).
        rewrite (eqP (IHn (low_half a') (low_half b') Hlo_lo)) (eqP (IHn (high_half a') (high_half b') Hhi_hi)) (eqP (IHn (high_half a' 0+# low_half a') (high_half b' 0+# low_half b') Hcross)).
        rewrite (Karatsuba_eq Hsz' Hsz64' Ha_odd').
        have Hfull_mul: full_mul a' b' == (zext 2 (full_mul a b)). rewrite -to_nat_inj_ss; [by rewrite to_nat_zext !to_nat_full_mul' /a' /b' !to_nat_zext | by rewrite /a' /b' size_zext !size_full_mul !size_zext !addn1 addSnnS -addn2 (addC (size a) (size b)) addnCAC -addnACl].
        by rewrite (eqP Hfull_mul) -addnn {2}(eqP Hsz) -size_full_mul low_zext.
  Qed.

  Lemma Karatsuba_full_mul a b: size a == size b -> Karatsuba_fullmul a b == full_mul a b.
  Proof. rewrite /Karatsuba_fullmul; apply Karatsuba'_full_mul. Qed.

  Compute to_Zpos (Karatsuba_fullmul (from_Zpos 8192 546464946494564165146496446494654616649466446546541646495464649464945641651464964464946546166494664465465416464954646494649456416514649644649465461664946644654654164649) (from_Zpos 8192 165416541644964516515646464694654165516155464649464945641651464964464946546166494664465465416464954646494649456416514649644649465461664946644654654164649)).
  Compute to_Zpos (General_Karatsuba_fullmul 64 (from_Zpos 8192 546464946494564165146496446494654616649466446546541646495464649464945641651464964464946546166494664465465416464954646494649456416514649644649465461664946644654654164649) (from_Zpos 8192 165416541644964516515646464694654165516155464649464945641651464964464946546166494664465465416464954646494649456416514649644649465461664946644654654164649)).

  (*---------------------------------------------------------------------------
    Other tries (unrelated to Karatsuba algorithm) (imcomplete)
    ---------------------------------------------------------------------------*)

  Lemma to_nat_msb bs: to_nat bs = (msb bs) * 2 ^ (size bs).-1 + to_nat (low (size bs).-1 bs).
  Proof.
    case /lastP: bs; first by done. move => s x. rewrite to_nat_rcons !msb_rcons size_rcons Nat.pred_succ low_rcons; last by done.
    by rewrite low_size addC.
  Qed.

  Lemma to_Zpos_msb bs: to_Zpos bs = ((msb bs) * 2 ^ Z.of_nat (size bs).-1 + to_Zpos (low (size bs).-1 bs))%Z.
  Proof.
    case /lastP: bs; first by done. move => s x. rewrite to_Zpos_rcons !msb_rcons size_rcons Nat.pred_succ low_rcons; last by done.
    by rewrite low_size Z.add_comm.
  Qed.

  Lemma Z_true x: (true * x)%Z = x%Z.
  Proof. by case x. Qed.

  Lemma Z_powS n m: (0 <= m)%Z -> (n * n ^ m)%Z = (n ^ (m + 1 ))%Z.
  Proof.
    elim: m; first by done. 2 :{ move => p Hge. pose proof (Z.le_lt_trans _ _ _ Hge (Zlt_neg_0 p)) as Hp. discriminate. }
    move => p Hp; by rewrite /Z.pow /Z.pow_pos //= -Pos.iter_succ Pos.add_1_r.
  Qed.

  Lemma to_Z_msb bs b: to_Z (rcons bs b) = (-b * 2 ^ Z.of_nat (size bs) + to_Zpos (low (size bs) bs))%Z.
  Proof.
    elim: b; last by rewrite //= to_Z_rcons low_size. rewrite low_size Z.add_comm to_Z_to_Zpos to_Zpos_msb.
    rewrite !size_rcons Nat.pred_succ low_rcons; last by done. rewrite low_size msb_rcons //.
    apply (Z.add_cancel_l _ _ (true * 2 ^ Z.of_nat (size bs))). rewrite !Z_true Z.add_assoc Z.add_opp_r {2}(Z.add_comm (2 ^ Z.of_nat (size bs)) (to_Zpos bs)).
    rewrite Z.add_simpl_r Z.add_comm. rewrite Zplus_assoc_reverse Z.add_shuffle2 Z.add_diag Z_powS; last by apply Nat2Z.is_nonneg.
    by rewrite -addn1 Nat2Z.inj_add //= Z.add_assoc Z.add_opp_r Z.add_simpl_l.
  Qed.

  Lemma full_mul_add_distr bs1 bs2: size bs1 == size bs2 -> (to_Zpos (full_mul bs1 bs2) = to_Zpos bs1 * (msb bs2) * 2 ^ Z.of_nat (size bs1).-1 + to_Zpos bs1 * to_Zpos (low (size bs1).-1 bs2))%Z.
  Proof. move => Hsz; rewrite to_Zpos_full_mul (to_Zpos_msb bs2) Z.mul_add_distr_l !(eqP Hsz) Z.mul_assoc //=. Qed.

  (* about abs in Z *)

  Lemma Z_abs_le n: (n <= Z.abs n)%Z.
  Proof. elim: n; first by done. move => p //=; apply Z.le_refl. move => p //=; apply Z.le_refl. Qed.

  Lemma Z_abs_neg_le n: (-n <= Z.abs n)%Z.
  Proof. elim: n; first by done. move => p //=. move => p //=; apply Z.le_refl. Qed.

  Lemma Z_mul_pos_add_max a b c d: (0 <= a)%Z -> (0 <= b)%Z -> (a * c + b * d <= (a + b) * Z.max c d)%Z.
  Proof.
    move => Hapos Hbpos. elim: (Z.le_ge_cases c d) => Hcd.
    - rewrite (Z.max_r c d Hcd) Z.mul_add_distr_r; apply Zplus_le_compat_r. apply (Z.mul_le_mono_nonneg_l c d a Hapos Hcd).
    - rewrite (Z.max_l c d Hcd) Z.mul_add_distr_r; apply Zplus_le_compat_l. apply (Z.mul_le_mono_nonneg_l d c b Hbpos Hcd).
  Qed.

  Lemma Z_mul_neg_add_max a b c d: (a < 0)%Z -> (b < 0)%Z -> (a * c + b * d <= ((-a + -b) * Z.max (-c) (-d)))%Z.
  Proof.
    move => Haneg Hbneg. rewrite -Z.mul_opp_opp -(Z.mul_opp_opp b d); apply Z_mul_pos_add_max; try apply Z.lt_le_incl; try apply Z.opp_lt_mono; by rewrite Z.opp_involutive Z.opp_0.
  Qed.

  Lemma Z_mul_add_max a b c d: (a * c + b * d <= (Z.abs a + Z.abs b) * Z.max (Z.abs c) (Z.abs d))%Z.
  Proof.
    pose proof (Z_abs_le) as Habs. pose proof (Habs (a * c + b * d)%Z) as Hadd_le.
    apply (Z.le_trans (a * c + b * d)%Z (Z.abs (a * c + b * d))%Z _); first by exact: Hadd_le.
    apply (Z.le_trans (Z.abs (a * c + b * d))%Z (Z.abs (a * c) + Z.abs (b * d))%Z _); first by apply Z.abs_triangle.
    rewrite !Z.abs_mul; apply Z_mul_pos_add_max; by apply Z.abs_nonneg.
  Qed.

  Lemma Z_abs_le_neg a b: (b <= 0)%Z -> (Z.abs a <= Z.abs b)%Z -> (b <= a)%Z.
  Proof.
    move => Hbnonpos; rewrite (Z.abs_neq b Hbnonpos). elim: a; first by done.
    - move => p _ //=; apply (Z.le_trans _ 0 _ Hbnonpos). apply Zle_0_pos.
    - move => p Hle //=; apply Z.opp_le_mono. exact: Hle.
  Qed.

  Lemma Z_mul_add_min a b c d: (-((Z.abs a + Z.abs b) * Z.max (Z.abs c) (Z.abs d)) <= a * c + b * d)%Z.
  Proof.
    have Hneg: (- ((Z.abs a + Z.abs b) * Z.max (Z.abs c) (Z.abs d)) <= 0)%Z.
    {
      apply Z.opp_le_mono; rewrite //= Z.opp_involutive. apply Ztac.mul_le. apply Ztac.add_le; by apply Z.abs_nonneg.
      apply (Z.le_trans _ (Z.abs d) _ (Z.abs_nonneg d) (Z.le_max_r (Z.abs c) (Z.abs d))).
    }
    apply Z_abs_le_neg; first by exact Hneg. rewrite (Z.abs_neq _ Hneg) Z.opp_involutive.
    apply (Z.le_trans (Z.abs (a * c + b * d))%Z (Z.abs (a * c) + Z.abs (b * d))%Z _); first by apply Z.abs_triangle.
    rewrite !Z.abs_mul; apply Z_mul_pos_add_max; by apply Z.abs_nonneg.
  Qed.

  Lemma Z_le_le_abs a b c: (a <= b)%Z -> (b <= c)%Z -> (Z.abs b <= Z.max (Z.abs a) (Z.abs c))%Z.
  Proof.
    elim: b. move => _ _ //=; apply (Z.le_trans _ _ _ (Z.abs_nonneg c) (Z.le_max_r (Z.abs a) (Z.abs c))).
    move => p Ha Hc //=. pose proof Z_abs_le as H. apply (Z.le_trans _ (Z.abs c)%Z _ (Z.le_trans _ _ _ Hc (H c)) (Z.le_max_r (Z.abs a) (Z.abs c))).
    move => p Ha Hc //=. apply Z.opp_le_mono in Ha. rewrite Pos2Z.opp_neg in Ha. pose proof Z_abs_neg_le as H.
    apply (Z.le_trans _ (Z.abs a)%Z _ (Z.le_trans _ _ _ Ha (H a)) (Z.le_max_l (Z.abs a) (Z.abs c))).
  Qed.

  Lemma Z_le_lt_abs a b c: (a <= b)%Z -> (b < c)%Z -> (Z.abs b <= Z.max (Z.abs a) (Z.abs c))%Z.
  Proof. move => Ha Hc; apply (Z_le_le_abs Ha (Z.lt_le_incl _ _ Hc)). Qed.

  Lemma Z_lt_le_abs a b c: (a < b)%Z -> (b <= c)%Z -> (Z.abs b <= Z.max (Z.abs a) (Z.abs c))%Z.
  Proof. move => Ha Hc; apply (Z_le_le_abs (Z.lt_le_incl _ _ Ha) Hc). Qed.

  Lemma Z_lt_lt_abs a b c: (a < b)%Z -> (b < c)%Z -> (Z.abs b < Z.max (Z.abs a) (Z.abs c))%Z.
  Proof.
    pose proof Z_abs_le as Hpos; pose proof Z_abs_neg_le as Hneg. elim: b. move => _ Hc //=; apply (Z.lt_le_trans _ _ _ (Z.lt_le_trans _ _ _ Hc (Hpos c)) (Z.le_max_r (Z.abs a) (Z.abs c))).
    move => p Ha Hc //=. apply (Z.lt_le_trans _ (Z.abs c)%Z _ (Z.lt_le_trans _ _ _ Hc (Hpos c)) (Z.le_max_r (Z.abs a) (Z.abs c))).
    move => p Ha Hc //=. apply Z.opp_lt_mono in Ha. rewrite Pos2Z.opp_neg in Ha.
    apply (Z.lt_le_trans _ (Z.abs a)%Z _ (Z.lt_le_trans _ _ _ Ha (Hneg a)) (Z.le_max_l (Z.abs a) (Z.abs c))).
  Qed.

  Lemma Z_abs_pos p: (Z.abs (Z.pos p) = Z.pos p)%Z.
  Proof. by done. Qed.

  Lemma Z_abs_neg p: (Z.abs (Z.neg p) = Z.pos p)%Z.
  Proof. by done. Qed.

  Lemma Zmult_lt_compat2_general a b c d: (0 < a <= c)%Z -> (0 <= d)%Z -> (b < d)%Z -> (a * b < c * d)%Z.
  Proof.
    move => [Ha Hc] Hd. elim: b; intros.
    - rewrite Z.mul_0_r; apply Z.mul_pos_pos; try done. apply (Z.lt_le_trans _ _ _ Ha Hc).
    - apply Zmult_lt_compat2; try done.
    - apply (Z.lt_le_trans _ 0 _); try apply Z.mul_pos_neg; try done. apply Ztac.mul_le; try done.
      apply Z.lt_le_incl. apply (Z.lt_le_trans _ _ _ Ha Hc).
  Qed.

  Lemma Zmult_lt_compat_general a b c d: (0 <= a < c)%Z -> (0 < d)%Z -> (b <= d)%Z -> (a * b < c * d)%Z.
  Proof.
    move => [Ha Hc] Hd. elim: b; intros.
    - rewrite Z.mul_0_r; apply Z.mul_pos_pos; try done. apply (Z.le_lt_trans _ _ _ Ha Hc).
    - apply (Z.le_lt_trans _ (a * d)%Z _). apply Zmult_le_compat_l; try done. apply Zmult_lt_compat_r; try done.
    - apply (Z.le_lt_trans _ 0 _); try apply Z.mul_nonneg_nonpos; try done. apply Z.mul_pos_pos; try done.
      apply (Z.le_lt_trans _ _ _ Ha Hc).
  Qed.

  Lemma test u v F G:
    (Z.abs u + Z.abs v <= 2 ^ 62)%Z -> (- 2 ^ 62 < u + v)%Z ->
    (- 2 ^ 255 <= F < 2 ^ 255)%Z -> (- 2 ^ 255 <= G < 2 ^ 255)%Z -> (-2^317 <= u * F + v * G < 2^317)%Z.
  Proof.
    pose proof Z_abs_le as Hpos; pose proof Z_abs_neg_le as Hneg.
    move => Habs_add Hadd [HleF HFlt] [HleG HGlt]. split.
    {
      apply (Z.le_trans (- 2 ^ 317)%Z (- ((Z.abs u + Z.abs v) * Z.max (Z.abs F) (Z.abs G)))%Z _); last by apply Z_mul_add_min.
      apply Z.opp_le_mono; rewrite !Z.opp_involutive (Z.pow_add_r 2 62 255); [|done|done]. apply Zmult_le_compat; first by exact Habs_add.
      apply Z.max_lub; [apply (Z_le_lt_abs HleF HFlt) | apply (Z_le_lt_abs HleG HGlt)]. apply Ztac.add_le; by apply Z.abs_nonneg.
      apply (Z.le_trans _ _ _ (Z.abs_nonneg F) (Z.le_max_l (Z.abs F) (Z.abs G))).
    }
    move : Habs_add Hadd HleF HFlt HleG HGlt. elim: u; elim: v; intros; try done.
    - rewrite Z.mul_0_l Z.add_0_l (Z.pow_add_r 2 62 255); try done. move: HleG HGlt; elim: G; intros; try done. apply Zmult_lt_compat2; try done.
    - rewrite Z.mul_0_l Z.add_0_l (Z.pow_add_r 2 255 62); try done. move: HleG HGlt; elim: G; intros; try done.
      apply (Z.le_lt_trans _ _ _ (Hpos (Z.neg p * Z.neg p0)%Z)); rewrite Z.abs_mul Z.mul_comm; apply Zmult_lt_compat2; split; try done.
      rewrite Z.opp_le_mono Z.opp_involutive Pos2Z.opp_neg in HleG; try done. rewrite Z.add_0_l Z.opp_lt_mono Z.opp_involutive Pos2Z.opp_neg in Hadd; try done.
    - rewrite Z.mul_0_l Z.add_0_r (Z.pow_add_r 2 62 255); try done. move: HleF HFlt; elim: F; intros; try done. apply Zmult_lt_compat2; try done.
    - apply (Z.le_lt_trans _ ((Z.pos p0 + Z.pos p) * Z.max F G)%Z _ ); try apply Z_mul_pos_add_max; try apply Zle_0_pos.
      rewrite (Z.pow_add_r 2 62 255); try done. apply Zmult_lt_compat2_general; try done. apply Z.max_lub_lt; try done.
    - apply (Z.lt_eq_cases (Z.abs (Z.pos p0) + Z.abs (Z.neg p))%Z (2 ^ 62)%Z) in Habs_add. elim: Habs_add => Habs_add.
      + apply (Z.le_lt_trans _ ((Z.abs (Z.pos p0) + Z.abs (Z.neg p)) * Z.max (Z.abs F) (Z.abs G))%Z _ ); try apply Z_mul_add_max; rewrite (Z.pow_add_r 2 62 255); try done.
        apply Zmult_lt_compat_general; try split; try done. pose proof (Z_le_lt_abs HleF HFlt); pose proof (Z_le_lt_abs HleG HGlt); apply Z.max_lub; try done.
      + rewrite Z_abs_pos Z_abs_neg in Habs_add. rewrite -(Z.mul_opp_opp (Z.neg p) G) Pos2Z.opp_neg. apply (Z.lt_le_trans (Z.pos p0 * F + Z.pos p * - G)%Z (Z.pos p0 * 2 ^ 255 + Z.pos p * 2 ^ 255)%Z (2 ^ 317)%Z).
        * apply Z.add_lt_le_mono; try apply Zmult_lt_compat_l; try apply Zmult_le_compat_l; try done. by rewrite Z.opp_le_mono Z.opp_involutive.
        * rewrite -Z.mul_add_distr_r Habs_add //=.
    - rewrite Z.mul_0_l Z.add_0_r (Z.pow_add_r 2 255 62); try done. move: HleF HFlt; elim: F; intros; try done.
      apply (Z.le_lt_trans _ _ _ (Hpos (Z.neg p * Z.neg p0)%Z)); rewrite Z.abs_mul Z.mul_comm; apply Zmult_lt_compat2; split; try done.
      rewrite Z.opp_le_mono Z.opp_involutive Pos2Z.opp_neg in HleF; try done. rewrite Z.add_0_r Z.opp_lt_mono Z.opp_involutive Pos2Z.opp_neg in Hadd; try done.
    - apply (Z.lt_eq_cases (Z.abs (Z.neg p0) + Z.abs (Z.pos p))%Z (2 ^ 62)%Z) in Habs_add. elim: Habs_add => Habs_add.
      + apply (Z.le_lt_trans _ ((Z.abs (Z.neg p0) + Z.abs (Z.pos p)) * Z.max (Z.abs F) (Z.abs G))%Z _ ); try apply Z_mul_add_max; rewrite (Z.pow_add_r 2 62 255); try done.
        apply Zmult_lt_compat_general; try split; try done. pose proof (Z_le_lt_abs HleF HFlt); pose proof (Z_le_lt_abs HleG HGlt); apply Z.max_lub; try done.
      + rewrite Z_abs_pos Z_abs_neg in Habs_add. rewrite -(Z.mul_opp_opp (Z.neg p0) F) Pos2Z.opp_neg. apply (Z.lt_le_trans (Z.pos p0 * - F + Z.pos p * G)%Z (Z.pos p0 * 2 ^ 255 + Z.pos p * 2 ^ 255)%Z (2 ^ 317)%Z).
        * apply Z.add_le_lt_mono; try apply Zmult_lt_compat_l; try apply Zmult_le_compat_l; try done. by rewrite Z.opp_le_mono Z.opp_involutive.
        * rewrite -Z.mul_add_distr_r Habs_add //=.
    - apply (Z.le_lt_trans _ ((-Z.neg p0 + -Z.neg p) * Z.max (-F) (-G))%Z _ ); try apply Z_mul_neg_add_max; try done.
      rewrite (Z.pow_add_r 2 62 255); try done. apply Zmult_lt_compat_general; try split; try done. apply Z.opp_lt_mono; try done.
      apply Z.opp_le_mono in HleF; apply Z.opp_le_mono in HleG. apply Z.max_lub; try done.
  Qed.

  (* about long_udivB *)

  Definition long_udivB (bs1 bs2 : bits) : bits * bits := udivB (zext (size bs2 - size bs1) bs1) (zext (size bs1 - size bs2) bs2).
  Definition long_udivB' (bs1 bs2 : bits) : bits := (long_udivB bs1 bs2).1.
  Definition long_uremB bs1 bs2 := (long_udivB bs1 bs2).2.

  Lemma size_long_udivB bs1 bs2: size (long_udivB bs1 bs2).1 = maxn (size bs1) (size bs2).
  Proof. by rewrite /long_udivB size_udivB size_zext maxnE. Qed.

  Lemma size_long_uremB bs1 bs2: size (long_udivB bs1 bs2).2 = maxn (size bs1) (size bs2).
  Proof. by rewrite /long_udivB size_uremB size_zext maxnE. Qed.

  Lemma to_Zpos_udivB_rev : forall m n , size n = size m -> ~~(n == zeros (size n)) ->
                                     to_Zpos (udivB m n).1 = (Z.div (to_Zpos m) (to_Zpos n)).
  Proof. move => m n; rewrite -(revK m) => Hsz Hnotzeros; rewrite to_Zpos_udivB; [done | by rewrite Hsz  size_rev| done]. Qed.

  Lemma to_Zpos_uremB_rev : forall m n , size n = size m -> ~~(n == zeros (size n)) ->
                                     to_Zpos (udivB m n).2 = (Zmod (to_Zpos m) (to_Zpos n)).
  Proof. move => m n; rewrite -(revK m) => Hsz Hnotzeros; rewrite to_Zpos_uremB; [done | by rewrite Hsz  size_rev| done]. Qed.

  Lemma addn_subn_eq m n: m + (n - m) = n + (m - n).
  Proof. by rewrite -!maxnE maxn_sym. Qed.

  Lemma to_Zpos_long_udivB : forall m n: bits , ~~(n == zeros (size n)) ->
                                     to_Zpos (long_udivB (rev m) n).1 = (Z.div (to_Zpos (rev m)) (to_Zpos n)).
  Proof.
    rewrite /long_udivB => m n Hnotzeros. set bs1 := zext (size n - size (rev m)) (rev m); set bs2:= zext (size (rev m) - size n) n.
    rewrite to_Zpos_udivB_rev; [by rewrite !to_Zpos_zext | by rewrite !size_zext addn_subn_eq | by rewrite -ltB0n ltB_zext_r ltB0n].
  Qed.

  Lemma to_Zpos_long_udivB_rev: forall m n: bits , ~~(n == zeros (size n)) ->
                                     to_Zpos (long_udivB m n).1 = (Z.div (to_Zpos m) (to_Zpos n)).
  Proof. move => m n; rewrite -(revK m) => Hnotzeros; rewrite to_Zpos_long_udivB; done. Qed.

  Lemma to_Zpos_long_udivB' : forall m n: bits , ~~ (n == zeros (size n)) ->
                                     to_Zpos (long_udivB' m n) = (Z.div (to_Zpos m) (to_Zpos n)).
  Proof. move => m n Hnotzeros; rewrite /long_udivB' to_Zpos_long_udivB_rev; done. Qed.

  Lemma to_Zpos_long_uremB : forall m n: bits , ~~(n == zeros (size n)) ->
                                     to_Zpos (long_udivB (rev m) n).2 = (Zmod (to_Zpos (rev m)) (to_Zpos n)).
  Proof.
    rewrite /long_udivB => m n Hnotzeros. set bs1 := zext (size n - size (rev m)) (rev m); set bs2:= zext (size (rev m) - size n) n.
    rewrite to_Zpos_uremB_rev; [by rewrite !to_Zpos_zext | by rewrite !size_zext addn_subn_eq | by rewrite -ltB0n ltB_zext_r ltB0n].
  Qed.

  Lemma to_Zpos_long_uremB' : forall m n: bits , ~~ (n == zeros (size n)) ->
                                     to_Zpos (long_uremB m n) = (Zmod (to_Zpos m) (to_Zpos n)).
  Proof. move => m n; rewrite -(revK m) => Hnotzeros; rewrite to_Zpos_long_uremB; done. Qed.

  Lemma long_udivB0 : forall n m, (long_udivB m (zeros n)) = (ones (maxn (size m) n), zext (n - size m) m).
  Proof. intros; by rewrite/long_udivB zext_zero udivB0 size_zext size_zeros maxnE. Qed.

  Lemma long_udiv0B : forall n (m: bits), ~~(m==zeros(size m)) -> long_udivB (zeros n) m = (zeros (maxn n (size m)), zeros (maxn n (size m))).
  Proof.
    intros; rewrite/long_udivB zext_zero size_zeros udiv0B; [by rewrite addC !maxnE | by rewrite size_zext addC addn_subn_eq |].
    by rewrite -ltB0n ltB_zext_r ltB0n.
  Qed.

  Lemma zext_from_Zpos m n p: (0 <= p < 2 ^ Z.of_nat n)%Z -> zext m (from_Zpos n p) = from_Zpos (m+n) p.
  Proof.
    move => [Hge0 Hltbound]; apply to_Zpos_inj_ss; first by rewrite size_zext !size_from_Zpos addC.
    rewrite to_Zpos_zext !to_Zpos_from_Zpos_bounded; try done. rewrite addC Nat2Z.inj_add Z.pow_add_r; try apply Zle_0_nat.
    apply (Z.lt_le_trans p (2 ^ Z.of_nat n)%Z _); try done. apply Z.le_mul_diag_r; try apply (Zlt_le_succ 0 (2 ^ Z.of_nat m)%Z); try apply pow2_nat2z_gt0.
  Qed.

  Lemma long_udivB1: forall n (m: bits), 0 < n -> ~~(m==zeros(size m)) -> long_udivB m (from_Zpos n 1) = (zext (n - size m) m, zeros (maxn n (size m))).
  Proof.
    intros; rewrite /long_udivB size_from_Zpos zext_from_Zpos; try split; try apply Z.pow_gt_1; try done. 2:{ rewrite -Nat2Z.inj_0; apply inj_lt; apply (ltP H). }
    rewrite addC. have Hsz: size (zext (n - size m) m) = n + (size m - n). by rewrite size_zext addn_subn_eq.
    rewrite -Hsz maxnE addn_subn_eq udivB1 size_zext; [ done | by rewrite addn_subn_eq -Hsz -ltB0n ltB_zext_r ltB0n].
  Qed.

  Lemma long_udivB_lt bs1 bs2 :
    ~~ (bs1 == zeros (size bs1)) ->
    (from_Zpos (size bs2) 1) <# bs2 ->
    (long_udivB bs1 bs2).1 <# bs1.
  Proof.
    intros; rewrite /long_udivB to_Zpos_ltB_eqn -(to_Zpos_zext bs1 (size bs2 - size bs1)); set bs1' := (zext (size bs2 - size bs1) bs1); set bs2' := (zext (size bs1 - size bs2) bs2).
    rewrite -to_Zpos_ltB_eqn; apply udivB_lt; [ by rewrite !size_zext addn_subn_eq | by rewrite -ltB0n ltB_zext_r ltB0n|].
    assert (H2 := H0). move: H0; rewrite !to_Zpos_ltB_eqn !to_Zpos_from_Zpos; try done. move => H0; rewrite Zmod_1_l; try rewrite to_Zpos_zext; rewrite Zmod_1_l in H0; try apply Z.pow_gt_1; try done; rewrite -Nat2Z.inj_0; apply inj_lt; case: (Nat.eq_0_gt_0_cases (size bs2)) => Hsz; try done; try by rewrite (eqP (size0 Hsz)) /= ltBnn in H2.
    rewrite size_zext; by apply Nat.lt_lt_add_r.
  Qed.

  Lemma to_Zpos_from_Zpos_eq n z: to_Zpos (from_Zpos n z) = z <-> (0 <= z < 2 ^ Z.of_nat n)%Z.
  Proof.
    split; intros. 2 :{ move: H => [H0 Hn]; by rewrite (to_Zpos_from_Zpos_bounded H0 Hn). }
    rewrite -H to_Zpos_from_Zpos. apply Z.mod_pos_bound; apply Z.pow_pos_nonneg; [done | apply Zle_0_nat]. rewrite -H; apply to_Zpos_ge0.
  Qed.


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Monads.Monad.
Require Import Tactics.CpdtTactics.

Set Implicit Arguments.

(** https://wiki.haskell.org/State_Monad *)
Module Type State <: Monad.
  (* State *)
  Parameter S : Type.

  Definition m (A : Type) := S -> prod A S.

  Definition ret {A : Type} (a : A) :=
    fun (s : S) =>
      (a, s).
  Definition bind {A B : Type} (n : S -> prod A S)
                  (f : A -> (S -> prod B S)) :=
    fun (s : S) =>
      let (r, s') := n s in f r s'.

  Infix ">>=" := bind (at level 50, left associativity).
  Ltac nake := unfold m; unfold ret; unfold bind.

  Theorem left_id : forall (A B : Type) (x : A) (f : A -> m B),
    ret x >>= f = f x.
  Proof.
    nake. crush.
  Qed.

  Theorem right_id : forall (A : Type) (x : m A),
    x >>= ret = x.
  Proof.
    nake. intros.
    apply functional_extensionality; intros.
    destruct (x x0); crush.
  Qed.

  Theorem bind_assoc :
    forall (A B C : Type) (n : m A) (f : A -> m B) (g : B -> m C),
      (n >>= f) >>= g = n >>= (fun x => f x >>= g).
  Proof.
    nake. intros.
    apply functional_extensionality; intros.
    destruct (n x); auto.
  Qed.
End State.


(**
MathComp における古典論理
======
2020/01/25

この文書のソースコードは以下にあります。

https://github.com/suharahiromichi/coq/blob/master/pearl/ssr_classically.v

 *)

(**
OCaml 4.07.1, Coq 8.9.1, MathComp 1.9.0
 *)

From mathcomp Require Import all_ssreflect.

(**
----------------
# MathComp は排中律を仮定しているのか

Stackoverflow (英語版）に、こんな質問がありました([1.])。

``forall A: Prop, A \/ ~A``

の証明を教えてほしいという趣旨です。クローズしているようなのですが、
その回答にあるように、MathComp のライブラリには排中律の公理が定義されていないので、
任意の ``A : Prop`` については証明できません。

排中律の公理を自分で定義するか、
Standard CoqのClassical.vを導入すればよいのですが、
そもそも MathComp のライブラリには公理、すなわち、証明なしで導入される
命題は含まれていないのです。

このことは [2.] の3.3節に説明があって、

The Mathematical Components library is axiom free. This makes the
library compatible with any combination of axioms that is known to be
consistent with the Calculus of Inductive Constructions.

要するに（Standard Coqと違って）、
CICとの互換性が保たれない（かもしれない）命題は一切入れないのだ、
ということのようです（注1）。これを "axiom free" というのだそうです。

では、排中律ががなくて困ることはないのでしょうか？

結論からいうと、ある命題が同値なbool値の式に変換（リフレクト）できるならば（注2)、
その命題は真か偽の決まる（注3）という決定性があることになり、
排中律や二重否定除去が定理として証明できるはずです。
なので、公理として排中律を導入する必要はないわけです。

（注1）実際には、MathComp のライブラリの中で Axiom コマンドは使われています。

（注2) bool型の式は、計算すればtrueかfalseに値が決まる決定性を持つため。

（注3) 正確には、真であると証明できるか、その否定が証明できる、というべき。
 *)

(**
----------------
# Standard Coq の場合

Standard Coq では Classical.v で次のように定義されています。
 *)
Require Import Classical.
(**
まず、排中律(classic)が公理として定義され、
 *)
Check classic : forall P : Prop, P \/ ~ P.  (* 排中律 *)

(**
それから二重否定除去(NNPP)が証明されています。
 *)
Lemma NNPP : forall P : Prop, ~ ~ P -> P.   (* 二重否定除去 *)
Proof.
  intro P.
  now case (classic P).
Qed.

(**
----------------
# MathComp の場合

## 一般の命題 P

MathComp では、Prop型の命題 P が bool型の式 b にリフレクトできる（注4）
ことを ``reflect P b`` で表します。``reflect P b`` が成り立っていることを前提として
（公理とするわけではない）、排中律を導いてみましょう。

（注4） b を ``b = true`` というProp型の命題と解釈したときに、それがPと同値である。
*)

(**
命題Pにリフレクトできるブール型の式bがあるなら、命題Pは排中律は成り立つ。

証明自体は単純で、b を true と false で場合分け(case)したのち、
true ならゴールの選言のleftをとり、bool値にリフレクトするとtrue。
false ならゴールの選言のrightをとり、bool値にリフレクトすると~~ false。
になります。bool値falseの否定はtrueに決まっているので、どちらも真になります。
 *)

Lemma ssr_em_p (P : Prop) (b : bool) : reflect P b -> P \/ ~ P.
Proof.
  case: b => Hr.
  - left.
    apply/Hr.
    done.
  - right.
    apply/Hr.
    done.

    Restart.

    by case: b => Hr; [left | right]; apply/Hr.
Qed.

(**
Staandard Coq の場合と同様に、排中律から二重否定除去は証明できます。
 *)
Lemma ssr_nnpp_p (P : Prop) (b : bool) : reflect P b -> ~ ~ P -> P.
  move=> Hr.
    by case: (ssr_em_p P b Hr).
Qed.

(**
[2.] の3.3節では、

```
Definition classically P := forall b : bool, (P -> b) -> b
```

を導入していくつかの補題を証明していますが、classically の「見た目」から判るように
これはモナディックな定義です。今回はそれを使いません。
モナデックな方法ついては稿を改めて説明したいとおもいます。
*)

(**
## 具体的な P (自然数の等式の例)

では、命題Pにリフレクトできるブール式bがあるような命題Pとはなんでしょうか。

自然数どうしの等式がこれにあたります。
*)

(**
MathComp では、このような決定性のある等式の成り立つ型を eqType といいます。
nat は eqType ですので（注5）、これが成り立ちます。

（注5）eqType のインスタンス nat_eqType が nat の正準型（カノニカル）であるという。
*)

(**
自然数の等式の命題 m = n は、bool型の式 m == n にリフレクトできます。
具体的には、次の補題 eqP が MathComp のなかで定義されています。
*)

Check @eqP nat_eqType : forall (m n : nat), reflect (m = n) (m == n).

(**
eqP を使うと、自然数の等式の命題の排中律と二重否定除去が証明できます。
*)

Lemma ssr_em_eq (m n : nat) : m = n \/ m <> n.
Proof.
  apply: ssr_em_p.
    by apply: eqP.
Qed.

Lemma ssr_nnpp_eq (m n : nat) : ~ m <> n -> m = n.
Proof.
  apply: ssr_nnpp_p.
    by apply: eqP.
Qed.

(**
# まとめ

実際、ふたつの自然数m と n の等式 m = n は、成立するかしないかのどちらかで、決定性
があります。また、 m <> n の否定は m = n でよいはずです。

MathComp はこのように、Coqのうえで普通の「数学」をするための仕組みなわけです。
*)

(**
---------------
# 文献

[1.] Does ssreflect assume excluded middle?

https://stackoverflow.com/questions/34520944/does-ssreflect-assume-excluded-middle

[2.] Mathematical Components Book

https://math-comp.github.io/mcb/

 *)

(* END *)


Require Import Coq.Lists.ListSet.
Require Import Coq.Arith.Arith.
Require Import Coq.Init.Specif.
Require Export Coq.Lists.List.

Require Export formulatheory_int formulatheory_def formulatheory_inst
               featuremodelsemantics_def featuremodelsemantics_int featuremodelsemantics_inst.

Import  FormulaTheory FeatureModelSemantics.

Class FeatureModelRefinement (FML Nm F: Type) {FormT: FormulaTheory FML Nm F}
                             {FMS: FeatureModelSemantics FML F Nm }: Type :=
 {
  (*====================functions=======================*)
  addMandatoryNode: F -> F -> Nm -> Nm -> Prop;
  addOptionalNode : F -> F -> Nm -> Nm -> Prop;

  (*===========Axioms - Lemmas - Theorems====================*)
  name_dec :
    forall x y: Nm, {x = y} + {x <> y};
  form_dec :
    forall x y: FML, {x = y} + {x <> y};
  wtFormAddNode: forall (abs con: F) (n1 n2: Nm),
    wfTree(abs) /\ wfTree(con) /\
      names_(con) = set_add name_dec n2 (names_ (abs)) /\
        set_In n1 (names_ (abs)) /\
          (~set_In n2 (names_ (abs)))
            -> (forall (f: FML), wt abs f -> wt con f);
  addMandatoryWF: forall (abs: F) (n1 n2: Nm) (con:F),
    addMandatoryNode abs con n1 n2 -> wfFM (con);
  addMandatoryT: forall (abs: F) (n1 n2: Nm),
    exists (con: F), addMandatoryNode abs con n1 n2 ->
      (forall (c: set Nm),
        set_In c (semantics abs)
          -> if Is_truePB(set_In n1 c) then (set_In (set_add name_dec n2 c) (semantics con))
            else set_In c (semantics con)) /\
              (forall (c: set Nm),
                set_In c (semantics con)
                  -> if Is_truePB(set_In n2 c) then (set_In (set_remove name_dec n2 c) (semantics abs))
                    else set_In c (semantics abs)) /\
                      wfFM(con);
  addMandatoryTWF: forall (abs: F) (con: F) (n1 n2: Nm),
  addMandatoryNode abs con n1 n2 ->
    (forall (c: set Nm),
      set_In c (semantics abs)
        -> if Is_truePB(set_In n1 c) then (set_In (set_add name_dec n2 c) (semantics con))
         else set_In c (semantics con)) /\
           (forall (c: set Nm),
              set_In c (semantics con)
                -> if Is_truePB(set_In n2 c) then (set_In (set_remove name_dec n2 c) (semantics abs))
                  else set_In c (semantics abs)) /\
                    wfFM(con);
  wfPreservation: forall (abs: F) (con: F) (n1 n2: Nm),
    addOptionalNode abs con n1 n2 -> wfFM (con);
  addNode: forall (abs: F) (n1 n2: Nm),
    exists (con: F), addOptionalNode abs con n1 n2 ->
      refines abs con /\ wfFM con;
  addOptNode: forall (abs: F) (con: F) (n1 n2: Nm),
    addMandatoryNode abs con n1 n2 ->
     refines abs con /\ wfFM con

}.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Require Import Classical.

Coq < Section Exercise_01.

Coq < Goal forall a b:Prop, ~(a) -> (a -> b).
1 subgoal

  ============================
   forall a b : Prop, ~ a -> a -> b

Unnamed_thm < intros.
1 subgoal

  a : Prop
  b : Prop
  H : ~ a
  H0 : a
  ============================
   b

Unnamed_thm < tauto.
No more subgoals.

Unnamed_thm < Qed.
intros.
tauto.

Unnamed_thm is defined

Coq <

*)

Require Import Classical.
Section Exercise_01.
Goal forall a b:Prop, ~(a) -> (a -> b).
intros.
 tauto.
 Qed.