Module ZIntervals


Require Import Coqlib Utf8 ToString PrintPos FastArith.
Require Import Util AdomLib.
Require Import Integers.
Require Psatz.

Inductive zitv : Type :=
| ZITV: Zfast -> Zfast -> zitv.

Instance ZitvToString : ToString zitv :=
  { to_string i :=
      let 'ZITV min max := i in
      ("[" ++ to_string min ++ "," ++ to_string max ++ "]")%string
  }.

Instance leb_zitv : leb_op zitv := fun (i1 i2: zitv) =>
  let 'ZITV min1 max1 := i1 in
  let 'ZITV min2 max2 := i2 in
  Zfastleb min2 min1 && Zfastleb max1 max2.

Lemma leb_eq:
  ∀ i:zitv, ii = true.
Proof.
  destruct i as [[][]]; unfold leb. simpl. fastunwrap. rewrite !Z.leb_refl. auto.
Qed.

Instance join_zitv : join_op zitv zitv := fun i1 i2 =>
  let 'ZITV min1 max1 := i1 in
  let 'ZITV min2 max2 := i2 in
  match Zfastcompare min1 min2, Zfastcompare max1 max2 with
  | (Lt | Eq), (Eq | Gt) => i1
  | (Eq | Gt), Lt | Gt, Eq => i2
  | Lt, Lt => ZITV min1 max2
  | Gt, Gt => ZITV min2 max1
  end.

Lemma join_eq:
  ∀ x:zitv, xx = x.
Proof.
  unfold join. destruct x. simpl. fastunwrap. rewrite !Z.compare_refl. auto.
Qed.

Instance meet_zitv : meet_op zitv (zitv+⊥) := fun i1 i2 =>
  let 'ZITV min1 max1 := i1 in
  let 'ZITV min2 max2 := i2 in
  match Zfastcompare min1 min2, Zfastcompare max1 max2 with
  | (Eq | Gt), (Lt | Eq) => NotBot i1
  | (Lt | Eq), Gt | Lt, Eq => NotBot i2
  | Gt, Gt => if Zfastleb min1 max2 then NotBot (ZITV min1 max2) else Bot
  | Lt, Lt => if Zfastleb min2 max1 then NotBot (ZITV min2 max1) else Bot
  end.

Definition widening_hints : list Zfast :=
  (- Z.shiftl 1 63 : Zfast) ::
  (- Z.shiftl 1 31 : Zfast) ::
  (- Z.shiftl 1 15 : Zfast) ::
  (- Z.shiftl 1 7 : Zfast) ::
  (F0:Zfast) :: (F1:Zfast) ::
  (Z.shiftl 1 7 - 1 : Zfast) ::
  (Z.shiftl 1 8 - 1 : Zfast) ::
  (Z.shiftl 1 15 - 1 : Zfast) ::
  (Z.shiftl 1 16 - 1 : Zfast) ::
  (Z.shiftl 1 31 - 1 : Zfast) ::
  (Z.shiftl 1 32 - 1 : Zfast) ::
  (Z.shiftl 1 63 - 1 : Zfast) :: nil.

Definition widening_hints_rev : list Zfast :=
  List.rev_append widening_hints nil.

Definition next_larger z :=
  List.find (Zfastleb z) widening_hints.

Lemma next_larger_larger:
  ∀ n m, next_larger n = Some m -> n <= m.
Proof.
  unfold next_larger. induction widening_hints. discriminate. simpl. intros.
  fastunwrap. destruct (Z.leb_spec n a). inv H; Psatz.lia. auto.
Qed.

Definition next_smaller z :=
  List.find (fun x => Zfastleb x z) widening_hints_rev.

Lemma next_smaller_smaller:
  ∀ n m, next_smaller n = Some m -> m <= n.
Proof.
  unfold next_smaller. induction widening_hints_rev. discriminate. simpl. intros.
  fastunwrap. destruct (Z.leb_spec a n). inv H; Psatz.lia. auto.
Qed.

Definition widen_zitv i1 i2 :=
  let 'ZITV min1 max1 := i1 in
  let 'ZITV min2 max2 := i2 in
  let lemin := Zfastleb min1 min2 in
  let lemax := Zfastleb max2 max1 in
  if lemin && lemax then Just i1
  else
    let min :=
      if lemin then Some min1
      else next_smaller min2
    in
    let max :=
      if lemax then Some max1
      else next_larger max2
    in
    match min, max with
    | Some min, Some max => Just (ZITV min max)
    | _, _ => All
    end.

Lemma widen_eq:
  ∀ x:zitv, widen_zitv x x = Just x.
Proof.
  unfold widen_zitv. destruct x. fastunwrap. rewrite !Z.leb_refl. auto.
Qed.

Instance gamma_zitv : gamma_op zitv Z := fun i v =>
  let 'ZITV m M := i in m <= v <= M.

Instance leb_zitv_correct : leb_op_correct zitv Z.
Proof.
  intros [[?][?]] [[?][?]]. unfold leb. simpl. fastunwrap.
  destruct (Z.leb_spec x1 x), (Z.leb_spec x0 x2); try discriminate. intros; Psatz.lia.
Qed.

Instance join_zitv_correct : join_op_correct zitv zitv Z.
Proof.
  intros [[?][?]] [[?][?]] ? [[? ?]|[? ?]]; unfold join; simpl;
  fastunwrap;
  destruct (Z.compare_spec x x1), (Z.compare_spec x0 x2);
  split; simpl in *; Psatz.lia.
Qed.

Lemma widen_incr:
  ∀ ab1 ab2, γ ab1 ⊆ γ (widen_zitv ab1 ab2).
Proof.
  unfold widen_zitv. intros [[m1][M1]] [[m2][M2]] n H. fastunwrap.
  destruct andb. auto.
  pose proof next_smaller_smaller m2.
  pose proof next_larger_larger M2.
  destruct (Z.leb_spec m1 m2), (Z.leb_spec M2 M1); auto.
  destruct H, next_larger; simpl in *. specialize (H1 _ eq_refl). Psatz.lia. auto.
  destruct H, next_smaller; simpl in *. specialize (H0 _ eq_refl). Psatz.lia. auto.
  destruct H, next_smaller, next_larger; simpl in *; auto.
  specialize (H0 _ eq_refl). specialize (H1 _ eq_refl). Psatz.lia.
Qed.

Instance meet_zitv_correct: meet_op_correct zitv (zitv+⊥) Z.
Proof.
  intros [[mx] [Mx]] [[my] [My]] z Hz; simpl in *; unfold meet; simpl; fastunwrap.
  destruct Hz as [[][]]; fastunwrap.
  destruct (Zcompare_spec mx my), (Zcompare_spec Mx My); try (split; simpl; Psatz.lia).
  destruct (Z.leb_spec my Mx); try (split; simpl; Psatz.lia). Psatz.lia.
  destruct (Z.leb_spec mx My); try (split; simpl; Psatz.lia). Psatz.lia.
Qed.

Definition forward_neg (x:zitv+⊤) : zitv+⊤ :=
  match x with
  | Just (ZITV mx Mx) => Just (ZITV (Zfastopp Mx) (Zfastopp mx))
  | All => All
  end.

Lemma forward_neg_correct:
  ∀ x x_ab, x ∈ γ x_ab -> (-x) ∈ γ (forward_neg x_ab) .
Proof.
  intros x [|[[mx] [Mx]]] Hx; simpl in *; intuition.
Qed.

Definition forward_mult (x y:zitv+⊤) : zitv+⊤+⊥ :=
  match x, y with
  | Just (ZITV mx Mx), Just (ZITV my My) =>
    let b1 := Zfastmul mx my in let b2 := Zfastmul mx My in
    let b3 := Zfastmul Mx my in let b4 := Zfastmul Mx My in
    NotBot (Just (ZITV (Zfastmin (Zfastmin b1 b4) (Zfastmin b3 b2))
                       (Zfastmax (Zfastmax b1 b4) (Zfastmax b3 b2))))
  | All, Just (ZITV m M) | Just (ZITV m M), All =>
     if (Zfasteqb m F0 && Zfasteqb M F0) then NotBot (Just (ZITV F0 F0))
     else NotBot All
  | All, All => NotBot All
  end.

Lemma Mult_interval_correct_min_max :
  forall a b c d x y : Z,
    a <= x <= b ->
    c <= y <= d ->
    Zmin (Zmin (a*c) (b*d)) (Zmin (b*c) (a*d)) <= x * y
        <= Zmax (Zmax (a*c) (b*d)) (Zmax (b*c) (a*d)).
Proof.
  intros. split.
  repeat apply Z.min_case_strong;
    destruct (Z.nonpos_pos_cases x), (Z.nonpos_pos_cases y);
    destruct (Z.nonpos_pos_cases a), (Z.nonpos_pos_cases b);
    destruct (Z.nonpos_pos_cases c), (Z.nonpos_pos_cases c);
    Psatz.nia.
  repeat apply Z.max_case_strong;
    destruct (Z.nonpos_pos_cases x), (Z.nonpos_pos_cases y);
    destruct (Z.nonpos_pos_cases a), (Z.nonpos_pos_cases b);
    destruct (Z.nonpos_pos_cases c), (Z.nonpos_pos_cases c);
    Psatz.nia.
Qed.

Lemma forward_mult_correct:
  ∀ x x_ab, x ∈ γ x_ab ->
  ∀ y y_ab, y ∈ γ y_ab ->
    (x * y)%Z ∈ γ (forward_mult x_ab y_ab).
Proof.
  intros x [|[[mx] [Mx]]] Hx y [|[[my] [My]]] Hy; simpl in Hx, Hy.
  - tauto.
  - destruct my, My; simpl; try tauto. Psatz.nia.
  - destruct mx, Mx; simpl; try tauto. Psatz.nia.
  - destruct mx, Mx; unfold forward_mult; fastunwrap;
    apply Mult_interval_correct_min_max; auto.
Qed.

Definition forward_div_pos (x:zitv+⊤) (my My:Zfast) : zitv+⊤ :=
  match x with
  | Just (ZITV mx Mx) =>
    Just (ZITV (Zfastquot mx (if Zfastleb F0 mx then My else my))
               (Zfastquot Mx (if Zfastleb F0 Mx then my else My)))
  | All => All
  end.

Lemma Zquot_le_compat_l_neg:
  ∀ p q r : Z, p < 0 -> 0 < q <= r -> p ÷ q <= p ÷ r.
Proof.
  intros.
  rewrite Z.opp_le_mono.
  rewrite <- !Z.quot_opp_l by Psatz.lia.
  apply Z.quot_le_compat_l; Psatz.lia.
Qed.

Lemma forward_div_pos_correct:
  ∀ x x_ab, x ∈ γ x_ab ->
  ∀ y my My, 0 < my /\ my <= y <= My ->
    (x ÷ y) ∈ γ (forward_div_pos x_ab my My).
Proof.
  intros x [|[[mx] [Mx]]] Hx [|y|] [|my|] [|My|] Hy; unfold forward_div_pos; fastunwrap;
  try (exfalso; Psatz.lia).
  auto. simpl in *. split.
  - pose proof (Zle_cases 0 mx). destruct (0 <=? mx); fastunwrap.
    eapply Zle_trans; [apply Z.quot_le_compat_l|apply Z.quot_le_mono]; Psatz.lia.
    eapply Zle_trans; [apply Zquot_le_compat_l_neg|apply Z.quot_le_mono]; Psatz.lia.
  - pose proof (Zle_cases 0 Mx). destruct (0 <=? Mx); fastunwrap.
    eapply Zle_trans; [apply Z.quot_le_mono|apply Z.quot_le_compat_l]; Psatz.lia.
    eapply Zle_trans; [apply Z.quot_le_mono|apply Zquot_le_compat_l_neg]; Psatz.lia.
Qed.

Definition forward_div_neg (x:zitv+⊤) (my My:Zfast) : zitv+⊤ :=
  forward_neg (forward_div_pos x (Zfastopp My) (Zfastopp my)).

Lemma forward_div_neg_correct:
  ∀ x x_ab, x ∈ γ x_ab ->
  ∀ y my My, My < 0 /\ my <= y <= My ->
    (x ÷ y) ∈ γ (forward_div_neg x_ab my My).
Proof.
  unfold forward_div_neg. fastunwrap.
  intros x x_ab Hx [| |y] my My Hy; try (exfalso; Psatz.lia).
  rewrite <- Z.opp_involutive.
  apply forward_neg_correct.
  rewrite <- Z.quot_opp_r by discriminate.
  eapply forward_div_pos_correct. eauto. simpl. Psatz.lia.
Qed.

Definition forward_div (x y:zitv+⊤) : zitv+⊤+⊥ :=
  if yJust (ZITV F0 F0) then Bot
  else if xJust (ZITV F0 F0) then NotBot (Just (ZITV F0 F0))
  else match y with
       | All => NotBot All
       | Just (ZITV my My) =>
         let p :=
           if Zfastleb My F0 then Bot
           else NotBot (forward_div_pos x (Zfastmax F1 my) My)
         in
         let n :=
           if Zfastleb F0 my then Bot
           else NotBot (forward_div_neg x my (Zfastmin Fm1 My))
         in pn
       end.

Lemma forward_div_correct:
  ∀ x x_ab, x ∈ γ x_ab ->
  ∀ y y_ab, y ∈ γ y_ab ->
    y ≠ 0 ->
    (x ÷ y) ∈ γ (forward_div x_ab y_ab).
Proof.
  simpl. unfold forward_div. fastunwrap. intros. simpl.
  pose proof leb_correct y_ab (Just (ZITV 0 0)). destruct @leb.
  apply H1. edestruct H2; eauto. fastunwrap. Psatz.lia.
  pose proof leb_correct x_ab (Just (ZITV 0 0)). destruct @leb.
  assert (x=0). edestruct H3; eauto. fastunwrap. Psatz.lia.
  subst. rewrite Zquot.Zquot_0_l. split; fastunwrap; Psatz.lia.
  clear H2 H3.
  destruct y_ab as [|[[][]]]. auto. apply join_correct.
  destruct y, H0; fastunwrap. congruence.
  - left. rewrite (proj2 (Z.leb_gt _ _)) by Psatz.lia.
    apply forward_div_pos_correct. auto. Psatz.lia.
  - right. rewrite (proj2 (Z.leb_gt _ _)) by Psatz.lia.
    apply forward_div_neg_correct. auto. Psatz.lia.
Qed.

Definition forward_mod_pos_pos (x:zitv+⊤) (my My:Zfast) : zitv+⊤+⊥ :=
  match x with
  | All => NotBot (Just (ZITV F0 (Zfastsub My F1)))
  | Just (ZITV mx Mx) =>
    if Zfastleb F0 Mx then
      NotBot (Just (ZITV (if Zfastleb my Mx then F0 else Zfastmax F0 mx)
                         (Zfastmin (Zfastsub My F1) Mx)))
    else Bot
  end.

Lemma forward_mod_pos_pos_correct:
  ∀ x x_ab, x ∈ γ x_ab -> 0 <= x ->
  ∀ y my My, 0 < my /\ my <= y <= My ->
    (Z.rem x y) ∈ γ (forward_mod_pos_pos x_ab my My).
Proof.
  intros x x_ab Hx Hxpos [|y|] my My Hy; unfold forward_mod_pos_pos;
  fastunwrap; try (exfalso; Psatz.lia).

  assert (0 <= Z.rem x (Zpos y) <= My - 1).
  { pose proof (Zquot.Zrem_lt_pos_pos x (Z.pos y)). Psatz.lia. }

  destruct x_ab as [|[[mx] [Mx]]]. assumption. fastunwrap. simpl.
  pose proof (Zle_cases 0 Mx). destruct (0 <=? Mx); [|simpl in *; Psatz.lia].
  simpl in Hx. split.
  - pose proof (Zle_cases my Mx). destruct (my <=? Mx); simpl.
    Psatz.lia. apply Z.max_case_strong. Psatz.lia.
    rewrite Z.rem_small. Psatz.lia. split. auto. Psatz.lia.
  - apply Z.min_case_strong. simpl in *. Psatz.lia. intro.
    pose proof (Z.rem_le x (Zpos y)). simpl in *. Psatz.lia.
Qed.

Definition forward_mod_pos (x:zitv+⊤) (my My:Zfast) : zitv+⊤+⊥ :=
  forward_mod_pos_pos x my My
  fmap forward_neg (forward_mod_pos_pos (forward_neg x) my My).

Lemma forward_mod_pos_correct:
  ∀ x x_ab, x ∈ γ x_ab ->
  ∀ y my My, 0 < my /\ my <= y <= My ->
    (Z.rem x y) ∈ γ (forward_mod_pos x_ab my My).
Proof.
  intros x x_ab Hx y my My Hy. unfold forward_mod_pos.
  apply join_correct.
  destruct (Coqlib.zlt 0 x); [left|right].
  eapply forward_mod_pos_pos_correct; auto. Psatz.lia.
  eapply botbind_spec, forward_mod_pos_pos_correct, Hy.
  2:apply forward_neg_correct, Hx. 2:Psatz.lia.
  intros. rewrite <- Z.opp_involutive, <- Z.rem_opp_l'.
  apply forward_neg_correct, H.
Qed.

Definition forward_mod_neg (x:zitv+⊤) (my My:Zfast) : zitv+⊤+⊥ :=
  forward_mod_pos x (Zfastopp My) (Zfastopp my).

Lemma forward_mod_neg_correct:
  ∀ x x_ab, x ∈ γ x_ab ->
  ∀ y my My, My < 0 /\ my <= y <= My ->
    (Z.rem x y) ∈ γ (forward_mod_neg x_ab my My).
Proof.
  intros x x_ab Hx [| |y] my My Hy; try (exfalso; Psatz.lia).
  rewrite <- Z.rem_opp_r'.
  eapply forward_mod_pos_correct. auto. fastunwrap. Psatz.lia.
Qed.

Definition forward_mod (x y:zitv+⊤) : zitv+⊤+⊥ :=
  if yJust (ZITV F0 F0) then Bot
  else match y with
       | All =>
         match x with
         | All => NotBot All
         | Just (ZITV mx Mx) =>
           let M := Zfast_of_Nfast (Nfastmax (Zfastabs mx) (Zfastabs Mx)) in
           NotBot (Just (ZITV (Zfastopp M) M))
         end
       | Just (ZITV my My) =>
         let p :=
           if Zfastleb My F0 then Bot
           else forward_mod_pos x (Zfastmax F1 my) My
         in
         let n :=
           if Zfastleb F0 my then Bot
           else forward_mod_neg x my (Zfastmin Fm1 My)
         in pn
       end.

Lemma forward_mod_correct:
  ∀ x x_ab, x ∈ γ x_ab ->
  ∀ y y_ab, y ∈ γ y_ab ->
    y ≠ 0 ->
    (Z.rem x y) ∈ γ (forward_mod x_ab y_ab).
Proof.
  unfold forward_mod. fastunwrap. simpl.
  assert (∀ x y, Zabs (Z.rem x y) <= Zabs x).
  { intros.
    destruct (Z.eq_dec y 0).
    subst. rewrite Zquot.Zrem_0_r. apply Z.le_refl.
    rewrite <- Z.rem_abs; [apply Z.rem_le|]; try Psatz.lia. }
  intros. pose proof leb_correct y_ab (Just (ZITV 0 0)).
  destruct @leb. apply H2. edestruct H3; eauto. fastunwrap. Psatz.lia. clear H3.
  destruct y_ab as [|[[][]]], H1.
  - destruct x_ab as [|[]], H0. exact I. fastunwrap.
    eapply Z.abs_le, Zle_trans. apply H. fastunwrap. Psatz.lia.
  - fastunwrap. apply join_correct.
    destruct y. congruence.
    + left. rewrite (proj2 (Z.leb_gt _ _)) by Psatz.lia.
      apply forward_mod_pos_correct. auto. Psatz.lia.
    + right. rewrite (proj2 (Z.leb_gt _ _)) by Psatz.lia.
      apply forward_mod_neg_correct. auto. Psatz.lia.
Qed.

Definition forward_lnot (x:zitv+⊤) : zitv+⊤ :=
  match x with
  | Just (ZITV mx Mx) => Just (ZITV (Zfastsub Fm1 Mx) (Zfastsub Fm1 mx))
  | All => All
  end.

Lemma forward_lnot_correct:
  ∀ x x_ab, x ∈ γ x_ab -> (Z.lnot x) ∈ γ (forward_lnot x_ab) .
Proof.
  intros x [|[[mx] [Mx]]] Hx. auto. unfold forward_lnot, Z.lnot. fastunwrap.
  simpl Z.of_N. split; destruct Hx; fastunwrap; omega.
Qed.

Lemma le_common_bits :
  ∀ m p M, (m <= p <= M)%N ->
  ∀ i, (N.size (N.lxor m M) <= i)%N ->
  N.testbit m i = N.testbit p i /\ N.testbit p i = N.testbit M i.
Proof.
  intros.
  set (c:=N.size (N.lxor m M)) in *.
  replace i with (i-c + c)%N by Psatz.lia.
  rewrite <- !N.shiftr_spec by Psatz.lia.
  assert (N.shiftr m c <= N.shiftr p c <= N.shiftr M c)%N.
  { rewrite !N.shiftr_div_pow2.
    destruct H; split; apply N.div_le_mono; trivial; apply N.pow_nonzero; Psatz.lia. }
  assert (N.shiftr m c = N.shiftr M c).
  { apply N.lxor_eq.
    rewrite <- N.shiftr_lxor, N.shiftr_div_pow2.
    apply N.div_small, N.size_gt. }
  split; f_equal; Psatz.lia.
Qed.

Definition forward_and_pos (mx Mx my My:Nfast) : Nfast * Nfast :=
  let cx := N.size (Nfastlxor mx Mx) in
  let cy := N.size (Nfastlxor my My) in
  let c := Nfastmax cx cy in
  let onesc := Nfastones c in
  let high:Nfast := Nfastldiff (Nfastland mx my) onesc in
  (high, Nfastlor high (Nfastmin (Nfastland Mx onesc) (Nfastland My onesc))).

Lemma forward_and_pos_correct:
  ∀ mx x Mx, (mx <= x <= Mx)%N ->
  ∀ my y My, (my <= y <= My)%N ->
  ∀ r R, forward_and_pos mx Mx my My = (r, R) ->
  (r <= N.land x y <= R)%N.
Proof.
  unfold forward_and_pos; intros.
  rewrite Nfastldiff_Nldiff, Nfastones_Nones in H1. fastunwrap. inv H1. fastunwrap.
  set (mask:=(N.ones (N.max (N.size (N.lxor mx Mx)) (N.size (N.lxor my My))))).
  assert (N.ldiff (N.land mx my) mask = N.ldiff (N.land x y) mask).
  { apply N.bits_inj; intro. rewrite !N.ldiff_spec, !N.land_spec.
    destruct (N.le_gt_cases (N.max (N.size (N.lxor mx Mx)) (N.size (N.lxor my My))) n).
    - f_equal. f_equal;
        (eapply proj1, le_common_bits; [eauto|];
         revert H1; apply N.max_case_strong; intros; Psatz.lia).
    - unfold mask; rewrite N.ones_spec_low by trivial.
      repeat (destruct N.testbit; try reflexivity). }
  assert (∀ a b c, a <= b -> a <= c -> b-a <= c-a -> a <= b <= c)%N by (intros; Psatz.lia).
  apply H2; clear H2.
  - apply N.ldiff_le, N.bits_inj_0; intro.
    rewrite H1, !N.ldiff_spec, !N.land_spec; simpl.
    repeat (destruct N.testbit; try reflexivity).
  - apply N.ldiff_le, N.bits_inj_0; intro. simpl.
    rewrite !N.ldiff_spec, N.lor_spec, N.ldiff_spec; simpl.
    repeat (destruct N.testbit; try reflexivity).
  - rewrite H1, !N.sub_nocarry_ldiff.
    + assert (N.land (N.land x y) mask <= N.min (N.land Mx mask) (N.land My mask))%N.
      { apply N.le_trans with (N.min (N.land x mask) (N.land y mask)).
        apply N.min_glb; zify; apply Int.Ztestbit_le; trivial; intros i Hi;
        rewrite !Z2N.inj_testbit, !N.land_spec in * by trivial;
        repeat (destruct N.testbit; try (simpl; congruence)).
        apply N.min_le_compat.
        - assert (N.ldiff x mask = N.ldiff Mx mask).
          { apply N.bits_inj; intro. rewrite !N.ldiff_spec.
            destruct (N.le_gt_cases (N.max (N.size (N.lxor mx Mx)) (N.size (N.lxor my My))) n).
            - f_equal.
              eapply proj2, le_common_bits. eauto.
              revert H2; apply N.max_case_strong; intros; Psatz.lia.
            - unfold mask; rewrite N.ones_spec_low by trivial.
              repeat (destruct N.testbit; try reflexivity). }
          apply proj2 in H.
          rewrite <- N.lor_ldiff_and with (a:=x) (b:=mask) in H.
          rewrite <- N.lor_ldiff_and with (a:=Mx) (b:=mask) in H.
          rewrite <- !N.lxor_lor, <- !N.add_nocarry_lxor in H;
            try now (apply N.bits_inj_0; intro;
                     rewrite !N.land_spec, N.ldiff_spec;
                     repeat (destruct N.testbit; try reflexivity)).
          Psatz.lia.
        - assert (N.ldiff y mask = N.ldiff My mask).
          { apply N.bits_inj; intro. rewrite !N.ldiff_spec.
            destruct (N.le_gt_cases (N.max (N.size (N.lxor mx Mx)) (N.size (N.lxor my My))) n).
            - f_equal.
              eapply proj2, le_common_bits. eauto.
              revert H2; apply N.max_case_strong; intros; Psatz.lia.
            - unfold mask; rewrite N.ones_spec_low by trivial.
              repeat (destruct N.testbit; try reflexivity). }
          apply proj2 in H0.
          rewrite <- N.lor_ldiff_and with (a:=y) (b:=mask) in H0.
          rewrite <- N.lor_ldiff_and with (a:=My) (b:=mask) in H0.
          rewrite <- !N.lxor_lor, <- !N.add_nocarry_lxor in H0;
            try now (apply N.bits_inj_0; intro;
                     rewrite !N.land_spec, N.ldiff_spec;
                     repeat (destruct N.testbit; try reflexivity)).
          Psatz.lia. }
      match goal with H:(?a <= ?b)%N |- (?a' <= ?b')%N => replace a' with a; [replace b' with b|] end. trivial.
      * apply N.min_case; apply N.bits_inj; intro; simpl;
        rewrite !N.ldiff_spec, N.lor_spec, N.ldiff_spec, !N.land_spec;
        repeat (destruct N.testbit; try reflexivity).
      * apply N.bits_inj; intro; simpl;
        rewrite !N.ldiff_spec, !N.land_spec;
        repeat (destruct N.testbit; try reflexivity).
    + apply N.bits_inj; intro; simpl;
      rewrite !N.ldiff_spec, !N.lor_spec, N.ldiff_spec;
      repeat (destruct N.testbit; try reflexivity).
    + apply N.bits_inj_0; intro; simpl;
      rewrite !N.ldiff_spec;
      repeat (destruct N.testbit; try reflexivity).
Qed.

Definition forward_or_pos (mx Mx my My:Nfast) : Nfast * Nfast :=
  let N := Nfastones (Nfastmax (N.size Mx) (N.size My)) in
  let (m, M) := forward_and_pos (Nfastldiff N Mx) (Nfastldiff N mx)
                                (Nfastldiff N My) (Nfastldiff N my) in
  (Nfastldiff N M, Nfastldiff N m)%N.

Lemma forward_or_pos_correct:
  ∀ mx x Mx, (mx <= x <= Mx)%N ->
  ∀ my y My, (my <= y <= My)%N ->
  ∀ r R, forward_or_pos mx Mx my My = (r, R) ->
  (r <= N.lor x y <= R)%N.
Proof.
  intros. unfold forward_or_pos in H1.
  rewrite !Nfastldiff_Nldiff, Nfastones_Nones in H1. fastunwrap.
  set (N := N.ones (N.max (N.size Mx) (N.size My))) in *.
  assert (∀ x y, x <= y -> N.size x <= N.size y)%N.
  { intros. destruct x0, y0; auto. rewrite !N.size_log2 by discriminate.
    apply -> N.succ_le_mono. apply N.log2_le_mono, H2. }
  assert (∀ n, N.size n <= N.max (N.size Mx) (N.size My) -> N.ldiff n N = 0)%N.
  { intros. apply N.bits_inj_0. intros. rewrite N.ldiff_spec.
    destruct (N.leb_spec (N.size n) n0).
    - apply (N.pow_le_mono_r 2) in H4. 2:Psatz.lia. pose proof (N.size_gt n).
      assert (n < 2^n0)%N by Psatz.lia. apply N.div_small in H6.
      pose proof N.testbit_spec' n n0. rewrite H6 in H7.
      destruct N.testbit. discriminate. auto.
    - unfold N. rewrite N.ones_spec_low. destruct N.testbit; auto. Psatz.lia. }
  destruct (forward_and_pos (N.ldiff N Mx) (N.ldiff N mx)
                            (N.ldiff N My) (N.ldiff N my)) eqn:EQ.
  rewrite !Nfastldiff_Nldiff in H1. inv H1. pose proof EQ.
  apply forward_and_pos_correct with (x:=N.ldiff N x) (y:=N.ldiff N y) in H1.
  - rewrite <- !N.sub_nocarry_ldiff.
    replace (N.lor x y) with (N.ldiff N (N.land (N.ldiff N x) (N.ldiff N y))).
    rewrite <- N.sub_nocarry_ldiff. fastunwrap. Psatz.lia.
    + apply N.bits_inj_0. intros.
      rewrite N.ldiff_spec, N.land_spec, !N.ldiff_spec.
      destruct N.testbit, N.testbit, N.testbit; auto.
    + apply N.bits_inj. intro.
      rewrite N.ldiff_spec, N.land_spec, N.lor_spec, !N.ldiff_spec.
      destruct (N.leb_spec (N.max (N.size Mx) (N.size My)) n1); unfold N.
      2:rewrite N.ones_spec_low by auto; destruct N.testbit, N.testbit; now auto.
      rewrite N.ones_spec_high by auto. symmetry. apply orb_false_intro.
      * apply N.max_lub_l, (N.pow_le_mono_r 2) in H4. 2:Psatz.lia.
        pose proof (N.size_gt Mx). assert (x < 2 ^ n1)%N by Psatz.lia.
        apply N.div_small in H6. apply N.b2n_inj. rewrite N.testbit_spec', H6. auto.
      * apply N.max_lub_r, (N.pow_le_mono_r 2) in H4. 2:Psatz.lia.
        pose proof (N.size_gt My). assert (y < 2 ^ n1)%N by Psatz.lia.
        apply N.div_small in H6. apply N.b2n_inj. rewrite N.testbit_spec', H6. auto.
    + clear H1. inv EQ. fastunwrap. apply N.bits_inj_0. intros.
      rewrite !N.ldiff_spec, N.land_spec, !N.ldiff_spec.
      destruct (N.testbit N n). apply andb_false_r. auto.
    + clear H1. inv EQ. fastunwrap. apply N.bits_inj_0. intros.
      apply N.min_case;
      rewrite !N.ldiff_spec, N.lor_spec, !N.land_spec, N.ldiff_spec, N.land_spec,
        !N.ldiff_spec;
      destruct (N.testbit N n); auto using andb_false_r.
  - rewrite <- !N.sub_nocarry_ldiff;
    try (apply H3; etransitivity; [|apply N.le_max_l]; apply H2); Psatz.lia.
  - rewrite <- !N.sub_nocarry_ldiff;
    try (apply H3; etransitivity; [|apply N.le_max_r]; apply H2); Psatz.lia.
Qed.

Definition forward_diff_pos (mx Mx my My:Nfast) : Nfast * Nfast :=
  let N := Nfastones (Nfastmax (N.size Mx) (N.size My)) in
  forward_and_pos mx Mx (Nfastldiff N My) (Nfastldiff N my).

Lemma forward_diff_pos_correct:
  ∀ mx x Mx, (mx <= x <= Mx)%N ->
  ∀ my y My, (my <= y <= My)%N ->
  ∀ r R, forward_diff_pos mx Mx my My = (r, R) ->
  (r <= N.ldiff x y <= R)%N.
Proof.
  intros. unfold forward_diff_pos in H1. fastunwrap.
  set (N := N.ones (N.max (N.size Mx) (N.size My))) in *.
  assert (∀ x y, x <= y -> N.size x <= N.size y)%N.
  { intros. destruct x0, y0; auto. rewrite !N.size_log2 by discriminate.
    apply -> N.succ_le_mono. apply N.log2_le_mono, H2. }
  assert (∀ n, N.size n <= N.max (N.size Mx) (N.size My) -> N.ldiff n N = 0)%N.
  { intros. apply N.bits_inj_0. intros. rewrite N.ldiff_spec.
    destruct (N.leb_spec (N.size n) n0).
    - apply (N.pow_le_mono_r 2) in H4. 2:Psatz.lia. pose proof (N.size_gt n).
      assert (n < 2^n0)%N by Psatz.lia. apply N.div_small in H6.
      pose proof N.testbit_spec' n n0. rewrite H6 in H7.
      destruct N.testbit. discriminate. auto.
    - unfold N. rewrite N.ones_spec_low. destruct N.testbit; auto. Psatz.lia. }
  destruct (forward_and_pos mx Mx (N.ldiff N My) (N.ldiff N my)) eqn:EQ. inv H1.
  pose proof EQ.
  apply forward_and_pos_correct with (x:=x) (y:=N.ldiff N y) in H1; auto.
  - replace (N.ldiff x y) with (N.land x (N.ldiff N y)). auto.
    apply N.bits_inj. intro. rewrite N.land_spec, !N.ldiff_spec.
    destruct (N.leb_spec (N.max (N.size Mx) (N.size My)) n); unfold N.
    2:rewrite N.ones_spec_low by auto; destruct N.testbit, N.testbit; now auto.
    rewrite N.ones_spec_high by auto.
    apply N.max_lub_l, (N.pow_le_mono_r 2) in H4. 2:Psatz.lia.
    pose proof (N.size_gt Mx). assert (x < 2 ^ n)%N by Psatz.lia.
    replace (N.testbit x n) with false. auto.
    apply N.div_small in H6. apply N.b2n_inj. rewrite N.testbit_spec', H6. auto.
  - rewrite <- !N.sub_nocarry_ldiff;
    try (apply H3; etransitivity; [|apply N.le_max_r]; apply H2); Psatz.lia.
Qed.

Definition positive_part (i:zitv+⊤) : zitv+⊤+⊥ :=
  match i with
  | Just (ZITV x y) => if Zfastleb F0 y then NotBot (Just (ZITV (Zfastmax F0 x) y)) else Bot
  | All => NotBot All
  end.

Lemma positive_part_correct:
  ∀ i n, n ∈ γ i -> 0 <= n ->
  n ∈ γ (positive_part i).
Proof.
  destruct i as [|[[] []]]; simpl; intros. auto. fastunwrap. simpl.
  destruct (Z.leb_spec 0 x0). split; simpl in *; Psatz.lia. Psatz.lia.
Qed.

Definition pos_bind fJJ fJA fAJ x y : zitv+⊤+⊥ :=
  do x <- positive_part x;
  do y <- positive_part y;
  match x, y return zitv+⊤+⊥ with
  | Just (ZITV mx Mx), Just (ZITV my My) =>
    let '(m, M) := fJJ (Nfast_of_Zfast mx) (Nfast_of_Zfast Mx)
                       (Nfast_of_Zfast my) (Nfast_of_Zfast My) in
    NotBot (Just (ZITV (Zfast_of_Nfast m) (Zfast_of_Nfast M)))
  | Just (ZITV mx Mx), All =>
    match fJA (Nfast_of_Zfast mx) (Nfast_of_Zfast Mx) with
    | None => NotBot All
    | Some (m, M) =>
      NotBot (Just (ZITV (Zfast_of_Nfast m) (Zfast_of_Nfast M)))
    end
  | All, Just (ZITV my My) =>
    match fAJ (Nfast_of_Zfast my) (Nfast_of_Zfast My) with
    | None => NotBot All
    | Some (m, M) =>
      NotBot (Just (ZITV (Zfast_of_Nfast m) (Zfast_of_Nfast M)))
    end
  | All, All => NotBot All
  end.

Lemma pos_bind_spec:
  ∀ x_ab x, Z.of_N x ∈ γ x_ab ->
  ∀ y_ab y, Z.of_N y ∈ γ y_ab ->
  ∀ (fJJ:Nfast -> Nfast -> Nfast -> Nfast -> Nfast * Nfast)
    (fAJ fJA:Nfast -> Nfast -> option (Nfast * Nfast)) f,
  (∀ mx x Mx, (mx <= x <= Mx)%N ->
   ∀ my y My, (my <= y <= My)%N ->
   ∀ r R, fJJ mx Mx my My = (r, R) ->
          (r <= f x y <= R)%N) ->
  (∀ mx x Mx, (mx <= x <= Mx)%N ->
   ∀ y r R, fJA mx Mx = Some (r, R) ->
          (r <= f x y <= R)%N) ->
  (∀ x my y My, (my <= y <= My)%N ->
   ∀ r R, fAJ my My = Some (r, R) ->
          (r <= f x y <= R)%N) ->
  Z.of_N (f x y) ∈ γ (pos_bind fJJ fJA fAJ x_ab y_ab).
Proof.
  unfold pos_bind. intros.
  eapply botbind_spec, positive_part_correct. 2:apply H. 2:Psatz.lia. intros.
  eapply botbind_spec, positive_part_correct. 2:apply H0. 2:Psatz.lia. intros.
  destruct a as [|[[] []]], a0 as [|[[] []]]; simpl; auto; intros.
  - destruct (fAJ (Nfast_of_Zfast x0) (Nfast_of_Zfast x1)) as [[]|] eqn:EQ. 2:exact I.
    eapply H3 with (x:=x) (y:=y) in EQ. simpl; Psatz.lia.
    destruct x0, x1; simpl in *; Psatz.lia.
  - destruct (fJA (Nfast_of_Zfast x0) (Nfast_of_Zfast x1)) as [[]|] eqn:EQ. 2:exact I.
    eapply H2 with (x:=x) (y:=y) in EQ. simpl; Psatz.lia.
    destruct x0, x1; simpl in *; Psatz.lia.
  - destruct (fJJ (Nfast_of_Zfast x0) (Nfast_of_Zfast x1)
                  (Nfast_of_Zfast x2) (Nfast_of_Zfast x3)) eqn:EQ.
    eapply H1 with (x:=x) (y:=y) in EQ. simpl; Psatz.lia.
    destruct x0, x1; simpl in *; Psatz.lia.
    destruct x2, x3; simpl in *; Psatz.lia.
Qed.

Definition forward_land (x y:zitv+⊤) : zitv+⊤+⊥ :=
  pos_bind forward_and_pos (fun _ M => Some (F0, M))
                           (fun _ M => Some (F0, M)) x y
  pos_bind forward_diff_pos (fun _ M => Some (F0, M))
                            (fun _ _ => None) x (forward_lnot y) ⊔
  pos_bind forward_diff_pos (fun _ M => Some (F0, M))
                            (fun _ _ => None) y (forward_lnot x) ⊔
  fmap forward_lnot
    (pos_bind forward_or_pos (fun _ _ => None) (fun _ _ => None)
              (forward_lnot x) (forward_lnot y)).

Lemma forward_land_correct:
  ∀ x x_ab, x ∈ γ x_ab ->
  ∀ y y_ab, y ∈ γ y_ab ->
  Z.land x y ∈ γ (forward_land x_ab y_ab).
Proof.
  intros. unfold forward_land.
  assert (∀ x, ∃ x', x = Z.of_N x' \/ x = Z.lnot (Z.of_N x')).
  { intro. unfold Z.lnot. destruct x0.
    - exists 0%N. eauto.
    - eexists (Npos _). simpl. eauto.
    - eexists (Npos p - 1)%N. zify. omega. }
  destruct (H1 x) as [x' []], (H1 y) as [y' []]; subst.
  - replace (Z.land (Z.of_N x') (Z.of_N y')) with (Z.of_N (N.land x' y'))
      by (destruct x', y'; reflexivity).
    apply join_correct. left.
    apply join_correct. left.
    apply join_correct. left.
    apply pos_bind_spec; auto.
    + apply forward_and_pos_correct.
    + intros. inv H3. split. simpl. Psatz.lia.
      transitivity x; try (simpl; Psatz.lia). zify. apply Int.Ztestbit_le. auto.
      intros i Hi. rewrite !Z2N.inj_testbit, N.land_spec, Bool.andb_true_iff by auto.
      now intuition.
    + intros. inv H3. split. simpl. Psatz.lia.
      transitivity y; try (simpl; Psatz.lia). zify. apply Int.Ztestbit_le. auto.
      intros i Hi. rewrite !Z2N.inj_testbit, N.land_spec, Bool.andb_true_iff by auto.
      now intuition.
  - assert (γ (forward_lnot y_ab) (Z.of_N y')).
    { rewrite <- Z.lnot_involutive with (Z.of_N y'). auto using forward_lnot_correct. }
    replace (Z.land (Z.of_N x') (Z.lnot (Z.of_N y'))) with (Z.of_N (N.ldiff x' y'))
      by (destruct x', y'; try reflexivity; simpl;
          replace (Pos.pred_N (p0 + 1)) with (Npos p0); [reflexivity|];
          rewrite Pos.add_1_r, Pos.pred_N_succ; reflexivity).
    apply join_correct. left.
    apply join_correct. left.
    apply join_correct. right.
    apply pos_bind_spec; auto.
    + apply forward_diff_pos_correct.
    + intros. inv H4. split. simpl. Psatz.lia.
      transitivity x; try (simpl; Psatz.lia). zify. apply Int.Ztestbit_le. auto.
      intros i Hi. rewrite !Z2N.inj_testbit, N.ldiff_spec, Bool.andb_true_iff by auto.
      now intuition.
    + discriminate.
  - assert (γ (forward_lnot x_ab) (Z.of_N x')).
    { rewrite <- Z.lnot_involutive with (Z.of_N x'). auto using forward_lnot_correct. }
    replace (Z.land (Z.lnot (Z.of_N x')) (Z.of_N y')) with (Z.of_N (N.ldiff y' x'))
      by (destruct x', y'; try reflexivity; simpl;
          replace (Pos.pred_N (p + 1)) with (Npos p); [reflexivity|];
          rewrite Pos.add_1_r, Pos.pred_N_succ; reflexivity).
    apply join_correct. left.
    apply join_correct. right.
    apply pos_bind_spec; auto.
    + apply forward_diff_pos_correct.
    + intros. inv H4. split. simpl. Psatz.lia.
      transitivity x; try (simpl; Psatz.lia). zify. apply Int.Ztestbit_le. auto.
      intros i Hi. rewrite !Z2N.inj_testbit, N.ldiff_spec, Bool.andb_true_iff by auto.
      now intuition.
    + discriminate.
  - assert (γ (forward_lnot x_ab) (Z.of_N x')).
    { rewrite <- Z.lnot_involutive with (Z.of_N x'). auto using forward_lnot_correct. }
    assert (γ (forward_lnot y_ab) (Z.of_N y')).
    { rewrite <- Z.lnot_involutive with (Z.of_N y'). auto using forward_lnot_correct. }
    replace (Z.land (Z.lnot (Z.of_N x')) (Z.lnot (Z.of_N y'))) with (Z.lnot (Z.of_N (N.lor x' y')))
      by (rewrite <- Z.lnot_lor; destruct x', y'; reflexivity).
    apply join_correct. right. eapply botbind_spec.
    intros. apply forward_lnot_correct, H4.
    apply pos_bind_spec; auto.
    + apply forward_or_pos_correct.
    + discriminate.
    + discriminate.
Qed.

Definition forward_lor (x y:zitv+⊤) : zitv+⊤+⊥ :=
  fmap forward_lnot (forward_land (forward_lnot x) (forward_lnot y)).

Lemma forward_lor_correct:
  ∀ x x_ab, x ∈ γ x_ab ->
  ∀ y y_ab, y ∈ γ y_ab ->
  Z.lor x y ∈ γ (forward_lor x_ab y_ab).
Proof.
  intros.
  rewrite <- Z.lnot_involutive, Z.lnot_lor.
  eapply botbind_spec; intros.
  apply forward_lnot_correct; eauto.
  apply forward_land_correct; apply forward_lnot_correct; auto.
Qed.

Definition forward_lxor (x y:zitv+⊤) : zitv+⊤+⊥ :=
  do A <- forward_land x (forward_lnot y);
  do B <- forward_land (forward_lnot x) y;
  forward_lor A B.

Lemma forward_lxor_correct:
  ∀ x x_ab, x ∈ γ x_ab ->
  ∀ y y_ab, y ∈ γ y_ab ->
  Z.lxor x y ∈ γ (forward_lxor x_ab y_ab).
Proof.
  intros.
  replace (Z.lxor x y) with (Z.lor (Z.land x (Z.lnot y)) (Z.land(Z.lnot x) y)).
  eapply botbind_spec; intros. eapply botbind_spec; intros.
  apply forward_lor_correct; eauto.
  apply forward_land_correct; eauto; apply forward_lnot_correct; auto.
  apply forward_land_correct; eauto; apply forward_lnot_correct; auto.
  apply Z.bits_inj'; intros.
  rewrite !Z.lor_spec, !Z.land_spec, !Z.lnot_spec, Z.lxor_spec; auto.
  repeat (destruct Z.testbit; try reflexivity).
Qed.

Definition forward_shl (x y:zitv+⊤) : zitv+⊤+⊥ :=
  match x with
  | All => NotBot All
  | Just (ZITV mx Mx) =>
    if (Zfastleb F0 mx && Zfastleb Mx F0)%bool then NotBot (Just (ZITV F0 F0))
    else
      match y with
      | All => NotBot All
      | Just (ZITV my My) =>
        if (Zfastleb (Zfastopp F64) my && Zfastleb My F64)%bool then
          NotBot (Just (ZITV (Zfastshl mx (if Zfastleb F0 mx then my else My))
                             (Zfastshl Mx (if Zfastleb F0 Mx then My else my))))
        else
          NotBot All
      end
  end.

Lemma forward_shl_correct:
  ∀ x x_ab, x ∈ γ x_ab ->
  ∀ y y_ab, y ∈ γ y_ab ->
  Z.shiftl x y ∈ γ (forward_shl x_ab y_ab).
Proof.
  intros.
  destruct x_ab as [|[]]; unfold forward_shl. tauto.
  fastunwrap. simpl. destruct ((0 <=? z) && (z0 <=? 0))%bool eqn:EQ.
  - rewrite Bool.andb_true_iff in EQ.
    destruct (Z.leb_spec 0 z). destruct (Z.leb_spec z0 0).
    destruct H. replace x with 0 by Psatz.lia.
    rewrite Z.shiftl_0_l. split; reflexivity.
    destruct EQ. congruence. destruct EQ. congruence.
  - clear EQ.
    destruct y_ab as [|[]]. tauto. simpl in *. fastunwrap.
    destruct ((-64 <=? z1) && (z2 <=? 64))%bool. 2:simpl; easy.
    simpl in *.
    assert (forall a b c, 0 <= a -> b <= c -> Z.shiftl a b <= Z.shiftl a c). {
      intros.
      destruct (Z.nonpos_pos_cases b), (Z.nonpos_pos_cases c); try Psatz.lia.
      - rewrite !Z.shiftl_div_pow2 by Psatz.lia.
        apply Z.div_le_compat_l. auto.
        split. apply Z.pow_pos_nonneg; Psatz.lia. apply Z.pow_le_mono_r; Psatz.lia.
      - rewrite Z.shiftl_div_pow2, Z.shiftl_mul_pow2 by Psatz.lia.
        transitivity a.
        assert (a / 2 ^ (- b) <= a / 1).
        apply Z.div_le_compat_l. auto. pose proof (Z.pow_pos_nonneg 2 (-b)). Psatz.lia.
        rewrite Zdiv_1_r in H5. auto.
        assert (a * 1 <= a * 2 ^ c).
        apply Zmult_le_compat_l. pose proof (Z.pow_pos_nonneg 2 c). Psatz.lia. auto.
        rewrite Zmult_1_r in H5. auto.
      - rewrite !Z.shiftl_mul_pow2 by Psatz.lia.
        apply Zmult_le_compat_l. apply Z.pow_le_mono_r; Psatz.lia. auto.
    }
    assert (forall a b c, a < 0 -> b <= c -> Z.shiftl a c <= Z.shiftl a b). {
      intros.
      destruct (Z.nonpos_pos_cases b), (Z.nonpos_pos_cases c); try Psatz.lia.
      - specialize (H1 (Z.lnot a) b c).
        replace (Z.shiftl (Z.lnot a) b) with (Z.lnot (Z.shiftl a b)) in H1.
        replace (Z.shiftl (Z.lnot a) c) with (Z.lnot (Z.shiftl a c)) in H1.
        unfold Z.lnot in H1. omega.
        apply Z.bits_inj'. intros. rewrite Z.lnot_spec, !Z.shiftl_spec, Z.lnot_spec by Psatz.lia. reflexivity.
        apply Z.bits_inj'. intros. rewrite Z.lnot_spec, !Z.shiftl_spec, Z.lnot_spec by Psatz.lia. reflexivity.
      - rewrite Z.shiftl_mul_pow2, Z.shiftl_div_pow2 by Psatz.lia.
        transitivity a.
        assert ((-a) * 1 <= (-a) * 2 ^ c).
        apply Zmult_le_compat_l. pose proof (Z.pow_pos_nonneg 2 c). Psatz.lia. Psatz.lia.
        rewrite !Z.mul_opp_l in H6. Psatz.lia.
        rewrite <- Z.div_mul with (a:=a) (b:=2^(-b)) at 1.
        apply Z.div_le_mono.
        apply Z.pow_pos_nonneg; Psatz.lia.
        assert ((-a) * 1 <= (-a) * 2 ^ (-b)).
        apply Zmult_le_compat_l. pose proof (Z.pow_pos_nonneg 2 (-b)). Psatz.lia. Psatz.lia.
        rewrite !Z.mul_opp_l in H6. Psatz.lia.
        pose proof (Z.pow_pos_nonneg 2 (-b)). Psatz.lia.
      - rewrite !Z.shiftl_mul_pow2 by Psatz.lia.
        assert ((-a)*2^b <= (-a)*2^c).
        apply Zmult_le_compat_l. apply Z.pow_le_mono_r; Psatz.lia. Psatz.lia.
        rewrite !Z.mul_opp_l in H6. Psatz.lia.
    }
    assert (forall a b c, a <= b -> Z.shiftl a c <= Z.shiftl b c). {
      intros.
      destruct (Z.nonpos_pos_cases c).
      - rewrite !Z.shiftl_div_pow2 by Psatz.lia.
        apply Z.div_le_mono. apply Z.pow_pos_nonneg; Psatz.lia. auto.
      - rewrite !Z.shiftl_mul_pow2 by Psatz.lia.
        apply Zmult_le_compat_r. auto. pose proof (Z.pow_pos_nonneg 2 c). Psatz.lia.
    }
    destruct H0, H.
    split; [pose proof (Zle_cases 0 z)|pose proof (Zle_cases 0 z0)]; destruct Z.leb.
    + etransitivity. apply H1; eauto. apply H3; eauto.
    + etransitivity. apply H2. Psatz.lia. eauto. apply H3; eauto.
    + etransitivity. apply H3; eauto. apply H1; eauto.
    + etransitivity. apply H3; eauto. apply H2. Psatz.lia. eauto.
Qed.

Definition forward_shr (x y:zitv+⊤) : zitv+⊤+⊥ :=
  forward_shl x (forward_neg y).

Lemma forward_shr_correct:
  ∀ x x_ab, x ∈ γ x_ab ->
  ∀ y y_ab, y ∈ γ y_ab ->
  Z.shiftr x y ∈ γ (forward_shr x_ab y_ab).
Proof.
  intros.
  rewrite <- Z.shiftl_opp_r.
  apply forward_shl_correct. auto.
  apply forward_neg_correct, H0.
Qed.

Definition backward_cmp_l (c:comparison) (x y:zitv+⊤) : zitv+⊤+⊥ :=
  match c with
  | Ceq =>
    match x, y with
    | Just (ZITV mx Mx), Just (ZITV my My) =>
      if Zfastleb my Mx && Zfastleb mx My then NotBot y else Bot
    | _, _ => NotBot y
    end
  | Cne =>
    match y with
    | Just (ZITV my My) =>
      if Zfastleb My my then
        match x with
        | Just (ZITV mx Mx) =>
          if Zfastleb mx my && Zfastleb my mx then
            if Zfastleb Mx my && Zfastleb my Mx then Bot
            else NotBot (Just (ZITV (Zfastadd mx F1) Mx))
          else
            if Zfastleb Mx my && Zfastleb my Mx then
              NotBot (Just (ZITV mx (Zfastsub Mx F1)))
            else NotBot All
        | All => NotBot All
        end
      else NotBot All
    | All => NotBot All
    end
  | Cle =>
    match x, y with
    | Just (ZITV mx _), Just (ZITV _ My) =>
      if Zfastleb mx My then NotBot (Just (ZITV mx My)) else Bot
    | _, _ => NotBot All
    end
  | Cge =>
    match x, y with
    | Just (ZITV _ Mx), Just (ZITV my _) =>
      if Zfastleb my Mx then NotBot (Just (ZITV my Mx)) else Bot
    | _, _ => NotBot All
    end
  | Clt =>
    match x, y with
    | Just (ZITV mx _), Just (ZITV _ My) =>
      let Mx' := Zfastsub My F1 in
      if Zfastleb mx Mx' then NotBot (Just (ZITV mx Mx')) else Bot
    | _, _ => NotBot All
    end
  | Cgt =>
    match x, y with
    | Just (ZITV _ Mx), Just (ZITV my _) =>
      let mx' := Zfastadd my F1 in
      if Zfastleb mx' Mx then NotBot (Just (ZITV mx' Mx)) else Bot
    | _, _ => NotBot All
    end
  end.

Definition Zcmp (c:comparison) (z1 z2:Z) : bool :=
  match c, z1 ?= z2 with
  | Ceq, Eq | Clt, Lt | Cgt, Gt
  | Cle, (Lt|Eq) | Cge, (Gt|Eq)
  | Cne, (Lt|Gt) => true
  | _, _ => false
  end.

Lemma backward_cmp_l_correct:
  ∀ x x_ab, x ∈ γ x_ab ->
  ∀ y y_ab, y ∈ γ y_ab ->
  ∀ c, Zcmp c x y = true ->
    x ∈ γ (backward_cmp_l c x_ab y_ab).
Proof.
  intros x x_ab Hx y y_ab Hy [] Hc;
  simpl in Hc; destruct (Zcompare_spec x y);
  try discriminate; subst; clear Hc; unfold backward_cmp_l;
  destruct x_ab as [|[]], y_ab as [|[]]; fastunwrap;
  repeat match goal with
  | |- context [?a <=? ?b] => destruct (Z.leb_spec a b)
  end; simpl in *; try exact I; try Psatz.lia.
Qed.

Definition backward_mul_pos (res x:zitv+⊤) (my My:Zfast) : zitv+⊤+⊥ :=
  match res with
  | Just (ZITV mres Mres) =>
    let mx := Zfastopp (Zfastdiv (Zfastopp mres)
                                 (if Zfastleb F0 mres then My else my)) in
    let Mx := Zfastdiv Mres (if Zfastleb F0 Mres then my else My) in
    Just (ZITV mx Mx) ⊓ x
  | All => NotBot x
  end.

Lemma backward_mul_pos_correct:
  ∀ x x_ab, x ∈ γ x_ab ->
  ∀ y my My, 0 < my /\ my <= y <= My ->
  ∀ res_ab, (x * y)%Z ∈ γ res_ab ->
    x ∈ γ (backward_mul_pos res_ab x_ab my My).
Proof.
  intros x x_ab Hx y my My Hy [|[[mres] [Mres]]] Hres; auto.
  apply meet_correct. split; auto. fastunwrap. simpl.
  destruct Hres; split.
  - apply Z.opp_le_mono. simpl. rewrite Zopp_involutive.
    eapply Zle_trans with ((-mres)/y). simpl in *.
    eapply Zdiv_le_lower_bound. Psatz.lia. replace (-x*y) with (-(x*y)) by ring. Psatz.lia.
    destruct (Z.leb_spec 0 mres); fastunwrap.
    + apply Zdiv_le_lower_bound. Psatz.lia.
      rewrite (Z_div_mod_eq (-mres) y) at 2 by Psatz.lia.
      rewrite Zmult_comm.
      eapply Zle_trans with (y*((-mres)/y)).
      replace ((-mres)/y) with (-1*(-((-mres)/y))) by ring.
      rewrite !Zmult_assoc. apply Zmult_le_compat_r. Psatz.lia.
      pose proof (Z_div_pos mres y).
      destruct (Z_eq_dec (mres mod y) 0).
      rewrite Z_div_zero_opp_full; trivial. Psatz.lia.
      rewrite Z_div_nz_opp_full; trivial. Psatz.lia.
      pose proof (Z_mod_lt (-mres) y). Psatz.lia.
    + destruct (Z_eq_dec y my). subst; Psatz.lia.
      apply Zdiv_le_compat_l. Psatz.lia. Psatz.lia.
  - eapply Zle_trans with (Mres/y).
    eapply Zdiv_le_lower_bound. Psatz.lia. auto.
    destruct (Z.leb_spec 0 Mres); fastunwrap.
    + destruct (Z_eq_dec y my). subst; Psatz.lia.
      apply Zdiv_le_compat_l. Psatz.lia. Psatz.lia.
    + destruct (Z_eq_dec y My). subst; Psatz.lia.
      apply Zdiv_le_lower_bound. Psatz.lia.
      rewrite (Z_div_mod_eq Mres y) at 2 by Psatz.lia.
      rewrite Zmult_comm.
      eapply Zle_trans with (y*(Mres/y)).
      replace (Mres/y) with (-1*(-(Mres/y))) by ring.
      rewrite !Zmult_assoc. apply Zmult_le_compat_r. Psatz.lia.
      pose proof (Z_div_pos (-Mres) y).
      assert (Mres/y <= 0); [|Psatz.lia].
      eapply Zdiv_le_upper_bound. Psatz.lia. Psatz.lia.
      pose proof (Z_mod_lt Mres y). Psatz.lia.
Qed.

Definition backward_mul_neg (res x:zitv+⊤) (my My:Zfast) : zitv+⊤+⊥ :=
  backward_mul_pos (forward_neg res) x (Zfastopp My) (Zfastopp my).

Lemma backward_mul_neg_correct:
  ∀ x x_ab, x ∈ γ x_ab ->
  ∀ y my My, My < 0 /\ my <= y <= My ->
  ∀ res_ab, (x * y)%Z ∈ γ res_ab ->
    x ∈ γ (backward_mul_neg res_ab x_ab my My).
Proof.
  intros. apply backward_mul_pos_correct with (-y).
  auto. fastunwrap. Psatz.lia.
  replace (x* -y) with (-(x*y)) by ring.
  apply forward_neg_correct, H1.
Qed.

Definition backward_mul_0 (res:zitv+⊤) : zitv+⊤+⊥ :=
  if Just (ZITV F0 F0) ⊑ res then NotBot All else Bot.

Lemma backward_mul_0_correct:
  ∀ x,
  ∀ y, 0 <= y <= 0 ->
  ∀ res_ab, (x * y)%Z ∈ γ res_ab ->
    x ∈ γ (backward_mul_0 res_ab).
Proof.
  intros. replace y with 0 in * by Psatz.lia.
  destruct res_ab as [|[[[]] [[]]]]; simpl in *;
  try reflexivity;
  Psatz.lia.
Qed.

Definition backward_mul_l (res x y:zitv+⊤) : zitv+⊤+⊥ :=
  match y with
  | All => NotBot All
  | Just (ZITV my My) =>
    let p :=
      if Zfastleb My F0 then Bot
      else backward_mul_pos res x (Zfastmax F1 my) My
    in
    let n :=
      if Zfastleb F0 my then Bot
      else backward_mul_neg res x my (Zfastmin Fm1 My)
    in
    let z :=
      if Zfastleb my F0 && Zfastleb F0 My then backward_mul_0 res
      else Bot
    in
    pnz
  end.

Lemma backward_mul_l_correct:
  ∀ x x_ab, x ∈ γ x_ab ->
  ∀ y y_ab, y ∈ γ y_ab ->
  ∀ res_ab, (x * y)%Z ∈ γ res_ab ->
    x ∈ γ (backward_mul_l res_ab x_ab y_ab).
Proof.
  intros x x_ab Hx y y_ab Hy res_ab Hres.
  destruct y_ab as [|[[my][My]]]. auto.
  destruct y, Hy; unfold backward_mul_l; fastunwrap.
  - apply join_correct. right.
    rewrite !Zle_imp_le_bool by auto. eapply backward_mul_0_correct, Hres. Psatz.lia.
  - apply join_correct. left. apply join_correct. left.
    rewrite (proj2 (Z.leb_gt _ _)) by Psatz.lia.
    eapply backward_mul_pos_correct; eauto. Psatz.lia.
  - apply join_correct. left. apply join_correct. right.
    rewrite (proj2 (Z.leb_gt _ _)) by Psatz.lia.
    eapply backward_mul_neg_correct; eauto. Psatz.lia.
Qed.

Definition backward_or (res x y: zitv+⊤) : (zitv+⊤ * zitv+⊤)+⊥ :=
  match res with
  | Just (ZITV 0 0) =>
    do x' <- xres;
    do y' <- yres;
    NotBot (x', y')
  | _ => NotBot (x, y)
  end.

Lemma backward_or_correct:
  ∀ x x_ab, x ∈ γ x_ab ->
  ∀ y y_ab, y ∈ γ y_ab ->
  ∀ res_ab, (Z.lor x y) ∈ γ res_ab ->
    (x, y) ∈ γ (backward_or res_ab x_ab y_ab).
Proof.
  unfold backward_or.
  intros x x_ab H y y_ab H0 res_ab H1.
  destruct res_ab as [ | [[[]] [h]] ]; try (split; eauto).
  destruct h; try (split; eauto).
  assert (Z.lor x y = 0) as Hz. destruct H1; fastunwrap; Psatz.lia. clear H1.
  apply Z.lor_eq_0_iff in Hz. destruct Hz. subst x y.
  assert (γ (Just (ZITV 0 0)) 0) as K0. split; discriminate.
  apply botbind_spec with 0. intros x' Hx'.
  apply botbind_spec with 0. intros y' Hy'.
  split; eauto.
  apply meet_correct; split; auto.
  apply meet_correct; split; auto.
Qed.