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

Set Implicit Arguments.

Require Import ZArith.
Require Import BigNumPrelude.
Require Import DoubleType.
Require Import DoubleBase.
Require Import DoubleDivn1.
Require Import DoubleAdd.
Require Import DoubleSub.

Local Open Scope Z_scope.

Ltac zarith := auto with zarith.

Section POS_MOD.

 Variable w:Type.
 Variable w_0 : w.
 Variable w_digits : positive.
 Variable w_zdigits : w.
 Variable w_WW : w -> w -> zn2z w.
 Variable w_pos_mod : w -> w -> w.
 Variable w_compare : w -> w -> comparison.
 Variable ww_compare : zn2z w -> zn2z w -> comparison.
 Variable w_0W : w ->  zn2z w.
 Variable low: zn2z w -> w.
 Variable ww_sub: zn2z w -> zn2z w -> zn2z w.
 Variable ww_zdigits : zn2z w.

 Definition ww_pos_mod p x :=
  let zdigits := w_0W w_zdigits in
  match x with
  | W0 => W0
  | WW xh xl =>
    match ww_compare p zdigits with
    | Eq => w_WW w_0 xl
    | Lt => w_WW w_0 (w_pos_mod (low p) xl)
    | Gt =>
      match ww_compare p ww_zdigits with
      | Lt =>
        let n := low (ww_sub p zdigits) in
        w_WW (w_pos_mod n xh) xl
      | _ => x
      end
    end
  end.

  Variable w_to_Z : w -> Z.

  Notation wB  := (base w_digits).
  Notation wwB := (base (ww_digits w_digits)).
  Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).

  Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).

  Variable spec_w_0   : [|w_0|] = 0.

  Variable spec_to_Z  : forall x, 0 <= [|x|] < wB.

  Variable spec_to_w_Z  : forall x, 0 <= [[x]] < wwB.

  Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|].

  Variable spec_pos_mod : forall w p,
       [|w_pos_mod p w|] = [|w|] mod (2 ^ [|p|]).

  Variable spec_w_0W : forall l, [[w_0W l]] = [|l|].
  Variable spec_ww_compare : forall x y,
    ww_compare x y = Zcompare [[x]] [[y]].
 Variable spec_ww_sub: forall x y,
   [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB.

 Variable spec_zdigits : [| w_zdigits |] = Zpos w_digits.
 Variable spec_low: forall x, [| low x|] = [[x]] mod wB.
 Variable spec_ww_zdigits : [[ww_zdigits]] = 2 * [|w_zdigits|].
 Variable spec_ww_digits : ww_digits w_digits = xO w_digits.

  Hint Rewrite spec_w_0 spec_w_WW : w_rewrite.

 Lemma spec_ww_pos_mod : forall w p,
       [[ww_pos_mod p w]] = [[w]] mod (2 ^ [[p]]).
 assert (HHHHH:= lt_0_wB w_digits).
 assert (F0: forall x y, x - y + y = x); auto with zarith.
 intros w1 p; case (spec_to_w_Z p); intros HH1 HH2.
 unfold ww_pos_mod; case w1.
 simpl; rewrite Zmod_small; split; auto with zarith.
 intros xh xl; rewrite spec_ww_compare.
    case Zcompare_spec;
    rewrite spec_w_0W; rewrite spec_zdigits; fold wB;
    intros H1.
   rewrite H1; simpl ww_to_Z.
   autorewrite with w_rewrite rm10.
   rewrite Zplus_mod; auto with zarith.
   rewrite Z_mod_mult; auto with zarith.
   autorewrite with rm10.
   rewrite Zmod_mod; auto with zarith.
   rewrite Zmod_small; auto with zarith.
   autorewrite with w_rewrite rm10.
   simpl ww_to_Z.
   rewrite spec_pos_mod.
   assert (HH0: [|low p|] = [[p]]).
     rewrite spec_low.
     apply Zmod_small; auto with zarith.
     case (spec_to_w_Z p); intros HHH1 HHH2; split; auto with zarith.
     apply Zlt_le_trans with (1 := H1).
     unfold base; apply Zpower2_le_lin; auto with zarith.
   rewrite HH0.
   rewrite Zplus_mod; auto with zarith.
   unfold base.
   rewrite <- (F0 (Zpos w_digits) [[p]]).
   rewrite Zpower_exp; auto with zarith.
   rewrite Zmult_assoc.
   rewrite Z_mod_mult; auto with zarith.
   autorewrite with w_rewrite rm10.
   rewrite Zmod_mod; auto with zarith.
  rewrite spec_ww_compare.
    case Zcompare_spec; rewrite spec_ww_zdigits;
                     rewrite spec_zdigits; intros H2.
  replace (2^[[p]]) with wwB.
    rewrite Zmod_small; auto with zarith.
  unfold base; rewrite H2.
  rewrite spec_ww_digits; auto.
  assert (HH0: [|low (ww_sub p (w_0W w_zdigits))|] =
         [[p]] - Zpos w_digits).
    rewrite spec_low.
    rewrite spec_ww_sub.
    rewrite spec_w_0W; rewrite spec_zdigits.
    rewrite <- Zmod_div_mod; auto with zarith.
    rewrite Zmod_small; auto with zarith.
    split; auto with zarith.
    apply Zlt_le_trans with (Zpos w_digits); auto with zarith.
    unfold base; apply Zpower2_le_lin; auto with zarith.
    exists wB; unfold base; rewrite <- Zpower_exp; auto with zarith.
    rewrite spec_ww_digits;
      apply f_equal with (f := Zpower 2); rewrite Zpos_xO; auto with zarith.
   simpl ww_to_Z; autorewrite with w_rewrite.
   rewrite spec_pos_mod; rewrite HH0.
   pattern [|xh|] at 2;
     rewrite Z_div_mod_eq with (b := 2 ^ ([[p]] - Zpos w_digits));
     auto with zarith.
   rewrite (fun x => (Zmult_comm (2 ^ x))); rewrite Zmult_plus_distr_l.
   unfold base; rewrite <- Zmult_assoc; rewrite <- Zpower_exp;
    auto with zarith.
   rewrite F0; auto with zarith.
   rewrite <- Zplus_assoc; rewrite Zplus_mod; auto with zarith.
   rewrite Z_mod_mult; auto with zarith.
   autorewrite with rm10.
   rewrite Zmod_mod; auto with zarith.
   apply sym_equal; apply Zmod_small; auto with zarith.
   case (spec_to_Z xh); intros U1 U2.
   case (spec_to_Z xl); intros U3 U4.
   split; auto with zarith.
   apply Zplus_le_0_compat; auto with zarith.
   apply Zmult_le_0_compat; auto with zarith.
   match goal with |- 0 <= ?X mod ?Y =>
    case (Z_mod_lt X Y); auto with zarith
   end.
   match goal with |- ?X mod ?Y * ?U + ?Z < ?T =>
    apply Zle_lt_trans with ((Y - 1) * U + Z );
     [case (Z_mod_lt X Y); auto with zarith | idtac]
   end.
   match goal with |- ?X * ?U + ?Y < ?Z =>
    apply Zle_lt_trans with (X * U + (U - 1))
   end.
   apply Zplus_le_compat_l; auto with zarith.
   case (spec_to_Z xl); unfold base; auto with zarith.
   rewrite Zmult_minus_distr_r; rewrite <- Zpower_exp; auto with zarith.
   rewrite F0; auto with zarith.
  rewrite Zmod_small; auto with zarith.
  case (spec_to_w_Z (WW xh xl)); intros U1 U2.
  split; auto with zarith.
  apply Zlt_le_trans with (1:= U2).
  unfold base; rewrite spec_ww_digits.
  apply Zpower_le_monotone; auto with zarith.
  split; auto with zarith.
  rewrite Zpos_xO; auto with zarith.
 Qed.

End POS_MOD.

Section DoubleDiv32.

 Variable w             : Type.
 Variable w_0           : w.
 Variable w_Bm1         : w.
 Variable w_Bm2         : w.
 Variable w_WW          : w -> w -> zn2z w.
 Variable w_compare     : w -> w -> comparison.
 Variable w_add_c       : w -> w -> carry w.
 Variable w_add_carry_c : w -> w -> carry w.
 Variable w_add         : w -> w -> w.
 Variable w_add_carry   : w -> w -> w.
 Variable w_pred        : w -> w.
 Variable w_sub         : w -> w -> w.
 Variable w_mul_c       : w -> w -> zn2z w.
 Variable w_div21       : w -> w -> w -> w*w.
 Variable ww_sub_c      : zn2z w -> zn2z w -> carry (zn2z w).

 Definition w_div32 a1 a2 a3 b1 b2 :=
  Eval lazy beta iota delta [ww_add_c_cont ww_add] in
  match w_compare a1 b1 with
  | Lt =>
    let (q,r) := w_div21 a1 a2 b1 in
    match ww_sub_c (w_WW r a3) (w_mul_c q b2) with
    | C0 r1 => (q,r1)
    | C1 r1 =>
      let q := w_pred q in
      ww_add_c_cont w_WW w_add_c w_add_carry_c
      (fun r2=>(w_pred q, ww_add w_add_c w_add w_add_carry r2 (WW b1 b2)))
      (fun r2 => (q,r2))
      r1 (WW b1 b2)
    end
  | Eq =>
    ww_add_c_cont w_WW w_add_c w_add_carry_c
    (fun r => (w_Bm2, ww_add w_add_c w_add w_add_carry r (WW b1 b2)))
    (fun r => (w_Bm1,r))
    (WW (w_sub a2 b2) a3) (WW b1 b2)
  | Gt => (w_0, W0) (* cas absurde *)
  end.

 (* Proof *)

  Variable w_digits      : positive.
  Variable w_to_Z : w -> Z.

  Notation wB  := (base w_digits).
  Notation wwB := (base (ww_digits w_digits)).
  Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
  Notation "[+| c |]" :=
   (interp_carry 1 wB w_to_Z c) (at level 0, x at level 99).
  Notation "[-| c |]" :=
   (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99).

  Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).
  Notation "[-[ c ]]" :=
   (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c)
   (at level 0, x at level 99).

  Variable spec_w_0   : [|w_0|] = 0.
  Variable spec_w_Bm1   : [|w_Bm1|] = wB - 1.
  Variable spec_w_Bm2   : [|w_Bm2|] = wB - 2.

  Variable spec_to_Z  : forall x, 0 <= [|x|] < wB.

  Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|].
  Variable spec_compare :
     forall x y, w_compare x y = Zcompare [|x|] [|y|].
  Variable spec_w_add_c  : forall x y, [+|w_add_c x y|] = [|x|] + [|y|].
  Variable spec_w_add_carry_c :
         forall x y, [+|w_add_carry_c x y|] = [|x|] + [|y|] + 1.

  Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB.
  Variable spec_w_add_carry :
	 forall x y, [|w_add_carry x y|] = ([|x|] + [|y|] + 1) mod wB.

  Variable spec_pred : forall x, [|w_pred x|] = ([|x|] - 1) mod wB.
  Variable spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB.

  Variable spec_mul_c : forall x y, [[ w_mul_c x y ]] = [|x|] * [|y|].
  Variable spec_div21 : forall a1 a2 b,
      wB/2 <= [|b|] ->
      [|a1|] < [|b|] ->
      let (q,r) := w_div21 a1 a2 b in
      [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\
      0 <= [|r|] < [|b|].

  Variable spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]].

  Ltac Spec_w_to_Z x :=
   let H:= fresh "HH" in
   assert (H:= spec_to_Z x).
  Ltac Spec_ww_to_Z x :=
   let H:= fresh "HH" in
   assert (H:= spec_ww_to_Z w_digits w_to_Z spec_to_Z x).

  Theorem wB_div2: forall x, wB/2  <= x -> wB <= 2 * x.
   intros x H; rewrite <- wB_div_2; apply Zmult_le_compat_l; auto with zarith.
  Qed.

  Lemma Zmult_lt_0_reg_r_2 : forall n m : Z, 0 <= n -> 0 < m * n -> 0 < m.
  Proof.
   intros n m H1 H2;apply Zmult_lt_0_reg_r with n;trivial.
   destruct (Zle_lt_or_eq _ _ H1);trivial.
   subst;rewrite Zmult_0_r in H2;discriminate H2.
  Qed.

  Theorem spec_w_div32 : forall a1 a2 a3 b1 b2,
     wB/2 <= [|b1|] ->
     [[WW a1 a2]] < [[WW b1 b2]] ->
     let (q,r) := w_div32 a1 a2 a3 b1 b2 in
     [|a1|] * wwB + [|a2|] * wB  + [|a3|] =
        [|q|] *  ([|b1|] * wB + [|b2|])  + [[r]] /\
     0 <= [[r]] < [|b1|] * wB + [|b2|].
  Proof.
   intros a1 a2 a3 b1 b2 Hle Hlt.
   assert (U:= lt_0_wB w_digits); assert (U1:= lt_0_wwB w_digits).
   Spec_w_to_Z a1;Spec_w_to_Z a2;Spec_w_to_Z a3;Spec_w_to_Z b1;Spec_w_to_Z b2.
   rewrite wwB_wBwB; rewrite Zpower_2; rewrite Zmult_assoc;rewrite <- Zmult_plus_distr_l.
   change (w_div32 a1 a2 a3 b1 b2) with
    match w_compare a1 b1 with
    | Lt =>
     let (q,r) := w_div21 a1 a2 b1 in
     match ww_sub_c (w_WW r a3) (w_mul_c q b2) with
     | C0 r1 => (q,r1)
     | C1 r1 =>
      let q := w_pred q in
      ww_add_c_cont w_WW w_add_c w_add_carry_c
      (fun r2=>(w_pred q, ww_add w_add_c w_add w_add_carry r2 (WW b1 b2)))
      (fun r2 => (q,r2))
      r1 (WW b1 b2)
     end
    | Eq =>
     ww_add_c_cont w_WW w_add_c w_add_carry_c
     (fun r => (w_Bm2, ww_add w_add_c w_add w_add_carry r (WW b1 b2)))
     (fun r => (w_Bm1,r))
     (WW (w_sub a2 b2) a3) (WW b1 b2)
    | Gt => (w_0, W0) (* cas absurde *)
    end.
   rewrite spec_compare. case Zcompare_spec; intro Hcmp.
   simpl in Hlt.
   rewrite Hcmp in Hlt;assert ([|a2|] < [|b2|]). omega.
   assert ([[WW (w_sub a2 b2) a3]] = ([|a2|]-[|b2|])*wB + [|a3|] + wwB).
    simpl;rewrite spec_sub.
    assert ([|a2|] - [|b2|] = wB*(-1) + ([|a2|] - [|b2|] + wB)). ring.
    assert (0 <= [|a2|] - [|b2|] + wB < wB). omega.
    rewrite <-(Zmod_unique ([|a2|]-[|b2|]) wB (-1) ([|a2|]-[|b2|]+wB) H1 H0).
    rewrite wwB_wBwB;ring.
   assert (U2 := wB_pos w_digits).
   eapply spec_ww_add_c_cont with (P :=
     fun (x y:zn2z w) (res:w*zn2z w) =>
     let (q, r) := res in
     ([|a1|] * wB + [|a2|]) * wB + [|a3|] =
     [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\
     0 <= [[r]] < [|b1|] * wB + [|b2|]);eauto.
   rewrite H0;intros r.
   repeat
    (rewrite spec_ww_add;eauto || rewrite spec_w_Bm1 || rewrite spec_w_Bm2);
   simpl ww_to_Z;try rewrite Zmult_1_l;intros H1.
   assert (0<= ([[r]] + ([|b1|] * wB + [|b2|])) - wwB < [|b1|] * wB + [|b2|]).
   Spec_ww_to_Z r;split;zarith.
   rewrite H1.
   assert (H12:= wB_div2 Hle). assert (wwB <= 2 * [|b1|] * wB).
   rewrite wwB_wBwB; rewrite Zpower_2; zarith.
   assert (-wwB < ([|a2|] - [|b2|]) * wB + [|a3|] < 0).
   split. apply Zlt_le_trans with (([|a2|] - [|b2|]) * wB);zarith.
   rewrite wwB_wBwB;replace (-(wB^2)) with (-wB*wB);[zarith | ring].
   apply Zmult_lt_compat_r;zarith.
   apply Zle_lt_trans with (([|a2|] - [|b2|]) * wB + (wB -1));zarith.
   replace ( ([|a2|] - [|b2|]) * wB + (wB - 1)) with
     (([|a2|] - [|b2|] + 1) * wB + - 1);[zarith | ring].
   assert (([|a2|] - [|b2|] + 1) * wB <= 0);zarith.
   replace 0 with (0*wB);zarith.
   replace (([|a2|] - [|b2|]) * wB + [|a3|] + wwB + ([|b1|] * wB + [|b2|]) +
              ([|b1|] * wB + [|b2|]) - wwB) with
         (([|a2|] - [|b2|]) * wB + [|a3|] + 2*[|b1|] * wB + 2*[|b2|]);
   [zarith | ring].
   rewrite <- (Zmod_unique ([[r]] + ([|b1|] * wB + [|b2|])) wwB
             1 ([[r]] + ([|b1|] * wB + [|b2|]) - wwB));zarith;try (ring;fail).
   split. rewrite H1;rewrite Hcmp;ring. trivial.
   Spec_ww_to_Z (WW b1 b2). simpl in HH4;zarith.
   rewrite H0;intros r;repeat
    (rewrite spec_w_Bm1 || rewrite spec_w_Bm2);
   simpl ww_to_Z;try rewrite Zmult_1_l;intros H1.
   assert ([[r]]=([|a2|]-[|b2|])*wB+[|a3|]+([|b1|]*wB+[|b2|])). zarith.
   split. rewrite H2;rewrite Hcmp;ring.
   split. Spec_ww_to_Z r;zarith.
   rewrite H2.
   assert (([|a2|] - [|b2|]) * wB + [|a3|] < 0);zarith.
   apply Zle_lt_trans with (([|a2|] - [|b2|]) * wB + (wB -1));zarith.
   replace ( ([|a2|] - [|b2|]) * wB + (wB - 1)) with
     (([|a2|] - [|b2|] + 1) * wB + - 1);[zarith|ring].
   assert (([|a2|] - [|b2|] + 1) * wB <= 0);zarith.
   replace 0 with (0*wB);zarith.
   (* Cas Lt *)
   assert (Hdiv21 := spec_div21 a2 Hle Hcmp);
    destruct (w_div21 a1 a2 b1) as (q, r);destruct Hdiv21.
   rewrite H.
   assert (Hq := spec_to_Z q).
   generalize
    (spec_ww_sub_c (w_WW r a3) (w_mul_c q b2));
    destruct (ww_sub_c (w_WW r a3) (w_mul_c q b2))
    as [r1|r1];repeat (rewrite spec_w_WW || rewrite spec_mul_c);
    unfold interp_carry;intros H1.
    rewrite H1.
   split. ring. split.
   rewrite <- H1;destruct (spec_ww_to_Z w_digits w_to_Z spec_to_Z r1);trivial.
   apply Zle_lt_trans with ([|r|] * wB + [|a3|]).
   assert ( 0 <= [|q|] * [|b2|]);zarith.
   apply beta_lex_inv;zarith.
   assert ([[r1]] = [|r|] * wB + [|a3|] - [|q|] * [|b2|] + wwB).
   rewrite <- H1;ring.
   Spec_ww_to_Z r1; assert (0 <= [|r|]*wB). zarith.
   assert (0 < [|q|] * [|b2|]). zarith.
   assert (0 < [|q|]).
    apply Zmult_lt_0_reg_r_2 with [|b2|];zarith.
   eapply spec_ww_add_c_cont with (P :=
     fun (x y:zn2z w) (res:w*zn2z w) =>
     let (q0, r0) := res in
      ([|q|] * [|b1|] + [|r|]) * wB + [|a3|] =
      [|q0|] * ([|b1|] * wB + [|b2|]) + [[r0]] /\
      0 <= [[r0]] < [|b1|] * wB + [|b2|]);eauto.
   intros r2;repeat (rewrite spec_pred || rewrite spec_ww_add;eauto);
   simpl ww_to_Z;intros H7.
   assert (0 < [|q|] - 1).
   assert (1 <= [|q|]). zarith.
   destruct (Zle_lt_or_eq _ _ H6);zarith.
   rewrite <- H8 in H2;rewrite H2 in H7.
   assert (0 < [|b1|]*wB). apply Zmult_lt_0_compat;zarith.
   Spec_ww_to_Z r2. zarith.
   rewrite (Zmod_small ([|q|] -1));zarith.
   rewrite (Zmod_small ([|q|] -1 -1));zarith.
   assert ([[r2]] + ([|b1|] * wB + [|b2|]) =
       wwB * 1 +
       ([|r|] * wB + [|a3|] - [|q|] * [|b2|] + 2 * ([|b1|] * wB + [|b2|]))).
   rewrite H7;rewrite H2;ring.
   assert
    ([|r|]*wB + [|a3|] - [|q|]*[|b2|] + 2 * ([|b1|]*wB + [|b2|])
        < [|b1|]*wB + [|b2|]).
   Spec_ww_to_Z r2;omega.
   Spec_ww_to_Z (WW b1 b2). simpl in HH5.
   assert
    (0 <= [|r|]*wB + [|a3|] - [|q|]*[|b2|] + 2 * ([|b1|]*wB + [|b2|])
       < wwB). split;try omega.
   replace (2*([|b1|]*wB+[|b2|])) with ((2*[|b1|])*wB+2*[|b2|]). 2:ring.
   assert (H12:= wB_div2 Hle). assert (wwB <= 2 * [|b1|] * wB).
   rewrite wwB_wBwB; rewrite Zpower_2; zarith. omega.
   rewrite <- (Zmod_unique
            ([[r2]] + ([|b1|] * wB + [|b2|]))
            wwB
            1
            ([|r|] * wB + [|a3|] - [|q|] * [|b2|] + 2*([|b1|] * wB + [|b2|]))
            H10 H8).
   split. ring. zarith.
   intros r2;repeat (rewrite spec_pred);simpl ww_to_Z;intros H7.
   rewrite (Zmod_small ([|q|] -1));zarith.
   split.
   replace [[r2]] with  ([[r1]] + ([|b1|] * wB + [|b2|]) -wwB).
   rewrite H2; ring. rewrite <- H7; ring.
   Spec_ww_to_Z r2;Spec_ww_to_Z r1. omega.
   simpl in Hlt.
   assert ([|a1|] * wB + [|a2|] <= [|b1|] * wB + [|b2|]). zarith.
   assert (H1 := beta_lex _ _ _ _ _ H HH0 HH3). rewrite spec_w_0;simpl;zarith.
  Qed.

End DoubleDiv32.

Section DoubleDiv21.
 Variable w : Type.
 Variable w_0 : w.

 Variable w_0W : w -> zn2z w.
 Variable w_div32 : w -> w -> w -> w -> w -> w * zn2z w.

 Variable ww_1 : zn2z w.
 Variable ww_compare : zn2z w -> zn2z w -> comparison.
 Variable ww_sub : zn2z w -> zn2z w -> zn2z w.

 Definition ww_div21 a1 a2 b :=
  match a1 with
  | W0 =>
    match ww_compare a2 b with
    | Gt => (ww_1, ww_sub a2 b)
    | Eq => (ww_1, W0)
    | Lt => (W0, a2)
    end
  | WW a1h a1l =>
    match a2 with
    | W0 =>
      match b with
      | W0 => (W0,W0) (* cas absurde *)
      | WW b1 b2 =>
        let (q1, r)  := w_div32 a1h a1l w_0 b1 b2 in
        match r with
        | W0 => (WW q1 w_0, W0)
        | WW r1 r2 =>
	  let (q2, s)  := w_div32 r1 r2 w_0 b1 b2 in
          (WW q1 q2, s)
        end
      end
    | WW a2h a2l =>
      match b with
      | W0 => (W0,W0) (* cas absurde *)
      | WW b1 b2 =>
        let (q1, r)  := w_div32 a1h a1l a2h b1 b2 in
        match r with
        | W0 => (WW q1 w_0, w_0W a2l)
        | WW r1 r2 =>
	  let (q2, s)  := w_div32 r1 r2 a2l b1 b2 in
          (WW q1 q2, s)
        end
      end
    end
  end.

 (* Proof *)

  Variable w_digits : positive.
  Variable w_to_Z : w -> Z.
  Notation wB  := (base w_digits).
  Notation wwB := (base (ww_digits w_digits)).
  Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
  Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).
  Notation "[-[ c ]]" :=
   (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c)
   (at level 0, x at level 99).

  Variable spec_w_0   : [|w_0|] = 0.
  Variable spec_to_Z  : forall x, 0 <= [|x|] < wB.
  Variable spec_w_0W : forall l, [[w_0W l]] = [|l|].
  Variable spec_w_div32 : forall a1 a2 a3 b1 b2,
     wB/2 <= [|b1|] ->
     [[WW a1 a2]] < [[WW b1 b2]] ->
     let (q,r) := w_div32 a1 a2 a3 b1 b2 in
     [|a1|] * wwB + [|a2|] * wB  + [|a3|] =
        [|q|] *  ([|b1|] * wB + [|b2|])  + [[r]] /\
     0 <= [[r]] < [|b1|] * wB + [|b2|].
  Variable spec_ww_1 : [[ww_1]] = 1.
  Variable spec_ww_compare :  forall x y,
    ww_compare x y = Zcompare [[x]] [[y]].
  Variable spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB.

  Theorem wwB_div: wwB  = 2 * (wwB / 2).
  Proof.
   rewrite wwB_div_2; rewrite  Zmult_assoc; rewrite  wB_div_2; auto.
   rewrite <- Zpower_2; apply wwB_wBwB.
  Qed.

  Ltac Spec_w_to_Z x :=
   let H:= fresh "HH" in
   assert (H:= spec_to_Z x).
  Ltac Spec_ww_to_Z x :=
   let H:= fresh "HH" in
   assert (H:= spec_ww_to_Z w_digits w_to_Z spec_to_Z x).

  Theorem   spec_ww_div21 : forall a1 a2 b,
     wwB/2 <= [[b]] ->
     [[a1]] < [[b]] ->
     let (q,r) := ww_div21 a1 a2 b in
     [[a1]] *wwB+[[a2]] = [[q]] *  [[b]] + [[r]] /\ 0 <= [[r]] < [[b]].
  Proof.
   assert (U:= lt_0_wB w_digits).
   assert (U1:= lt_0_wwB w_digits).
   intros a1 a2 b H Hlt; unfold ww_div21.
   Spec_ww_to_Z b; assert (Eq: 0 < [[b]]).    Spec_ww_to_Z a1;omega.
   generalize Hlt H ;clear Hlt H;case a1.
   intros H1 H2;simpl in H1;Spec_ww_to_Z a2.
   rewrite spec_ww_compare. case Zcompare_spec;
   simpl;try rewrite spec_ww_1;autorewrite with rm10; intros;zarith.
   rewrite spec_ww_sub;simpl. rewrite Zmod_small;zarith.
   split. ring.
   assert (wwB <= 2*[[b]]);zarith.
   rewrite wwB_div;zarith.
   intros a1h a1l.  Spec_w_to_Z a1h;Spec_w_to_Z a1l. Spec_ww_to_Z a2.
   destruct a2 as [ |a3 a4];
    (destruct b as [ |b1 b2];[unfold Zle in Eq;discriminate Eq|idtac]);
   try (Spec_w_to_Z a3; Spec_w_to_Z a4); Spec_w_to_Z b1; Spec_w_to_Z b2;
   intros Hlt H;  match goal with |-context [w_div32 ?X ?Y ?Z ?T ?U] =>
     generalize (@spec_w_div32 X Y Z T U); case (w_div32 X Y Z T U);
     intros q1 r H0
   end; (assert (Eq1: wB / 2 <= [|b1|]);[
    apply (@beta_lex (wB / 2) 0 [|b1|] [|b2|] wB); auto with zarith;
    autorewrite with rm10;repeat rewrite (Zmult_comm wB);
    rewrite <- wwB_div_2; trivial
   | generalize (H0 Eq1 Hlt);clear H0;destruct r as [ |r1 r2];simpl;
     try rewrite spec_w_0; try rewrite spec_w_0W;repeat rewrite Zplus_0_r;
     intros (H1,H2) ]).
   split;[rewrite wwB_wBwB; rewrite Zpower_2 | trivial].
   rewrite Zmult_assoc;rewrite Zmult_plus_distr_l;rewrite <- Zmult_assoc;
   rewrite <- Zpower_2; rewrite <- wwB_wBwB;rewrite H1;ring.
   destruct H2 as (H2,H3);match goal with |-context [w_div32 ?X ?Y ?Z ?T ?U] =>
     generalize (@spec_w_div32 X Y Z T U); case (w_div32 X Y Z T U);
     intros q r H0;generalize (H0 Eq1 H3);clear H0;intros (H4,H5) end.
   split;[rewrite wwB_wBwB | trivial].
   rewrite Zpower_2.
   rewrite Zmult_assoc;rewrite Zmult_plus_distr_l;rewrite <- Zmult_assoc;
   rewrite <- Zpower_2.
   rewrite <- wwB_wBwB;rewrite H1.
   rewrite spec_w_0 in H4;rewrite Zplus_0_r in H4.
   repeat rewrite Zmult_plus_distr_l. rewrite <- (Zmult_assoc [|r1|]).
   rewrite <- Zpower_2; rewrite <- wwB_wBwB;rewrite H4;simpl;ring.
   split;[rewrite wwB_wBwB | split;zarith].
   replace (([|a1h|] * wB + [|a1l|]) * wB^2 + ([|a3|] * wB + [|a4|]))
   with (([|a1h|] * wwB + [|a1l|] * wB + [|a3|])*wB+ [|a4|]).
   rewrite H1;ring. rewrite wwB_wBwB;ring.
   change [|a4|] with (0*wB+[|a4|]);apply beta_lex_inv;zarith.
   assert (1 <= wB/2);zarith.
    assert (H_:= wB_pos w_digits);apply Zdiv_le_lower_bound;zarith.
   destruct H2 as (H2,H3);match goal with |-context [w_div32 ?X ?Y ?Z ?T ?U] =>
     generalize (@spec_w_div32 X Y Z T U); case (w_div32 X Y Z T U);
     intros q r H0;generalize (H0 Eq1 H3);clear H0;intros (H4,H5) end.
   split;trivial.
   replace (([|a1h|] * wB + [|a1l|]) * wwB + ([|a3|] * wB + [|a4|])) with
   (([|a1h|] * wwB + [|a1l|] * wB + [|a3|])*wB + [|a4|]);
   [rewrite H1 | rewrite wwB_wBwB;ring].
   replace (([|q1|]*([|b1|]*wB+[|b2|])+([|r1|]*wB+[|r2|]))*wB+[|a4|]) with
   (([|q1|]*([|b1|]*wB+[|b2|]))*wB+([|r1|]*wwB+[|r2|]*wB+[|a4|]));
   [rewrite H4;simpl|rewrite wwB_wBwB];ring.
  Qed.

End DoubleDiv21.

Section DoubleDivGt.
 Variable w : Type.
 Variable w_digits : positive.
 Variable w_0 : w.

 Variable w_WW : w -> w -> zn2z w.
 Variable w_0W : w -> zn2z w.
 Variable w_compare : w -> w -> comparison.
 Variable w_eq0 : w -> bool.
 Variable w_opp_c : w -> carry w.
 Variable w_opp w_opp_carry : w -> w.
 Variable w_sub_c : w -> w -> carry w.
 Variable w_sub w_sub_carry : w -> w -> w.

 Variable w_div_gt : w -> w -> w*w.
 Variable w_mod_gt : w -> w -> w.
 Variable w_gcd_gt : w -> w -> w.
 Variable w_add_mul_div : w -> w -> w -> w.
 Variable w_head0 : w -> w.
 Variable w_div21 : w -> w -> w -> w * w.
 Variable w_div32 : w -> w -> w -> w -> w -> w * zn2z w.

 Variable _ww_zdigits : zn2z w.
 Variable ww_1 : zn2z w.
 Variable ww_add_mul_div : zn2z w -> zn2z w -> zn2z w -> zn2z w.

 Variable w_zdigits : w.

 Definition ww_div_gt_aux ah al bh bl :=
  Eval lazy beta iota delta [ww_sub ww_opp] in
    let p := w_head0 bh in
    match w_compare p w_0 with
    | Gt =>
      let b1 := w_add_mul_div p bh bl in
      let b2 := w_add_mul_div p bl w_0 in
      let a1 := w_add_mul_div p w_0 ah in
      let a2 := w_add_mul_div p ah al in
      let a3 := w_add_mul_div p al w_0 in
      let (q,r) := w_div32 a1 a2 a3 b1 b2 in
      (WW w_0 q, ww_add_mul_div
        (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c
            w_opp w_sub w_sub_carry _ww_zdigits (w_0W p)) W0 r)
    | _ => (ww_1, ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c
            w_opp w_sub w_sub_carry (WW ah al) (WW bh bl))
    end.

 Definition ww_div_gt a b :=
  Eval lazy beta iota delta [ww_div_gt_aux double_divn1
  double_divn1_p double_divn1_p_aux double_divn1_0 double_divn1_0_aux
  double_split double_0 double_WW] in
  match a, b with
  | W0, _ => (W0,W0)
  | _, W0 => (W0,W0)
  | WW ah al, WW bh bl =>
    if w_eq0 ah then
     let (q,r) := w_div_gt al bl in
     (WW w_0 q, w_0W r)
    else
     match w_compare w_0 bh with
     | Eq =>
       let(q,r):=
        double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21
                  w_compare w_sub 1 a bl in
       (q, w_0W r)
     | Lt => ww_div_gt_aux ah al bh bl
     | Gt => (W0,W0) (* cas absurde *)
     end
  end.

 Definition ww_mod_gt_aux ah al bh bl :=
  Eval lazy beta iota delta [ww_sub ww_opp] in
    let p := w_head0 bh in
    match w_compare p w_0 with
    | Gt =>
      let b1 := w_add_mul_div p bh bl in
      let b2 := w_add_mul_div p bl w_0 in
      let a1 := w_add_mul_div p w_0 ah in
      let a2 := w_add_mul_div p ah al in
      let a3 := w_add_mul_div p al w_0 in
      let (q,r) := w_div32 a1 a2 a3 b1 b2 in
      ww_add_mul_div (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c
         w_opp w_sub w_sub_carry _ww_zdigits (w_0W p)) W0 r
    | _ =>
      ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c
         w_opp w_sub w_sub_carry (WW ah al) (WW bh bl)
    end.

 Definition ww_mod_gt a b :=
  Eval lazy beta iota delta [ww_mod_gt_aux double_modn1
  double_modn1_p double_modn1_p_aux double_modn1_0 double_modn1_0_aux
  double_split double_0 double_WW snd] in
  match a, b with
  | W0, _ => W0
  | _, W0 => W0
  | WW ah al, WW bh bl =>
    if w_eq0 ah then w_0W (w_mod_gt al bl)
    else
     match w_compare w_0 bh with
     | Eq =>
       w_0W (double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21
             w_compare w_sub 1 a bl)
     | Lt => ww_mod_gt_aux ah al bh bl
     | Gt => W0 (* cas absurde *)
     end
  end.

  Definition ww_gcd_gt_body (cont: w->w->w->w->zn2z w) (ah al bh bl: w) :=
   Eval lazy beta iota delta [ww_mod_gt_aux double_modn1
   double_modn1_p double_modn1_p_aux double_modn1_0 double_modn1_0_aux
   double_split double_0 double_WW snd] in
    match w_compare w_0 bh with
    | Eq =>
      match w_compare w_0 bl with
      | Eq => WW ah al (* normalement n'arrive pas si forme normale *)
      | Lt =>
	let m := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21
                   w_compare w_sub 1 (WW ah al) bl in
        WW w_0 (w_gcd_gt bl m)
      | Gt => W0 (* absurde *)
      end
    | Lt =>
      let m := ww_mod_gt_aux ah al bh bl in
      match m with
      | W0 => WW bh bl
      | WW mh ml =>
        match w_compare w_0 mh with
        | Eq =>
          match w_compare w_0 ml with
          | Eq => WW bh bl
          | _  =>
            let r := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21
                      w_compare w_sub 1 (WW bh bl) ml in
            WW w_0 (w_gcd_gt ml r)
          end
        | Lt =>
          let r := ww_mod_gt_aux bh bl mh ml in
          match r with
          | W0 => m
          | WW rh rl => cont mh ml rh rl
          end
        | Gt => W0 (* absurde *)
        end
      end
    | Gt => W0 (* absurde *)
    end.

  Fixpoint ww_gcd_gt_aux
     (p:positive) (cont: w -> w -> w -> w -> zn2z w) (ah al bh bl : w)
        {struct p} : zn2z w :=
    ww_gcd_gt_body
       (fun mh ml rh rl => match p with
        | xH => cont mh ml rh rl
        | xO p => ww_gcd_gt_aux p (ww_gcd_gt_aux p cont) mh ml rh rl
        | xI p => ww_gcd_gt_aux p (ww_gcd_gt_aux p cont) mh ml rh rl
        end) ah al bh bl.

  (* Proof *)

  Variable w_to_Z : w -> Z.
  Notation wB  := (base w_digits).
  Notation wwB := (base (ww_digits w_digits)).
  Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
  Notation "[-| c |]" :=
   (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99).

  Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).

  Variable spec_w_0   : [|w_0|] = 0.
  Variable spec_to_Z  : forall x, 0 <= [|x|] < wB.
  Variable spec_to_w_Z  : forall x, 0 <= [[x]] < wwB.

  Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|].
  Variable spec_w_0W : forall l, [[w_0W l]] = [|l|].
  Variable spec_compare :
     forall x y, w_compare x y = Zcompare [|x|] [|y|].
  Variable spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0.

  Variable spec_opp_c : forall x, [-|w_opp_c x|] = -[|x|].
  Variable spec_opp : forall x, [|w_opp x|] = (-[|x|]) mod wB.
  Variable spec_opp_carry : forall x, [|w_opp_carry x|] = wB - [|x|] - 1.

  Variable spec_sub_c : forall x y, [-|w_sub_c x y|] = [|x|] - [|y|].
  Variable spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB.
  Variable spec_sub_carry :
	 forall x y, [|w_sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB.

  Variable spec_div_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] ->
      let (q,r) := w_div_gt a b in
      [|a|] = [|q|] * [|b|] + [|r|] /\
      0 <= [|r|] < [|b|].
  Variable spec_mod_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] ->
      [|w_mod_gt a b|] = [|a|] mod [|b|].
  Variable spec_gcd_gt : forall a b, [|a|] > [|b|] ->
      Zis_gcd [|a|] [|b|] [|w_gcd_gt a b|].

  Variable spec_add_mul_div : forall x y p,
       [|p|] <= Zpos w_digits ->
       [| w_add_mul_div p x y |] =
         ([|x|] * (2 ^ ([|p|])) +
          [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB.
  Variable spec_head0  : forall x,  0 < [|x|] ->
	 wB/ 2 <= 2 ^ [|w_head0 x|] * [|x|] < wB.

  Variable spec_div21 : forall a1 a2 b,
      wB/2 <= [|b|] ->
      [|a1|] < [|b|] ->
      let (q,r) := w_div21 a1 a2 b in
      [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\
      0 <= [|r|] < [|b|].

  Variable spec_w_div32 : forall a1 a2 a3 b1 b2,
     wB/2 <= [|b1|] ->
     [[WW a1 a2]] < [[WW b1 b2]] ->
     let (q,r) := w_div32 a1 a2 a3 b1 b2 in
     [|a1|] * wwB + [|a2|] * wB  + [|a3|] =
        [|q|] *  ([|b1|] * wB + [|b2|])  + [[r]] /\
     0 <= [[r]] < [|b1|] * wB + [|b2|].

  Variable spec_w_zdigits: [|w_zdigits|] = Zpos w_digits.

  Variable spec_ww_digits_ : [[_ww_zdigits]] = Zpos (xO w_digits).
  Variable spec_ww_1 : [[ww_1]] = 1.
  Variable spec_ww_add_mul_div : forall x y p,
       [[p]] <= Zpos (xO w_digits) ->
       [[ ww_add_mul_div p x y ]] =
         ([[x]] * (2^[[p]]) +
          [[y]] / (2^(Zpos (xO w_digits) - [[p]]))) mod wwB.

  Ltac Spec_w_to_Z x :=
   let H:= fresh "HH" in
   assert (H:= spec_to_Z x).

  Ltac Spec_ww_to_Z x :=
   let H:= fresh "HH" in
   assert (H:= spec_ww_to_Z w_digits w_to_Z spec_to_Z x).

  Lemma to_Z_div_minus_p : forall x p,
   0 < [|p|] < Zpos w_digits  ->
   0 <= [|x|] / 2 ^ (Zpos w_digits - [|p|]) < 2 ^ [|p|].
  Proof.
   intros x p H;Spec_w_to_Z x.
   split. apply Zdiv_le_lower_bound;zarith.
   apply Zdiv_lt_upper_bound;zarith.
   rewrite <- Zpower_exp;zarith.
   ring_simplify ([|p|] + (Zpos w_digits - [|p|])); unfold base in HH;zarith.
  Qed.
  Hint Resolve to_Z_div_minus_p : zarith.

  Lemma spec_ww_div_gt_aux : forall ah al bh bl,
      [[WW ah al]] > [[WW bh bl]] ->
      0 < [|bh|] ->
      let (q,r) := ww_div_gt_aux ah al bh bl in
      [[WW ah al]] = [[q]] * [[WW bh bl]] + [[r]] /\
      0 <= [[r]] < [[WW bh bl]].
  Proof.
   intros ah al bh bl Hgt Hpos;unfold ww_div_gt_aux.
   change
   (let (q, r) := let p := w_head0 bh in
    match w_compare p w_0 with
    | Gt =>
      let b1 := w_add_mul_div p bh bl in
      let b2 := w_add_mul_div p bl w_0 in
      let a1 := w_add_mul_div p w_0 ah in
      let a2 := w_add_mul_div p ah al in
      let a3 := w_add_mul_div p al w_0 in
      let (q,r) := w_div32 a1 a2 a3 b1 b2 in
      (WW w_0 q, ww_add_mul_div
        (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c
            w_opp w_sub w_sub_carry _ww_zdigits (w_0W p)) W0 r)
    | _ => (ww_1, ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c
            w_opp w_sub w_sub_carry (WW ah al) (WW bh bl))
    end in [[WW ah al]]=[[q]]*[[WW bh bl]]+[[r]] /\ 0 <=[[r]]< [[WW bh bl]]).
   assert (Hh := spec_head0 Hpos).
   lazy zeta.
   rewrite spec_compare; case Zcompare_spec;
    rewrite spec_w_0; intros HH.
   generalize Hh; rewrite HH; simpl Zpower;
        rewrite Zmult_1_l; intros (HH1, HH2); clear HH.
   assert (wwB <= 2*[[WW bh bl]]).
    apply Zle_trans with (2*[|bh|]*wB).
    rewrite wwB_wBwB; rewrite Zpower_2; apply Zmult_le_compat_r; zarith.
    rewrite <- wB_div_2; apply Zmult_le_compat_l; zarith.
    simpl ww_to_Z;rewrite Zmult_plus_distr_r;rewrite Zmult_assoc.
    Spec_w_to_Z bl;zarith.
   Spec_ww_to_Z (WW ah al).
   rewrite spec_ww_sub;eauto.
   simpl;rewrite spec_ww_1;rewrite Zmult_1_l;simpl.
   simpl ww_to_Z in Hgt, H, HH;rewrite Zmod_small;split;zarith.
   case (spec_to_Z (w_head0 bh)); auto with zarith.
   assert ([|w_head0 bh|] < Zpos w_digits).
    destruct (Z_lt_ge_dec [|w_head0 bh|]  (Zpos w_digits));trivial.
    exfalso.
    assert (2 ^ [|w_head0 bh|] * [|bh|] >= wB);auto with zarith.
    apply Zle_ge; replace wB with (wB * 1);try ring.
    Spec_w_to_Z bh;apply Zmult_le_compat;zarith.
    unfold base;apply Zpower_le_monotone;zarith.
   assert (HHHH : 0 < [|w_head0 bh|] < Zpos w_digits); auto with zarith.
   assert (Hb:= Zlt_le_weak _ _ H).
   generalize (spec_add_mul_div w_0 ah Hb)
    (spec_add_mul_div ah al Hb)
    (spec_add_mul_div al w_0 Hb)
    (spec_add_mul_div bh bl Hb)
    (spec_add_mul_div bl w_0  Hb);
   rewrite spec_w_0; repeat rewrite Zmult_0_l;repeat rewrite Zplus_0_l;
   rewrite Zdiv_0_l;repeat rewrite Zplus_0_r.
   Spec_w_to_Z ah;Spec_w_to_Z bh.
   unfold base;repeat rewrite Zmod_shift_r;zarith.
   assert (H3:=to_Z_div_minus_p ah HHHH);assert(H4:=to_Z_div_minus_p al HHHH);
   assert (H5:=to_Z_div_minus_p bl HHHH).
   rewrite Zmult_comm in Hh.
   assert (2^[|w_head0 bh|] < wB). unfold base;apply Zpower_lt_monotone;zarith.
   unfold base in H0;rewrite Zmod_small;zarith.
   fold wB; rewrite (Zmod_small ([|bh|] * 2 ^ [|w_head0 bh|]));zarith.
   intros U1 U2 U3 V1 V2.
   generalize (@spec_w_div32 (w_add_mul_div (w_head0 bh) w_0 ah)
               (w_add_mul_div (w_head0 bh) ah al)
               (w_add_mul_div (w_head0 bh) al w_0)
               (w_add_mul_div (w_head0 bh) bh bl)
               (w_add_mul_div (w_head0 bh) bl w_0)).
   destruct (w_div32 (w_add_mul_div (w_head0 bh) w_0 ah)
              (w_add_mul_div (w_head0 bh) ah al)
              (w_add_mul_div (w_head0 bh) al w_0)
              (w_add_mul_div (w_head0 bh) bh bl)
              (w_add_mul_div (w_head0 bh) bl w_0)) as (q,r).
   rewrite V1;rewrite V2. rewrite Zmult_plus_distr_l.
   rewrite <- (Zplus_assoc ([|bh|] * 2 ^ [|w_head0 bh|] * wB)).
   unfold base;rewrite <- shift_unshift_mod;zarith. fold wB.
   replace ([|bh|] * 2 ^ [|w_head0 bh|] * wB + [|bl|] * 2 ^ [|w_head0 bh|]) with
    ([[WW bh bl]] * 2^[|w_head0 bh|]). 2:simpl;ring.
   fold wwB. rewrite wwB_wBwB. rewrite Zpower_2. rewrite U1;rewrite U2;rewrite U3.
   rewrite Zmult_assoc. rewrite Zmult_plus_distr_l.
   rewrite (Zplus_assoc ([|ah|] / 2^(Zpos(w_digits) - [|w_head0 bh|])*wB * wB)).
   rewrite <- Zmult_plus_distr_l.  rewrite <- Zplus_assoc.
   unfold base;repeat rewrite <- shift_unshift_mod;zarith. fold wB.
   replace ([|ah|] * 2 ^ [|w_head0 bh|] * wB + [|al|] * 2 ^ [|w_head0 bh|]) with
    ([[WW ah al]] * 2^[|w_head0 bh|]). 2:simpl;ring.
   intros Hd;destruct Hd;zarith.
   simpl. apply beta_lex_inv;zarith. rewrite U1;rewrite V1.
   assert ([|ah|] / 2 ^ (Zpos (w_digits) - [|w_head0 bh|]) < wB/2);zarith.
   apply Zdiv_lt_upper_bound;zarith.
   unfold base.
   replace (2^Zpos (w_digits)) with (2^(Zpos (w_digits) - 1)*2).
   rewrite Z_div_mult;zarith.  rewrite <- Zpower_exp;zarith.
   apply Zlt_le_trans with wB;zarith.
   unfold base;apply Zpower_le_monotone;zarith.
   pattern 2 at 2;replace 2 with (2^1);trivial.
   rewrite <- Zpower_exp;zarith. ring_simplify (Zpos (w_digits) - 1 + 1);trivial.
   change [[WW w_0 q]] with ([|w_0|]*wB+[|q|]);rewrite spec_w_0;rewrite
   Zmult_0_l;rewrite Zplus_0_l.
   replace [[ww_add_mul_div (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry
       _ww_zdigits (w_0W (w_head0 bh))) W0 r]] with ([[r]]/2^[|w_head0 bh|]).
   assert (0 < 2^[|w_head0 bh|]). apply Zpower_gt_0;zarith.
   split.
   rewrite <- (Z_div_mult [[WW ah al]] (2^[|w_head0 bh|]));zarith.
   rewrite H1;rewrite Zmult_assoc;apply Z_div_plus_l;trivial.
   split;[apply Zdiv_le_lower_bound| apply Zdiv_lt_upper_bound];zarith.
   rewrite spec_ww_add_mul_div.
   rewrite spec_ww_sub; auto with zarith.
   rewrite spec_ww_digits_.
   change (Zpos (xO (w_digits))) with (2*Zpos (w_digits));zarith.
   simpl ww_to_Z;rewrite Zmult_0_l;rewrite Zplus_0_l.
   rewrite spec_w_0W.
   rewrite (fun x y => Zmod_small (x-y)); auto with zarith.
   ring_simplify (2 * Zpos w_digits - (2 * Zpos w_digits - [|w_head0 bh|])).
   rewrite Zmod_small;zarith.
   split;[apply Zdiv_le_lower_bound| apply Zdiv_lt_upper_bound];zarith.
   Spec_ww_to_Z r.
   apply Zlt_le_trans with wwB;zarith.
   rewrite <- (Zmult_1_r wwB);apply Zmult_le_compat;zarith.
   split; auto with zarith.
   apply Zle_lt_trans with (2 * Zpos w_digits); auto with zarith.
   unfold base, ww_digits; rewrite (Zpos_xO w_digits).
   apply Zpower2_lt_lin; auto with zarith.
   rewrite spec_ww_sub; auto with zarith.
   rewrite spec_ww_digits_; rewrite spec_w_0W.
   rewrite Zmod_small;zarith.
   rewrite Zpos_xO; split; auto with zarith.
   apply Zle_lt_trans with (2 * Zpos w_digits); auto with zarith.
   unfold base, ww_digits; rewrite (Zpos_xO w_digits).
   apply Zpower2_lt_lin; auto with zarith.
   Qed.

  Lemma spec_ww_div_gt : forall a b, [[a]] > [[b]] -> 0 < [[b]] ->
      let (q,r) := ww_div_gt a b in
      [[a]] = [[q]] * [[b]] + [[r]] /\
      0 <= [[r]] < [[b]].
  Proof.
   intros a b Hgt Hpos;unfold ww_div_gt.
   change (let (q,r) :=   match a, b with
  | W0, _ => (W0,W0)
  | _, W0 => (W0,W0)
  | WW ah al, WW bh bl =>
    if w_eq0 ah then
     let (q,r) := w_div_gt al bl in
     (WW w_0 q, w_0W r)
    else
     match w_compare w_0 bh with
     | Eq =>
       let(q,r):=
        double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21
                  w_compare w_sub 1 a bl in
       (q, w_0W r)
     | Lt => ww_div_gt_aux ah al bh bl
     | Gt => (W0,W0) (* cas absurde *)
     end
  end in [[a]] = [[q]] * [[b]] + [[r]] /\ 0 <= [[r]] < [[b]]).
   destruct a as [ |ah al]. simpl in Hgt;omega.
   destruct b as [ |bh bl]. simpl in Hpos;omega.
   Spec_w_to_Z ah; Spec_w_to_Z al; Spec_w_to_Z bh; Spec_w_to_Z bl.
   assert (H:=@spec_eq0 ah);destruct (w_eq0 ah).
   simpl ww_to_Z;rewrite H;trivial. simpl in Hgt;rewrite H in Hgt;trivial.
   assert ([|bh|] <= 0).
   apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith.
   assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;rewrite H1;simpl in Hgt.
   simpl. simpl in Hpos;rewrite H1 in Hpos;simpl in Hpos.
   assert (H2:=spec_div_gt Hgt Hpos);destruct (w_div_gt al bl).
   repeat rewrite spec_w_0W;simpl;rewrite spec_w_0;simpl;trivial.
   clear H.
   rewrite spec_compare; case Zcompare_spec; intros Hcmp.
   rewrite spec_w_0 in Hcmp. change [[WW bh bl]] with ([|bh|]*wB+[|bl|]).
   rewrite <- Hcmp;rewrite Zmult_0_l;rewrite Zplus_0_l.
   simpl in Hpos;rewrite <- Hcmp in Hpos;simpl in Hpos.
   assert (H2:= @spec_double_divn1 w w_digits w_zdigits w_0 w_WW w_head0 w_add_mul_div
    w_div21 w_compare w_sub w_to_Z spec_to_Z spec_w_zdigits spec_w_0 spec_w_WW spec_head0
    spec_add_mul_div spec_div21 spec_compare spec_sub 1 (WW ah al) bl Hpos).
   destruct (double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21
              w_compare w_sub 1
             (WW ah al) bl).
   rewrite spec_w_0W;unfold ww_to_Z;trivial.
   apply spec_ww_div_gt_aux;trivial. rewrite spec_w_0 in Hcmp;trivial.
   rewrite spec_w_0 in Hcmp;exfalso;omega.
  Qed.

  Lemma spec_ww_mod_gt_aux_eq : forall ah al bh bl,
   ww_mod_gt_aux ah al bh bl = snd (ww_div_gt_aux ah al bh bl).
  Proof.
   intros ah al bh bl. unfold ww_mod_gt_aux, ww_div_gt_aux.
   case w_compare; auto.
   case w_div32; auto.
  Qed.

  Lemma spec_ww_mod_gt_aux : forall ah al bh bl,
   [[WW ah al]] > [[WW bh bl]] ->
    0 < [|bh|] ->
    [[ww_mod_gt_aux ah al bh bl]] = [[WW ah al]] mod [[WW bh bl]].
  Proof.
   intros. rewrite spec_ww_mod_gt_aux_eq;trivial.
   assert (H3 := spec_ww_div_gt_aux ah al bl H H0).
   destruct (ww_div_gt_aux ah al bh bl) as (q,r);simpl. simpl in H,H3.
   destruct H3;apply Zmod_unique with [[q]];zarith.
   rewrite H1;ring.
  Qed.

  Lemma spec_w_mod_gt_eq : forall a b, [|a|] > [|b|] -> 0 <[|b|] ->
    [|w_mod_gt a b|] = [|snd (w_div_gt a b)|].
  Proof.
   intros a b Hgt Hpos.
   rewrite spec_mod_gt;trivial.
   assert (H:=spec_div_gt Hgt Hpos).
   destruct (w_div_gt a b) as (q,r);simpl.
   rewrite Zmult_comm in H;destruct H.
   symmetry;apply Zmod_unique with [|q|];trivial.
  Qed.

  Lemma spec_ww_mod_gt_eq : forall a b, [[a]] > [[b]] -> 0 < [[b]] ->
      [[ww_mod_gt a b]] = [[snd (ww_div_gt a b)]].
  Proof.
   intros a b Hgt Hpos.
   change (ww_mod_gt a b) with
   (match a, b with
  | W0, _ => W0
  | _, W0 => W0
  | WW ah al, WW bh bl =>
    if w_eq0 ah then w_0W (w_mod_gt al bl)
    else
     match w_compare w_0 bh with
     | Eq =>
       w_0W (double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21
             w_compare w_sub 1 a bl)
     | Lt => ww_mod_gt_aux ah al bh bl
     | Gt => W0 (* cas absurde *)
     end end).
   change (ww_div_gt a b) with
   (match a, b with
  | W0, _ => (W0,W0)
  | _, W0 => (W0,W0)
  | WW ah al, WW bh bl =>
    if w_eq0 ah then
     let (q,r) := w_div_gt al bl in
     (WW w_0 q, w_0W r)
    else
     match w_compare w_0 bh with
     | Eq =>
       let(q,r):=
        double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21
                  w_compare w_sub 1 a bl in
       (q, w_0W r)
     | Lt => ww_div_gt_aux ah al bh bl
     | Gt => (W0,W0) (* cas absurde *)
     end
  end).
   destruct a as [ |ah al];trivial.
   destruct b as [ |bh bl];trivial.
   Spec_w_to_Z ah; Spec_w_to_Z al; Spec_w_to_Z bh; Spec_w_to_Z bl.
   assert (H:=@spec_eq0 ah);destruct (w_eq0 ah).
   simpl in Hgt;rewrite H in Hgt;trivial.
   assert ([|bh|] <= 0).
   apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith.
   assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;simpl in Hgt.
   simpl in Hpos;rewrite H1 in Hpos;simpl in Hpos.
   rewrite spec_w_0W;rewrite spec_w_mod_gt_eq;trivial.
   destruct (w_div_gt al bl);simpl;rewrite spec_w_0W;trivial.
   clear H.
   rewrite spec_compare; case Zcompare_spec; intros H2.
   rewrite (@spec_double_modn1_aux w w_zdigits w_0 w_WW w_head0 w_add_mul_div
            w_div21 w_compare w_sub w_to_Z spec_w_0 spec_compare 1 (WW ah al) bl).
   destruct (double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub 1
             (WW ah al) bl);simpl;trivial.
   rewrite spec_ww_mod_gt_aux_eq;trivial;symmetry;trivial.
   trivial.
  Qed.

  Lemma spec_ww_mod_gt : forall a b, [[a]] > [[b]] -> 0 < [[b]] ->
      [[ww_mod_gt a b]] = [[a]] mod [[b]].
  Proof.
   intros a b Hgt Hpos.
   assert (H:= spec_ww_div_gt a b Hgt Hpos).
   rewrite (spec_ww_mod_gt_eq a b Hgt Hpos).
   destruct (ww_div_gt a b)as(q,r);destruct H.
   apply Zmod_unique with[[q]];simpl;trivial.
   rewrite Zmult_comm;trivial.
  Qed.

  Lemma Zis_gcd_mod : forall a b d,
   0 < b -> Zis_gcd b (a mod b) d -> Zis_gcd a b d.
  Proof.
   intros a b d H H1; apply Zis_gcd_for_euclid with (a/b).
   pattern a at 1;rewrite (Z_div_mod_eq a b).
   ring_simplify (b * (a / b) + a mod b - a / b * b);trivial. zarith.
  Qed.

  Lemma spec_ww_gcd_gt_aux_body :
   forall ah al bh bl n cont,
    [[WW bh bl]] <= 2^n ->
    [[WW ah al]] > [[WW bh bl]] ->
    (forall xh xl yh yl,
     [[WW xh xl]] > [[WW yh yl]] -> [[WW yh yl]] <= 2^(n-1) ->
     Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) ->
    Zis_gcd [[WW ah al]] [[WW bh bl]] [[ww_gcd_gt_body cont ah al bh bl]].
  Proof.
   intros ah al bh bl n cont Hlog Hgt Hcont.
   change (ww_gcd_gt_body cont ah al bh bl) with (match w_compare w_0 bh with
    | Eq =>
      match w_compare w_0 bl with
      | Eq => WW ah al (* normalement n'arrive pas si forme normale *)
      | Lt =>
	let m := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21
                   w_compare w_sub 1 (WW ah al) bl in
        WW w_0 (w_gcd_gt bl m)
      | Gt => W0 (* absurde *)
      end
    | Lt =>
      let m := ww_mod_gt_aux ah al bh bl in
      match m with
      | W0 => WW bh bl
      | WW mh ml =>
        match w_compare w_0 mh with
        | Eq =>
          match w_compare w_0 ml with
          | Eq => WW bh bl
          | _  =>
            let r := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21
                      w_compare w_sub 1 (WW bh bl) ml in
            WW w_0 (w_gcd_gt ml r)
          end
        | Lt =>
          let r := ww_mod_gt_aux bh bl mh ml in
          match r with
          | W0 => m
          | WW rh rl => cont mh ml rh rl
          end
        | Gt => W0 (* absurde *)
        end
      end
    | Gt => W0 (* absurde *)
    end).
   rewrite spec_compare, spec_w_0.
   case Zcompare_spec; intros Hbh.
   simpl ww_to_Z in *. rewrite <- Hbh.
   rewrite Zmult_0_l;rewrite Zplus_0_l.
   rewrite spec_compare, spec_w_0.
   case Zcompare_spec; intros Hbl.
   rewrite <- Hbl;apply Zis_gcd_0.
   simpl;rewrite spec_w_0;rewrite Zmult_0_l;rewrite Zplus_0_l.
   apply Zis_gcd_mod;zarith.
   change ([|ah|] * wB + [|al|]) with (double_to_Z w_digits w_to_Z 1 (WW ah al)).
   rewrite <- (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW w_head0 w_add_mul_div
    w_div21 w_compare w_sub w_to_Z spec_to_Z spec_w_zdigits spec_w_0 spec_w_WW spec_head0 spec_add_mul_div
    spec_div21 spec_compare spec_sub 1 (WW ah al) bl Hbl).
   apply spec_gcd_gt.
   rewrite  (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW); trivial.
   apply Zlt_gt;match goal with | |- ?x mod ?y < ?y =>
    destruct (Z_mod_lt x y);zarith end.
   Spec_w_to_Z bl;exfalso;omega.
   assert (H:= spec_ww_mod_gt_aux _ _ _ Hgt Hbh).
   assert (H2 : 0 < [[WW bh bl]]).
   simpl;Spec_w_to_Z bl. apply Zlt_le_trans with ([|bh|]*wB);zarith.
   apply Zmult_lt_0_compat;zarith.
   apply Zis_gcd_mod;trivial. rewrite <- H.
   simpl in *;destruct (ww_mod_gt_aux ah al bh bl) as [ |mh ml].
   simpl;apply Zis_gcd_0;zarith.
   rewrite spec_compare, spec_w_0; case Zcompare_spec; intros Hmh.
   simpl;rewrite <- Hmh;simpl.
   rewrite spec_compare, spec_w_0; case Zcompare_spec; intros Hml.
   rewrite <- Hml;simpl;apply Zis_gcd_0.
   simpl; rewrite spec_w_0; simpl.
   apply Zis_gcd_mod;zarith.
   change ([|bh|] * wB + [|bl|]) with (double_to_Z w_digits w_to_Z 1 (WW bh bl)).
   rewrite <- (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW w_head0 w_add_mul_div
   w_div21 w_compare w_sub w_to_Z spec_to_Z spec_w_zdigits spec_w_0 spec_w_WW spec_head0 spec_add_mul_div
   spec_div21 spec_compare spec_sub 1 (WW bh bl) ml Hml).
   apply spec_gcd_gt.
   rewrite  (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW); trivial.
   apply Zlt_gt;match goal with | |- ?x mod ?y < ?y =>
   destruct (Z_mod_lt x y);zarith end.
   Spec_w_to_Z ml;exfalso;omega.
   assert ([[WW bh bl]] > [[WW mh ml]]).
   rewrite H;simpl; apply Zlt_gt;match goal with | |- ?x mod ?y < ?y =>
   destruct (Z_mod_lt x y);zarith end.
   assert (H1:= spec_ww_mod_gt_aux _ _ _ H0 Hmh).
   assert (H3 : 0 < [[WW mh ml]]).
   simpl;Spec_w_to_Z ml. apply Zlt_le_trans with ([|mh|]*wB);zarith.
   apply Zmult_lt_0_compat;zarith.
   apply Zis_gcd_mod;zarith. simpl in *;rewrite <- H1.
   destruct (ww_mod_gt_aux bh bl mh ml) as [ |rh rl]. simpl; apply Zis_gcd_0.
   simpl;apply Hcont. simpl in H1;rewrite H1.
   apply Zlt_gt;match goal with | |- ?x mod ?y < ?y =>
   destruct (Z_mod_lt x y);zarith end.
   apply Zle_trans with (2^n/2).
   apply Zdiv_le_lower_bound;zarith.
   apply Zle_trans with ([|bh|] * wB + [|bl|]);zarith.
   assert (H3' := Z_div_mod_eq [[WW bh bl]] [[WW mh ml]] (Zlt_gt _ _ H3)).
   assert (H4' : 0 <= [[WW bh bl]]/[[WW mh ml]]).
   apply Zge_le;apply Z_div_ge0;zarith. simpl in *;rewrite H1.
   pattern ([|bh|] * wB + [|bl|]) at 2;rewrite H3'.
   destruct (Zle_lt_or_eq _ _ H4').
   assert (H6' : [[WW bh bl]] mod [[WW mh ml]] =
                  [[WW bh bl]] - [[WW mh ml]] * ([[WW bh bl]]/[[WW mh ml]])).
   simpl;pattern ([|bh|] * wB + [|bl|]) at 2;rewrite H3';ring. simpl in H6'.
   assert ([[WW mh ml]] <= [[WW mh ml]] * ([[WW bh bl]]/[[WW mh ml]])).
   simpl;pattern ([|mh|]*wB+[|ml|]) at 1;rewrite <- Zmult_1_r;zarith.
   simpl in *;assert (H8 := Z_mod_lt [[WW bh bl]] [[WW mh ml]]);simpl in H8;
    zarith.
   assert (H8 := Z_mod_lt [[WW bh bl]] [[WW mh ml]]);simpl in *;zarith.
   rewrite <- H4 in H3';rewrite Zmult_0_r in H3';simpl in H3';zarith.
   pattern n at 1;replace n with (n-1+1);try ring.
   rewrite Zpower_exp;zarith. change (2^1) with 2.
   rewrite Z_div_mult;zarith.
   assert (2^1 <= 2^n). change (2^1) with 2;zarith.
   assert (H7 := @Zpower_le_monotone_inv 2 1 n);zarith.
   Spec_w_to_Z mh;exfalso;zarith.
   Spec_w_to_Z bh;exfalso;zarith.
  Qed.

  Lemma spec_ww_gcd_gt_aux :
   forall p cont n,
   (forall xh xl yh yl,
     [[WW xh xl]] > [[WW yh yl]] ->
     [[WW yh yl]] <= 2^n ->
      Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) ->
   forall ah al bh bl , [[WW ah al]] > [[WW bh bl]] ->
     [[WW bh bl]] <= 2^(Zpos p + n) ->
     Zis_gcd [[WW ah al]] [[WW bh bl]]
        [[ww_gcd_gt_aux p cont ah al bh bl]].
  Proof.
   induction p;intros cont n Hcont ah al bh bl Hgt Hs;simpl ww_gcd_gt_aux.
   assert (0 < Zpos p). unfold Zlt;reflexivity.
   apply spec_ww_gcd_gt_aux_body with (n := Zpos (xI p) + n);
   trivial;rewrite Zpos_xI.
   intros. apply IHp with (n := Zpos p + n);zarith.
   intros. apply IHp with (n := n );zarith.
   apply Zle_trans with (2 ^ (2* Zpos p + 1+ n -1));zarith.
   apply Zpower_le_monotone2;zarith.
   assert (0 < Zpos p). unfold Zlt;reflexivity.
   apply spec_ww_gcd_gt_aux_body with (n := Zpos (xO p) + n );trivial.
   rewrite (Zpos_xO p).
   intros. apply IHp with (n := Zpos p + n - 1);zarith.
   intros. apply IHp with (n := n -1 );zarith.
   intros;apply Hcont;zarith.
   apply Zle_trans with (2^(n-1));zarith.
   apply Zpower_le_monotone2;zarith.
   apply Zle_trans with (2 ^ (Zpos p + n -1));zarith.
   apply Zpower_le_monotone2;zarith.
   apply Zle_trans with (2 ^ (2*Zpos p + n -1));zarith.
   apply Zpower_le_monotone2;zarith.
   apply spec_ww_gcd_gt_aux_body with (n := n+1);trivial.
   rewrite Zplus_comm;trivial.
   ring_simplify (n + 1 - 1);trivial.
  Qed.

End DoubleDivGt.

Section DoubleDiv.

 Variable w : Type.
 Variable w_digits : positive.
 Variable ww_1 : zn2z w.
 Variable ww_compare : zn2z w -> zn2z w -> comparison.

 Variable ww_div_gt : zn2z w -> zn2z w -> zn2z w * zn2z w.
 Variable ww_mod_gt : zn2z w -> zn2z w -> zn2z w.

 Definition ww_div a b :=
  match ww_compare a b with
  | Gt => ww_div_gt a b
  | Eq => (ww_1, W0)
  | Lt => (W0, a)
  end.

 Definition ww_mod a b :=
  match ww_compare a b with
  | Gt => ww_mod_gt a b
  | Eq => W0
  | Lt => a
  end.

  Variable w_to_Z : w -> Z.
  Notation wB  := (base w_digits).
  Notation wwB := (base (ww_digits w_digits)).
  Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
  Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).
  Variable spec_to_Z  : forall x, 0 <= [|x|] < wB.
  Variable spec_ww_1 : [[ww_1]] = 1.
  Variable spec_ww_compare :  forall x y,
    ww_compare x y = Zcompare [[x]] [[y]].
  Variable spec_ww_div_gt : forall a b, [[a]] > [[b]] -> 0 < [[b]] ->
      let (q,r) := ww_div_gt a b in
      [[a]] = [[q]] * [[b]] + [[r]] /\
      0 <= [[r]] < [[b]].
  Variable spec_ww_mod_gt : forall a b, [[a]] > [[b]] -> 0 < [[b]] ->
      [[ww_mod_gt a b]] = [[a]] mod [[b]].

  Ltac Spec_w_to_Z x :=
   let H:= fresh "HH" in
   assert (H:= spec_to_Z x).

  Ltac Spec_ww_to_Z x :=
   let H:= fresh "HH" in
   assert (H:= spec_ww_to_Z w_digits w_to_Z spec_to_Z x).

  Lemma spec_ww_div : forall a b, 0 < [[b]] ->
      let (q,r) := ww_div a b in
      [[a]] = [[q]] * [[b]] + [[r]] /\
      0 <= [[r]] < [[b]].
  Proof.
   intros a b Hpos;unfold ww_div.
   rewrite spec_ww_compare; case Zcompare_spec; intros.
   simpl;rewrite spec_ww_1;split;zarith.
   simpl;split;[ring|Spec_ww_to_Z a;zarith].
   apply spec_ww_div_gt;auto with zarith.
  Qed.

  Lemma  spec_ww_mod :  forall a b, 0 < [[b]] ->
      [[ww_mod a b]] = [[a]] mod [[b]].
  Proof.
   intros a b Hpos;unfold ww_mod.
   rewrite spec_ww_compare; case Zcompare_spec; intros.
   simpl;apply Zmod_unique with 1;try rewrite H;zarith.
   Spec_ww_to_Z a;symmetry;apply Zmod_small;zarith.
   apply spec_ww_mod_gt;auto with zarith.
  Qed.

 Variable w_0 : w.
 Variable w_1 : w.
 Variable w_compare : w -> w -> comparison.
 Variable w_eq0 : w -> bool.
 Variable w_gcd_gt : w -> w -> w.
 Variable _ww_digits : positive.
 Variable spec_ww_digits_ : _ww_digits = xO w_digits.
 Variable ww_gcd_gt_fix :
   positive -> (w -> w -> w -> w -> zn2z w) ->
             w -> w -> w -> w -> zn2z w.

  Variable spec_w_0   : [|w_0|] = 0.
  Variable spec_w_1   : [|w_1|] = 1.
  Variable spec_compare :
    forall x y, w_compare x y = Zcompare [|x|] [|y|].
  Variable spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0.
  Variable spec_gcd_gt : forall a b, [|a|] > [|b|] ->
      Zis_gcd [|a|] [|b|] [|w_gcd_gt a b|].
  Variable spec_gcd_gt_fix :
   forall p cont n,
   (forall xh xl yh yl,
     [[WW xh xl]] > [[WW yh yl]] ->
     [[WW yh yl]] <= 2^n ->
      Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) ->
   forall ah al bh bl , [[WW ah al]] > [[WW bh bl]] ->
     [[WW bh bl]] <= 2^(Zpos p + n) ->
     Zis_gcd [[WW ah al]] [[WW bh bl]]
        [[ww_gcd_gt_fix p cont ah al bh bl]].

 Definition gcd_cont (xh xl yh yl:w) :=
  match w_compare w_1 yl with
  | Eq => ww_1
  | _ => WW xh xl
  end.

  Lemma spec_gcd_cont : forall xh xl yh yl,
     [[WW xh xl]] > [[WW yh yl]] ->
     [[WW yh yl]] <= 1 ->
      Zis_gcd [[WW xh xl]] [[WW yh yl]] [[gcd_cont xh xl yh yl]].
  Proof.
   intros xh xl yh yl Hgt' Hle. simpl in Hle.
   assert ([|yh|] = 0).
    change 1 with (0*wB+1) in Hle.
    assert (0 <= 1 < wB). split;zarith. apply wB_pos.
    assert (H1:= beta_lex _ _ _ _ _ Hle (spec_to_Z yl) H).
    Spec_w_to_Z yh;zarith.
   unfold gcd_cont; rewrite spec_compare, spec_w_1.
   case Zcompare_spec; intros Hcmpy.
   simpl;rewrite H;simpl;
   rewrite spec_ww_1;rewrite <- Hcmpy;apply Zis_gcd_mod;zarith.
   rewrite <- (Zmod_unique ([|xh|]*wB+[|xl|]) 1 ([|xh|]*wB+[|xl|]) 0);zarith.
   rewrite H in Hle; exfalso;zarith.
   assert (H0 : [|yl|] = 0) by (Spec_w_to_Z yl;zarith).
   simpl. rewrite H0, H;simpl;apply Zis_gcd_0;trivial.
  Qed.

  Variable cont : w -> w -> w -> w -> zn2z w.
  Variable spec_cont : forall xh xl yh yl,
     [[WW xh xl]] > [[WW yh yl]] ->
     [[WW yh yl]] <= 1 ->
      Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]].

  Definition ww_gcd_gt a b :=
   match a, b with
   | W0, _ => b
   | _, W0 => a
   | WW ah al, WW bh bl =>
     if w_eq0 ah then (WW w_0 (w_gcd_gt al bl))
     else ww_gcd_gt_fix _ww_digits cont ah al bh bl
   end.

  Definition ww_gcd a b :=
   Eval lazy beta delta [ww_gcd_gt] in
   match ww_compare a b with
   | Gt => ww_gcd_gt a b
   | Eq => a
   | Lt => ww_gcd_gt b a
   end.

  Lemma spec_ww_gcd_gt : forall a b, [[a]] > [[b]] ->
      Zis_gcd [[a]] [[b]] [[ww_gcd_gt a b]].
  Proof.
   intros a b Hgt;unfold ww_gcd_gt.
   destruct a as [ |ah al]. simpl;apply Zis_gcd_sym;apply Zis_gcd_0.
   destruct b as [ |bh bl]. simpl;apply Zis_gcd_0.
   simpl in Hgt. generalize (@spec_eq0 ah);destruct (w_eq0 ah);intros.
   simpl;rewrite H in Hgt;trivial;rewrite H;trivial;rewrite spec_w_0;simpl.
   assert ([|bh|] <= 0).
   apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith.
   Spec_w_to_Z bh;assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;simpl in Hgt.
   rewrite H1;simpl;auto. clear H.
   apply spec_gcd_gt_fix with (n:= 0);trivial.
   rewrite Zplus_0_r;rewrite spec_ww_digits_.
   change (2 ^ Zpos (xO w_digits)) with wwB. Spec_ww_to_Z (WW bh bl);zarith.
  Qed.

  Lemma spec_ww_gcd : forall a b, Zis_gcd [[a]] [[b]] [[ww_gcd a b]].
  Proof.
   intros a b.
   change (ww_gcd a b) with
    (match ww_compare a b with
     | Gt => ww_gcd_gt a b
     | Eq => a
     | Lt => ww_gcd_gt b a
     end).
   rewrite spec_ww_compare; case Zcompare_spec; intros Hcmp.
   Spec_ww_to_Z b;rewrite Hcmp.
   apply Zis_gcd_for_euclid with 1;zarith.
   ring_simplify ([[b]] - 1 * [[b]]). apply Zis_gcd_0;zarith.
   apply Zis_gcd_sym;apply spec_ww_gcd_gt;zarith.
   apply spec_ww_gcd_gt;zarith.
  Qed.

End DoubleDiv.


From ITree Require Import
     Axioms
     ITree
     ITreeFacts
.

From ITree.Extra Require Export Secure.Labels.

From Paco Require Import paco.

(* will need more propositional constraints on Preorders *)

Section SecureUntimed.
  Context {E : Type -> Type} {R1 R2 : Type}.
  Context (Label : Preorder).
  Context (priv : forall A, E A -> L).
  Context (RR : R1 -> R2 -> Prop).

  Coercion is_true : bool >-> Sortclass.

  Variant secure_eqitF (b1 b2 : bool) (l : L) vclo (sim : itree E R1 -> itree E R2 -> Prop) : itree' E R1 -> itree' E R2 -> Prop :=

    (* eqitF constructors *)
    | secEqRet r1 r2 : RR r1 r2 -> secure_eqitF b1 b2 l vclo sim (RetF r1) (RetF r2)
    | secEqTau t1 t2 : sim t1 t2 -> secure_eqitF b1 b2 l vclo sim (TauF t1) (TauF t2)
    | secEqTauL t1 t2 (CHECK : b1) : sim t1 t2 -> secure_eqitF b1 b2 l vclo sim (TauF t1) (observe t2)
    | secEqTauR t1 t2 (CHECK : b2) : sim t1 t2 -> secure_eqitF b1 b2 l vclo sim (observe t1) (TauF t2)
    (* info_flow protecting coinductive constructors *)
    | EqVisPriv {A} (e : E A) k1 k2 (SECCHECK : leq (priv A e) l) :
        ((forall a, vclo sim (k1 a) (k2 a) : Prop)) -> secure_eqitF b1 b2 l vclo sim (VisF e k1) (VisF e k2)
    | EqVisUnPrivTauLCo {A} (e : E A) k1 t2 (SECCHECK : ~ leq (priv A e) l) (SIZECHECK : nonempty A) :
        (forall a, vclo sim (k1 a) t2) -> secure_eqitF b1 b2 l vclo sim (VisF e k1) (TauF t2)
    | EqVisUnPrivTauRCo {A} (e : E A) t1 k2 (SECCHECK : ~ leq (priv A e) l) (SIZECHECK : nonempty A) :
        (forall a, vclo sim t1 (k2 a)) -> secure_eqitF b1 b2 l vclo sim (TauF t1) (VisF e k2)
    | EqVisUnPrivVisCo {A B} (e1 : E A) (e2 : E B) k1 k2 (SECCHECK1 : ~ leq (priv A e1) l) (SECCHECK2 : ~ leq (priv B e2) l)
        (SIZECHECK1 : nonempty A ) (SIZECHECK2 : nonempty B) :
        (forall a b, vclo sim (k1 a) (k2 b)) -> secure_eqitF b1 b2 l vclo sim (VisF e1 k1) (VisF e2 k2)
    (* info_flow protecting inductive constructors *)
    | EqVisUnPrivLInd {A} (e : E A) k1 t2 (CHECK : b1) (SECCHECK : ~ leq (priv A e) l) (SIZECHECK : nonempty A) :
        (forall a, vclo sim (k1 a) t2) ->
        secure_eqitF b1 b2 l vclo sim (VisF e k1) (observe t2)
    | EqVisUnPrivRInd {A} (e : E A) t1 k2 (CHECK : b2) (SECCHECK : ~ leq (priv A e) l) (SIZECHECK : nonempty A) :
        (forall a, vclo sim t1 (k2 a) ) ->
        secure_eqitF b1 b2 l vclo sim (observe t1) (VisF e k2)
    (* info_flow protecting constructors for halting events, should capture the notion that a secret halt means
       that either it halted or it is performing some secret or silent computation and you can't tell which *)
    | EqVisUnprivHaltLTauR {A} (e : E A) k1 t2 (SECCHECK : ~ leq (priv A e) l ) (SIZECHECK : empty A) :
        sim (Vis e k1) t2 -> secure_eqitF b1 b2 l vclo sim (VisF e k1) (TauF t2)
    | EqVisUnprivHaltRTauL {A} (e : E A) t1 k2 (SECCHECK : ~ leq (priv A e) l ) (SIZECHECK : empty A) :
        sim t1 (Vis e k2) -> secure_eqitF b1 b2  l vclo sim (TauF t1) (VisF e k2)
    | EqVisUnprivHaltLVisR {A B} (e1 : E A) (e2 : E B) k1 k2 (SECCHECK1 : ~ leq (priv A e1) l) (SECCHECK2 : ~ leq (priv B e2) l)
            (SIZECHECK : empty A) :
      (forall b, vclo sim (Vis e1 k1) (k2 b) ) -> secure_eqitF b1 b2 l vclo sim (VisF e1 k1) (VisF e2 k2)
    | EqVisUnprivHaltRVisL {A B} (e1 : E A) (e2 : E B) k1 k2 (SECCHECK1 : ~ leq (priv A e1) l) (SECCHECK2 : ~ leq (priv B e2) l)
            (SIZECHECK : empty B) :
        (forall a, vclo sim (k1 a) (Vis e2 k2)) -> secure_eqitF b1 b2 l vclo sim (VisF e1 k1) (VisF e2 k2)
  .

  Hint Constructors secure_eqitF : itree.

  Definition secure_eqit_ (b1 b2 : bool) (l : L) vclo (sim : itree E R1 -> itree E R2 -> Prop) : itree E R1 -> itree E R2 -> Prop :=
    fun t1 t2 => secure_eqitF b1 b2 l vclo sim (observe t1) (observe t2).

  Hint Unfold secure_eqit_ : itree.

  Lemma secure_eqitF_mono b1 b2 l x0 x1 vclo vclo' sim sim'
        (IN: secure_eqitF b1 b2 l vclo sim x0 x1)
        (MON: monotone2 vclo)
        (LEc: vclo <3= vclo')
        (LE: sim <2= sim'):
    secure_eqitF b1 b2 l vclo' sim' x0 x1.
  Proof.
    intros. induction IN; eauto with itree.
  Qed.

  Lemma secure_eqit_mono b1 b2 l vclo (MON: monotone2 vclo) : monotone2 (secure_eqit_ b1 b2 l vclo).
  Proof.
    do 2 red. intros; eapply secure_eqitF_mono; eauto.
  Qed.

  Hint Resolve secure_eqit_mono : paco.

  Definition eqit_secure b1 b2 l := paco2 (secure_eqit_ b1 b2 l id) bot2.

  (* want and eqitC_secure which could help prove some interesting stuff

   *)

  (*
    Note that this is not reflexive (think it is symmetric and transitive)
    Suppose SecureFlip : E bool has privilege 1 and trigger SecureFlip is
    observed at privilege 0. We end to prove eqit_secure false false 0 of it
    requires us to show forall a b, eqit_secure false false 0 (Ret a) (Ret b)
    this is false, suppose a = true and b = false and the relation is equality

   *)

End SecureUntimed.

#[export] Hint Resolve secure_eqit_mono : paco.

#[export] Hint Constructors secure_eqitF : itree.

Definition NatPreorder : Preorder :=
  {|
  L := nat;
  leq := fun n m => n <= m
  |}.

Section SecureUntimedUnReflexive.
(*
  Variant NonDet : Type -> Type :=
    | SecureFlip : NonDet bool
    | PublicOut : NonDet unit
    | Halt : NonDet void

.

(*
CoInductive itree E R :=
...
| Vis {A : Type} (e : E A) (k : A -> itree E R)

suppose A := void

k ≅ empty_cont

bind (Vis Halt k1) k2 ≅ Vis Halt k1

E := HaltE unit

Definition halt : itree E R := Vis HaltE (fun _ => Tau Tau ...)

*)

  Definition priv_counter : forall A, NonDet A -> nat :=
    fun _ e =>
      match e with
      | SecureFlip => 1
      | PublicOut => 0
      | Halt => 10
      end.

  Variant Exc : Type -> Type :=
    Throw : Exc void.

  Definition refl_counter : itree NonDet bool := trigger SecureFlip. (* b := Flip; return b *)

  Lemma refl_counter_counter : ~ eqit_secure NatPreorder priv_counter eq true true 0 refl_counter refl_counter.
    Proof.
      intro Hcontra. punfold Hcontra; try eapply secure_eqit_mono; eauto.
      red in Hcontra. cbn in *. inv Hcontra; ddestruction; subst.
      - cbv in SECCHECK. inv SECCHECK.
      - specialize (H0 true false). pclearbot. pinversion H0; try eapply secure_eqit_mono; eauto.
        discriminate.
      - rewrite H3 in H0. clear H3. specialize (H0 true). cbn in *.
        inv H0; ddestruction; subst. specialize (H2 false). rewrite H in H2.
        inv H2. discriminate.
      -  rewrite H in H0. injection H0; intros; ddestruction; subst; ddestruction; subst.
         specialize (H1 true). cbn in *. inv H1; ddestruction; subst; ddestruction; subst.
         rewrite H6 in H3. specialize (H3 false). cbn in *. inv H3; discriminate.
      - inv SIZECHECK. apply H; apply true.
      - inv SIZECHECK. apply H; apply true.
    Qed.

    Lemma halt_not_ret : forall A (a : A) k, ~ eqit_secure NatPreorder priv_counter eq true true 0 (Vis Halt k) (Ret a).
    Proof.
      intros. intro Hcontra. pinversion Hcontra. ddestruction; subst.
      inv SIZECHECK. contradiction.
    Qed.

    Lemma halt_spin : eqit_secure NatPreorder priv_counter eq true true 0 (trigger Halt) (ITree.spin).
    Proof.
      pcofix CIH. pfold. red. cbn. eapply EqVisUnprivHaltLTauR.
      - intro. inv H.
      - constructor. intros; contradiction.
      - right. apply CIH.
    Qed.

    (*transitivity problems in presence of E void *)
    Definition refl_counter2 : itree NonDet unit := ITree.bind refl_counter (fun b : bool => if b then Ret tt else trigger PublicOut).
    (* b := SecretFlip; if b then return tt else PublicOut; return tt*)
    Lemma refl_counter2_counter : ~ eqit_secure NatPreorder priv_counter eq true true 0 refl_counter2 refl_counter2.
      Proof.
        unfold refl_counter2. intro Hcontra. punfold Hcontra; try eapply secure_eqit_mono; eauto.
        red in Hcontra. cbn in Hcontra. inv Hcontra; ddestruction; subst; try (inv SIZECHECK; apply H; constructor; fail).
        - inv SECCHECK.
        - specialize (H0 true false). pclearbot. punfold H0; try eapply secure_eqit_mono; eauto.
          red in H0. cbn in *. inv H0; ddestruction; subst.
          cbn in *. apply SECCHECK; auto.
        - rewrite H3 in H0; clear H3. specialize (H0 true). cbn in *.
          inv H0; ddestruction; subst; ddestruction.
          specialize (H2 false). rewrite H in H2. cbn in *. inv H2;
          ddestruction; subst; apply SECCHECK1; constructor.
        - rewrite <- H0 in H. injection H; intros; ddestruction; subst; ddestruction; subst.
          specialize (H1 true). inv H1; ddestruction; subst.
          rewrite H6 in H3. specialize (H3 false). cbn in *.
          inv H3; ddestruction; subst. apply SECCHECK1; constructor.
      Qed.

*)
Section eqit_secureC.
  (* might not be the order I eventually want but whatever*)
  Context {E: Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop).
  Context (Label : Preorder) (priv : forall A, E A -> L) (l : L).

  Variant eqit_secure_trans_clo (b1 b2 b1' b2' : bool) (r : itree E R1 -> itree E R2 -> Prop) :
    itree E R1 -> itree E R2 -> Prop :=
        eqit_secure_trans_clo_intro t1 t2 t1' t2' RR1 RR2
      (EQVl: eqit_secure Label priv RR1 b1 b1' l t1 t1')
      (EQVr: eqit_secure Label priv RR2 b2 b2' l t2 t2')
      (REL: r t1' t2')
      (LERR1: forall x x' y, RR1 x x' -> RR x' y -> RR x y)
      (LERR2: forall x y y', RR2 y y' -> RR x y' -> RR x y) :
      eqit_secure_trans_clo b1 b2 b1' b2' r t1 t2.

  Hint Constructors eqit_secure_trans_clo : itree.

  Definition eqit_secureC b1 b2 := eqit_secure_trans_clo b1 b2 false false.
  Hint Unfold eqit_secureC : itree.

  Lemma eqit_secureC_mon b1 b2 r1 r2 t1 t2
    (IN : eqit_secureC b1 b2 r1 t1 t2)
    (LE: r1 <2= r2) :
    eqit_secureC b1 b2 r2 t1 t2.
  Proof.
    destruct IN; eauto with itree.
  Qed.

End eqit_secureC.

Ltac unpriv_co := try apply EqVisUnPrivVisCo;
                  try apply EqVisUnPrivTauLCo;
                  try apply EqVisUnPrivTauRCo;
                  auto with itree; intros.

Ltac unpriv_ind := try apply EqVisUnPrivLInd;
                   try apply EqVisUnPrivRInd;
                   auto with itree; intros.

Ltac unpriv_halt :=
  match goal with
  | [  Hemp : empty ?A |- secure_eqitF _ _ _ _ _ _ _ _ (@VisF _ _ _ ?A _ _) _ ] =>
    try apply  EqVisUnprivHaltLTauR; try apply EqVisUnprivHaltLVisR; auto with itree; intros

  | [  Hemp : empty ?A |- secure_eqitF _ _ _ _ _ _ _ _ _ (@VisF _ _ _ ?A _ _)  ] =>
    try apply EqVisUnprivHaltRTauL; try apply EqVisUnprivHaltRVisL; auto with itree; intros end.

Ltac contra_size :=
  match goal with
  | [ Hemp : empty ?A, Hne : nonempty ?A |- _ ] => inv Hemp; inv Hne; contradiction end.

(*
Ltac unpriv_halt := try apply EqVisUnprivHaltLTauR;
                    try apply EqVisUnprivHaltRTauL;
                    try apply
*)
Ltac gfinal_with H := gfinal; left; apply H.

Ltac ne A := let Hne := fresh "H" in assert (Hne : nonempty A); eauto; inv Hne.

Lemma eqit_secure_sym : forall b1 b2 E R1 R2 RR Label priv l (t1 : itree E R1) (t2 : itree E R2),
    eqit_secure Label priv RR b1 b2 l t1 t2 -> eqit_secure Label priv (flip RR) b2 b1 l t2 t1.
Proof.
  intros b1 b2 E R1 R2 RR Label priv l. pcofix CIH.
  intros t1 t2 Hsec. pfold. red. punfold Hsec. red in Hsec.
  hinduction Hsec before r; intros; eauto with itree; pclearbot;
  try (unpriv_co; right; apply CIH; apply H);
  try unpriv_halt.
  - constructor; auto. intros. right. apply CIH; apply H.
  - constructor; auto. right. eapply CIH. apply H.
  - constructor; auto. right. eapply CIH. apply H.
  - specialize (H a). remember (k2 a) as t. clear Heqt k2.
     left.
     intros. pfold. red. cbn. punfold H. red in H. cbn in H.
     inv H; ddestruction; subst; try contra_size; try contradiction; pclearbot; eauto with itree;
     try (unpriv_halt; fail).
     + constructor; auto. right. eapply CIH; eauto. apply H2.
     + unpriv_halt. right. eapply CIH. apply H1.
     + unpriv_halt. right. eapply CIH. apply H1.
  - specialize (H b). remember (k1 b) as t. clear Heqt k1.
     left.
     intros. pfold. red. cbn. punfold H. red in H. cbn in H.
     inv H; ddestruction; subst; try contra_size; try contradiction; pclearbot; eauto with itree;
     try (unpriv_halt; fail).
     + constructor; auto. right. eapply CIH; eauto. apply H2.
     + unpriv_halt. right. inv SIZECHECK0. contradiction.
     + unpriv_halt. right. eapply CIH. apply H2.
Qed.

Lemma secure_eqit_mon : forall E (b1 b2 b3 b4 : bool) R1 R2 RR1 RR2 Label priv l
      (t1 : itree E R1) (t2 : itree E R2),
    (b1 -> b3) -> (b2 -> b4) -> (RR1 <2= RR2) ->
    eqit_secure Label priv RR1 b1 b2 l t1 t2 -> eqit_secure Label priv RR2 b3 b4 l t1 t2.
Proof.
  intros. generalize dependent t2. revert t1. pcofix CIH.
  intros t1 t2 Ht12. pstep. red.
  punfold Ht12. red in Ht12.
  hinduction Ht12 before r; intros; eauto; pclearbot;
  try (unpriv_co; right; apply CIH; try red; eauto; fail);
  try (unpriv_halt; try contra_size; right; apply CIH; try red; eauto; fail).
  all : (constructor; auto; right;  eauto; apply CIH; apply H2).
Qed.

End SecureUntimedUnReflexive.


Require Import Coqlib.
Require Import Errors.
Require Import Integers.
Require Import Tree.
Require Import String.
Require Import Asm.

Require Extractor.
Require TransUtil.
Require TransLayerStatement.
Require TransBranchInfo.

Local Open Scope error_monad_scope.

Set Implicit Arguments.

Fixpoint calculate_length (e : expression) (pil : list pin_info) : res int :=
  match e with
  | Length_Expression id =>
    do proto_info <- TransUtil.find_protocol_info_in_pin_list id pil;
    OK (proto_length proto_info)
  | Binary_Expression bin_op bin_expr1 bin_expr2 =>
    do len1 <- calculate_length bin_expr1 pil;
    do len2 <- calculate_length bin_expr2 pil;
    OK (Int.add len1 len2)
  | Constant_Expression con =>
    TransUtil.to_int con
  | _ =>
    Error (msg "invalid expression type b0!")
  end.

Definition trans_cell_one_pc_item
  (b_index : int)
  (bi : branch_info)
  (pil : list pin_info) : res one_pc_item :=
  do stmt_list <- OK (stmt bi);
  OK (One_Pc_Item b_index Int.one)
  .

Fixpoint trans_cell_one_pc_item_list
  (b_index : int)
  (bil : list branch_info)
  (pil : list pin_info) : res (list one_pc_item) :=
  match bil with
  | nil =>
    OK nil
  | hd :: tl =>
    do v1 <- trans_cell_one_pc_item b_index hd pil;
    do v2 <- trans_cell_one_pc_item_list (Int.add b_index Int.one) tl pil;
    OK (v1 :: v2)
  end.

Definition trans_cell_one_pc
  (bil : list branch_info)
  (pil : list pin_info) : res one_pc :=
  do one_pc_item_list <- trans_cell_one_pc_item_list Int.one bil pil;
  OK (One_Pc one_pc_item_list)
  .

Fixpoint trans_cell_one_pb_item
  (l_index : int)
  (b_index : int)
  (bi : branch_info)
  (pil : list pin_info)
  (ps : protocol_set) : res one_pb_item :=
  OK (One_Pb_Item l_index (cond bi) b_index ).

Fixpoint trans_cell_one_pb_item_list
  (l_index : int)
  (b_index : int)
  (ibl : list branch_info)
  (pil : list pin_info)
  (ps : protocol_set) : res (list one_pb_item) :=
  match ibl with
  | nil =>
    OK nil
  | hd :: tl =>
    do v1 <- trans_cell_one_pb_item l_index b_index hd pil ps;
    do v2 <- trans_cell_one_pb_item_list l_index (Int.add b_index Int.one) tl pil ps;
    OK (v1 :: v2)
  end.

Definition trans_cell_one_pb
  (l_index : int)
  (bil : list branch_info)
  (pil : list pin_info)
  (ps : protocol_set) : res one_pb :=
  do one_pb_item_list <- trans_cell_one_pb_item_list  l_index Int.one bil pil ps;
  OK (One_Pb one_pb_item_list)
  .

Definition translate
  (l_index : int)
  (cba : cell_b1_action)
  (cbr : cell_b1_register)
  (pil : list pin_info)
  (ps : protocol_set) : res cell_one :=
  match cba with
  | Cell_B1_Action layer_stmt =>
    match layer_stmt with
    | Layer_Statement stmt_list =>
      do layer_branch_info_list <- TransLayerStatement.translate stmt_list pil;
      do one_pb <- trans_cell_one_pb l_index layer_branch_info_list pil ps;
      do one_pc <- trans_cell_one_pc layer_branch_info_list pil;
      OK (Cell_One one_pb one_pc)
    end
  end.