(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2013-2018 Sylvie Boldo
#<br />#
Copyright (C) 2013-2018 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Rounding to odd and its properties, including the equivalence
      between rnd_NE and double rounding with rnd_odd and then rnd_NE *)

Require Import Reals Psatz.
Require Import Core Operations.

Definition Zrnd_odd x :=  match Req_EM_T x (IZR (Zfloor x))  with
  | left _   => Zfloor x
  | right _  => match (Z.even (Zfloor x)) with
      | true => Zceil x
      | false => Zfloor x
     end
  end.

Global Instance valid_rnd_odd : Valid_rnd Zrnd_odd.
Proof.
split.
(* . *)
intros x y Hxy.
assert (Zfloor x <= Zrnd_odd y)%Z.
(* .. *)
apply Zle_trans with (Zfloor y).
now apply Zfloor_le.
unfold Zrnd_odd; destruct (Req_EM_T  y (IZR (Zfloor y))).
now apply Zle_refl.
case (Z.even (Zfloor y)).
apply le_IZR.
apply Rle_trans with y.
apply Zfloor_lb.
apply Zceil_ub.
now apply Zle_refl.
unfold Zrnd_odd at 1.
(* . *)
destruct (Req_EM_T  x (IZR (Zfloor x))) as [Hx|Hx].
(* .. *)
apply H.
(* .. *)
case_eq (Z.even (Zfloor x)); intros Hx2.
2: apply H.
unfold Zrnd_odd; destruct (Req_EM_T  y (IZR (Zfloor y))) as [Hy|Hy].
apply Zceil_glb.
now rewrite <- Hy.
case_eq (Z.even (Zfloor y)); intros Hy2.
now apply Zceil_le.
apply Zceil_glb.
assert (H0:(Zfloor x <= Zfloor y)%Z) by now apply Zfloor_le.
case (Zle_lt_or_eq _ _  H0); intros H1.
apply Rle_trans with (1:=Zceil_ub _).
rewrite Zceil_floor_neq.
apply IZR_le; omega.
now apply sym_not_eq.
contradict Hy2.
rewrite <- H1, Hx2; discriminate.
(* . *)
intros n; unfold Zrnd_odd.
rewrite Zfloor_IZR, Zceil_IZR.
destruct (Req_EM_T  (IZR n) (IZR n)); trivial.
case (Z.even n); trivial.
Qed.

Lemma Zrnd_odd_Zodd: forall x, x <> (IZR (Zfloor x)) ->
  (Z.even (Zrnd_odd x)) = false.
Proof.
intros x Hx; unfold Zrnd_odd.
destruct (Req_EM_T  x (IZR (Zfloor x))) as [H|H].
now contradict H.
case_eq (Z.even (Zfloor x)).
(* difficult case *)
intros H'.
rewrite Zceil_floor_neq.
rewrite Z.even_add, H'.
reflexivity.
now apply sym_not_eq.
trivial.
Qed.

Lemma Zfloor_plus: forall (n:Z) y,
  (Zfloor (IZR n+y) = n + Zfloor y)%Z.
Proof.
intros n y; unfold Zfloor.
unfold Zminus; rewrite Zplus_assoc; f_equal.
apply sym_eq, tech_up.
rewrite plus_IZR.
apply Rplus_lt_compat_l.
apply archimed.
rewrite plus_IZR, Rplus_assoc.
apply Rplus_le_compat_l.
apply Rplus_le_reg_r with (-y)%R.
ring_simplify (y+1+-y)%R.
apply archimed.
Qed.

Lemma Zceil_plus: forall (n:Z) y,
  (Zceil (IZR n+y) = n + Zceil y)%Z.
Proof.
intros n y; unfold Zceil.
rewrite Ropp_plus_distr, <- Ropp_Ropp_IZR.
rewrite Zfloor_plus.
ring.
Qed.

Lemma Zeven_abs: forall z, Z.even (Zabs z) = Z.even z.
Proof.
intros z; case (Zle_or_lt z 0); intros H1.
rewrite Z.abs_neq; try assumption.
apply Z.even_opp.
rewrite Z.abs_eq; auto with zarith.
Qed.

Lemma Zrnd_odd_plus: forall x y, (x = IZR (Zfloor x)) ->
    Z.even (Zfloor x) = true ->
   (IZR (Zrnd_odd (x+y)) = x+IZR (Zrnd_odd y))%R.
Proof.
intros x y Hx H.
unfold Zrnd_odd; rewrite Hx, Zfloor_plus.
case (Req_EM_T y (IZR (Zfloor y))); intros Hy.
rewrite Hy; repeat rewrite <- plus_IZR.
repeat rewrite Zfloor_IZR.
case (Req_EM_T _ _); intros K; easy.
case (Req_EM_T _ _); intros K.
contradict Hy.
apply Rplus_eq_reg_l with (IZR (Zfloor x)).
now rewrite K, plus_IZR.
rewrite Z.even_add, H; simpl.
case (Z.even (Zfloor y)).
now rewrite Zceil_plus, plus_IZR.
now rewrite plus_IZR.
Qed.

Section Fcore_rnd_odd.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.

Context { valid_exp : Valid_exp fexp }.
Context { exists_NE_ : Exists_NE beta fexp }.

Notation format := (generic_format beta fexp).
Notation canonical := (canonical beta fexp).
Notation cexp := (cexp beta fexp).

Definition Rnd_odd_pt (x f : R) :=
  format f /\ ((f = x)%R \/
    ((Rnd_DN_pt format x f \/ Rnd_UP_pt format x f) /\
    exists g : float beta, f = F2R g /\ canonical g /\ Z.even (Fnum g) = false)).

Definition Rnd_odd (rnd : R -> R) :=
  forall x : R, Rnd_odd_pt x (rnd x).

Theorem Rnd_odd_pt_opp_inv :   forall x f : R,
  Rnd_odd_pt (-x) (-f) -> Rnd_odd_pt x f.
Proof with auto with typeclass_instances.
intros x f (H1,H2).
split.
replace f with (-(-f))%R by ring.
now apply generic_format_opp.
destruct H2.
left.
replace f with (-(-f))%R by ring.
rewrite H; ring.
right.
destruct H as (H2,(g,(Hg1,(Hg2,Hg3)))).
split.
destruct H2.
right.
replace f with (-(-f))%R by ring.
replace x with (-(-x))%R by ring.
apply Rnd_UP_pt_opp...
apply generic_format_opp.
left.
replace f with (-(-f))%R by ring.
replace x with (-(-x))%R by ring.
apply Rnd_DN_pt_opp...
apply generic_format_opp.
exists (Float beta (-Fnum g) (Fexp g)).
split.
rewrite F2R_Zopp.
replace f with (-(-f))%R by ring.
rewrite Hg1; reflexivity.
split.
now apply canonical_opp.
simpl.
now rewrite Z.even_opp.
Qed.

Theorem round_odd_opp :
  forall x,
  round beta fexp Zrnd_odd (-x) = (- round beta fexp Zrnd_odd x)%R.
Proof.
intros x; unfold round.
rewrite <- F2R_Zopp.
unfold F2R; simpl.
apply f_equal2; apply f_equal.
rewrite scaled_mantissa_opp.
generalize (scaled_mantissa beta fexp x); intros r.
unfold Zrnd_odd.
case (Req_EM_T (- r) (IZR (Zfloor (- r)))).
case (Req_EM_T r (IZR (Zfloor r))).
intros Y1 Y2.
apply eq_IZR.
now rewrite opp_IZR, <- Y1, <-Y2.
intros Y1 Y2.
absurd (r=IZR (Zfloor r)); trivial.
pattern r at 2; replace r with (-(-r))%R by ring.
rewrite Y2, <- opp_IZR.
rewrite Zfloor_IZR.
rewrite opp_IZR, <- Y2.
ring.
case (Req_EM_T r (IZR (Zfloor r))).
intros Y1 Y2.
absurd (-r=IZR (Zfloor (-r)))%R; trivial.
pattern r at 2; rewrite Y1.
rewrite <- opp_IZR, Zfloor_IZR.
now rewrite opp_IZR, <- Y1.
intros Y1 Y2.
unfold Zceil; rewrite Ropp_involutive.
replace  (Z.even (Zfloor (- r))) with (negb (Z.even (Zfloor r))).
case (Z.even (Zfloor r));  simpl; ring.
apply trans_eq with (Z.even (Zceil r)).
rewrite Zceil_floor_neq.
rewrite Z.even_add.
destruct (Z.even (Zfloor r)); reflexivity.
now apply sym_not_eq.
rewrite <- (Z.even_opp (Zfloor (- r))).
reflexivity.
apply cexp_opp.
Qed.

Theorem round_odd_pt :
  forall x,
  Rnd_odd_pt x (round beta fexp Zrnd_odd x).
Proof with auto with typeclass_instances.
cut (forall x : R, (0 < x)%R -> Rnd_odd_pt x (round beta fexp Zrnd_odd x)).
intros H x; case (Rle_or_lt 0 x).
intros H1; destruct H1.
now apply H.
rewrite <- H0.
rewrite round_0...
split.
apply generic_format_0.
now left.
intros Hx; apply Rnd_odd_pt_opp_inv.
rewrite <- round_odd_opp.
apply H.
auto with real.
(* *)
intros x Hxp.
generalize (generic_format_round beta fexp Zrnd_odd x).
set (o:=round beta fexp Zrnd_odd x).
intros Ho.
split.
assumption.
(* *)
case (Req_dec o x); intros Hx.
now left.
right.
assert (o=round beta fexp Zfloor x \/ o=round beta fexp Zceil x).
unfold o, round, F2R;simpl.
case (Zrnd_DN_or_UP Zrnd_odd  (scaled_mantissa beta fexp x))...
intros H; rewrite H; now left.
intros H; rewrite H; now right.
split.
destruct H; rewrite H.
left; apply round_DN_pt...
right; apply round_UP_pt...
(* *)
unfold o, Zrnd_odd, round.
case (Req_EM_T (scaled_mantissa beta fexp x)
     (IZR (Zfloor (scaled_mantissa beta fexp x)))).
intros T.
absurd (o=x); trivial.
apply round_generic...
unfold generic_format, F2R; simpl.
rewrite <- (scaled_mantissa_mult_bpow beta fexp) at 1.
apply f_equal2; trivial; rewrite T at 1.
apply f_equal, sym_eq, Ztrunc_floor.
apply Rmult_le_pos.
now left.
apply bpow_ge_0.
intros L.
case_eq (Z.even (Zfloor (scaled_mantissa beta fexp x))).
(* . *)
generalize (generic_format_round beta fexp Zceil x).
unfold generic_format.
set (f:=round beta fexp Zceil x).
set (ef := cexp f).
set (mf := Ztrunc (scaled_mantissa beta fexp f)).
exists (Float beta mf ef).
unfold canonical.
rewrite <- H0.
repeat split; try assumption.
apply trans_eq with (negb (Z.even (Zfloor (scaled_mantissa beta fexp x)))).
2: rewrite H1; reflexivity.
apply trans_eq with (negb (Z.even (Fnum
  (Float beta  (Zfloor (scaled_mantissa beta fexp x)) (cexp x))))).
2: reflexivity.
case (Rle_lt_or_eq_dec 0 (round beta fexp Zfloor x)).
rewrite <- round_0 with beta fexp Zfloor...
apply round_le...
now left.
intros Y.
generalize (DN_UP_parity_generic beta fexp)...
unfold DN_UP_parity_prop.
intros T; apply T with x; clear T.
unfold generic_format.
rewrite <- (scaled_mantissa_mult_bpow beta fexp x) at 1.
unfold F2R; simpl.
apply Rmult_neq_compat_r.
apply Rgt_not_eq, bpow_gt_0.
rewrite Ztrunc_floor.
assumption.
apply Rmult_le_pos.
now left.
apply bpow_ge_0.
unfold canonical.
simpl.
apply sym_eq, cexp_DN...
unfold canonical.
rewrite <- H0; reflexivity.
reflexivity.
apply trans_eq with (round beta fexp Ztrunc (round beta fexp Zceil x)).
reflexivity.
apply round_generic...
intros Y.
replace  (Fnum {| Fnum := Zfloor (scaled_mantissa beta fexp x); Fexp := cexp x |})
   with (Fnum (Float beta 0 (fexp (mag beta 0)))).
generalize (DN_UP_parity_generic beta fexp)...
unfold DN_UP_parity_prop.
intros T; apply T with x; clear T.
unfold generic_format.
rewrite <- (scaled_mantissa_mult_bpow beta fexp x) at 1.
unfold F2R; simpl.
apply Rmult_neq_compat_r.
apply Rgt_not_eq, bpow_gt_0.
rewrite Ztrunc_floor.
assumption.
apply Rmult_le_pos.
now left.
apply bpow_ge_0.
apply canonical_0.
unfold canonical.
rewrite <- H0; reflexivity.
rewrite <- Y; unfold F2R; simpl; ring.
apply trans_eq with (round beta fexp Ztrunc (round beta fexp Zceil x)).
reflexivity.
apply round_generic...
simpl.
apply eq_IZR, Rmult_eq_reg_r with (bpow (cexp x)).
unfold round, F2R in Y; simpl in Y; rewrite <- Y.
simpl; ring.
apply Rgt_not_eq, bpow_gt_0.
(* . *)
intros Y.
case (Rle_lt_or_eq_dec 0 (round beta fexp Zfloor x)).
rewrite <- round_0 with beta fexp Zfloor...
apply round_le...
now left.
intros Hrx.
set (ef := cexp x).
set (mf := Zfloor (scaled_mantissa beta fexp x)).
exists (Float beta mf ef).
unfold canonical.
repeat split; try assumption.
simpl.
apply trans_eq with (cexp (round beta fexp Zfloor x )).
apply sym_eq, cexp_DN...
reflexivity.
intros Hrx; contradict Y.
replace (Zfloor (scaled_mantissa beta fexp x)) with 0%Z.
simpl; discriminate.
apply eq_IZR, Rmult_eq_reg_r with (bpow (cexp x)).
unfold round, F2R in Hrx; simpl in Hrx; rewrite <- Hrx.
simpl; ring.
apply Rgt_not_eq, bpow_gt_0.
Qed.

Theorem Rnd_odd_pt_unique :
  forall x f1 f2 : R,
  Rnd_odd_pt x f1 -> Rnd_odd_pt x f2 ->
  f1 = f2.
Proof.
intros x f1 f2 (Ff1,H1) (Ff2,H2).
(* *)
case (generic_format_EM beta fexp x); intros L.
apply trans_eq with x.
case H1; try easy.
intros (J,_); case J; intros J'.
apply Rnd_DN_pt_idempotent with format; assumption.
apply Rnd_UP_pt_idempotent with format; assumption.
case H2; try easy.
intros (J,_); case J; intros J'; apply sym_eq.
apply Rnd_DN_pt_idempotent with format; assumption.
apply Rnd_UP_pt_idempotent with format; assumption.
(* *)
destruct H1 as [H1|(H1,H1')].
contradict L; now rewrite <- H1.
destruct H2 as [H2|(H2,H2')].
contradict L; now rewrite <- H2.
destruct H1 as [H1|H1]; destruct H2 as [H2|H2].
apply Rnd_DN_pt_unique with format x; assumption.
destruct H1' as (ff,(K1,(K2,K3))).
destruct H2' as (gg,(L1,(L2,L3))).
absurd (true = false); try discriminate.
rewrite <- L3.
apply trans_eq with (negb (Z.even (Fnum ff))).
rewrite K3; easy.
apply sym_eq.
generalize (DN_UP_parity_generic beta fexp).
unfold DN_UP_parity_prop; intros T; apply (T x); clear T; try assumption...
rewrite <- K1; apply Rnd_DN_pt_unique with (generic_format beta fexp) x; try easy...
now apply round_DN_pt...
rewrite <- L1; apply Rnd_UP_pt_unique with (generic_format beta fexp) x; try easy...
now apply round_UP_pt...
(* *)
destruct H1' as (ff,(K1,(K2,K3))).
destruct H2' as (gg,(L1,(L2,L3))).
absurd (true = false); try discriminate.
rewrite <- K3.
apply trans_eq with (negb (Z.even (Fnum gg))).
rewrite L3; easy.
apply sym_eq.
generalize (DN_UP_parity_generic beta fexp).
unfold DN_UP_parity_prop; intros T; apply (T x); clear T; try assumption...
rewrite <- L1; apply Rnd_DN_pt_unique with (generic_format beta fexp) x; try easy...
now apply round_DN_pt...
rewrite <- K1; apply Rnd_UP_pt_unique with (generic_format beta fexp) x; try easy...
now apply round_UP_pt...
apply Rnd_UP_pt_unique with format x; assumption.
Qed.

Theorem Rnd_odd_pt_monotone :
  round_pred_monotone (Rnd_odd_pt).
Proof with auto with typeclass_instances.
intros x y f g H1 H2 Hxy.
apply Rle_trans with (round beta fexp Zrnd_odd x).
right; apply Rnd_odd_pt_unique with x; try assumption.
apply round_odd_pt.
apply Rle_trans with (round beta fexp Zrnd_odd y).
apply round_le...
right; apply Rnd_odd_pt_unique with y; try assumption.
apply round_odd_pt.
Qed.

End Fcore_rnd_odd.

Section Odd_prop_aux.

Variable beta : radix.
Hypothesis Even_beta: Z.even (radix_val beta)=true.

Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.
Variable fexpe : Z -> Z.

Context { valid_exp : Valid_exp fexp }.
Context { exists_NE_ : Exists_NE beta fexp }. (* for underflow reason *)
Context { valid_expe : Valid_exp fexpe }.
Context { exists_NE_e : Exists_NE beta fexpe }. (* for defining rounding to odd *)

Hypothesis fexpe_fexp: forall e, (fexpe e <= fexp e -2)%Z.

Lemma generic_format_fexpe_fexp: forall x,
 generic_format beta fexp x ->  generic_format beta fexpe x.
Proof.
intros x Hx.
apply generic_inclusion_mag with fexp; trivial; intros Hx2.
generalize (fexpe_fexp (mag beta x)).
omega.
Qed.

Lemma exists_even_fexp_lt: forall (c:Z->Z), forall (x:R),
      (exists f:float beta, F2R f = x /\ (c (mag beta x) < Fexp f)%Z) ->
      exists f:float beta, F2R f =x /\ canonical beta c f /\ Z.even (Fnum f) = true.
Proof with auto with typeclass_instances.
intros c x (g,(Hg1,Hg2)).
exists (Float beta
     (Fnum g*Z.pow (radix_val beta) (Fexp g - c (mag beta x)))
     (c (mag beta x))).
assert (F2R (Float beta
     (Fnum g*Z.pow (radix_val beta) (Fexp g - c (mag beta x)))
     (c (mag beta x))) = x).
unfold F2R; simpl.
rewrite mult_IZR, IZR_Zpower.
rewrite Rmult_assoc, <- bpow_plus.
rewrite <- Hg1; unfold F2R.
apply f_equal, f_equal.
ring.
omega.
split; trivial.
split.
unfold canonical, cexp.
now rewrite H.
simpl.
rewrite Z.even_mul.
rewrite Z.even_pow.
rewrite Even_beta.
apply Bool.orb_true_intro.
now right.
omega.
Qed.

Variable choice:Z->bool.
Variable x:R.

Variable d u: float beta.
Hypothesis Hd: Rnd_DN_pt (generic_format beta fexp) x (F2R d).
Hypothesis Cd: canonical beta fexp d.
Hypothesis Hu: Rnd_UP_pt (generic_format beta fexp) x (F2R u).
Hypothesis Cu: canonical beta fexp u.

Hypothesis xPos: (0 < x)%R.

Let m:= ((F2R d+F2R u)/2)%R.

Lemma d_eq: F2R d= round beta fexp Zfloor x.
Proof with auto with typeclass_instances.
apply Rnd_DN_pt_unique with (generic_format beta fexp) x...
apply round_DN_pt...
Qed.

Lemma u_eq: F2R u= round beta fexp Zceil x.
Proof with auto with typeclass_instances.
apply Rnd_UP_pt_unique with (generic_format beta fexp) x...
apply round_UP_pt...
Qed.

Lemma d_ge_0: (0 <= F2R d)%R.
Proof with auto with typeclass_instances.
rewrite d_eq; apply round_ge_generic...
apply generic_format_0.
now left.
Qed.

Lemma mag_d:  (0< F2R d)%R ->
    (mag beta (F2R d) = mag beta x :>Z).
Proof with auto with typeclass_instances.
intros Y.
rewrite d_eq; apply mag_DN...
now rewrite <- d_eq.
Qed.

Lemma Fexp_d: (0 < F2R d)%R -> Fexp d =fexp (mag beta x).
Proof with auto with typeclass_instances.
intros Y.
now rewrite Cd, <- mag_d.
Qed.

Lemma format_bpow_x: (0 < F2R d)%R
    -> generic_format beta fexp  (bpow (mag beta x)).
Proof with auto with typeclass_instances.
intros Y.
apply generic_format_bpow.
apply valid_exp.
rewrite <- Fexp_d; trivial.
apply Zlt_le_trans with  (mag beta (F2R d))%Z.
rewrite Cd; apply mag_generic_gt...
now apply Rgt_not_eq.
apply Hd.
apply mag_le; trivial.
apply Hd.
Qed.

Lemma format_bpow_d: (0 < F2R d)%R ->
  generic_format beta fexp (bpow (mag beta (F2R d))).
Proof with auto with typeclass_instances.
intros Y; apply generic_format_bpow.
apply valid_exp.
apply mag_generic_gt...
now apply Rgt_not_eq.
now apply generic_format_canonical.
Qed.

Lemma d_le_m: (F2R d <= m)%R.
Proof.
assert (F2R d <= F2R u)%R.
  apply Rle_trans with x.
  apply Hd.
  apply Hu.
unfold m.
lra.
Qed.

Lemma m_le_u: (m <= F2R u)%R.
Proof.
assert (F2R d <= F2R u)%R.
  apply Rle_trans with x.
  apply Hd.
  apply Hu.
unfold m.
lra.
Qed.

Lemma mag_m: (0 < F2R d)%R -> (mag beta m =mag beta (F2R d) :>Z).
Proof with auto with typeclass_instances.
intros dPos; apply mag_unique_pos.
split.
apply Rle_trans with (F2R d).
destruct (mag beta (F2R d)) as (e,He).
simpl.
rewrite Rabs_right in He.
apply He.
now apply Rgt_not_eq.
apply Rle_ge; now left.
apply d_le_m.
case m_le_u; intros H.
apply Rlt_le_trans with (1:=H).
rewrite u_eq.
apply round_le_generic...
apply generic_format_bpow.
apply valid_exp.
apply mag_generic_gt...
now apply Rgt_not_eq.
now apply generic_format_canonical.
case (Rle_or_lt x (bpow (mag beta (F2R d)))); trivial; intros Z.
absurd ((bpow (mag beta (F2R d)) <= (F2R d)))%R.
apply Rlt_not_le.
destruct  (mag beta (F2R d)) as (e,He).
simpl in *; rewrite Rabs_right in He.
apply He.
now apply Rgt_not_eq.
apply Rle_ge; now left.
apply Rle_trans with (round beta fexp Zfloor x).
2: right; apply sym_eq, d_eq.
apply round_ge_generic...
apply generic_format_bpow.
apply valid_exp.
apply mag_generic_gt...
now apply Rgt_not_eq.
now apply generic_format_canonical.
now left.
replace m with (F2R d).
destruct (mag beta (F2R d)) as (e,He).
simpl in *; rewrite Rabs_right in He.
apply He.
now apply Rgt_not_eq.
apply Rle_ge; now left.
unfold m in H |- *.
lra.
Qed.

Lemma mag_m_0: (0 = F2R d)%R
    -> (mag beta m =mag beta (F2R u)-1:>Z)%Z.
Proof with auto with typeclass_instances.
intros Y.
apply mag_unique_pos.
unfold m; rewrite <- Y, Rplus_0_l.
rewrite u_eq.
destruct (mag beta x) as (e,He).
rewrite Rabs_pos_eq in He by now apply Rlt_le.
rewrite round_UP_small_pos with (ex:=e).
rewrite mag_bpow.
ring_simplify (fexp e + 1 - 1)%Z.
split.
unfold Zminus; rewrite bpow_plus.
unfold Rdiv; apply Rmult_le_compat_l.
apply bpow_ge_0.
simpl; unfold Z.pow_pos; simpl.
rewrite Zmult_1_r; apply Rinv_le.
exact Rlt_0_2.
apply IZR_le.
specialize (radix_gt_1 beta).
omega.
apply Rlt_le_trans with (bpow (fexp e)*1)%R.
2: right; ring.
unfold Rdiv; apply Rmult_lt_compat_l.
apply bpow_gt_0.
lra.
now apply He, Rgt_not_eq.
apply exp_small_round_0_pos with beta (Zfloor) x...
now apply He, Rgt_not_eq.
now rewrite <- d_eq, Y.
Qed.

Lemma u'_eq:  (0 < F2R d)%R -> exists f:float beta, F2R f = F2R u /\ (Fexp f = Fexp d)%Z.
Proof with auto with typeclass_instances.
intros Y.
rewrite u_eq; unfold round.
eexists; repeat split.
simpl; now rewrite Fexp_d.
Qed.

Lemma m_eq :
  (0 < F2R d)%R ->
  exists f:float beta,
  F2R f = m /\ (Fexp f = fexp (mag beta x) - 1)%Z.
Proof with auto with typeclass_instances.
intros Y.
specialize (Zeven_ex (radix_val beta)); rewrite Even_beta.
intros (b, Hb); rewrite Zplus_0_r in Hb.
destruct u'_eq as (u', (Hu'1,Hu'2)); trivial.
exists (Fmult (Float beta b (-1)) (Fplus d u'))%R.
split.
rewrite F2R_mult, F2R_plus, Hu'1.
unfold m; rewrite Rmult_comm.
unfold Rdiv; apply f_equal.
unfold F2R; simpl; unfold Z.pow_pos; simpl.
rewrite Zmult_1_r, Hb, mult_IZR.
simpl; field.
apply Rgt_not_eq, Rmult_lt_reg_l with (1 := Rlt_0_2).
rewrite Rmult_0_r, <- (mult_IZR 2), <-Hb.
apply radix_pos.
apply trans_eq with (-1+Fexp (Fplus d u'))%Z.
unfold Fmult.
destruct  (Fplus d u'); reflexivity.
rewrite Zplus_comm; unfold Zminus; apply f_equal2.
2: reflexivity.
rewrite Fexp_Fplus.
rewrite Z.min_l.
now rewrite Fexp_d.
rewrite Hu'2; omega.
Qed.

Lemma m_eq_0: (0 = F2R d)%R ->  exists f:float beta,
   F2R f = m /\ (Fexp f = fexp (mag beta (F2R u)) -1)%Z.
Proof with auto with typeclass_instances.
intros Y.
specialize (Zeven_ex (radix_val beta)); rewrite Even_beta.
intros (b, Hb); rewrite Zplus_0_r in Hb.
exists (Fmult (Float beta b (-1)) u)%R.
split.
rewrite F2R_mult; unfold m; rewrite <- Y, Rplus_0_l.
rewrite Rmult_comm.
unfold Rdiv; apply f_equal.
unfold F2R; simpl; unfold Z.pow_pos; simpl.
rewrite Zmult_1_r, Hb, mult_IZR.
simpl; field.
apply Rgt_not_eq, Rmult_lt_reg_l with (1 := Rlt_0_2).
rewrite Rmult_0_r, <- (mult_IZR 2), <-Hb.
apply radix_pos.
apply trans_eq with (-1+Fexp u)%Z.
unfold Fmult.
destruct u; reflexivity.
rewrite Zplus_comm, Cu; unfold Zminus; now apply f_equal2.
Qed.

Lemma fexp_m_eq_0:  (0 = F2R d)%R ->
  (fexp (mag beta (F2R u)-1) < fexp (mag beta (F2R u))+1)%Z.
Proof with auto with typeclass_instances.
intros Y.
assert ((fexp (mag beta (F2R u) - 1) <= fexp (mag beta (F2R u))))%Z.
2: omega.
destruct (mag beta x) as (e,He).
rewrite Rabs_right in He.
2: now left.
assert (e <= fexp e)%Z.
apply exp_small_round_0_pos with beta (Zfloor) x...
now apply He, Rgt_not_eq.
now rewrite <- d_eq, Y.
rewrite u_eq, round_UP_small_pos with (ex:=e); trivial.
2: now apply He, Rgt_not_eq.
rewrite mag_bpow.
ring_simplify (fexp e + 1 - 1)%Z.
replace (fexp (fexp e)) with (fexp e).
case exists_NE_; intros V.
contradict V; rewrite Even_beta; discriminate.
rewrite (proj2 (V e)); omega.
apply sym_eq, valid_exp; omega.
Qed.

Lemma Fm:  generic_format beta fexpe m.
Proof.
case (d_ge_0); intros Y.
(* *)
destruct m_eq as (g,(Hg1,Hg2)); trivial.
apply generic_format_F2R' with g.
now apply sym_eq.
intros H; unfold cexp; rewrite Hg2.
rewrite mag_m; trivial.
rewrite <- Fexp_d; trivial.
rewrite Cd.
unfold cexp.
generalize (fexpe_fexp (mag beta (F2R d))).
omega.
(* *)
destruct m_eq_0 as (g,(Hg1,Hg2)); trivial.
apply generic_format_F2R' with g.
assumption.
intros H; unfold cexp; rewrite Hg2.
rewrite mag_m_0; try assumption.
apply Zle_trans with (1:=fexpe_fexp _).
generalize (fexp_m_eq_0 Y).
omega.
Qed.

Lemma Zm:
   exists g : float beta, F2R g = m /\ canonical beta fexpe g /\ Z.even (Fnum g) = true.
Proof with auto with typeclass_instances.
case (d_ge_0); intros Y.
(* *)
destruct m_eq as (g,(Hg1,Hg2)); trivial.
apply exists_even_fexp_lt.
exists g; split; trivial.
rewrite Hg2.
rewrite mag_m; trivial.
rewrite <- Fexp_d; trivial.
rewrite Cd.
unfold cexp.
generalize (fexpe_fexp  (mag beta (F2R d))).
omega.
(* *)
destruct m_eq_0 as (g,(Hg1,Hg2)); trivial.
apply exists_even_fexp_lt.
exists g; split; trivial.
rewrite Hg2.
rewrite mag_m_0; trivial.
apply Zle_lt_trans with (1:=fexpe_fexp _).
generalize (fexp_m_eq_0 Y).
omega.
Qed.

Lemma DN_odd_d_aux :
  forall z, (F2R d <= z < F2R u)%R ->
  Rnd_DN_pt (generic_format beta fexp) z (F2R d).
Proof with auto with typeclass_instances.
intros z Hz1.
replace (F2R d) with (round beta fexp Zfloor z).
apply round_DN_pt...
case (Rnd_DN_UP_pt_split _ _ _ _ Hd Hu (round beta fexp Zfloor z)).
apply generic_format_round...
intros Y; apply Rle_antisym; trivial.
apply round_DN_pt...
apply Hd.
apply Hz1.
intros Y ; elim (Rlt_irrefl z).
apply Rlt_le_trans with (1:=proj2 Hz1), Rle_trans with (1:=Y).
apply round_DN_pt...
Qed.

Lemma UP_odd_d_aux :
  forall z, (F2R d < z <= F2R u)%R ->
  Rnd_UP_pt (generic_format beta fexp) z (F2R u).
Proof with auto with typeclass_instances.
intros z Hz1.
replace (F2R u) with (round beta fexp Zceil z).
apply round_UP_pt...
case (Rnd_DN_UP_pt_split _ _ _ _ Hd Hu (round beta fexp Zceil z)).
apply generic_format_round...
intros Y ; elim (Rlt_irrefl z).
apply Rle_lt_trans with (2:=proj1 Hz1), Rle_trans with (2:=Y).
apply round_UP_pt...
intros Y; apply Rle_antisym; trivial.
apply round_UP_pt...
apply Hu.
apply Hz1.
Qed.

Lemma round_N_odd_pos :
  round beta fexp (Znearest choice) (round beta fexpe Zrnd_odd x) =
               round beta fexp (Znearest choice) x.
Proof with auto with typeclass_instances.
set (o:=round beta fexpe Zrnd_odd x).
case (generic_format_EM beta fexp x); intros Hx.
replace o with x; trivial.
unfold o; apply sym_eq, round_generic...
now apply generic_format_fexpe_fexp.
assert (K1:(F2R d <= o)%R).
apply round_ge_generic...
apply generic_format_fexpe_fexp, Hd.
apply Hd.
assert (K2:(o <= F2R u)%R).
apply round_le_generic...
apply generic_format_fexpe_fexp, Hu.
apply Hu.
assert (P:(x <> m -> o=m -> (forall P:Prop, P))).
intros Y1 Y2.
assert (H:(Rnd_odd_pt beta fexpe x o)).
apply round_odd_pt...
destruct H as (_,H); destruct H.
absurd (x=m)%R; try trivial.
now rewrite <- Y2, H.
destruct H as (_,(k,(Hk1,(Hk2,Hk3)))).
destruct Zm as (k',(Hk'1,(Hk'2,Hk'3))).
absurd (true=false).
discriminate.
rewrite <- Hk3, <- Hk'3.
apply f_equal, f_equal.
apply canonical_unique with fexpe...
now rewrite Hk'1, <- Y2.
assert (generic_format beta fexp o -> (forall P:Prop, P)).
intros Y.
assert (H:(Rnd_odd_pt beta fexpe x o)).
apply round_odd_pt...
destruct H as (_,H); destruct H.
absurd (generic_format beta fexp x); trivial.
now rewrite <- H.
destruct H as (_,(k,(Hk1,(Hk2,Hk3)))).
destruct (exists_even_fexp_lt fexpe o) as (k',(Hk'1,(Hk'2,Hk'3))).
eexists; split.
apply sym_eq, Y.
simpl; unfold cexp.
apply Zle_lt_trans with (1:=fexpe_fexp _).
omega.
absurd (true=false).
discriminate.
rewrite <- Hk3, <- Hk'3.
apply f_equal, f_equal.
apply canonical_unique with fexpe...
now rewrite Hk'1, <- Hk1.
case K1; clear K1; intros K1.
2: apply H; rewrite <- K1; apply Hd.
case K2; clear K2; intros K2.
2: apply H; rewrite K2; apply Hu.
case (Rle_or_lt  x m); intros Y;[destruct Y|idtac].
(* . *)
apply trans_eq with (F2R d).
apply round_N_eq_DN_pt with (F2R u)...
apply DN_odd_d_aux; split; try left; assumption.
apply UP_odd_d_aux; split; try left; assumption.
assert (o <= (F2R d + F2R u) / 2)%R.
apply round_le_generic...
apply Fm.
now left.
destruct H1; trivial.
apply P.
now apply Rlt_not_eq.
trivial.
apply sym_eq, round_N_eq_DN_pt with (F2R u)...
(* . *)
replace o with x.
reflexivity.
apply sym_eq, round_generic...
rewrite H0; apply Fm.
(* . *)
apply trans_eq with (F2R u).
apply round_N_eq_UP_pt with (F2R d)...
apply DN_odd_d_aux; split; try left; assumption.
apply UP_odd_d_aux; split; try left; assumption.
assert ((F2R d + F2R u) / 2 <= o)%R.
apply round_ge_generic...
apply Fm.
now left.
destruct H0; trivial.
apply P.
now apply Rgt_not_eq.
rewrite <- H0; trivial.
apply sym_eq, round_N_eq_UP_pt with (F2R d)...
Qed.

End Odd_prop_aux.

Section Odd_prop.

Variable beta : radix.
Hypothesis Even_beta: Z.even (radix_val beta)=true.

Variable fexp : Z -> Z.
Variable fexpe : Z -> Z.
Variable choice:Z->bool.

Context { valid_exp : Valid_exp fexp }.
Context { exists_NE_ : Exists_NE beta fexp }. (* for underflow reason *)
Context { valid_expe : Valid_exp fexpe }.
Context { exists_NE_e : Exists_NE beta fexpe }. (* for defining rounding to odd *)

Hypothesis fexpe_fexp: forall e, (fexpe e <= fexp e -2)%Z.

Theorem round_N_odd :
  forall x,
  round beta fexp (Znearest choice) (round beta fexpe Zrnd_odd x) =
               round beta fexp (Znearest choice) x.
Proof with auto with typeclass_instances.
intros x.
case (total_order_T x 0); intros H; [case H; clear H; intros H | idtac].
rewrite <- (Ropp_involutive x).
rewrite round_odd_opp.
rewrite 2!round_N_opp.
apply f_equal.
destruct (canonical_generic_format beta fexp (round beta fexp Zfloor (-x))) as (d,(Hd1,Hd2)).
apply generic_format_round...
destruct (canonical_generic_format beta fexp (round beta fexp Zceil (-x))) as (u,(Hu1,Hu2)).
apply generic_format_round...
apply round_N_odd_pos with d u...
rewrite <- Hd1; apply round_DN_pt...
rewrite <- Hu1; apply round_UP_pt...
auto with real.
(* . *)
rewrite H; repeat rewrite round_0...
(* . *)
destruct (canonical_generic_format beta fexp (round beta fexp Zfloor x)) as (d,(Hd1,Hd2)).
apply generic_format_round...
destruct (canonical_generic_format beta fexp (round beta fexp Zceil x)) as (u,(Hu1,Hu2)).
apply generic_format_round...
apply round_N_odd_pos with d u...
rewrite <- Hd1; apply round_DN_pt...
rewrite <- Hu1; apply round_UP_pt...
Qed.

End Odd_prop.

Section Odd_propbis.

Variable beta : radix.
Hypothesis Even_beta: Z.even (radix_val beta)=true.

Variable emin prec:Z.
Variable choice:Z->bool.

Hypothesis prec_gt_1: (1 < prec)%Z.

Notation format := (generic_format beta (FLT_exp emin prec)).
Notation round_flt :=(round beta (FLT_exp emin prec) (Znearest choice)).
Notation cexp_flt := (cexp beta (FLT_exp emin prec)).
Notation fexpe k := (FLT_exp (emin-k) (prec+k)).

Lemma Zrnd_odd_plus': forall x y,
  (exists n:Z, exists e:Z, (x = IZR n*bpow beta e)%R /\ (1 <= e)%Z) ->
   (IZR (Zrnd_odd (x+y)) = x+IZR (Zrnd_odd y))%R.
Proof.
intros x y (n,(e,(H1,H2))).
apply Zrnd_odd_plus.
rewrite H1.
rewrite <- IZR_Zpower.
2: auto with zarith.
now rewrite <- mult_IZR, Zfloor_IZR.
rewrite H1, <- IZR_Zpower.
2: auto with zarith.
rewrite <- mult_IZR, Zfloor_IZR.
rewrite Z.even_mul.
rewrite Z.even_pow.
2: auto with zarith.
rewrite Even_beta.
apply Bool.orb_true_iff; now right.
Qed.

Theorem mag_round_odd: forall (x:R),
 (emin < mag beta x)%Z ->
  (mag_val beta _ (mag beta (round beta (FLT_exp emin prec) Zrnd_odd x))
      = mag_val beta x (mag beta x))%Z.
Proof with auto with typeclass_instances.
intros x.
assert (T:Prec_gt_0 prec).
unfold Prec_gt_0; auto with zarith.
case (Req_dec x 0); intros Zx.
intros _; rewrite Zx, round_0...
destruct (mag beta x) as (e,He); simpl; intros H.
apply mag_unique; split.
apply abs_round_ge_generic...
apply FLT_format_bpow...
auto with zarith.
now apply He.
assert (V:
  (Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) <= bpow beta e)%R).
apply abs_round_le_generic...
apply FLT_format_bpow...
auto with zarith.
left; now apply He.
case V; try easy; intros K.
assert (H0:Rnd_odd_pt beta (FLT_exp emin prec) x (round beta (FLT_exp emin prec) Zrnd_odd x)).
apply round_odd_pt...
destruct H0 as (_,HH); destruct HH as [H0|(H0,(g,(Hg1,(Hg2,Hg3))))].
absurd (Rabs x < bpow beta e)%R.
apply Rle_not_lt; right.
now rewrite <- H0,K.
now apply He.
pose (gg:=Float beta (Zpower beta (e-FLT_exp emin prec (e+1))) (FLT_exp emin prec (e+1))).
assert (Y1: F2R gg = bpow beta e).
unfold F2R; simpl.
rewrite IZR_Zpower.
rewrite <- bpow_plus.
f_equal; ring.
assert (FLT_exp emin prec (e+1) <= e)%Z; [idtac|auto with zarith].
unfold FLT_exp.
apply Z.max_case_strong; auto with zarith.
assert (Y2: canonical beta (FLT_exp emin prec) gg).
unfold canonical; rewrite Y1; unfold gg; simpl.
unfold cexp; now rewrite mag_bpow.
assert (Y3: Fnum gg = Zabs (Fnum g)).
apply trans_eq with (Fnum (Fabs g)).
2: destruct g; unfold Fabs; now simpl.
f_equal.
apply canonical_unique with (FLT_exp emin prec); try assumption.
destruct g; unfold Fabs; apply canonical_abs; easy.
now rewrite Y1, F2R_abs, <- Hg1,K.
assert (Y4: Z.even (Fnum gg) = true).
unfold gg; simpl.
rewrite Z.even_pow; try assumption.
assert (FLT_exp emin prec (e+1) < e)%Z; [idtac|auto with zarith].
unfold FLT_exp.
apply Z.max_case_strong; auto with zarith.
absurd (true = false).
discriminate.
rewrite <- Hg3.
rewrite <- Zeven_abs.
now rewrite <- Y3.
Qed.

Theorem fexp_round_odd: forall (x:R),
  (cexp_flt (round beta (FLT_exp emin prec) Zrnd_odd x)
      = cexp_flt x)%Z.
Proof with auto with typeclass_instances.
intros x.
assert (G0:Valid_exp (FLT_exp emin prec)).
apply FLT_exp_valid; unfold Prec_gt_0; auto with zarith.
case (Req_dec x 0); intros Zx.
rewrite Zx, round_0...
case (Zle_or_lt (mag beta x) emin).
unfold cexp; destruct (mag beta x) as (e,He); simpl.
intros H; unfold FLT_exp at 4.
rewrite Z.max_r.
2: auto with zarith.
apply Z.max_r.
assert (G: Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) = bpow beta emin).
assert (G1: (Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) <= bpow beta emin)%R).
apply abs_round_le_generic...
apply generic_format_bpow'...
unfold FLT_exp; rewrite Z.max_r; auto with zarith.
left; apply Rlt_le_trans with (bpow beta e).
now apply He.
now apply bpow_le.
assert (G2: (0 <= Rabs (round beta (FLT_exp emin prec) Zrnd_odd x))%R).
apply Rabs_pos.
assert (G3: (Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) <> 0)%R).
assert (H0:Rnd_odd_pt beta (FLT_exp emin prec) x
    (round beta (FLT_exp emin prec) Zrnd_odd x)).
apply round_odd_pt...
destruct H0 as (_,H0); destruct H0 as [H0|(_,(g,(Hg1,(Hg2,Hg3))))].
apply Rgt_not_eq; rewrite H0.
apply Rlt_le_trans with (bpow beta (e-1)).
apply bpow_gt_0.
now apply He.
rewrite Hg1; intros K.
contradict Hg3.
replace (Fnum g) with 0%Z.
easy.
case (Z.eq_dec (Fnum g) Z0); intros W; try easy.
contradict K.
apply Rabs_no_R0.
now apply F2R_neq_0.
apply Rle_antisym; try assumption.
apply Rle_trans with (succ beta (FLT_exp emin prec) 0).
right; rewrite succ_0.
rewrite ulp_FLT_small; try easy.
unfold Prec_gt_0; auto with zarith.
rewrite Rabs_R0; apply bpow_gt_0.
apply succ_le_lt...
apply generic_format_0.
apply generic_format_abs; apply generic_format_round...
case G2; [easy|intros; now contradict G3].
rewrite <- mag_abs.
rewrite G, mag_bpow; auto with zarith.
intros H; unfold cexp.
now rewrite mag_round_odd.
Qed.

End Odd_propbis.


(*
Copyright 2010 IMDEA Software Institute
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
    http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
*)

(******************************************************************************)
(* This file defines ordType - the structure for types with a decidable       *)
(* (strict) order relation.                                                   *)
(* ordType is a subclass of mathcomp's eqType                                 *)
(* This file also defines some important instances of ordType                 *)
(******************************************************************************)

From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import ssrnat eqtype seq path fintype.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Module Ordered.

Section RawMixin.

Structure mixin_of (T : eqType) :=
  Mixin {ordering : rel T;
         _ : irreflexive ordering;
         _ : transitive ordering;
         _ : forall x y, [|| ordering x y, x == y | ordering y x]}.

End RawMixin.

(* the class takes a naked type T and returns all the *)
(* relatex mixins; the inherited ones and the added ones *)
Section ClassDef.

Record class_of (T : Type) := Class {
   base : Equality.class_of T;
   mixin : mixin_of (EqType T base)}.

Local Coercion base : class_of >-> Equality.class_of.

Structure type : Type := Pack {sort : Type; _ : class_of sort}.
Local Coercion sort : type >-> Sortclass.

Variables (T : Type) (cT : type).
Definition class := let: Pack _ c as cT' := cT return class_of cT' in c.
Definition clone c of phant_id class c := @Pack T c.

(* produce an ordered type out of the inherited mixins *)
(* equalize m0 and m by means of a phantom; will be exploited *)
(* further down in the definition of OrdType *)
Definition pack b (m0 : mixin_of (EqType T b)) :=
  fun m & phant_id m0 m => Pack (@Class T b m).

Definition eqType := Eval hnf in EqType cT class.

End ClassDef.

Module Exports.
Coercion sort : type >-> Sortclass.
Coercion eqType : type >-> Equality.type.
Canonical Structure eqType.
Notation ordType := Ordered.type.
Notation OrdMixin := Mixin.
Notation OrdType T m := (@pack T _ m _ id).
Definition ord T : rel (sort T) := (ordering (mixin (class T))).
Notation "[ 'ordType' 'of' T 'for' cT ]" := (@clone T cT _ id)
  (at level 0, format "[ 'ordType'  'of'  T  'for'  cT ]") : form_scope.
Notation "[ 'ordType' 'of' T ]" := (@clone T _ _ id)
  (at level 0, format "[ 'ordType'  'of'  T ]") : form_scope.
End Exports.
End Ordered.
Export Ordered.Exports.

Definition oleq (T : ordType) (t1 t2 : T) := ord t1 t2 || (t1 == t2).

Prenex Implicits ord oleq.

Section Lemmas.
Variable T : ordType.
Implicit Types x y : T.

Lemma irr : irreflexive (@ord T).
Proof. by case: T=>s [b [m]]. Qed.

Lemma trans : transitive (@ord T).
Proof. by case: T=>s [b [m]]. Qed.

Lemma total x y : [|| ord x y, x == y | ord y x].
Proof. by case: T x y=>s [b [m]]. Qed.

Lemma nsym x y : ord x y -> ord y x -> False.
Proof. by move=>E1 E2; move: (trans E1 E2); rewrite irr. Qed.

Lemma orefl x : oleq x x.
Proof. by rewrite /oleq eq_refl orbT. Qed.

Lemma otrans : transitive (@oleq T).
Proof.
move=>x y z /=; case/orP; last by move/eqP=>->.
rewrite /oleq; move=>T1; case/orP; first by move/(trans T1)=>->.
by move/eqP=><-; rewrite T1.
Qed.

Lemma sorted_oleq s : sorted (@ord T) s -> sorted (@oleq T) s.
Proof. by elim: s=>[|x s IH] //=; apply: sub_path=>z y; rewrite /oleq=>->. Qed.

End Lemmas.

Hint Resolve orefl : core.

Section Totality.
Variable K : ordType.

CoInductive total_spec (x y : K) : bool -> bool -> bool -> Type :=
| total_spec_lt of ord x y : total_spec x y true false false
| total_spec_eq of x == y : total_spec x y false true false
| total_spec_gt of ord y x : total_spec x y false false true.

Lemma totalP x y : total_spec x y (ord x y) (x == y) (ord y x).
Proof.
case H1: (x == y).
- by rewrite (eqP H1) irr; apply: total_spec_eq.
case H2: (ord x y); case H3: (ord y x).
- by case: (nsym H2 H3).
- by apply: total_spec_lt H2.
- by apply: total_spec_gt H3.
by move: (total x y); rewrite H1 H2 H3.
Qed.
End Totality.

(* Monotone (i.e. strictly increasing) functions for Ord Types *)
Section Mono.
Variables (A B :ordType).

Definition strictly_increasing f x y := @ord A x y -> @ord B (f x) (f y).

Structure mono : Type := Mono
           {fun_of: A -> B; _: forall x y, strictly_increasing fun_of x y}.

End Mono.
Arguments strictly_increasing {A B} f x y.
Arguments Mono {A B _} _.

Section NatOrd.
Lemma irr_ltn_nat : irreflexive ltn. Proof. by move=>x; rewrite /= ltnn. Qed.
Lemma trans_ltn_nat : transitive ltn. Proof. by apply: ltn_trans. Qed.
Lemma total_ltn_nat x y : [|| x < y, x == y | y < x].
Proof. by case: ltngtP. Qed.

Definition nat_ordMixin := OrdMixin irr_ltn_nat trans_ltn_nat total_ltn_nat.
Canonical Structure nat_ordType := OrdType nat nat_ordMixin.
End NatOrd.

Section ProdOrd.
Variables K T : ordType.

(* lexicographic ordering *)
Definition lex : rel (K * T) :=
  fun x y => if x.1 == y.1 then ord x.2 y.2 else ord x.1 y.1.

Lemma irr_lex : irreflexive lex.
Proof. by move=>x; rewrite /lex eq_refl irr. Qed.

Lemma trans_lex : transitive lex.
Proof.
move=>[x1 x2][y1 y2][z1 z2]; rewrite /lex /=.
case: ifP=>H1; first by rewrite (eqP H1); case: eqP=>// _; apply: trans.
case: ifP=>H2; first by rewrite (eqP H2) in H1 *; rewrite H1.
case: ifP=>H3; last by apply: trans.
by rewrite (eqP H3)=>R1; move/(nsym R1).
Qed.

Lemma total_lex : forall x y, [|| lex x y, x == y | lex y x].
Proof.
move=>[x1 x2][y1 y2]; rewrite /lex /=.
case: ifP=>H1.
- rewrite (eqP H1) eq_refl -pair_eqE /= eq_refl /=; exact: total.
rewrite (eq_sym y1) -pair_eqE /= H1 /=.
by move: (total x1 y1); rewrite H1.
Qed.

Definition prod_ordMixin := OrdMixin irr_lex trans_lex total_lex.
Canonical Structure prod_ordType := Eval hnf in OrdType (K * T) prod_ordMixin.
End ProdOrd.

Section FinTypeOrd.
Variable T : finType.

Definition ordf : rel T :=
  fun x y => index x (enum T) < index y (enum T).

Lemma irr_ordf : irreflexive ordf.
Proof. by move=>x; rewrite /ordf ltnn. Qed.

Lemma trans_ordf : transitive ordf.
Proof. by move=>x y z; rewrite /ordf; apply: ltn_trans. Qed.

Lemma total_ordf x y : [|| ordf x y, x == y | ordf y x].
Proof.
rewrite /ordf; case: ltngtP=>//= H; rewrite ?orbT ?orbF //.
have [H1 H2]: x \in enum T /\ y \in enum T by rewrite !mem_enum.
by rewrite -(nth_index x H1) -(nth_index x H2) H eq_refl.
Qed.

Definition fin_ordMixin := OrdMixin irr_ordf trans_ordf total_ordf.
End FinTypeOrd.

(* notation to let us write I_n instead of (ordinal_finType n) *)
Notation "[ 'fin_ordMixin' 'of' T ]" :=
  (fin_ordMixin _ : Ordered.mixin_of [eqType of T]) (at level 0).

Definition ordinal_ordMixin n := [fin_ordMixin of 'I_n].
Canonical Structure ordinal_ordType n := OrdType 'I_n (ordinal_ordMixin n).

Section SeqOrd.
Variable (T : ordType).

Fixpoint ords x  : pred (seq T) :=
  fun y => match x , y with
                 | [::] , [::] => false
                 | [::] ,  t :: ts => true
                 | x :: xs , y :: ys => if x == y then ords xs ys
                                        else ord x y
                 | _ :: _ , [::] => false
             end.

Lemma irr_ords : irreflexive ords.
Proof. by elim=>//= a l ->; rewrite irr; case:eqP=> //=. Qed.

Lemma trans_ords : transitive ords.
Proof.
elim=>[|y ys IHy][|x xs][|z zs]//=.
case:eqP=>//[->|H0];case:eqP=>//H; first by move/IHy; apply.
- by case:eqP=>//; rewrite -H; first (by move/H0).
case:eqP=>//[->|H1] H2; first by move/(nsym H2).
by move/(trans H2).
Qed.

Lemma total_ords : forall x y, [|| ords x y, x == y | ords y x].
Proof.
elim=>[|x xs IH][|y ys]//=; case:eqP=>//[->|H1];
 (case:eqP=>//= H; first (by rewrite orbT //=)).
- by case:eqP=>//H3 ; case: (or3P (IH ys))=> [-> | /eqP H0 | ->];
 [ rewrite orTb // | apply: False_ind; apply: H; rewrite H0 | rewrite orbT //].
case:eqP; first by move/(esym)/H1.
by move=>_ ;case: (or3P (total x y))=>[-> //| /eqP /H1 //| -> //]; rewrite orbT.
Qed.

Definition seq_ordMixin := OrdMixin irr_ords trans_ords total_ords.
Canonical Structure seq_ordType := Eval hnf in OrdType (seq T) seq_ordMixin.
End SeqOrd.

(* A trivial total ordering for Unit *)
Section unitOrd.
Let ordtt (x y : unit ) := false.

Lemma irr_tt : irreflexive ordtt.
Proof. by []. Qed.

Lemma trans_tt : transitive ordtt.
Proof. by []. Qed.

Lemma total_tt x y : [|| ordtt x y, x == y | ordtt y x ].
Proof. by []. Qed.

Let unit_ordMixin := OrdMixin irr_tt trans_tt total_tt.
Canonical Structure unit_ordType := Eval hnf in OrdType unit unit_ordMixin.
End unitOrd.

(* ordering with path, seq and last *)

Lemma seq_last_in (A : eqType) (s : seq A) x :
        last x s \notin s -> s = [::].
Proof.
case: (lastP s)=>// {s} s y; case: negP=>//; elim; rewrite last_rcons.
by elim: s=>[|y' s IH]; rewrite /= inE // IH orbT.
Qed.

Lemma path_last (A : ordType) (s : seq A) x :
        path oleq x s -> oleq x (last x s).
Proof.
move/(order_path_min (@otrans _)); rewrite -nth_last.
by case: s =>// h s' /all_nthP->.
Qed.

(* in a sorted list, the last element is maximal *)
(* and the maximal element is last *)

Lemma sorted_last_key_max (A : ordType) (s : seq A) x y :
        sorted oleq s -> x \in s -> oleq x (last y s).
Proof.
elim: s x y=>[|z s IH] //= x y H; rewrite inE /=.
case: eqP=>[->|] /= _; first by apply: path_last.
by apply: IH (path_sorted H).
Qed.

Lemma sorted_max_key_last (A : ordType) (s : seq A) x y :
        sorted oleq s -> x \in s ->
        (forall z, z \in s -> oleq z x) -> last y s = x.
Proof.
elim: s x y => [|w s IH] //= x y; rewrite inE /=.
case: eqP=>[<- /= H1 _ H2 | _ H /= H1 H2]; last first.
- apply: IH (path_sorted H) H1 _ => z H3; apply: H2.
  by rewrite inE /= H3 orbT.
apply/eqP; move: (H2 (last x s)) (path_last H1); rewrite inE /= /oleq eq_sym.
case: totalP=>//=; case E: (last x s \in s)=>//.
by move/negbT/seq_last_in: E=>->; rewrite irr.
Qed.

Lemma seq_last_mono (A : ordType) (s1 s2 : seq A) x :
        path oleq x s1 -> path oleq x s2 ->
        {subset s1 <= s2} ->
        oleq (last x s1) (last x s2).
Proof.
case: s1=>/= [_ H1 _|a s]; first by apply: path_last H1.
case/andP=>H1 H2 H3 H; apply: sorted_last_key_max (path_sorted H3) _.
apply: {x s2 H1 H3} H; rewrite inE orbC -implyNb.
by case E: (_ \notin _) (@seq_last_in _ s a)=>//= ->.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export Qpositive_sub.

Inductive Q : Set :=
  | Zero : Q
  | Qpos : Qpositive -> Q
  | Qneg : Qpositive -> Q.

Definition Qone := Qpos One.

Definition Qpositive_le_dec :
  forall w w' : Qpositive, {Qpositive_le w w'} + {~ Qpositive_le w w'}.
intros w w'; unfold Qpositive_le in |- *; case (Qpositive_le_bool w w'); auto.
Defined.

Ltac Case' f :=
  match constr:(f) with
  | (Qpositive_le_dec ?X1 ?X2) =>
      case f;
       [ idtac
       | intros Dummy;
          generalize (not_Qpositive_le_not_eq _ _ Dummy)
           (not_Qpositive_le_Qpositive_le' _ _ Dummy) Dummy;
          clear Dummy ]
  | _ => case f
  end.

Definition Qpositive_eq_dec : forall w w' : Qpositive, {w = w'} + {w <> w'}.
intros w; elim w; intros until w'; case w';
 try (auto; right; discriminate; fail);
 (intros w'1; elim (H w'1);
   [ intros H1; left; rewrite H1; auto
   | intros H1; right; red in |- *; intros H2; elim H1; injection H2; auto ]).
Defined.

Definition Qplus (x y : Q) :=
  match x, y with
  | Qpos x', Qpos y' => Qpos (Qpositive_plus x' y')
  | Qpos x', Qneg y' =>
      match Qpositive_le_dec x' y' with
      | left h =>
          match Qpositive_eq_dec x' y' with
          | left h => Zero
          | right h => Qneg (Qpositive_sub y' x')
          end
      | right h => Qpos (Qpositive_sub x' y')
      end
  | Qneg x', Qneg y' => Qneg (Qpositive_plus x' y')
  | Qneg x', Qpos y' =>
      match Qpositive_le_dec x' y' with
      | left h =>
          match Qpositive_eq_dec x' y' with
          | left h => Zero
          | right h => Qpos (Qpositive_sub y' x')
          end
      | right h => Qneg (Qpositive_sub x' y')
      end
  | Qneg x', Zero => Qneg x'
  | Qpos x', Zero => Qpos x'
  | Zero, x => x
  end.

Definition Qmult (x y : Q) :=
  match x, y with
  | Qpos x', Qpos y' => Qpos (Qpositive_mult x' y')
  | Qpos x', Qneg y' => Qneg (Qpositive_mult x' y')
  | Qneg x', Qpos y' => Qneg (Qpositive_mult x' y')
  | Qneg x', Qneg y' => Qpos (Qpositive_mult x' y')
  | _, _ => Zero
  end.

Definition Qopp (x : Q) :=
  match x with
  | Zero => Zero
  | Qpos x' => Qneg x'
  | Qneg x' => Qpos x'
  end.

Theorem Qplus_sym : forall a b : Q, Qplus a b = Qplus b a.
intros a b; case a; case b; simpl in |- *; auto;
 try
  (intros a' b';
    apply f_equal with (f := Qpos) || apply f_equal with (f := Qneg);
    apply Qpositive_plus_sym).
intros b' a'; case (Qpositive_le_dec a' b').
case (Qpositive_eq_dec a' b').
case (Qpositive_le_dec b' a').
case (Qpositive_eq_dec b' a').
auto.
intros H; intros; elim H; auto.
intros H H1; intros; elim H; rewrite H1; apply Qpositive_le_refl.
case (Qpositive_le_dec b' a').
case (Qpositive_eq_dec b' a').
intros H H1 H2; elim H2; auto.
intros H; intros; elim H; apply Qpositive_le_antisym; auto.
auto.
case (Qpositive_le_dec b' a').
case (Qpositive_eq_dec b' a').
intros H H1 H2; elim H2; rewrite H; apply Qpositive_le_refl.
auto.
intros H1 H2; elim (Qpositive_le_total a' b'); intros H3;
 (elim H1; exact H3) || (elim H2; exact H3).
intros b' a'; case (Qpositive_le_dec a' b'); case (Qpositive_le_dec b' a').
intros H H1; case (Qpositive_eq_dec a' b').
case (Qpositive_eq_dec b' a'); auto.
intros H2 H3; elim H2; auto.
intros H2; elim H2; apply Qpositive_le_antisym; auto.
case (Qpositive_eq_dec a' b'); intros H H1 H2.
elim H1; rewrite H; apply Qpositive_le_refl.
auto.
case (Qpositive_eq_dec b' a').
intros H H1 H2; elim H2; rewrite H; apply Qpositive_le_refl.
auto.
elim (Qpositive_le_total a' b'); intros H;
 repeat (intros Dummy; try (elim Dummy; auto; fail); clear Dummy).
Qed.

Theorem Qplus_zero_left : forall n : Q, Qplus Zero n = n.
intros n; case n; auto.
Qed.

Theorem add_sub_le1 :
 forall a b c : Qpositive,
 a <> b ->
 Qpositive_le b a ->
 Qpositive_le (Qpositive_sub a b) c -> Qpositive_le a (Qpositive_plus b c).
intros a b c H H0 H1.
rewrite <- (Qpositive_sub_correct2 a b); auto.
rewrite (Qpositive_plus_sym b).
apply Qpositive_le_add.
auto.
Qed.

Theorem add_sub_le2 :
 forall a b c : Qpositive,
 a <> b ->
 Qpositive_le b a ->
 Qpositive_le a (Qpositive_plus b c) -> Qpositive_le (Qpositive_sub a b) c.
intros a b c H H1 H2; rewrite <- (Qpositive_sub_correct c b).
apply Qpositive_le_sub_r; auto with *.
rewrite Qpositive_plus_sym; apply sym_not_equal; apply Qpositive_plus_diff.
rewrite Qpositive_plus_sym; apply Qpositive_plus_le.
rewrite Qpositive_plus_sym; auto.
Qed.

Theorem add_sub_eq1 :
 forall a b c : Qpositive, a = Qpositive_plus b c -> Qpositive_sub a b = c.
intros a b c H; rewrite H; rewrite Qpositive_plus_sym;
 rewrite Qpositive_sub_correct; auto.
Qed.

Theorem add_sub_eq2 :
 forall a b c : Qpositive,
 a <> b ->
 Qpositive_le b a -> c = Qpositive_sub a b -> Qpositive_plus b c = a.
intros a b c H H0 H1; rewrite H1; rewrite Qpositive_plus_sym;
 rewrite Qpositive_sub_correct2; auto with *.
Qed.

Theorem Qplus_assoc_two_neg :
 forall (n : Q) (m' p' : Qpositive),
 Qplus n (Qplus (Qneg m') (Qneg p')) = Qplus (Qplus n (Qneg m')) (Qneg p').
intros n; case n.

(* Focus 1 *)
intros; repeat rewrite Qplus_zero_left; auto.
(* Focus 2 *)
simpl in |- *; intros n' m' p'.
Case' (Qpositive_le_dec n' (Qpositive_plus m' p')).
case (Qpositive_eq_dec n' (Qpositive_plus m' p')).
Case' (Qpositive_le_dec n' m').
case (Qpositive_eq_dec n' m').
intros e q e0; elim (Qpositive_plus_diff n' p').
pattern n' at 2 in |- *; rewrite e; auto.
intros n0 q e q0; elim n0; apply Qpositive_le_antisym; auto.
rewrite e; apply Qpositive_plus_le.
intros H H0 H1 e q; simpl in |- *.
Case' (Qpositive_le_dec (Qpositive_sub n' m') p').
case (Qpositive_eq_dec (Qpositive_sub n' m') p'); auto with *.
rewrite e; intros H2; elim H2.
rewrite Qpositive_plus_sym; rewrite Qpositive_sub_correct; auto.
rewrite e; intros H2; elim H2.
rewrite Qpositive_plus_sym; rewrite Qpositive_sub_correct; auto.
Case' (Qpositive_le_dec n' m').
case (Qpositive_eq_dec n' m').
simpl in |- *.
rewrite Qpositive_plus_sym.
intros e q n0 q0; rewrite e; rewrite Qpositive_sub_correct; auto with *.
simpl in |- *.
intros; rewrite Qpositive_plus_sub_assoc; auto.
simpl in |- *.
Case' (Qpositive_le_dec (Qpositive_sub n' m') p').
case (Qpositive_eq_dec (Qpositive_sub n' m') p').
intros e q H H0 H1 n0 q0; elim n0.
symmetry  in |- *; apply add_sub_eq2; auto with *.
intros; rewrite Qpositive_sub_sub_assoc; auto.
rewrite Qpositive_plus_sym; auto.
intros H H0 H3 H1 H2 H4 n0 q; elim H3.
apply add_sub_le2; auto.
Case' (Qpositive_le_dec n' m').
case (Qpositive_eq_dec n' m').
intros e q H H0 H1; elim H1; rewrite e; apply Qpositive_plus_le.
simpl in |- *.
intros n0 q H H0 H1; elim H1; apply Qpositive_le_trans with m'; auto with *.
apply Qpositive_plus_le.
simpl in |- *.
Case' (Qpositive_le_dec (Qpositive_sub n' m') p').
case (Qpositive_eq_dec (Qpositive_sub n' m') p').
intros e q H H0 H2 H1; elim H1.
symmetry  in |- *; apply add_sub_eq2; auto with *.
intros n0 q H H0 H3 H1 H2 H4; elim H4; apply add_sub_le1; auto with *.
intros; rewrite Qpositive_sub_sub_assoc_l; auto with *.

(* Focus 3 *)
intros m' n' p'; simpl in |- *.
rewrite Qpositive_plus_assoc; auto with *.
Qed.

Theorem Qplus_assoc_one_neg :
 forall n' m' p' : Qpositive,
 Qplus (Qpos n') (Qplus (Qpos m') (Qneg p')) =
 Qplus (Qplus (Qpos n') (Qpos m')) (Qneg p').
simpl in |- *; intros n' m' p'.
Case' (Qpositive_le_dec m' p').
intros Hle; case (Qpositive_eq_dec m' p').
intros Heq; Case' (Qpositive_le_dec (Qpositive_plus n' m') p').
intros Hle1.
elim (Qpositive_plus_diff p' n').
apply Qpositive_le_antisym.
apply Qpositive_plus_le.
generalize Hle1; rewrite Heq; rewrite Qpositive_plus_sym; auto.
intros H H0 H1; rewrite <- Heq.
rewrite Qpositive_sub_correct; auto.
Case' (Qpositive_le_dec n' (Qpositive_sub p' m')).
case (Qpositive_eq_dec n' (Qpositive_sub p' m')).
intros e q n0; Case' (Qpositive_le_dec (Qpositive_plus n' m') p').
case (Qpositive_eq_dec (Qpositive_plus n' m') p').
auto.
intros n1 q0.
elim n1; rewrite e.
rewrite Qpositive_sub_correct2; auto.
intros Hnot1 Hle' Hnot; elim Hnot; rewrite e.
rewrite Qpositive_sub_correct2; auto.
apply Qpositive_le_refl.
Case' (Qpositive_le_dec (Qpositive_plus n' m') p').
case (Qpositive_eq_dec (Qpositive_plus n' m') p').
intros e q n0 q0 n1.
elim n0.
rewrite <- e.
rewrite Qpositive_sub_correct; auto.
intros e q n0 q0 n1.
rewrite Qpositive_sub_sub_assoc_l; auto.
rewrite Qpositive_plus_sym; auto.
rewrite Qpositive_plus_sym; auto.
rewrite <- (Qpositive_sub_correct2 p' m'); auto.
rewrite (Qpositive_plus_sym m'); apply Qpositive_le_add; auto with *.
intros H H0 H1 n0 q n1.
elim n0; apply Qpositive_le_antisym; auto.
rewrite <- (Qpositive_sub_correct n' m').
apply Qpositive_le_sub_r; auto.
rewrite Qpositive_plus_sym; apply sym_not_equal; apply Qpositive_plus_diff.
rewrite Qpositive_plus_sym; apply Qpositive_plus_le.
Case' (Qpositive_le_dec (Qpositive_plus n' m') p').
case (Qpositive_eq_dec (Qpositive_plus n' m') p').
intros e q H H0 H1 n0.
elim H1; rewrite <- e; rewrite Qpositive_sub_correct; apply Qpositive_le_refl.
intros n0 q H H0 H1 n1.
elim H1.
rewrite <- (Qpositive_sub_correct n' m').
apply Qpositive_le_sub_r; auto with *.
apply sym_not_equal; rewrite Qpositive_plus_sym; apply Qpositive_plus_diff.
rewrite Qpositive_plus_sym; apply Qpositive_plus_le.
intros H H0 H3 H1 H2 H4 n0.
rewrite Qpositive_sub_sub_assoc; auto with *.
Case' (Qpositive_le_dec (Qpositive_plus n' m') p').
case (Qpositive_eq_dec (Qpositive_plus n' m') p').
intros e q H H0 H1.
elim H1.
rewrite <- e; rewrite Qpositive_plus_sym; apply Qpositive_plus_le.
intros n0 q H H0 H1.
elim H1.
apply Qpositive_le_trans with (Qpositive_plus n' m'); auto.
rewrite Qpositive_plus_sym; apply Qpositive_plus_le.
intros H H0 H3 H1 H2 H4.
rewrite Qpositive_plus_sym.
rewrite Qpositive_plus_sub_assoc; auto with *.
rewrite Qpositive_plus_sym; auto.
Qed.

Theorem Qplus_assoc_one_neg' :
 forall (n m : Q) (p' : Qpositive),
 Qplus n (Qplus m (Qneg p')) = Qplus (Qplus n m) (Qneg p').
intros n m; case m.
(* Focus 1 *)
intros; try rewrite <- (Qplus_sym Zero); repeat rewrite Qplus_zero_left;
 auto with *.
(* Focus 2 *)
case n.
(* 2.2 *)
2: intros n' m' p'; apply Qplus_assoc_one_neg.
intros m' p'; repeat rewrite Qplus_zero_left; auto.
intros n' m' p'.
repeat rewrite (Qplus_sym (Qneg n')).
repeat rewrite <- Qplus_assoc_two_neg.
repeat rewrite (Qplus_sym (Qneg n')).
auto.
(* Focus 3 *)
intros m' p'; apply Qplus_assoc_two_neg.
Qed.

Theorem Qplus_assoc :
 forall n m p : Q, Qplus n (Qplus m p) = Qplus (Qplus n m) p.
intros n m p; case p.
(* Focus 1 *)
intros; repeat rewrite <- (Qplus_sym Zero); repeat rewrite Qplus_zero_left;
 auto with *.
(* Focus 2 *)
intros p'; case m.
(* 2.1 *)
intros; try rewrite <- (Qplus_sym Zero); repeat rewrite Qplus_zero_left;
 auto with *.
(* 2.2 *)
intros m'; case n.
2: intros n'; simpl in |- *; rewrite Qpositive_plus_assoc; auto.
repeat rewrite Qplus_zero_left; auto.
intros n'; repeat rewrite (Qplus_sym (Qneg n'));
 repeat rewrite <- (Qplus_sym (Qpos p')).
rewrite Qplus_assoc_one_neg; auto.
(* 2.3 *)
intros m'; repeat rewrite <- (Qplus_sym (Qpos p')).
repeat rewrite Qplus_assoc_one_neg'.
rewrite (Qplus_sym n); auto.
(* Focus 3 *)
intros p'; apply Qplus_assoc_one_neg'.
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.Div2.

(* Why3 assumption *)
Definition unit := unit.

Axiom qtmark : Type.
Parameter qtmark_WhyType : WhyType qtmark.
Existing Instance qtmark_WhyType.

(* Why3 assumption *)
Inductive term :=
  | S : term
  | K : term
  | App : term -> term -> term.
Axiom term_WhyType : WhyType term.
Existing Instance term_WhyType.

(* Why3 assumption *)
Fixpoint is_value (t:term) {struct t}: Prop :=
  match t with
  | (K|S) => True
  | ((App K v)|(App S v)) => (is_value v)
  | (App (App S v1) v2) => (is_value v1) /\ (is_value v2)
  | _ => False
  end.

(* Why3 assumption *)
Inductive context :=
  | Hole : context
  | Left : context -> term -> context
  | Right : term -> context -> context.
Axiom context_WhyType : WhyType context.
Existing Instance context_WhyType.

(* Why3 assumption *)
Fixpoint is_context (c:context) {struct c}: Prop :=
  match c with
  | Hole => True
  | (Left c1 _) => (is_context c1)
  | (Right v c1) => (is_value v) /\ (is_context c1)
  end.

(* Why3 assumption *)
Fixpoint subst (c:context) (t:term) {struct c}: term :=
  match c with
  | Hole => t
  | (Left c1 t2) => (App (subst c1 t) t2)
  | (Right v1 c2) => (App v1 (subst c2 t))
  end.

(* Why3 assumption *)
Inductive infix_mnmngt: term -> term -> Prop :=
  | red_K : forall (c:context), (is_context c) -> forall (v1:term) (v2:term),
      (is_value v1) -> ((is_value v2) -> (infix_mnmngt (subst c (App (App K
      v1) v2)) (subst c v1)))
  | red_S : forall (c:context), (is_context c) -> forall (v1:term) (v2:term)
      (v3:term), (is_value v1) -> ((is_value v2) -> ((is_value v3) ->
      (infix_mnmngt (subst c (App (App (App S v1) v2) v3)) (subst c
      (App (App v1 v3) (App v2 v3)))))).

Axiom red_left : forall (t1:term) (t2:term) (t:term), (infix_mnmngt t1 t2) ->
  (infix_mnmngt (App t1 t) (App t2 t)).

Axiom red_right : forall (v:term) (t1:term) (t2:term), (is_value v) ->
  ((infix_mnmngt t1 t2) -> (infix_mnmngt (App v t1) (App v t2))).

(* Why3 assumption *)
Inductive relTR: term -> term -> Prop :=
  | BaseTransRefl : forall (x:term), (relTR x x)
  | StepTransRefl : forall (x:term) (y:term) (z:term), (relTR x y) ->
      ((infix_mnmngt y z) -> (relTR x z)).

Axiom relTR_transitive : forall (x:term) (y:term) (z:term), (relTR x y) ->
  ((relTR y z) -> (relTR x z)).

Axiom red_star_left : forall (t1:term) (t2:term) (t:term), (relTR t1 t2) ->
  (relTR (App t1 t) (App t2 t)).

Axiom red_star_right : forall (v:term) (t1:term) (t2:term), (is_value v) ->
  ((relTR t1 t2) -> (relTR (App v t1) (App v t2))).

Axiom reducible_or_value : forall (t:term), (exists t':term, (infix_mnmngt t
  t')) \/ (is_value t).

(* Why3 assumption *)
Definition irreducible (t:term): Prop := forall (t':term), ~ (infix_mnmngt t
  t').

Axiom irreducible_is_value : forall (t:term), (irreducible t) <-> (is_value
  t).

(* Why3 assumption *)
Inductive only_K: term -> Prop :=
  | only_K_K : (only_K K)
  | only_K_App : forall (t1:term) (t2:term), (only_K t1) -> ((only_K t2) ->
      (only_K (App t1 t2))).

Axiom only_K_reduces : forall (t:term), (only_K t) -> exists v:term, (relTR t
  v) /\ ((is_value v) /\ (only_K v)).

(* Why3 assumption *)
Fixpoint size (t:term) {struct t}: Z :=
  match t with
  | (K|S) => 0%Z
  | (App t1 t2) => ((1%Z + (size t1))%Z + (size t2))%Z
  end.

Axiom size_nonneg : forall (t:term), (0%Z <= (size t))%Z.

Parameter ks: Z -> term.

Axiom ksO : ((ks 0%Z) = K).

Axiom ksS : forall (n:Z), (0%Z <= n)%Z -> ((ks (n + 1%Z)%Z) = (App (ks n)
  K)).

Axiom ks1 : ((ks 1%Z) = (App K K)).

Axiom only_K_ks : forall (n:Z), (0%Z <= n)%Z -> (only_K (ks n)).

Axiom ks_inversion : forall (n:Z), (0%Z <= n)%Z -> ((n = 0%Z) \/
  ((0%Z < n)%Z /\ ((ks n) = (App (ks (n - 1%Z)%Z) K)))).

Axiom ks_injective : forall (n1:Z) (n2:Z), (0%Z <= n1)%Z -> ((0%Z <= n2)%Z ->
  (((ks n1) = (ks n2)) -> (n1 = n2))).

Require Import Why3. Ltac ae := why3 "alt-ergo".

(* Why3 goal *)
Theorem WP_parameter_reduction3 : forall (t:term), (exists n:Z,
  (0%Z <= n)%Z /\ (t = (ks n))) -> forall (x:term) (x1:term), (t = (App x
  x1)) -> ((exists n:Z, (0%Z <= n)%Z /\ (x = (ks n))) ->
  forall (result:term), ((is_value result) /\ forall (n:Z), (0%Z <= n)%Z ->
  (((x = (ks (2%Z * n)%Z)) -> (result = K)) /\
  ((x = (ks ((2%Z * n)%Z + 1%Z)%Z)) -> (result = (App K K))))) ->
  ((result = K) -> ((exists n:Z, (0%Z <= n)%Z /\ (x1 = (ks n))) ->
  forall (o:term), ((is_value o) /\ forall (n:Z), (0%Z <= n)%Z ->
  (((x1 = (ks (2%Z * n)%Z)) -> (o = K)) /\
  ((x1 = (ks ((2%Z * n)%Z + 1%Z)%Z)) -> (o = (App K K))))) -> forall (n:Z),
  (0%Z <= n)%Z -> ~ (t = (ks (2%Z * n)%Z))))).
intros t (n,(h1,h2)) x x1 h3 (n1,(h4,h5)) result (h6,h7) h8
        (n2,(h9,h10)) o (h11,h12) n0 h13.
subst.
intuition.
generalize (h12 n2 h9); clear h12; intros ht2.
assert (n2 = 0)%Z.
  generalize (ks_inversion n2 h9).
  intuition.
  generalize (ks_inversion n h1). ae.
assert (h: (0 <= 2*n0)%Z) by ae.
generalize (ks_inversion (2*n0)%Z h).
intuition.
ae.
subst.
assert (ks n1 = ks (2*(n0-1)+1))%Z by ae.
assert (n1 = 2 * (n0 - 1) + 1)%Z by ae.
ae.
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require map.Map.
Require map.Occ.
Require map.MapPermut.

(* Why3 assumption *)
Definition unit := unit.

(* Why3 assumption *)
Inductive array (a:Type) :=
  | mk_array : Z -> (map.Map.map Z a) -> array a.
Axiom array_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (array a).
Existing Instance array_WhyType.
Implicit Arguments mk_array [[a]].

(* Why3 assumption *)
Definition elts {a:Type} {a_WT:WhyType a} (v:(array a)): (map.Map.map Z a) :=
  match v with
  | (mk_array x x1) => x1
  end.

(* Why3 assumption *)
Definition length {a:Type} {a_WT:WhyType a} (v:(array a)): Z :=
  match v with
  | (mk_array x x1) => x
  end.

(* Why3 assumption *)
Definition get {a:Type} {a_WT:WhyType a} (a1:(array a)) (i:Z): a :=
  (map.Map.get (elts a1) i).

(* Why3 assumption *)
Definition set {a:Type} {a_WT:WhyType a} (a1:(array a)) (i:Z) (v:a): (array
  a) := (mk_array (length a1) (map.Map.set (elts a1) i v)).

(* Why3 assumption *)
Definition map_eq_sub {a:Type} {a_WT:WhyType a} (a1:(map.Map.map Z a))
  (a2:(map.Map.map Z a)) (l:Z) (u:Z): Prop := forall (i:Z), ((l <= i)%Z /\
  (i < u)%Z) -> ((map.Map.get a1 i) = (map.Map.get a2 i)).

(* Why3 assumption *)
Definition array_eq_sub {a:Type} {a_WT:WhyType a} (a1:(array a)) (a2:(array
  a)) (l:Z) (u:Z): Prop := ((length a1) = (length a2)) /\ (((0%Z <= l)%Z /\
  (l <= (length a1))%Z) /\ (((0%Z <= u)%Z /\ (u <= (length a1))%Z) /\
  (map_eq_sub (elts a1) (elts a2) l u))).

(* Why3 assumption *)
Definition array_eq {a:Type} {a_WT:WhyType a} (a1:(array a)) (a2:(array
  a)): Prop := ((length a1) = (length a2)) /\ (map_eq_sub (elts a1) (elts a2)
  0%Z (length a1)).

(* Why3 assumption *)
Definition exchange {a:Type} {a_WT:WhyType a} (a1:(map.Map.map Z a))
  (a2:(map.Map.map Z a)) (l:Z) (u:Z) (i:Z) (j:Z): Prop := ((l <= i)%Z /\
  (i < u)%Z) /\ (((l <= j)%Z /\ (j < u)%Z) /\ (((map.Map.get a1
  i) = (map.Map.get a2 j)) /\ (((map.Map.get a1 j) = (map.Map.get a2 i)) /\
  forall (k:Z), ((l <= k)%Z /\ (k < u)%Z) -> ((~ (k = i)) -> ((~ (k = j)) ->
  ((map.Map.get a1 k) = (map.Map.get a2 k))))))).

Axiom exchange_set : forall {a:Type} {a_WT:WhyType a},
  forall (a1:(map.Map.map Z a)) (l:Z) (u:Z) (i:Z) (j:Z), ((l <= i)%Z /\
  (i < u)%Z) -> (((l <= j)%Z /\ (j < u)%Z) -> (exchange a1
  (map.Map.set (map.Map.set a1 i (map.Map.get a1 j)) j (map.Map.get a1 i)) l
  u i j)).

(* Why3 assumption *)
Definition exchange1 {a:Type} {a_WT:WhyType a} (a1:(array a)) (a2:(array a))
  (i:Z) (j:Z): Prop := ((length a1) = (length a2)) /\ (exchange (elts a1)
  (elts a2) 0%Z (length a1) i j).

(* Why3 assumption *)
Definition permut {a:Type} {a_WT:WhyType a} (a1:(array a)) (a2:(array a))
  (l:Z) (u:Z): Prop := ((length a1) = (length a2)) /\ (((0%Z <= l)%Z /\
  (l <= (length a1))%Z) /\ (((0%Z <= u)%Z /\ (u <= (length a1))%Z) /\
  (map.MapPermut.permut (elts a1) (elts a2) l u))).

(* Why3 assumption *)
Definition permut_sub {a:Type} {a_WT:WhyType a} (a1:(array a)) (a2:(array a))
  (l:Z) (u:Z): Prop := (map_eq_sub (elts a1) (elts a2) 0%Z l) /\ ((permut a1
  a2 l u) /\ (map_eq_sub (elts a1) (elts a2) u (length a1))).

(* Why3 assumption *)
Definition permut_all {a:Type} {a_WT:WhyType a} (a1:(array a)) (a2:(array
  a)): Prop := ((length a1) = (length a2)) /\ (map.MapPermut.permut (elts a1)
  (elts a2) 0%Z (length a1)).

Axiom exchange_permut_sub : forall {a:Type} {a_WT:WhyType a},
  forall (a1:(array a)) (a2:(array a)) (i:Z) (j:Z) (l:Z) (u:Z), (exchange1 a1
  a2 i j) -> (((l <= i)%Z /\ (i < u)%Z) -> (((l <= j)%Z /\ (j < u)%Z) ->
  ((0%Z <= l)%Z -> ((u <= (length a1))%Z -> (permut_sub a1 a2 l u))))).

Axiom permut_sub_weakening : forall {a:Type} {a_WT:WhyType a},
  forall (a1:(array a)) (a2:(array a)) (l1:Z) (u1:Z) (l2:Z) (u2:Z),
  (permut_sub a1 a2 l1 u1) -> (((0%Z <= l2)%Z /\ (l2 <= l1)%Z) ->
  (((u1 <= u2)%Z /\ (u2 <= (length a1))%Z) -> (permut_sub a1 a2 l2 u2))).

Axiom exchange_permut_all : forall {a:Type} {a_WT:WhyType a},
  forall (a1:(array a)) (a2:(array a)) (i:Z) (j:Z), (exchange1 a1 a2 i j) ->
  (permut_all a1 a2).

(* Why3 assumption *)
Definition sorted_sub (a:(map.Map.map Z Z)) (l:Z) (u:Z): Prop :=
  forall (i1:Z) (i2:Z), ((l <= i1)%Z /\ ((i1 <= i2)%Z /\ (i2 < u)%Z)) ->
  ((map.Map.get a i1) <= (map.Map.get a i2))%Z.

(* Why3 assumption *)
Definition sorted_sub1 (a:(array Z)) (l:Z) (u:Z): Prop := (sorted_sub
  (elts a) l u).

(* Why3 assumption *)
Definition sorted (a:(array Z)): Prop := (sorted_sub (elts a) 0%Z
  (length a)).

Axiom empty_range_is_sorted : forall (a:(array Z)) (l:Z) (u:Z),
  (u = (length a)) -> ((u <= l)%Z -> (sorted_sub1 a l u)).

Axiom permut_sub_commutative : forall {a:Type} {a_WT:WhyType a},
  forall (a1:(array a)) (a2:(array a)) (l:Z) (u:Z), ((0%Z <= l)%Z /\
  ((l < u)%Z /\ ((u <= (length a1))%Z /\ ((length a1) <= (length a2))%Z))) ->
  ((permut_sub a1 a2 l u) -> (permut_sub a2 a1 l u)).

Axiom array_eq_is_permut_sub : forall {a:Type} {a_WT:WhyType a},
  forall (a1:(array a)) (a2:(array a)) (l:Z) (u:Z), ((0%Z <= l)%Z /\
  ((l < u)%Z /\ ((u <= (length a1))%Z /\ ((length a1) = (length a2))))) ->
  ((array_eq a1 a2) -> (permut_sub a1 a2 l u)).

Axiom exchange_commutative : forall {a:Type} {a_WT:WhyType a},
  forall (a1:(array a)) (a2:(array a)) (i:Z) (j:Z), (exchange1 a1 a2 i j) <->
  ((exchange1 a2 a1 i j) <-> ((exchange1 a2 a1 j i) <-> (exchange1 a1 a2 j
  i))).

Axiom exchange_is_permut : forall {a:Type} {a_WT:WhyType a},
  forall (a1:(array a)) (a2:(array a)) (i:Z) (j:Z), ((0%Z <= i)%Z /\
  ((i <= j)%Z /\ ((j < (length a1))%Z /\ ((length a1) = (length a2))))) ->
  ((exchange1 a1 a2 i j) -> (permut_sub a1 a2 i (j + 1%Z)%Z)).

Axiom permut_trans : forall {a:Type} {a_WT:WhyType a}, forall (a1:(array a))
  (a2:(array a)) (a3:(array a)) (i:Z) (j:Z), ((0%Z <= i)%Z /\ ((i <= j)%Z /\
  ((j < (length a1))%Z /\ (((length a1) = (length a2)) /\
  ((length a2) = (length a3)))))) -> ((permut_sub a1 a2 i (j + 1%Z)%Z) ->
  ((permut_sub a2 a3 i (j + 1%Z)%Z) -> (permut_sub a1 a3 i (j + 1%Z)%Z))).

(* Why3 goal *)
Theorem permut_trans_weakening : forall {a:Type} {a_WT:WhyType a},
  forall (a1:(array a)) (a2:(array a)) (a3:(array a)) (l1:Z) (l2:Z) (u1:Z)
  (u2:Z), ((0%Z <= l1)%Z /\ ((l1 <= l2)%Z /\ ((l2 < u2)%Z /\ ((u2 <= u1)%Z /\
  (u1 < (length a1))%Z)))) -> ((permut_sub a1 a2 l2 u2) -> ((permut_sub a2 a3
  l2 u2) -> (permut_sub a1 a3 l1 u1))).
intros a a_WT a1 a2 a3 l1 l2 u1 u2 (h1,(h2,(h3,(h4,h5)))) h6 h7.

Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import Compare.
Require Import Bool.
Require Import Sumbool.
Require Import Arith.
Require Import ZArith NArith Nnat Ndec Ndigits.
From IntMap Require Import Allmaps.
Require Import List.

Section BDDmisc.

Definition BDDvar := ad.

Definition BDDcompare (x y : BDDvar) :=
  match x, y with
  | N0, N0 => Datatypes.Eq
  | N0, Npos _ => Datatypes.Lt
  | Npos _, N0 => Datatypes.Gt
  | Npos p1, Npos p2 => Pcompare p1 p2 Datatypes.Eq
  end.

Definition ad_S (a : ad) :=
  match a with
  | N0 => Npos 1
  | Npos p => Npos (Psucc p)
  end.

Definition max (m n : nat) := if leb m n then n else m.

Definition BDDvar_max (x y : BDDvar) := if Nleb x y then y else x.

Inductive no_dup_list (A : Set) : list A -> Prop :=
  | no_dup_nil : no_dup_list A nil
  | no_dup_cons :
      forall (a : A) (l : list A),
      ~ In a l -> no_dup_list _ l -> no_dup_list _ (a :: l).

Lemma ad_S_is_S : forall a : ad, nat_of_N (ad_S a) = S (nat_of_N a).
Proof.
  simple induction a. reflexivity.  simpl in |- *. unfold nat_of_P in |- *. intro.
  exact (Pmult_nat_succ_morphism p 1).
Qed.

Lemma relation_sum :
 forall r : Datatypes.comparison,
 {r = Datatypes.Eq} + {r = Datatypes.Lt} + {r = Datatypes.Gt}.
Proof.
  intro.  elim r.  left; left; reflexivity.  left; right; reflexivity.  right; reflexivity.
Qed.

Lemma BDD_EGAL_complete :
 forall x y : BDDvar, BDDcompare x y = Datatypes.Eq -> x = y.
Proof.
  double induction x y.  reflexivity.  simpl in |- *.  intros; discriminate.  simpl in |- *.
  intros; discriminate.  simpl in |- *.  intros.  cut (p0 = p).  intro.  rewrite H0; reflexivity.
  apply Pcompare_Eq_eq.  assumption.
Qed.

Lemma BDDcompare_lt :
 forall x y : BDDvar,
 BDDcompare x y = Datatypes.Lt -> nat_of_N x < nat_of_N y.
Proof.
  double induction x y.  simpl in |- *.  intro.  discriminate.  simpl in |- *.  intros.
  cut (exists h : nat, nat_of_P p = S h).  intro.  inversion H0.  rewrite H1.
  apply lt_O_Sn.  apply ZL4.  simpl in |- *.  intros.  discriminate.  simpl in |- *.  intros.
  apply nat_of_P_lt_Lt_compare_morphism.  assumption.
Qed.

Lemma BDDlt_compare :
 forall x y : BDDvar,
 nat_of_N x < nat_of_N y -> BDDcompare x y = Datatypes.Lt.
Proof.
  double induction x y.  simpl in |- *.  intro.  absurd (0 < 0).  apply lt_n_O.  assumption.
  simpl in |- *.  reflexivity.  simpl in |- *.  intro.  cut (exists h : nat, nat_of_P p = S h).  intro.
  inversion H.  rewrite H0.  intro.  absurd (S x0 < 0).  apply lt_n_O.
  assumption.  apply ZL4.  simpl in |- *.  intro.  intros.  apply nat_of_P_lt_Lt_compare_complement_morphism.
  assumption.
Qed.

Lemma BDDcompare_trans :
 forall x y z : BDDvar,
 BDDcompare x y = Datatypes.Lt ->
 BDDcompare y z = Datatypes.Lt -> BDDcompare x z = Datatypes.Lt.
Proof.
  double induction x y.  simpl in |- *.  intros.  discriminate H.  simpl in |- *.  intro.
  simple induction z.  intros.  discriminate H0.  trivial.  simpl in |- *.  intros.
  discriminate H.  intro.  intro.  simple induction z.  simpl in |- *.  trivial.  intro.
  simpl in |- *.  intros.  cut (nat_of_P p0 < nat_of_P p).
  cut (nat_of_P p < nat_of_P p1).  intros.  apply nat_of_P_lt_Lt_compare_complement_morphism.
  apply lt_trans with (m := nat_of_P p).  assumption.  assumption.
  apply nat_of_P_lt_Lt_compare_morphism.  assumption.  apply nat_of_P_lt_Lt_compare_morphism.
  assumption.
Qed.

Lemma BDDcompare_sup_inf :
 forall x y : BDDvar,
 BDDcompare x y = Datatypes.Gt -> BDDcompare y x = Datatypes.Lt.
Proof.
  double induction x y.  simpl in |- *.  intro; discriminate.  simpl in |- *.  intro.  intro; discriminate.
  simpl in |- *.  reflexivity.  unfold BDDcompare in |- *.  intros.  apply ZC1.  assumption.
Qed.

Lemma lt_trans_1 : forall x y z : nat, x < y -> y < S z -> x < z.
Proof.
  intros.  unfold lt in H0.  unfold lt in H.  unfold lt in |- *.
  apply le_trans with (m := y).  assumption.  apply le_S_n.  assumption.
Qed.

Lemma BDDcompare_1 :
 forall x y : BDDvar,
 BDDcompare x y = Datatypes.Lt ->
 BDDcompare (ad_S x) y = Datatypes.Lt \/ ad_S x = y.
Proof.
  intros.  elim (relation_sum (BDDcompare (ad_S x) y)).  intro H0.  elim H0; intro.
  right.  apply BDD_EGAL_complete.  assumption.  left; assumption.  intro.
  absurd (nat_of_N x < nat_of_N x).  apply lt_irrefl.  apply lt_trans_1 with (y := nat_of_N y).
  apply BDDcompare_lt.  assumption.  rewrite <- (ad_S_is_S x).  apply BDDcompare_lt.
  apply BDDcompare_sup_inf.  assumption.
Qed.

Lemma andb3_lemma :
 forall b1 b2 b3 : bool,
 b1 && (b2 && b3) = true -> b1 = true /\ b2 = true /\ b3 = true.
Proof.
  intros b1 b2 b3.  elim b1.  simpl in |- *.  elim b2.  simpl in |- *.  auto.  simpl in |- *.
  intro; discriminate H.  simpl in |- *.  intro; discriminate H.
Qed.

Lemma andb3_lemma_1 :
 forall x x0 y y0 z z0 : ad,
 (x, (y, z)) <> (x0, (y0, z0)) ->
 Neqb x x0 && (Neqb y y0 && Neqb z z0) = false.
Proof.
  intros x x0 y y0 z z0 H.  elim (sumbool_of_bool (Neqb x x0)).  intro H0.
  elim (sumbool_of_bool (Neqb y y0)).  intro H1.  elim (sumbool_of_bool (Neqb z z0)).
  intro H2.  absurd ((x, (y, z)) = (x0, (y0, z0))).  assumption.  rewrite (Neqb_complete _ _ H0).
  rewrite (Neqb_complete _ _ H1).  rewrite (Neqb_complete _ _ H2).  reflexivity.
  intro H2.  rewrite H0.  rewrite H1.  rewrite H2.  reflexivity.  intro H1.  rewrite H0.
  rewrite H1.  reflexivity.  intro H0.  rewrite H0.  reflexivity.
Qed.

Lemma ad_S_le_then_neq :
 forall x y : ad, Nleb (ad_S x) y = true -> Neqb x y = false.
Proof.
  intros.  cut (Neqb x y = true \/ Neqb x y = false).  intro.  elim H0.
  clear H0.  intro.  cut (x = y).  intro.  rewrite H1 in H.  unfold Nleb in H.
  rewrite (ad_S_is_S y) in H.
  cut (leb (S (nat_of_N y)) (nat_of_N y) = false).  rewrite H.  intro.
  discriminate H2.  cut (nat_of_N y < S (nat_of_N y)).  intro.
  apply leb_correct_conv.  assumption.  unfold lt in |- *.  trivial.
  apply Neqb_complete.  assumption.  trivial. elim (Neqb x y). auto. auto.
Qed.

Lemma BDD_EGAL_correct : forall x : BDDvar, BDDcompare x x = Datatypes.Eq.
Proof.
  simple induction x.  reflexivity.  simpl in |- *.  intros.  apply Pcompare_refl.
Qed.

Lemma BDDcompare_inf_sup :
 forall x y : BDDvar,
 BDDcompare x y = Datatypes.Lt -> BDDcompare y x = Datatypes.Gt.
Proof.
  double induction x y.  simpl in |- *.  intro; discriminate.  simpl in |- *.
  intro; reflexivity.  simpl in |- *.  intros; discriminate.  simpl in |- *.  intros.
  apply ZC2.  assumption.
Qed.

Lemma ad_S_compare :
 forall x y : ad, BDDcompare x y = BDDcompare (ad_S x) (ad_S y).
Proof.
  intros x y.  elim (relation_sum (BDDcompare x y)).  intro y0.  elim y0; clear y0; intro y0.
  rewrite (BDD_EGAL_complete x y y0).  rewrite (BDD_EGAL_correct y).
  rewrite (BDD_EGAL_correct (ad_S y)).  reflexivity.  rewrite y0.  symmetry  in |- *.
  apply BDDlt_compare.  rewrite (ad_S_is_S x).  rewrite (ad_S_is_S y).
  apply lt_n_S.  apply BDDcompare_lt.  assumption.  intro y0.  simpl in |- *.  simpl in |- *.
  simpl in |- *.  rewrite y0.  symmetry  in |- *.  apply BDDcompare_inf_sup.  apply BDDlt_compare.
  rewrite (ad_S_is_S x).  rewrite (ad_S_is_S y).  apply lt_n_S.  apply BDDcompare_lt.
  apply BDDcompare_sup_inf.  assumption.
Qed.

Lemma prod_sum :
 forall (A B : Set) (p : A * B), exists a : A, (exists b : B, p = (a, b)).
Proof.
  intros A B p.  elim p.  intros y y0.  split with y.  split with y0.  reflexivity.
Qed.

Lemma lt_max_1_2 :
 forall x1 y1 x2 y2 : nat, x1 < x2 -> y1 < y2 -> max x1 y1 < max x2 y2.
Proof.
  intros x1 y1 x2 y2 H H0.  unfold max in |- *.  elim (sumbool_of_bool (leb x2 y2)).
  intro y.  rewrite y.
  elim (leb x1 y1).  assumption.  apply lt_le_trans with (m := x2).  assumption.
  apply leb_complete.  assumption.  intro y.  rewrite y.  elim (leb x1 y1).
  apply lt_trans with (m := y2).  assumption.  apply leb_complete_conv.  assumption.
  assumption.
Qed.

Lemma lt_max_1 :
 forall x1 y1 x2 y2 : nat, x1 < x2 -> y1 < x2 -> max x1 y1 < max x2 y2.
Proof.
  intros x1 y1 x2 y2 H H0.  unfold max in |- *.  elim (leb x1 y1).
  elim (sumbool_of_bool (leb x2 y2)); intro y; rewrite y.
  apply lt_le_trans with (m := x2).  assumption.  apply leb_complete; assumption.
  assumption.  elim (sumbool_of_bool (leb x2 y2)).  intro y.  rewrite y.  apply lt_le_trans with (m := x2).
  assumption.  apply leb_complete; assumption.  intro y; rewrite y.  assumption.
Qed.

Lemma lt_max_2 :
 forall x1 y1 x2 y2 : nat, x1 < y2 -> y1 < y2 -> max x1 y1 < max x2 y2.
Proof.
  intros x1 y1 x2 y2 H H0.  unfold max in |- *.  elim (leb x1 y1).  elim (sumbool_of_bool (leb x2 y2)).
  intro y.  rewrite y.  assumption.  intro y.  rewrite y.  apply lt_trans with (m := y2).
  assumption.  apply leb_complete_conv.  assumption.  elim (sumbool_of_bool (leb x2 y2)).
  intro y.  rewrite y.  assumption.  intro y.  rewrite y.  apply lt_trans with (m := y2).
  assumption.  apply leb_complete_conv.  assumption.
Qed.

Lemma max_x_x_eq_x : forall x : nat, max x x = x.
Proof.
  unfold max in |- *.  intro.  elim (leb x x).  reflexivity.  reflexivity.
Qed.

Lemma BDDvar_le_max_2 : forall x y : BDDvar, Nleb x (BDDvar_max y x) = true.
Proof.
  unfold BDDvar_max in |- *.  intros x y.  elim (sumbool_of_bool (Nleb y x)).
  intro y0.  rewrite y0.  apply Nleb_refl.  intro y0.  rewrite y0.
  apply Nltb_leb_weak.  assumption.
Qed.

Lemma BDDvar_max_max :
 forall x y : BDDvar,
 nat_of_N (BDDvar_max x y) = max (nat_of_N x) (nat_of_N y).
Proof.
  unfold BDDvar_max, max in |- *.  intros.  unfold Nleb in |- *.
  elim (leb (nat_of_N x) (nat_of_N y)).  reflexivity.  reflexivity.
Qed.

Lemma BDDvar_le_max_1 : forall x y : BDDvar, Nleb x (BDDvar_max x y) = true.
Proof.
  intros x y.  elim (sumbool_of_bool (Nleb x y)); unfold BDDvar_max in |- *.
  intro y0.  rewrite y0.  assumption.  intro y0.  rewrite y0.  apply Nleb_refl.
Qed.

Lemma BDDvar_max_inf :
 forall x y : BDDvar, BDDcompare x y = Datatypes.Lt -> BDDvar_max x y = y.
Proof.
  intros.  unfold BDDvar_max in |- *.  replace (Nleb x y) with true.  reflexivity.
  symmetry  in |- *.  unfold Nleb in |- *.  apply leb_correct.  apply lt_le_weak.
  apply BDDcompare_lt.  assumption.
Qed.

Lemma BDDvar_max_comm : forall x y : BDDvar, BDDvar_max x y = BDDvar_max y x.
Proof.
  unfold BDDvar_max in |- *.  intros x y.  elim (sumbool_of_bool (Nleb x y)).
  intro y0.  rewrite y0.  elim (sumbool_of_bool (Nleb y x)).  intro y1.  rewrite y1.
  apply Nleb_antisym.  assumption.  assumption.  intro y1.  rewrite y1.
  reflexivity.  intro y0.  rewrite y0.  elim (sumbool_of_bool (Nleb y x)).  intro y1.
  rewrite y1.  reflexivity.  intro y1.  rewrite y1.  apply Nleb_antisym.
  apply Nltb_leb_weak.  assumption.  apply Nltb_leb_weak.  assumption.
Qed.

Lemma nat_gt_1_lemma : forall n : nat, n <> 0 -> n <> 1 -> 2 <= n.
Proof.
  intros.  cut (1 <= n).  intro.  elim (le_le_S_eq _ _ H1).  tauto.  intro.
  absurd (n = 1).  assumption.  symmetry  in |- *.  assumption.  fold (0 < n) in |- *.
  apply neq_O_lt.  unfold not in |- *.  intro.  apply H.  rewrite H1; reflexivity.
Qed.

Lemma ad_gt_1_lemma :
 forall x : ad, x <> N0 -> x <> Npos 1 -> Nleb (Npos 2) x = true.
Proof.
  intros.  unfold Nleb in |- *.  unfold nat_of_N at 1 in |- *.  unfold nat_of_P in |- *.
  unfold Pos.iter_op in |- *.  unfold plus in |- *.  apply leb_correct.
  apply nat_gt_1_lemma.  unfold not in |- *.  intro.  apply H.
  replace N0 with (N_of_nat 0).  rewrite <- H1.  symmetry  in |- *.
  apply N_of_nat_of_N.  reflexivity.  unfold not in |- *.  intro.  apply H0.
  replace (Npos 1) with (N_of_nat 1).  rewrite <- H1.  symmetry  in |- *.
  apply N_of_nat_of_N.  reflexivity.
Qed.

Lemma Nltb_lebmma :
 forall a b : ad, Nleb a b = false -> Nleb (ad_S b) a = true.
Proof.
  intros.  unfold Nleb in |- *.  rewrite (ad_S_is_S b).  apply leb_correct.
  fold (nat_of_N b < nat_of_N a) in |- *.  apply leb_complete_conv.
  assumption.
Qed.

Lemma eq_ad_S_eq :
 forall a b : ad, Neqb (ad_S a) (ad_S b) = true -> Neqb a b = true.
Proof.
  intros.  cut (ad_S a = ad_S b).  rewrite <- (N_of_nat_of_N (ad_S a)).
  rewrite <- (N_of_nat_of_N (ad_S b)).  rewrite (ad_S_is_S a).
  rewrite (ad_S_is_S b).  intro.  cut (nat_of_N a = nat_of_N b).  intro.
  rewrite <- (N_of_nat_of_N a).  rewrite <- (N_of_nat_of_N b).  rewrite H1.
  apply Neqb_correct.  apply eq_add_S.
  rewrite <- (nat_of_N_of_nat (S (nat_of_N a))).  rewrite H0.
  apply nat_of_N_of_nat.  apply Neqb_complete.  assumption.
Qed.

Lemma ad_S_neq_N0 : forall a : ad, Neqb (ad_S a) N0 = false.
Proof.
  intros.  elim a.  reflexivity.  simpl in |- *.  reflexivity.
Qed.

Lemma list_sum :
 forall (A : Set) (l : list A),
 l = nil \/ (exists a : A, (exists l' : list A, l = a :: l')).
Proof.
  intros.  elim l.  left; reflexivity.  intros.  right.  split with a.
  split with l0.  reflexivity.
Qed.

Lemma no_dup_sum :
 forall (A : Set) (l : list A) (H : no_dup_list _ l),
 l = nil \/
 (exists a : A,
    (exists l0 : list A, ~ In a l0 /\ no_dup_list _ l0 /\ l = a :: l0)).
Proof.
  intros.  elim H.  left; reflexivity.  intros.  right.  split with a.
  split with l0.  split.  assumption.  split.  assumption.  reflexivity.
Qed.

Lemma no_dup_cons_no_dup :
 forall (A : Set) (l : list A) (a : A),
 no_dup_list _ (a :: l) -> no_dup_list _ l.
Proof.
  intros.  elim (no_dup_sum _ _ H).  intro; discriminate.  intros.
  elim H0; intros.  elim H1; intros.  elim H2; intros.  elim H4; intros.
  injection H6.  intros.  rewrite H7; assumption.
Qed.

Lemma no_dup_cons_no_in :
 forall (A : Set) (l : list A) (a : A), no_dup_list _ (a :: l) -> ~ In a l.
Proof.
  intros.  elim (no_dup_sum _ _ H).  intro; discriminate.  intros.
  elim H0; intros.  elim H1; intros.  elim H2; intros.  elim H4; intros.
  injection H6.  intros.  rewrite H7; rewrite H8; assumption.
Qed.

End BDDmisc.


Require Export UnitaryListRepresentation.

(** This gate set is use as the output of circuit mapping. It consists of
   single-qubit gates (from some other gate set), CX gates, and SWAP gates.
   We distinguish between CX and SWAP (which can be implemented using three
   CXs) to facilitate translation validation. *)

Inductive Map_Unitary (U : Set) : nat -> Set :=
  | UMap_U        : U -> Map_Unitary U 1
  | UMap_CNOT     : Map_Unitary U 2
  | UMap_SWAP     : Map_Unitary U 2.

Arguments UMap_U {U}.
Arguments UMap_CNOT {U}.
Arguments UMap_SWAP {U}.

Definition UM {U dim} u a : gate_app (Map_Unitary U) dim := App1 (UMap_U u) a.
Definition CNOT {U dim} a b : gate_app (Map_Unitary U) dim := App2 UMap_CNOT a b.
Definition SWAP {U dim} a b : gate_app (Map_Unitary U) dim := App2 UMap_SWAP a b.
Definition map_ucom_l (U : Set) dim := gate_list (Map_Unitary U) dim.

Definition match_gate {U : Set} {n} (match_gate : U -> U -> bool) (u u' : Map_Unitary U n) : bool :=
  match u, u' with
  | UMap_U u1, UMap_U u2 => match_gate u1 u2
  | UMap_CNOT, UMap_CNOT | UMap_SWAP, UMap_SWAP => true
  | _, _ => false
  end.

Module MappingGateSet (G : GateSet) <: GateSet.

Definition U := Map_Unitary (G.U 1).

Definition to_base {n dim} (u : U n) (qs : list nat) (pf : List.length qs = n) :=
  match u with
  | UMap_U u  => let q := List.nth O qs O in G.to_base u [q] (one_elem_list q)
  | UMap_CNOT => @SQIR.CNOT dim (List.nth O qs O) (List.nth (S O) qs O)
  | UMap_SWAP => @SQIR.SWAP dim (List.nth O qs O) (List.nth (S O) qs O)
  end.

Local Transparent SQIR.CNOT SQIR.SWAP.

Lemma to_base_only_uses_qs : forall {n} (dim : nat) (u : U n) (qs : list nat) (pf : List.length qs = n),
    @only_uses _ dim (to_base u qs pf) qs.
Proof.
  intros.
  destruct u; simpl.
  - destruct qs; inversion pf.
    destruct qs; inversion pf.
    simpl.
    apply G.to_base_only_uses_qs.
  - constructor; apply nth_In; lia.
  - repeat constructor; apply nth_In; lia.
Qed.

Lemma to_base_WT : forall {n} (dim : nat) (u : U n) (qs : list nat) (pf : List.length qs = n),
  @uc_well_typed _ dim (to_base u qs pf) <-> (bounded_list qs dim /\ List.NoDup qs).
Proof.
  intros n dim u s pf.
  split.
  - intro H.
    destruct u.
    all: repeat (destruct s; simpl in *; try lia).
    + apply G.to_base_WT in H. auto.
    + inversion H; subst.
      unfold bounded_list; split.
      intros x [Hx | [Hx | Hx]]; subst; easy.
      repeat constructor; auto.
      intro contra; destruct_In; auto.
    + inversion H; inversion H3; subst.
      unfold bounded_list; split.
      intros x [Hx | [Hx | Hx]]; subst; easy.
      repeat constructor; auto.
      intro contra; destruct_In; auto.
  - intro H.
    destruct u.
    all: repeat (destruct s; simpl in *; try lia).
    + apply G.to_base_WT. auto.
    + destruct H as [H1 H2].
      inversion H2; subst.
      assert (n < dim)%nat.
      { apply H1. left. auto. }
      assert (n0 < dim)%nat.
      { apply H1. right. left. auto. }
      assert (n <> n0).
      { intro contra. contradict H3. left. auto. }
      constructor; auto.
    + destruct H as [H1 H2].
      inversion H2; subst.
      assert (n < dim)%nat.
      { apply H1. left. auto. }
      assert (n0 < dim)%nat.
      { apply H1. right. left. auto. }
      assert (n <> n0).
      { intro contra. contradict H3. left. auto. }
      repeat constructor; auto.
Qed.

Lemma to_base_map_commutes : forall {n} (dim : nat) (u : U n) (qs : list nat) (pf : List.length qs = n) (f : nat -> nat) (pfm : List.length (map f qs) = n),
  @to_base _ dim u (map f qs) pfm = map_qubits f (to_base u qs pf).
Proof.
  intros n dim u qs pf f pfm.
  destruct u; simpl.
  repeat (destruct qs; simpl in *; try lia).
  erewrite <- G.to_base_map_commutes.
  reflexivity.
  all: repeat erewrite map_nth_In; try reflexivity; lia.
Qed.

Local Opaque SQIR.CNOT SQIR.SWAP.

Definition match_gate {n} (u u' : U n) : bool := match_gate G.match_gate u u'.

Lemma match_gate_refl : forall {n} (u : U n), match_gate u u = true.
Proof.
  intros.
  dependent destruction u; simpl; auto.
  apply G.match_gate_refl.
Qed.

Lemma match_gate_implies_equiv : forall {n} dim (u u' : U n) (qs : list nat) (pf : List.length qs = n),
  match_gate u u' = true -> uc_equiv (@to_base n dim u qs pf) (to_base u' qs pf).
Proof.
  intros.
  dependent destruction u; dependent destruction u'.
  all: inversion H; try reflexivity.
  apply G.match_gate_implies_equiv. auto.
Qed.

End MappingGateSet.