(****************************************************************************

          IEEE754  :  FroundMult

          Laurent Thery, Sylvie Boldo

  ******************************************************************************)
Require Export FroundProp.

Section FRoundP.
Variable b : Fbound.
Variable radix : Z.
Variable precision : nat.

Let FtoRradix := FtoR radix.
Coercion FtoRradix : float >-> R.
Hypothesis radixMoreThanOne : (1 < radix)%Z.

Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne).
Hint Resolve radixMoreThanZERO: zarith.
Hypothesis precisionGreaterThanOne : 1 < precision.
Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision.

Theorem errorBoundedMultMin :
 forall p q fmin : float,
 Fbounded b p ->
 Fbounded b q ->
 (0 <= p)%R ->
 (0 <= q)%R ->
 (- dExp b <= Fexp p + Fexp q)%Z ->
 isMin b radix (p * q) fmin ->
 exists r : float,
   r = (p * q - fmin)%R :>R /\ Fbounded b r /\ Fexp r = (Fexp p + Fexp q)%Z.
intros p q fmin Fp Fq H' H'0 H'1 H'2.
cut (0 <= Fnum p * Fnum q)%Z;
 [ intros multPos
 | apply Zle_mult_gen; apply (LeR0Fnum radix); auto with arith ].
cut (ex (fun m : Z => FtoRradix fmin = Float m (Fexp (Fmult p q)))).
2: unfold FtoRradix in |- *;
    apply
     RoundedModeRep
      with (b := b) (precision := precision) (P := isMin b radix);
    auto.
2: apply MinRoundedModeP with (precision := precision); auto.
2: rewrite (Fmult_correct radix); auto with zarith.
intros H'3; elim H'3; intros m E; clear H'3.
exists (Fminus radix (Fmult p q) (Float m (Fexp (Fmult p q)))).
split.
rewrite E; unfold FtoRradix in |- *; repeat rewrite Fminus_correct;
 repeat rewrite Fmult_correct; auto with zarith.
split.
cut (fmin <= Fmult p q)%R;
 [ idtac
 | unfold FtoRradix in |- *; rewrite Fmult_correct; auto; case H'2;
    auto with real zarith; (intros H1 H2; case H2; auto with zarith) ].
rewrite E; unfold Fmult, Fminus, Fopp, Fplus in |- *; simpl in |- *; auto.
repeat rewrite Zmin_n_n; repeat rewrite <- Zminus_diag_reverse; auto.
simpl in |- *; repeat rewrite Zpower_nat_O; repeat rewrite Zmult_1_r.
unfold FtoRradix, FtoR in |- *; simpl in |- *.
intros H'3;
 (cut (m <= Fnum p * Fnum q)%Z;
   [ idtac
   | apply le_IZR;
      apply Rmult_le_reg_l with (r := powerRZ radix (Fexp p + Fexp q));
      auto with real zarith;
      repeat rewrite (Rmult_comm (powerRZ radix (Fexp p + Fexp q)));
      auto with zarith ]); intros H'4.
repeat split; simpl in |- *; auto.
case (ZquotientProp (Fnum p * Fnum q) (Zpower_nat radix precision));
 auto with zarith.
intros x (H'5, (H'6, H'7)).
cut
 (Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision) *
  powerRZ radix (precision + (Fexp p + Fexp q)) <= fmin)%R;
 [ rewrite E; intros H'8 | idtac ].
cut
 (Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision) *
  powerRZ radix precision <= m)%R; [ intros H'9 | idtac ].
rewrite Zabs_eq; auto with zarith.
apply Zle_lt_trans with x; auto.
replace x with
 (Fnum p * Fnum q +
  -
  (Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision) *
   Zpower_nat radix precision))%Z.
apply Zplus_le_compat_l; auto.
apply Zle_Zopp.
apply le_IZR; auto.
rewrite Rmult_IZR.
rewrite Zpower_nat_Z_powerRZ; auto with zarith.
pattern (Fnum p * Fnum q)%Z at 1 in |- *; rewrite H'5; ring.
rewrite pGivesBound.
rewrite <- (Zabs_eq (Zpower_nat radix precision)); auto with zarith.
apply Zlt_Zabs_inv2; auto.
apply Rmult_le_reg_l with (r := powerRZ radix (Fexp p + Fexp q));
 auto with real zarith.
repeat rewrite (Rmult_comm (powerRZ radix (Fexp p + Fexp q))); auto.
rewrite Rmult_assoc; rewrite <- powerRZ_add; auto with real zarith.
case
 (FboundedMbound _ radixMoreThanOne b precision)
  with
    (z := (precision + (Fexp p + Fexp q))%Z)
    (m := Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision));
 auto with zarith.
apply Zmult_le_reg_r with (p := Zpower_nat radix precision); auto with zarith.
apply Zlt_gt; auto with zarith.
pattern (Zpower_nat radix precision) at 2 in |- *;
 rewrite <- (fun x => Zabs_eq (Zpower_nat radix x)).
rewrite <- Zabs_Zmult.
apply Zle_trans with (1 := H'6); auto with zarith.
rewrite Zabs_Zmult.
apply Zle_trans with (Zpower_nat radix precision * Zabs (Fnum q))%Z.
apply Zle_Zmult_comp_r; auto with zarith.
apply Zlt_le_weak; rewrite <- pGivesBound; case Fp; auto with float.
apply Zle_Zmult_comp_l; auto with zarith.
apply Zlt_le_weak; rewrite <- pGivesBound; case Fq; auto with float.
auto with zarith.
intros x0 (H'8, H'9); rewrite <- H'9.
case H'2.
intros H'10 (H'11, H'12); apply H'12; auto.
rewrite H'9; auto.
rewrite powerRZ_add; auto with real zarith.
rewrite <- Rmult_assoc.
unfold FtoRradix in |- *; rewrite <- Fmult_correct; auto with zarith.
unfold Fmult, FtoR in |- *; simpl in |- *.
repeat rewrite (fun x => Rmult_comm x (powerRZ radix (Fexp p + Fexp q))).
apply Rmult_le_compat_l; auto with real zarith.
rewrite <- Zpower_nat_Z_powerRZ; auto with zarith.
pattern (Fnum p * Fnum q)%Z at 2 in |- *;
 rewrite <- (Zabs_eq (Fnum p * Fnum q)); auto.
rewrite <- Rmult_IZR; apply Rle_IZR; apply Zle_Zabs_inv2; auto.
simpl in |- *; auto.
apply Zmin_n_n; auto.
Qed.

Theorem errorBoundedMultMax :
 forall p q fmax : float,
 Fbounded b p ->
 Fbounded b q ->
 (0 <= p)%R ->
 (0 <= q)%R ->
 (- dExp b <= Fexp p + Fexp q)%Z ->
 isMax b radix (p * q) fmax ->
 exists r : float,
   FtoRradix r = (p * q - fmax)%R /\
   Fbounded b r /\ Fexp r = (Fexp p + Fexp q)%Z.
intros p q fmax Fp Fq H' H'0 H'1 H'2.
cut (0 <= Fnum p * Fnum q)%Z;
 [ intros multPos
 | apply Zle_mult_gen; apply (LeR0Fnum radix); auto with arith ].
case (ZquotientProp (Fnum p * Fnum q) (Zpower_nat radix precision));
 auto with zarith.
intros r; intros (H'3, (H'4, H'5)).
cut (0 <= Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision))%Z;
 [ intros Z2 | apply ZquotientPos; auto with zarith ].
cut (0 <= r)%Z;
 [ intros Z3
 | replace r with
    (Fnum p * Fnum q -
     Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision) *
     Zpower_nat radix precision)%Z;
    [ idtac | pattern (Fnum p * Fnum q)%Z at 1 in |- *; rewrite H'3; ring ];
    auto ].
2: apply Zle_Zminus_ZERO; rewrite Zabs_eq in H'4; auto with zarith;
    rewrite Zabs_eq in H'4; auto with zarith.
case (Z_eq_dec r 0); intros Z4.
exists (Fzero (Fexp p + Fexp q)); repeat (split; auto with float).
replace (FtoRradix (Fzero (Fexp p + Fexp q))) with 0%R;
 [ idtac | unfold Fzero, FtoRradix, FtoR in |- *; simpl in |- *; ring ].
apply Rplus_eq_reg_l with (r := FtoRradix fmax).
replace (fmax + 0)%R with (FtoRradix fmax); [ idtac | ring ].
replace (fmax + (p * q - fmax))%R with (p * q)%R; [ idtac | ring ].
unfold FtoRradix in |- *; rewrite <- (Fmult_correct radix); auto with zarith.
case
 (FboundedMbound _ radixMoreThanOne b precision)
  with
    (z := (precision + (Fexp p + Fexp q))%Z)
    (m := Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision));
 auto with zarith.
apply Zmult_le_reg_r with (p := Zpower_nat radix precision); auto with zarith.
apply Zlt_gt; auto with zarith.
pattern (Zpower_nat radix precision) at 2 in |- *;
 rewrite <- (fun x => Zabs_eq (Zpower_nat radix x)).
rewrite <- Zabs_Zmult.
apply Zle_trans with (1 := H'4); auto with zarith.
rewrite Zabs_Zmult.
apply Zle_trans with (Zpower_nat radix precision * Zabs (Fnum q))%Z.
apply Zle_Zmult_comp_r; auto with zarith.
apply Zlt_le_weak; rewrite <- pGivesBound; case Fp; auto with float.
apply Zle_Zmult_comp_l; auto with zarith.
apply Zlt_le_weak; rewrite <- pGivesBound; case Fq; auto with float.
auto with zarith.
intros x (H'6, H'7).
cut (FtoR radix (Fmult p q) = FtoR radix x).
intros H'8; rewrite H'8.
apply sym_eq; apply (ProjectMax b radix); auto.
rewrite <- H'8; auto.
rewrite Fmult_correct; auto with zarith.
rewrite H'7.
unfold FtoRradix, FtoR in |- *; simpl in |- *.
rewrite powerRZ_add with (n := Z_of_nat precision); auto with real zarith.
pattern (Fnum p * Fnum q)%Z at 1 in |- *; rewrite H'3.
rewrite plus_IZR; rewrite Rmult_IZR.
repeat rewrite Zpower_nat_Z_powerRZ; auto with real zarith.
rewrite Z4; simpl;ring.
cut (ex (fun m : Z => FtoRradix fmax = Float m (Fexp (Fmult p q))));
 [ intros Z5 | idtac ].
2: unfold FtoRradix in |- *;
    apply
     RoundedModeRep
      with (b := b) (precision := precision) (P := isMax b radix);
    auto.
2: apply MaxRoundedModeP with (precision := precision); auto.
2: rewrite (Fmult_correct radix); auto with zarith.
elim Z5; intros m E; clear Z5.
exists (Fopp (Fminus radix (Float m (Fexp (Fmult p q))) (Fmult p q))).
split.
rewrite E; unfold FtoRradix in |- *; repeat rewrite Fopp_correct;
 repeat rewrite Fminus_correct; repeat rewrite Fmult_correct;
 auto with zarith; ring.
cut
 (Fexp (Fopp (Fminus radix (Float m (Fexp (Fmult p q))) (Fmult p q))) =
  (Fexp p + Fexp q)%Z); [ intros Z5 | idtac ].
split; auto.
split; [ idtac | rewrite Z5; auto ].
cut (Fmult p q <= fmax)%R;
 [ idtac
 | unfold FtoRradix in |- *; rewrite Fmult_correct; auto; case H'2;
    auto with real zarith; (intros H1 H2; case H2; auto) ].
cut
 (fmax <=
  Zsucc (Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision)) *
  powerRZ radix (precision + (Fexp p + Fexp q)))%R.
rewrite E; repeat rewrite Zmin_n_n; repeat rewrite <- Zminus_diag_reverse;
 repeat rewrite Zpower_nat_O; repeat rewrite Zmult_1_r;
 auto.
unfold Fmult, Fminus, Fplus, Fopp in |- *; simpl in |- *.
repeat rewrite Zmin_n_n; repeat rewrite <- Zminus_diag_reverse;
 repeat rewrite Zpower_nat_O; repeat rewrite Zmult_1_r;
 auto.
intros H1 H2; rewrite Zabs_Zopp; apply Zlt_Zabs_intro.
apply Zlt_le_trans with 0%Z; auto with zarith.
cut (Fnum p * Fnum q <= m)%Z; auto with zarith.
apply le_IZR;
 apply (Rle_monotony_contra_exp radix) with (z := (Fexp p + Fexp q)%Z);
 auto with zarith.
cut
 (m <=
  Zsucc (Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision)) *
  Zpower_nat radix precision)%Z; [ intros H'9 | idtac ].
apply Zle_lt_trans with (Zpower_nat radix precision - r)%Z;
 [ idtac | rewrite pGivesBound; auto with zarith ].
replace r with
 (Fnum p * Fnum q -
  Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision) *
  Zpower_nat radix precision)%Z.
replace
 (Zpower_nat radix precision -
  (Fnum p * Fnum q -
   Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision) *
   Zpower_nat radix precision))%Z with
 (Zsucc (Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision)) *
  Zpower_nat radix precision - Fnum p * Fnum q)%Z;
 auto with zarith.
unfold Zsucc in |- *; simpl in |- *; ring.
pattern (Fnum p * Fnum q)%Z at 1 in |- *; rewrite H'3; ring.
apply le_IZR;
 apply (Rle_monotony_contra_exp radix) with (z := (Fexp p + Fexp q)%Z);
 auto with zarith.
replace
 (IZR
    (Zsucc (Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision)) *
     Zpower_nat radix precision) * powerRZ radix (Fexp p + Fexp q))%R with
 (Zsucc (Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision)) *
  powerRZ radix (precision + (Fexp p + Fexp q)))%R;
 [ auto | idtac ].
rewrite powerRZ_add; auto with real zarith.
repeat rewrite Rmult_IZR; repeat rewrite Zpower_nat_Z_powerRZ; auto with zarith.
ring.
case
 (FboundedMbound _ radixMoreThanOne b precision)
  with
    (z := (precision + (Fexp p + Fexp q))%Z)
    (m := Zsucc (Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision)));
 auto with arith.
rewrite Zabs_eq; auto with zarith.
apply Zlt_le_succ.
case (Zle_lt_or_eq _ _ multPos); intros Eq1.
cut (0 < Zabs (Fnum p))%Z; [ intros Eq2 | idtac ].
cut (0 < Zabs (Fnum q))%Z; [ intros Eq3 | idtac ].
apply Zlt_mult_simpl_l with (c := Zpower_nat radix precision);
 auto with zarith.
rewrite (fun x y z => Zmult_comm x (Zquotient y z)).
apply Zle_lt_trans with (Fnum p * Fnum q)%Z.
rewrite Zabs_eq in H'4; auto with zarith; rewrite Zabs_eq in H'4;
 auto with zarith.
rewrite <- (Zabs_eq (Fnum p * Fnum q)); auto with zarith; rewrite Zabs_Zmult.
apply Zlt_trans with (Zabs (Fnum p) * Zpower_nat radix precision)%Z.
cut (Zabs (Fnum q) < Zpower_nat radix precision)%Z;
 [ intros Eq4; apply Zmult_gt_0_lt_compat_l
 | rewrite <- pGivesBound; case Fq ]; auto with zarith.
cut (Zabs (Fnum p) < Zpower_nat radix precision)%Z;
 [ intros Eq4; apply Zmult_gt_0_lt_compat_r
 | rewrite <- pGivesBound; case Fp ]; auto with zarith.
case (Zle_lt_or_eq _ _ (Zle_ZERO_Zabs (Fnum q))); auto.
intros Eq3; Contradict Eq1; replace (Fnum q) with 0%Z; auto with zarith.
generalize Eq3; case (Fnum q); simpl in |- *; auto; intros; discriminate.
case (Zle_lt_or_eq _ _ (Zle_ZERO_Zabs (Fnum p))); auto.
intros Eq3; Contradict Eq1; replace (Fnum p) with 0%Z; auto with zarith.
generalize Eq3; case (Fnum p); simpl in |- *; auto; intros; discriminate.
rewrite <- Eq1; replace (Zquotient 0 (Zpower_nat radix precision)) with 0%Z;
 auto with zarith.
apply Zle_trans with (1 := H'1); auto with zarith.
intros f1 (Hf1, Hf2); rewrite <- Hf2.
case H'2; intros L1 (L2, L3); apply L3; auto.
rewrite Hf2; unfold Fmult, FtoRradix, FtoR in |- *.
replace
 (Fnum p * powerRZ radix (Fexp p) * (Fnum q * powerRZ radix (Fexp q)))%R with
 (Fnum p * Fnum q * powerRZ radix (Fexp p + Fexp q))%R.
replace
 (Zsucc (Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision)) *
  powerRZ radix (precision + (Fexp p + Fexp q)))%R with
 ((Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision) *
   Zpower_nat radix precision + Zpower_nat radix precision)%Z *
  powerRZ radix (Fexp p + Fexp q))%R.
apply Rle_monotone_exp; auto with real zarith.
rewrite <- Rmult_IZR; apply Rle_IZR.
pattern (Fnum p * Fnum q)%Z at 1 in |- *; rewrite H'3;
 cut (r < Zpower_nat radix precision)%Z; auto with zarith.
rewrite Zabs_eq in H'5; auto with zarith; rewrite Zabs_eq in H'5;
 auto with zarith.
unfold Zsucc in |- *; repeat rewrite Rmult_IZR || rewrite plus_IZR;
 simpl in |- *.
rewrite (powerRZ_add radix precision); auto with real zarith;
 rewrite <- (Zpower_nat_Z_powerRZ radix precision); auto with real zarith;
 ring.
rewrite powerRZ_add; auto with real zarith; ring.
unfold Fopp, Fminus, Fmult in |- *; simpl in |- *; auto.
apply Zmin_n_n.
Qed.

Theorem multExpMin :
 forall P,
 RoundedModeP b radix P ->
 forall p q pq : float,
 P (p * q)%R pq ->
 exists s : float,
   Fbounded b s /\ s = pq :>R /\ (Fexp p + Fexp q <= Fexp s)%Z.
intros P H' p q pq H'0.
case
 (RoundedModeRep b radix precision) with (p := Fmult p q) (q := pq) (P := P);
 auto with zarith.
rewrite Fmult_correct; auto with zarith.
simpl in |- *; intros x H'1.
case
 (eqExpLess _ radixMoreThanOne b)
  with (p := pq) (q := Float x (Fexp (Fmult p q)));
 auto.
apply RoundedModeBounded with (radix := radix) (P := P) (r := (p * q)%R);
 auto.
simpl in |- *; intros x0 H'2; elim H'2; intros H'3 H'4; elim H'4;
 intros H'5 H'6; clear H'4 H'2.
exists x0; split; [ idtac | split ]; auto.
unfold FtoRradix in |- *; rewrite H'5; auto.
apply le_IZR; auto.
Qed.

Theorem multExpUpperBound :
 forall P,
 RoundedModeP b radix P ->
 forall p q pq : float,
 P (p * q)%R pq ->
 Fbounded b p ->
 Fbounded b q ->
 (- dExp b <= Fexp p + Fexp q)%Z ->
 exists r : float,
   Fbounded b r /\ r = pq :>R /\ (Fexp r <= precision + (Fexp p + Fexp q))%Z.
intros P H' p q pq H'0 H'1 H'2 H'3.
replace (precision + (Fexp p + Fexp q))%Z with
 (Fexp (Float (pPred (vNum b)) (precision + (Fexp p + Fexp q))));
 [ idtac | simpl in |- *; auto ].
unfold FtoRradix in |- *; apply eqExpMax; auto.
apply RoundedModeBounded with (radix := radix) (P := P) (r := (p * q)%R);
 auto; auto.
unfold pPred in |- *; apply maxFbounded; auto.
apply Zle_trans with (1 := H'3); auto with zarith.
replace (FtoR radix (Float (pPred (vNum b)) (precision + (Fexp p + Fexp q))))
 with (radix * Float (pPred (vNum b)) (pred precision + (Fexp p + Fexp q)))%R.
rewrite Fabs_correct; auto with zarith.
unfold FtoRradix in |- *;
 apply
  RoundedModeMultAbs
   with (b := b) (precision := precision) (P := P) (r := (p * q)%R);
 auto.
unfold pPred in |- *; apply maxFbounded; auto with zarith.
rewrite Rabs_mult; auto.
apply
 Rle_trans
  with
    (FtoR radix
       (Fmult (Float (pPred (vNum b)) (Fexp p))
          (Float (pPred (vNum b)) (Fexp q)))).
rewrite Fmult_correct; auto with arith.
apply Rmult_le_compat; auto with real.
rewrite <- (Fabs_correct radix); try apply maxMax1; auto with zarith.
rewrite <- (Fabs_correct radix); try apply maxMax1; auto with zarith.
unfold Fmult, FtoR in |- *; simpl in |- *; auto.
rewrite powerRZ_add with (n := Z_of_nat (pred precision));
 auto with real arith.
repeat rewrite <- Rmult_assoc.
repeat rewrite (fun (z : Z) (x : R) => Rmult_comm x (powerRZ radix z));
 auto.
apply Rmult_le_compat_l; auto with real arith.
rewrite <- Rmult_assoc.
rewrite (fun x : R => Rmult_comm x radix).
rewrite <- powerRZ_Zs; auto with real arith.
replace (Zsucc (pred precision)) with (Z_of_nat precision).
rewrite Rmult_IZR; auto.
apply Rmult_le_compat; auto with real arith.
replace 0%R with (IZR 0); unfold pPred in |- *; try apply Rle_IZR;
 auto with real zarith.
replace 0%R with (IZR 0); unfold pPred in |- *; try apply Rle_IZR;
 auto with real zarith.
unfold pPred in |- *; rewrite pGivesBound; rewrite <- Zpower_nat_Z_powerRZ;
 auto with real zarith.
rewrite inj_pred; auto with arith zarith.
auto with real zarith.
auto with real zarith.
unfold FtoRradix, FtoR in |- *; simpl in |- *.
repeat rewrite (Rmult_comm (pPred (vNum b))).
rewrite <- Rmult_assoc.
rewrite <- powerRZ_Zs; auto with real zarith.
rewrite inj_pred; auto with arith zarith.
replace (Zsucc (Zpred precision + (Fexp p + Fexp q))) with
 (precision + (Fexp p + Fexp q))%Z; auto; unfold Zsucc, Zpred in |- *;
 ring.
Qed.

Theorem errorBoundedMultPos :
 forall P,
 RoundedModeP b radix P ->
 forall p q f : float,
 Fbounded b p ->
 Fbounded b q ->
 (0 <= p)%R ->
 (0 <= q)%R ->
 (- dExp b <= Fexp p + Fexp q)%Z ->
 P (p * q)%R f ->
 exists r : float,
   r = (p * q - f)%R :>R /\ Fbounded b r /\ Fexp r = (Fexp p + Fexp q)%Z.
intros P H p q f H0 H1 H2 H3 H4 H5.
generalize errorBoundedMultMin errorBoundedMultMax; intros H6 H7.
cut (MinOrMaxP b radix P);
 [ intros | case H; intros H'1 (H'2, (H'3, H'4)); auto ].
case (H8 (p * q)%R f); auto.
Qed.

Theorem errorBoundedMultNeg :
 forall P,
 RoundedModeP b radix P ->
 forall p q f : float,
 Fbounded b p ->
 Fbounded b q ->
 (p <= 0)%R ->
 (0 <= q)%R ->
 (- dExp b <= Fexp p + Fexp q)%Z ->
 P (p * q)%R f ->
 exists r : float,
   r = (p * q - f)%R :>R /\ Fbounded b r /\ Fexp r = (Fexp p + Fexp q)%Z.
intros P H p q f H0 H1 H2 H3 H4 H5.
generalize errorBoundedMultMin errorBoundedMultMax; intros H6 H7.
cut (MinOrMaxP b radix P);
 [ intros | case H; intros H'1 (H'2, (H'3, H'4)); auto ].
case (H8 (p * q)%R f); auto; intros H9.
generalize (H7 (Fopp p) q (Fopp f)); intros H12.
lapply H12; auto with float; intros H10; clear H12.
lapply H10; auto; intros H12; clear H10.
lapply H12;
 [ intros H10
 | unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real ];
 clear H12.
lapply H10; auto; intros H12; clear H10.
lapply H12; [ intros H10 | simpl in |- *; auto ]; clear H12.
lapply H10; [ intros H12 | idtac ]; clear H10.
2: replace (Fopp p * q)%R with (- (p * q))%R;
    [ apply MinOppMax; auto | idtac ].
2: unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real.
elim H12; intros r H10; clear H12; elim H10; intros H11 H12; clear H10.
elim H12; clear H12; intros H10 H12.
exists (Fopp r); split; [ generalize H11 | split; auto with float ].
unfold FtoRradix in |- *; repeat rewrite Fopp_correct; intros H13;
 rewrite H13; ring.
generalize (H6 (Fopp p) q (Fopp f)); intros H12.
lapply H12; auto with float; intros H10; clear H12.
lapply H10; auto; intros H12; clear H10.
lapply H12;
 [ intros H10
 | unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real ];
 clear H12.
lapply H10; auto; intros H12; clear H10.
lapply H12; [ intros H10 | simpl in |- *; auto ]; clear H12.
lapply H10; [ intros H12 | idtac ]; clear H10.
2: replace (Fopp p * q)%R with (- (p * q))%R;
    [ apply MaxOppMin; auto | idtac ].
2: unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real.
elim H12; intros r H10; clear H12; elim H10; intros H11 H12; clear H10.
elim H12; clear H12; intros H10 H12.
exists (Fopp r); split; [ generalize H11 | split; auto with float ].
unfold FtoRradix in |- *; repeat rewrite Fopp_correct; intros H13;
 rewrite H13; ring.
Qed.

Theorem errorBoundedMult :
 forall P,
 RoundedModeP b radix P ->
 forall p q f : float,
 Fbounded b p ->
 Fbounded b q ->
 (- dExp b <= Fexp p + Fexp q)%Z ->
 P (p * q)%R f ->
 exists r : float,
   r = (p * q - f)%R :>R /\ Fbounded b r /\ Fexp r = (Fexp p + Fexp q)%Z.
intros P H p q f H0 H1 H2 H3.
case (Rle_or_lt 0 p); intros H4; case (Rle_or_lt 0 q); intros H5.
apply errorBoundedMultPos with P; auto.
replace (Fexp p) with (Fexp (Fopp p)); auto with float.
replace (Fexp q) with (Fexp (Fopp q)); auto with float.
cut ((p * q)%R = (Fopp p * Fopp q)%R); [ intros H6; rewrite H6 | idtac ].
apply errorBoundedMultNeg with P; auto with float real.
unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real.
unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real.
rewrite <- H6; auto.
unfold FtoRradix in |- *; repeat rewrite Fopp_correct; ring.
apply errorBoundedMultNeg with P; auto with float real.
replace (Fexp p) with (Fexp (Fopp p)); auto with float.
replace (Fexp q) with (Fexp (Fopp q)); auto with float.
cut ((p * q)%R = (Fopp p * Fopp q)%R); [ intros H6; rewrite H6 | idtac ].
apply errorBoundedMultPos with P; auto with float real.
unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real.
unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real.
rewrite <- H6; auto.
unfold FtoRradix in |- *; repeat rewrite Fopp_correct; ring.
Qed.

Theorem errorBoundedMultExp_aux :
 forall n1 n2 : Z,
 (Zabs n1 < Zpos (vNum b))%Z ->
 (Zabs n2 < Zpos (vNum b))%Z ->
 (exists ny : Z,
    (exists ey : Z,
       (n1 * n2)%R = (ny * powerRZ radix ey)%R :>R /\
       (Zabs ny < Zpos (vNum b))%Z)) ->
 exists nx : Z,
   (exists ex : Z,
      (n1 * n2)%R = (nx * powerRZ radix ex)%R :>R /\
      (Zabs nx < Zpos (vNum b))%Z /\
      (0 <= ex)%Z /\ (ex <= precision)%Z).
intros n1 n2 H H0 H1.
case H1; intros ny (ey, (H2, H3)).
case (Zle_or_lt 0 ey); intros Zl1.
case (Zle_or_lt ey precision); intros Zl2.
exists ny; exists ey; repeat (split; auto).
exists (ny * Zpower_nat radix (Zabs_nat (ey - precision)))%Z;
 exists (Z_of_nat precision); repeat (split; auto with zarith).
replace (IZR (ny * Zpower_nat radix (Zabs_nat (ey - precision)))) with
 (ny * powerRZ radix (ey - precision))%R.
rewrite Rmult_assoc; rewrite <- powerRZ_add; auto with zarith real.
replace (ey - precision + precision)%Z with ey; [ auto | ring ].
rewrite Rmult_IZR.
rewrite Zpower_nat_powerRZ_absolu; auto with real zarith.
rewrite Zabs_Zmult.
apply lt_IZR; apply Rmult_lt_reg_l with (r := powerRZ radix precision);
 auto with real zarith.
repeat rewrite (fun x y => Rmult_comm (powerRZ x y)).
rewrite Rmult_IZR.
rewrite Rmult_assoc.
rewrite (Zabs_eq (Zpower_nat radix (Zabs_nat (ey - precision))));
 auto with zarith.
rewrite Zpower_nat_powerRZ_absolu; auto with real zarith.
rewrite <- powerRZ_add; auto with real zarith.
replace (ey - precision + precision)%Z with ey; [ idtac | ring ].
replace (powerRZ radix precision) with (IZR (Zpos (vNum b)));
 [ idtac
 | rewrite pGivesBound; rewrite <- Zpower_nat_powerRZ_absolu;
    try rewrite absolu_INR; auto with zarith ].
rewrite <- (fun x y => Rabs_pos_eq (powerRZ x y)); auto with real zarith.
rewrite <- Faux.Rabsolu_Zabs; rewrite <- Rabs_mult; rewrite <- H2.
rewrite Rabs_mult; repeat rewrite Faux.Rabsolu_Zabs; auto with real zarith.
case (Zle_lt_or_eq 0 (Zabs n2)); auto with zarith; intros Z1.
apply Rlt_trans with (Zpos (vNum b) * Zabs n2)%R;
 auto with real zarith.
rewrite <- Z1; auto with real zarith.
replace (Zabs n1 * 0%Z)%R with (0 * Zpos (vNum b))%R;
 [ auto with real zarith | simpl; ring ].
exists (n1 * n2)%Z; exists 0%Z; repeat (split; auto with zarith).
rewrite Rmult_IZR; rewrite powerRZ_O; ring.
apply lt_IZR.
rewrite <- Faux.Rabsolu_Zabs; rewrite Rmult_IZR; rewrite H2.
rewrite Rabs_mult.
apply Rle_lt_trans with (Rabs ny).
pattern (Rabs ny) at 2 in |- *; replace (Rabs ny) with (Rabs ny * 1)%R;
 [ apply Rmult_le_compat_l | ring ]; auto with arith real.
rewrite (Rabs_pos_eq (powerRZ radix ey));
 [ idtac | apply powerRZ_le; auto with arith real ].
replace 1%R with (powerRZ radix 0); [ apply Rle_powerRZ | simpl in |- * ];
 auto with real arith zarith.
rewrite Faux.Rabsolu_Zabs; auto with real zarith.
Qed.

Theorem errorBoundedMultExpPos :
 forall P,
 RoundedModeP b radix P ->
 forall p q pq : float,
 Fbounded b p ->
 Fbounded b q ->
 (0 <= p)%R ->
 (0 <= q)%R ->
 P (p * q)%R pq ->
 (- dExp b <= Fexp p + Fexp q)%Z ->
 ex
   (fun r : float =>
    ex
      (fun s : float =>
       Fbounded b r /\
       Fbounded b s /\
       r = pq :>R /\
       s = (p * q - r)%R :>R /\
       Fexp s = (Fexp p + Fexp q)%Z :>Z /\
       (Fexp s <= Fexp r)%Z /\ (Fexp r <= precision + (Fexp p + Fexp q))%Z)).
intros P H p q pq H0 H1 H2 H3 H4 H5.
case (multExpUpperBound P H p q pq); auto; intros r (H'1, (H'2, H'3)).
case (Req_dec (p * q - pq) 0); intros H6.
case (Req_dec pq 0); intros H7.
cut (Fbounded b (Fzero (Fexp p + Fexp q))); [ intros Fb1 | idtac ].
exists (Fzero (Fexp p + Fexp q)); exists (Fzero (Fexp p + Fexp q));
 repeat (split; simpl in |- *; auto with zarith).
rewrite H7; unfold FtoRradix in |- *; apply FzeroisReallyZero.
unfold FtoRradix in |- *; rewrite FzeroisReallyZero; rewrite <- H7.
pattern (FtoRradix pq) at 1 in |- *; rewrite H7; auto with real.
repeat (split; auto); simpl in |- *; auto with arith zarith.
case (errorBoundedMultExp_aux (Fnum p) (Fnum q)); auto with float real zarith.
exists (Fnum pq); exists (Fexp pq - (Fexp p + Fexp q))%Z; split.
apply Rmult_eq_reg_l with (powerRZ radix (Fexp p + Fexp q));
 auto with real zarith.
repeat rewrite (fun x y => Rmult_comm (powerRZ x y)).
apply trans_eq with (p * q)%R; auto.
rewrite <- (Fmult_correct radix); auto with real zarith;
 unfold FtoRradix, FtoR, Fmult in |- *; simpl in |- *;
 rewrite Rmult_IZR; auto.
apply trans_eq with (FtoRradix pq); auto with real.
rewrite Rmult_assoc; rewrite <- powerRZ_add; auto with real zarith.
replace (Fexp pq - (Fexp p + Fexp q) + (Fexp p + Fexp q))%Z with (Fexp pq);
 auto; ring.
cut (Fbounded b pq); [ intros Z1; case Z1 | idtac ]; auto with real zarith.
apply (RoundedModeBounded b radix P (p * q)); auto.
intros nx (ex, (H'4, (H'5, (H'6, H'7)))).
cut (FtoRradix pq = FtoRradix (Float nx (ex + (Fexp p + Fexp q))) :>R);
 [ intros Eq1 | idtac ].
exists (Float nx (ex + (Fexp p + Fexp q))); exists (Fzero (Fexp p + Fexp q));
 repeat (split; simpl in |- *; auto with real zarith).
rewrite <- Eq1; rewrite H6; apply (FzeroisReallyZero radix).
replace (FtoRradix pq) with (p * q)%R.
unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *.
rewrite powerRZ_add; auto with zarith real.
repeat rewrite <- Rmult_assoc; rewrite <- H'4; rewrite powerRZ_add;
 [ ring | auto with zarith real ].
replace (FtoRradix p * FtoRradix q)%R with
 (pq + (FtoRradix p * FtoRradix q - FtoRradix pq))%R;
 [ rewrite H6 | idtac ]; ring.
case (errorBoundedMultPos P H p q pq); auto.
intros s (H'4, (H'5, H'6)).
exists r; exists s; repeat (split; auto with zarith).
rewrite H'2; auto.
apply Zlt_le_weak;
 apply RoundedModeErrorExpStrict with b radix precision P (p * q)%R;
 auto.
cut (CompatibleP b radix P);
 [ intros H'7 | case H; try intros H'7 (H'8, (H'9, H'10)); auto ].
apply H'7 with (p * q)%R pq; auto with real.
fold FtoRradix in |- *; rewrite H'2; auto with real.
fold FtoRradix in |- *; rewrite H'4; auto with real.
Qed.

Theorem errorBoundedMultExp :
 forall P, (RoundedModeP b radix P) ->
 forall p q pq : float,
  (Fbounded b p) -> (Fbounded b q) ->
  (P (p * q)%R pq) ->
   (-(dExp b) <= Fexp p + Fexp q)%Z ->
   exists r : float,
   exists s : float,
      (Fbounded b r) /\ (Fbounded b s) /\
       r = pq :>R /\ s = (p * q - r)%R :>R /\
       (Fexp s =  Fexp p + Fexp q)%Z /\
       (Fexp s <= Fexp r)%Z /\
       (Fexp r <= precision + (Fexp p + Fexp q))%Z.
intros P H p q pq H1 H2 H3 H4.
cut (MinOrMaxP b radix P);
 [ intros | case H; intros H'1 (H'2, (H'3, H'4)); auto ].
case H0 with (p*q)%R pq; auto; intros H0'; clear H0.
case (Rle_or_lt 0 p); intros Rl1.
case (Rle_or_lt 0 q); intros Rl2.
apply (errorBoundedMultExpPos P); auto.
case errorBoundedMultExpPos with (isMax b radix) p (Fopp q) (Fopp pq); auto with float real.
apply MaxRoundedModeP with precision; auto.
rewrite (Fopp_correct radix); auto with real.
replace (FtoRradix p * FtoRradix (Fopp q))%R with
 (- (FtoRradix p * FtoRradix q))%R; [apply MinOppMax;auto|idtac].
rewrite (Fopp_correct radix);
 fold FtoRradix in |- *; auto with zarith; ring.
intros r (s, (H5, (H6, (H7, (H8, H9))))); exists (Fopp r); exists (Fopp s);
 repeat (split; simpl in |- *; auto with float real zarith).
repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix in |- *;
 rewrite H7; repeat rewrite (Fopp_correct radix); auto with zarith;
 fold FtoRradix; ring.
repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix in |- *;
 rewrite H8; repeat rewrite (Fopp_correct radix); auto with zarith;
 fold FtoRradix; ring.
case (Rle_or_lt 0 q); intros Rl2.
case errorBoundedMultExpPos with (isMax b radix) (Fopp p) q (Fopp pq); auto with float real.
apply MaxRoundedModeP with precision; auto.
rewrite (Fopp_correct radix); auto with real.
replace (FtoRradix (Fopp p) * FtoRradix q)%R with
 (- (FtoRradix p * FtoRradix q))%R; [apply MinOppMax;auto|idtac].
rewrite (Fopp_correct radix);
 fold FtoRradix in |- *; auto with zarith; ring.
intros r (s, (H5, (H6, (H7, (H8, H9))))); exists (Fopp r); exists (Fopp s);
 repeat (split; simpl in |- *; auto with float real zarith).
repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix in |- *;
 rewrite H7; repeat rewrite (Fopp_correct radix); auto with zarith;
 fold FtoRradix; ring.
repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix in |- *;
 rewrite H8; repeat rewrite (Fopp_correct radix); auto with zarith;
 fold FtoRradix;ring.
case (errorBoundedMultExpPos P H (Fopp p) (Fopp q) pq); auto with float real.
rewrite (Fopp_correct radix); auto with real.
rewrite (Fopp_correct radix); auto with real.
replace (FtoRradix (Fopp p) * FtoRradix (Fopp q))%R with
 (FtoRradix p * FtoRradix q)%R; auto; repeat rewrite (Fopp_correct radix);
 fold FtoRradix in |- *; auto with zarith; ring.
intros r (s, (H5, (H6, (H7, (H8, (H9, (H10, H11))))))); exists r; exists s;
 repeat (split; simpl in |- *; auto with float real zarith).
fold FtoRradix in |- *; rewrite H8; repeat rewrite (Fopp_correct radix);
 auto with zarith; fold FtoRradix; ring.
case (Rle_or_lt 0 p); intros Rl1.
case (Rle_or_lt 0 q); intros Rl2.
apply (errorBoundedMultExpPos P); auto.
case errorBoundedMultExpPos with (isMin b radix) p (Fopp q) (Fopp pq); auto with float real.
apply MinRoundedModeP with precision; auto.
rewrite (Fopp_correct radix); auto with real.
replace (FtoRradix p * FtoRradix (Fopp q))%R with
 (- (FtoRradix p * FtoRradix q))%R; [apply MaxOppMin;auto|idtac].
rewrite (Fopp_correct radix);
 fold FtoRradix in |- *; auto with zarith; ring.
intros r (s, (H5, (H6, (H7, (H8, H9))))); exists (Fopp r); exists (Fopp s);
 repeat (split; simpl in |- *; auto with float real zarith).
repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix in |- *;
 rewrite H7; repeat rewrite (Fopp_correct radix); auto with zarith;
 fold FtoRradix; ring.
repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix in |- *;
 rewrite H8; repeat rewrite (Fopp_correct radix); auto with zarith;
 fold FtoRradix; ring.
case (Rle_or_lt 0 q); intros Rl2.
case errorBoundedMultExpPos with (isMin b radix) (Fopp p) q (Fopp pq); auto with float real.
apply MinRoundedModeP with precision; auto.
rewrite (Fopp_correct radix); auto with real.
replace (FtoRradix (Fopp p) * FtoRradix q)%R with
 (- (FtoRradix p * FtoRradix q))%R; [apply MaxOppMin;auto|idtac].
rewrite (Fopp_correct radix);
 fold FtoRradix in |- *; auto with zarith; ring.
intros r (s, (H5, (H6, (H7, (H8, H9))))); exists (Fopp r); exists (Fopp s);
 repeat (split; simpl in |- *; auto with float real zarith).
repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix in |- *;
 rewrite H7; repeat rewrite (Fopp_correct radix); auto with zarith;
 fold FtoRradix; ring.
repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix in |- *;
 rewrite H8; repeat rewrite (Fopp_correct radix); auto with zarith;
 fold FtoRradix;ring.
case (errorBoundedMultExpPos P H (Fopp p) (Fopp q) pq); auto with float real.
rewrite (Fopp_correct radix); auto with real.
rewrite (Fopp_correct radix); auto with real.
replace (FtoRradix (Fopp p) * FtoRradix (Fopp q))%R with
 (FtoRradix p * FtoRradix q)%R; auto; repeat rewrite (Fopp_correct radix);
 fold FtoRradix in |- *; auto with zarith; ring.
intros r (s, (H5, (H6, (H7, (H8, (H9, (H10, H11))))))); exists r; exists s;
 repeat (split; simpl in |- *; auto with float real zarith).
fold FtoRradix in |- *; rewrite H8; repeat rewrite (Fopp_correct radix);
 auto with zarith; fold FtoRradix; ring.
Qed.

End FRoundP.


Require Import List.
Require Import Peano_dec.
Require Import Div2.
Require Import Arith.
Require Import Program.
Require Import Recdef.
Require Import Omega.

Require Import Lib.Prelude.
Require Import Lib.Pigeonhole.
Require Import Lib.Unique.
Require Import Lib.Partition.
Require Import Lib.Remove.

Lemma necessarily_in (a k : nat) (us : list nat)
   (ListBounds : Forall (fun u => a <= u < k + a) us)
   (L : length us = k) (U : unique_list nat us) : forall y, a <= y < k + a -> In y us.
  Proof.
    intros y Bounds; case (in_dec eq_nat_dec y us).
      now intuition.
      (* If ~ In y us ... *)
      intros Nelem; set (vs := remove eq_nat_dec y (seq a k)).
      (* Derive a contradition using the pigeon hole principle *)
      assert (PH : exists x, occur _ eq_nat_dec x us >= 2).
        apply (pigeon_hole _ eq_nat_dec vs us).
        (* We must show incl us vs ... *)
        assert (incl us (seq a k)) by
          now (intros x V; apply in_seq; apply (Forall_forall (fun u => a <= u < k + a) us)).
        now (apply incl_remove).
        (* And we must show that length us > length vs *)
        assert (Lengths : length vs < length (seq a k)) by
            (subst vs; apply length_remove_element; apply in_seq; omega).
        now (rewrite L; rewrite seq_length in Lengths; omega).
    (* Now derive a contradiction *)
    destruct PH as [x Occurs].
    rewrite unique_in in Occurs;
      [exfalso; omega | assumption | apply (occur_in _ eq_nat_dec)].
      omega.
  Qed.

Lemma missing_element (b : nat) (n : nat) : forall us a,
    length us = n ->
    unique_list nat us ->
    Forall (fun u => a <= u < b) us ->
    length us < b - a ->
    exists x, a <= x < b /\ ~ In x us.
  Proof.
    induction n.
    (* Base case *)
    intros us a L; rewrite (length_zero nat us); [ | assumption].
      now (intros _ _ H; exists a; split; [omega | intros F; exfalso; apply F]).
    (* Cons branch *)
    intros us a L U Bounds L'; case (in_dec eq_nat_dec a us).
      (* If In a us *)
      intros H.
      assert (LR : length (remove eq_nat_dec a us) = n) by
        now (apply eq_add_S; rewrite <- L, (length_remove_unique _ eq_nat_dec a us)).
      destruct (IHn (remove eq_nat_dec a us) (S a)) as [m [B N]].
        now trivial.
        now (apply unique_remove).
        now (apply remove_least).
        now omega.
      destruct (IHn (remove eq_nat_dec a us) (S a)) as [y [Bs Nelem]].
        now trivial.
        now apply (unique_remove _ eq_nat_dec a us).
        now apply (remove_least a b us).
        now omega.
      exists y; split.
        now omega.
        now (intros Elem; apply Nelem; apply remove_distinct; try omega).
      (* If ~ In a us *)
      intros Nelem; exists a; split; [omega | assumption].
  Qed.

Program Fixpoint minfrom (a : nat)
 (xs : {xs' : list nat | unique_list nat xs' /\ Forall (fun x => a <= x) xs'})
 (n : {n' : nat | length xs = n'}) {measure (length xs)} :
 {m : nat | a <= m /\ ~In m xs /\ forall y, a <= y < m -> In y xs}
  := match n with
       | O => a
       | n =>
         let b := S (a + div2 n) in
         match partition _ _ (fun x => lt_dec x b) xs with
           | (us , vs) =>
             let m := length us in
               match lt_eq_lt_dec m (b - a) with
                 | inleft (right eq) => minfrom b vs (n - m)
                 | inleft (left neq) => minfrom a us m
                 | inright neq => !
               end
         end
     end.

  Next Obligation.
    split; constructor.
      now (rewrite (length_zero nat xs)).
      now (intros y H; exfalso; omega).
  Qed.

  Next Obligation.
    change vs with (snd (us,vs)); rewrite Heq_anonymous; split.
      now (apply partition_unique_right).
      now (apply (Forall_impl (P := fun x => ~ x < S (a + div2 (length xs))));
        [intros; omega | apply partition_prop]).
  Defined.

  Next Obligation.
    apply plus_minus.
    change us with (fst (us,vs)); change vs at 2 with (snd (us,vs)).
    now (rewrite Heq_anonymous, partition_length).
  Defined.

  Next Obligation.
    change (match a with 0 => S (a + div2 (length xs))
               | S l => a + div2 (length xs) - l end)
      with (S (a + div2 (length xs)) - a) in eq.
    rewrite <- (partition_length _ _ (fun x => lt_dec x (S (a + div2 (length xs)))) xs),
            <- Heq_anonymous; simpl; rewrite eq; omega.
  Defined.

  Local Obligation Tactic := idtac.

  Next Obligation.
    intros a [xs [U LeA]] [n L] minfrom filtered_var k NonZero.
    intros Heq_n b filtered_var0 us vs Heq_anonymous m filtered_var1 eq Heq_anonymous0.
    subst filtered_var filtered_var0 filtered_var1 m.
    destruct_call minfrom as [x [Lower [Nelem Least]]].
    simpl; simpl in Lower, Nelem, Least; split; [ | split].
      (* Now we need to show a <= x *)
      now (subst b; omega).
      (* ... and ~In x xs *)
      intro F; apply Nelem; change vs with (snd (us,vs)); rewrite Heq_anonymous.
      now (apply in_right_partition; try omega).
      (* ... and forall y, a <= y < x -> In y xs *)
      intros y Bounds; destruct (le_dec b y) as [Le | Gt ].
        (* b <= y *)
        assert (AlsoIn : In y vs -> In y xs) by
          (change vs with (snd (us,vs)); rewrite Heq_anonymous; apply partition_in_right).
        now (apply AlsoIn, Least; omega).
        (* b > y *)
        assert (InUs : In y us).
          (* Assemble the required arguments for necessarily_in ... *)
          assert (H :  Forall (fun u : nat => a <= u < b - a + a) us).
            apply forall_cong; change us with (fst (us,vs)); rewrite Heq_anonymous; split.
              now (apply (forall_partition_left); refine (Forall_impl _ _ LeA)).
              now (apply (Forall_impl (P := fun x => x < S (a + div2 k)));
                [intros; subst b; omega |
                apply (proj1 (partition_prop _ _ (fun x => lt_dec x (S (a + div2 k))) xs))]).
            assert (Uus : unique_list nat us) by
              (change us with (fst (us,vs)); rewrite Heq_anonymous;
                apply (partition_unique_left); assumption).
            assert (B : a <= y < b - a + a) by omega.
            now (apply (necessarily_in a (b - a) us)).
        (* Now we only need to show that In y us -> In y xs *)
        apply (partition_in_left _ _ (fun x => lt_dec x (S (a + div2 k)))).
        now (subst b; simpl in Heq_anonymous; rewrite <- Heq_anonymous).
    Qed.

  Local Obligation Tactic := program_simpl.

  Next Obligation.
    change us with (fst (us,vs)); rewrite Heq_anonymous.
    split; [ apply partition_unique_left | apply forall_partition_left]; assumption.
  Qed.

  Next Obligation.
    change (match a with 0 => S (a + div2 (length xs))
               | S l => a + div2 (length xs) - l end)
      with (S (a + div2 (length xs)) - a) in neq.
    destruct xs as [ | x xs].
      now (exfalso; apply H).
      assert (LT : div2 (length (x :: xs)) < length (x :: xs)) by
        (apply lt_div2; omega).
      now (apply (lt_le_trans _ _ _ neq); omega).
  Defined.

  Local Obligation Tactic := idtac.

  Next Obligation.
    intros a [xs [U LeA]] [n L] minfrom filtered_var k NonZero.
    intros Heq_n b filtered_var0 us vs Heq_anonymous m filtered_var1 eq Heq_anonymous0.
    subst filtered_var filtered_var0 filtered_var1 m.
    destruct_call minfrom as [x [Lower [Nelem Least]]].
    simpl; simpl in Lower, Nelem, Least; split; [ | split].
    (* We need to show a <= x *)
    now assumption.
    (* ... and ~ In x xs *)
    intro Elem; clear minfrom; clear Heq_n.
    destruct (missing_element b (length us) us a) as [z [zBounds zNelem]].
      now (reflexivity).
      now (change us with (fst (us,vs)); rewrite Heq_anonymous; apply partition_unique_left).
      apply forall_cong; split; change us with (fst (us,vs));
        rewrite Heq_anonymous; simpl.
        now (apply forall_partition_left; refine (Forall_impl _ _ LeA)).
      now (apply (proj1 (partition_prop _ _ _ _))).
      now omega.
    assert (B : ~ (x < b)).
      intros F; apply Nelem.
      now (change us with (fst (us,vs)); rewrite Heq_anonymous; apply (in_left_partition)).
      now (apply zNelem, Least; omega).
  (* ... and forall y, a <= y < x -> In y xs *)
  intros y Bounds; cut (In y us); [ idtac | apply Least; assumption].
    now (change us with (fst (us,vs)); rewrite Heq_anonymous; apply partition_in_left).
  Qed.

  Local Obligation Tactic := program_simpl.

  Next Obligation.
    change (match a with 0 => S (a + div2 (length xs))
               | S l => a + div2 (length xs) - l end)
      with (S (a + div2 (length xs)) - a) in neq.
    (* There must be an element of the list that occurs more than once ... *)
    assert (PH : exists x, occur _ eq_nat_dec x us >= 2).
    apply (pigeon_hole _ eq_nat_dec (seq a (S (a + div2 (length xs)) - a))).
      (* Proof that us is included in the sequence [a ... a + b] *)
      intros x Elem.
      (* by proving that any inhabitant of us lies between a and a + b *)
      apply in_seq; split.
        (* a <= x for all x in us *)
        apply (proj1 (Forall_forall (fun x => a <= x) us)); try assumption.
          change us with (fst (us,vs)); rewrite Heq_anonymous.
          now (apply forall_partition_left).
        (* x < S (a + b) for x in us *)
        assert (Lt : Forall (fun x => x < (S (a + div2 (length xs)))) us).
          now (change us with (fst (us,vs)); rewrite Heq_anonymous; apply partition_prop).
        replace (S (a + div2 (length xs)) - a + a) with
          (S (a + div2 (length xs))) by omega.
        now (apply (proj1 (Forall_forall (fun x => x < S (a + div2 (length xs))) us))).
    (* Proof that length us > legnth [a .. a + b] *)
    now (rewrite seq_length; omega).
    (* Derive a contradiction from the assumption that x contains unique values *)
    assert (U : unique_list nat us) by
      now (change us with (fst (us,vs)); rewrite Heq_anonymous; apply partition_unique_left).
    destruct PH as [x OccursTwice].
    rewrite unique_in in OccursTwice.
      now omega.
      now assumption.
      now (apply (occur_in _ eq_nat_dec); omega).
  Defined.

Program Definition minfree (xs : {xs' : list nat | unique_list nat xs'}) :
  {m : nat | ~In m xs /\ forall y, y < m -> In y xs}
  := minfrom 0 xs (length xs).

Local Obligation Tactic := idtac.

Next Obligation.
  intros [xs U]; split; [assumption | ].
  induction xs.
    now (constructor).
    now (simpl in *; destruct U as [Hd Tl]; constructor; [omega | apply IHxs]).
  Defined.

Next Obligation.
  trivial.
  Defined.

Next Obligation.
  intros [xs U]; destruct_call minfrom as [m [A [B C]]]; simpl in *.
  split; [assumption | intros; apply C; split; omega].
  Defined.


(******************************************************************)
(* Mergesort (subset types) *)

From sortalgs Require Import sorted.

Open Scope list_scope.
Import List.ListNotations.

Require Import Lia.
Require Import Program.

Lemma lem_sorted_concat_1 `{DecTotalOrder} :
  forall l l1 l2 x y,
    Permutation l (l1 ++ y :: l2) -> Sorted (x :: l1) -> leb x y ->
    Sorted (y :: l2) -> Sorted l -> Sorted (x :: l).
Proof.
  intros.
  rewrite lem_lelst_sorted in *.
  sauto db: lelst inv: -.
Qed.

Lemma lem_sorted_concat_2 `{DecTotalOrder} :
  forall l l1 l2 x y,
    Permutation l (x :: l1 ++ l2) -> Sorted (x :: l1) -> leb y x ->
    Sorted (y :: l2) -> Sorted l -> Sorted (y :: l).
Proof.
  intros.
  rewrite lem_lelst_sorted in *.
  sauto db: lelst inv: -.
Qed.

Program Fixpoint merge `{DecTotalOrder}
  (l1 l2 : {l | Sorted l}) {measure (length l1 + length l2)} :
  {l | Sorted l /\ Permutation l (l1 ++ l2)} :=
  match l1 with
  | [] => l2
  | h1 :: t1 =>
    match l2 with
    | [] => l1
    | h2 :: t2 =>
      if leb_total_dec h1 h2 then
        h1 :: merge t1 l2
      else
        h2 :: merge l1 t2
    end
  end.
Next Obligation.
  sauto db: list.
Qed.
Next Obligation.
  eauto using lem_sorted_tail.
Qed.
Next Obligation.
  sauto use: lem_sorted_concat_1.
Qed.
Next Obligation.
  eauto using lem_sorted_tail.
Qed.
Next Obligation.
  simpl; lia.
Qed.
Next Obligation.
  split.
  - sauto use: lem_sorted_concat_2.
  - simpl_sigma.
    rewrite List.app_comm_cons.
    apply Permutation_cons_app.
    intuition.
Qed.

Program Fixpoint split {A} (l : list A) {measure (length l)} :
  { (l1, l2) : list A * list A |
    length l1 <= length l2 + 1 /\ length l2 <= length l1 + 1 /\
    Permutation l (l1 ++ l2) } :=
  match l with
  | [] => ([], [])
  | [x] => ([x], [])
  | x :: y :: t =>
    match split t with
    | (l1, l2) => (x :: l1, y :: l2)
    end
  end.
Solve Obligations with sauto use: Permutation_cons_app.

Lemma lem_split {A} : forall l : list A,
    2 <= List.length l ->
    forall l1 l2, (l1, l2) = ` (split l) ->
    List.length l1 < List.length l /\
    List.length l2 < List.length l.
Proof.
  intros l ? l1 l2 ?.
  assert (length l = length l1 + length l2).
  { sauto use: Permutation_length, app_length. }
  sauto.
Qed.

Ltac use_lem_split :=
  match goal with
  | [ H1: [] <> ?l, H2: forall x, [x] <> ?l |- _ ] =>
    assert (2 <= length l) by
        (clear - H1 H2; destruct l; hauto depth: 1 inv: list)
  end;
  use @lem_split; eauto.

Obligation Tactic := idtac.

Program Fixpoint mergesort {A} `{DecTotalOrder A} (l : list A)
  {measure (length l)} : {l' | Sorted l' /\ Permutation l' l} :=
  match l with
  | [] => []
  | [x] => [x]
  | _ =>
    match split l with
    | (l1, l2) => merge (mergesort l1) (mergesort l2)
    end
  end.
Next Obligation.
  sauto.
Qed.
Next Obligation.
  sauto.
Qed.
Next Obligation.
  program_simpl; use_lem_split.
Qed.
Next Obligation.
  sauto.
Qed.
Next Obligation.
  program_simpl; use_lem_split.
Qed.
Next Obligation.
  sauto.
Qed.
Next Obligation.
  split.
  - sauto.
  - qauto use: Permutation_app, Permutation_sym, perm_trans.
Qed.
Next Obligation.
  sauto.
Qed.
Next Obligation.
  program_simpl.
Defined.


Require Export UniMath.MoreFoundations.Notations.
Require Export UniMath.MoreFoundations.Propositions.

Declare Scope subtype.
Delimit Scope subtype with subtype.

Local Open Scope subtype.

Local Open Scope logic.
Local Open Scope type.

(** The powerset, or set of all subsets, of a set. *)
Definition subtype_set X : hSet := make_hSet (hsubtype X) (isasethsubtype X).

Definition subtype_isIn {X:UU} {S:hsubtype X} (s:S) (T:hsubtype X) : hProp := T (pr1 s).

Notation " s ∈ T " := (subtype_isIn s T) (at level 70) : subtype.

Notation " s ∉ T " := (¬ (subtype_isIn s T) : hProp) (at level 70) : subtype.

Definition subtype_containedIn {X:UU} : hrel (subtype_set X) := λ S T, ∀ x:X, S x ⇒ T x.

Notation " S ⊆ T " := (subtype_containedIn S T) (at level 70) : subtype.

Definition subtype_notContainedIn {X:UU} (S T : hsubtype X) : hProp := ∃ x:X, S x ∧ ¬ (T x).

Definition subtype_inc {X:UU} {S T : hsubtype X} : S ⊆ T -> S -> T.
Proof.
  intros le s. exact (pr1 s,, le (pr1 s) (pr2 s)).
Defined.

Notation " S ⊈ T " := (subtype_notContainedIn S T) (at level 70) : subtype.

Definition subtype_smallerThan {X:UU} (S T : hsubtype X) : hProp := (S ⊆ T) ∧ (T ⊈ S).

Notation " S ⊊ T " := (subtype_smallerThan S T) (at level 70) : subtype.

Definition subtype_equal {X:UU} (S T : hsubtype X) : hProp := ∀ x, S x ⇔ T x.

Notation " S ≡ T " := (subtype_equal S T) (at level 70) : subtype.

Definition subtype_notEqual {X:UU} (S T : hsubtype X) : hProp := (S ⊈ T) ∨ (T ⊈ S).

Notation " S ≢ T " := (subtype_notEqual S T) (at level 70) : subtype.

Lemma subtype_notEqual_containedIn {X:UU} (S T : hsubtype X) : S ⊆ T -> S ≢ T -> T ⊈ S.
Proof.
  intros ci ne. apply (squash_to_hProp ne); clear ne; intros [n|n].
  - apply (squash_to_hProp n); clear n; intros [x [p q]]. apply fromempty.
    change (neg (T x)) in q. apply q; clear q. apply (ci x). exact p.
  - exact n.
Defined.

Lemma subtype_notEqual_to_negEqual {X:UU} (S T : hsubtype X) : S ≢ T -> ¬ (S ≡ T).
Proof.
  intros n. apply (squash_to_prop n).
  + apply isapropneg.         (* uses funextemptyAxiom *)
  + intros [c|c].
    * apply (squash_to_prop c).
      ** apply isapropneg.         (* uses funextemptyAxiom *)
      ** intros [x [Sx nTx]] e. use nTx; clear nTx. exact (pr1 (e x) Sx).
    * apply (squash_to_prop c).
      ** apply isapropneg.         (* uses funextemptyAxiom *)
      ** intros [x [Tx nSx]] e. use nSx; clear nSx. exact (pr2 (e x) Tx).
Defined.

Lemma subtype_notEqual_from_negEqual {X:UU} (S T : hsubtype X) : LEM -> (S ≢ T <- ¬ (S ≡ T)).
Proof.
  intros lem ne. unfold subtype_equal in ne.
  assert (q := negforall_to_existsneg _ lem ne); clear ne.
  apply (squash_to_hProp q); clear q; intros [x n].
  unfold subtype_notEqual.
  assert (r := weak_fromnegdirprod _ _ n); clear n. unfold dneg in r.
  assert (s := proof_by_contradiction lem r); clear r.
  apply (squash_to_hProp s); clear s. intros s. apply hinhpr. induction s as [s|s].
  + apply ii1, hinhpr. exists x. now apply negimpl_to_conj.
  + apply ii2, hinhpr. exists x. now apply negimpl_to_conj.
Defined.

Definition emptysubtype (X : UU) : hsubtype X
  := λ x, hfalse.

Definition subtype_difference {X:UU} (S T : hsubtype X) : hsubtype X := λ x, S x ∧ ¬ (T x).

Notation " S - T " := (subtype_difference S T) : subtype.

Definition subtype_difference_containedIn {X:UU} (S T : hsubtype X) : (S - T) ⊆ S.
Proof.
  intros x u. exact (pr1 u).
Defined.

Lemma subtype_equal_cond {X:UU} (S T : hsubtype X) : S ⊆ T ∧ T ⊆ S ⇔ S ≡ T.
Proof.
  split.
  - intros c x. induction c as [st ts].
    split.
    + intro s. exact (st x s).
    + intro t. exact (ts x t).
  - intro e. split.
    + intros x s. exact (pr1 (e x) s).
    + intros x t. exact (pr2 (e x) t).
Defined.

Definition subtype_union {X I:UU} (S : I -> hsubtype X) : hsubtype X := λ x, ∃ i, S i x.

Notation "⋃ S" := (subtype_union S) (at level 100, no associativity) : subtype.

Definition subtype_binaryunion {X} (A B : hsubtype X) : hsubtype X
  := fun x => A x ∨ B x.

Notation "A ∪ B" := (subtype_binaryunion A B)
                              (at level 40, left associativity) : subtype.
  (* precedence tighter than "⊆", also than "-" [subtype_difference].  *)
  (* in agda-input method, type \cup or ∪ *)

Definition subtype_binaryunion_leq1 {X} (A B : hsubtype X) : A ⊆ (A ∪ B)
  := fun x => hdisj_in1.

Definition subtype_binaryunion_leq2 {X} (A B : hsubtype X) : B ⊆ (A ∪ B)
  := fun x => hdisj_in2.

Definition subtype_union_containedIn {X:hSet} {I:UU} (S : I -> hsubtype X) i : S i ⊆ ⋃ S
  := λ x s, hinhpr (i,,s).

(** Given a family of subtypes of X indexed by a type I, an element x : X is in
    their intersection if it is an element of each subtype.
 *)

Definition subtype_intersection {X I:UU} (S : I -> hsubtype X) : hsubtype X := λ x, ∀ i, S i x.

Notation "⋂ S" := (subtype_intersection S) (at level 100, no associativity) : subtype.

Theorem hsubtype_univalence {X:UU} (S T : hsubtype X) : (S = T) ≃ (S ≡ T).
Proof.
  intros. intermediate_weq (∏ x, S x = T x).
  - apply weqtoforallpaths.
  - unfold subtype_equal. apply weqonsecfibers; intro x.
    apply weqlogeq.
Defined.

Theorem hsubtype_rect {X:UU} (S T : hsubtype X) (P : S ≡ T -> UU) :
  (∏ e : S=T, P (hsubtype_univalence S T e)) ≃ ∏ f, P f.
Proof.
  intros. apply weqinvweq, weqonsecbase.
Defined.

Ltac hsubtype_induction f e := generalize f; apply hsubtype_rect; intro e; clear f.

Lemma subtype_containment_istrans X : istrans (@subtype_containedIn X).
Proof.
  intros S T U i j x. exact (j x ∘ i x).
Defined.

Lemma subtype_containment_isrefl X : isrefl (@subtype_containedIn X).
Proof.
  intros S x s. exact s.
Defined.

Lemma subtype_containment_ispreorder X : ispreorder (@subtype_containedIn X).
Proof.
  use make_dirprod.
  - apply subtype_containment_istrans.
  - apply subtype_containment_isrefl.
Defined.

Lemma subtype_containment_isantisymm X : isantisymm (@subtype_containedIn X).
Proof.
  intros S T i j. apply (invmap (hsubtype_univalence S T)). apply subtype_equal_cond.
  split; assumption.
Defined.

Lemma subtype_containment_isPartialOrder X : isPartialOrder (@subtype_containedIn X).
Proof.
  use make_dirprod.
  - apply subtype_containment_ispreorder.
  - apply subtype_containment_isantisymm.
Defined.

Lemma subtype_inc_comp {X:UU} {S T U : hsubtype X} (i:S⊆T) (j:T⊆U) (s:S) :
  subtype_inc j (subtype_inc i s) = subtype_inc (λ x, j x ∘ i x) s.
Proof.
  reflexivity.
Defined.

Lemma subtype_deceq {X} (S:hsubtype X) : isdeceq X -> isdeceq (carrier S).
Proof.
  intro i. intros s t. induction (i (pr1 s) (pr1 t)) as [eq|ne].
  - apply ii1, subtypePath_prop, eq.
  - apply ii2. intro eq. apply ne. apply maponpaths. exact eq.
Defined.

Definition isDecidablePredicate {X} (S:X->hProp) := ∏ x, decidable (S x).

Definition subtype_plus {X} (S:hsubtype X) (z:X) : hsubtype X := λ x, S x ∨ z = x.

Definition subtype_plus_incl {X} (S:hsubtype X) (z:X) : S ⊆ subtype_plus S z.
Proof.
  intros s Ss. now apply hinhpr,ii1.
Defined.

Definition subtype_plus_has_point {X} (S:hsubtype X) (z:X) : subtype_plus S z z.
Proof.
  now apply hinhpr, ii2.
Defined.

Definition subtype_plus_in {X} {S:hsubtype X} {z:X} {T:hsubtype X} :
  S ⊆ T -> T z -> subtype_plus S z ⊆ T.
Proof.
  intros le Tz x S'x. apply (squash_to_hProp S'x). intros [Sx|e].
  - exact (le x Sx).
  - induction e. exact Tz.
Defined.

Section Complement.

  Context {X : UU}.

  Definition subtype_complement (S : hsubtype X) : hsubtype X := fun x => hneg (S x).

  (** Something can't be in a subtype and its complement. *)
  Lemma not_in_subtype_and_complement (S : hsubtype X) :
    ∏ x, S x -> subtype_complement S x -> empty.
  Proof.
    intros x in_S in_neg_S; exact (in_neg_S in_S).
  Defined.

  (** The intersection of a family containing a set and its complement is empty. *)
  Lemma subtype_complement_intersection_empty {S} {I : UU} {f : I -> hsubtype X} :
    (∑ i : I, f i = S) ->
    (∑ j : I, f j = subtype_complement S) ->
    subtype_intersection f ≡ emptysubtype _.
  Proof.
    intros has_S has_neg_S x; use make_dirprod.
    - intros in_intersection.
      pose (in_S := in_intersection (pr1 has_S)).
      pose (in_neg_S := in_intersection (pr1 has_neg_S)).
      cbn in *.

      pose (in_S' := (eqtohomot (pr2 has_S)) x).
      pose (in_neg_S' := (eqtohomot (pr2 has_neg_S)) x).

      apply (not_in_subtype_and_complement S x).
      + abstract (induction in_S'; assumption).
      + abstract (induction in_neg_S'; assumption).

    - intros empt; induction empt.
  Qed.

  (** The union of a family containing a set and its complement is the whole set (assuming LEM). *)
  Lemma subtype_complement_union {S} (lem : LEM) {I : UU} {f : I -> hsubtype X} :
    (∑ i : I, f i = S) ->
    (∑ j : I, f j = subtype_complement S) ->
    subtype_union f ≡ totalsubtype _.
  Proof.
    intros has_S has_neg_S x; use make_dirprod.
    - intro; exact tt.
    - intro.
      induction (lem (S x)).
      + apply hinhpr.
        exists (pr1 has_S).
        abstract (rewrite (pr2 has_S); assumption).
      + apply hinhpr.
        exists (pr1 has_neg_S).
        abstract (rewrite (pr2 has_neg_S); assumption).
  Qed.

End Complement.

(* We could define the intersection as follows but this makes it more complicated than it should be *)
Definition binary_intersection' {X : UU} (U V : hsubtype X) : hsubtype X
  := subtype_intersection (λ b,  bool_rect (λ _ : bool, hsubtype X) U V b).

Definition binary_intersection {X : UU} (U V : hsubtype X) : hsubtype X
  := λ x, U x ∧ V x.

Lemma binary_intersection_commutative {X : UU} (U V : hsubtype X)
  : ∏ x : X, (binary_intersection U V) x -> (binary_intersection V U) x.
Proof.
  intros ? p.
  exact (transportf _ (iscomm_hconj (U x) (V x)) p).
Qed.

Definition intersection_contained_l {X : UU} (U V : hsubtype X)
  : subtype_containedIn (binary_intersection U V) U.
Proof.
  intros ? xinUV.
  apply xinUV.
Qed.

Definition intersection_contained_r {X : UU} (U V : hsubtype X)
  : subtype_containedIn (binary_intersection U V) V.
Proof.
  intros ? xinUV.
  apply xinUV.
Qed.

Definition intersection_contained {X : UU} {U U' V V' : hsubtype X}
           (uu : subtype_containedIn U U')
           (vv : subtype_containedIn V V')
  : subtype_containedIn (binary_intersection U V) (binary_intersection U' V').
Proof.
  intros x p.
  cbn.
  split.
  - apply (uu x).
    exact ((intersection_contained_l U V) x p).
  - apply (vv x).
    exact ((intersection_contained_r U V) x p).
Qed.

Lemma isaprop_subtype_containedIn {X : UU} (U V : hsubtype X)
  : isaprop (subtype_containedIn U V).
Proof.
  apply impred_isaprop ; intro.
  apply isapropimpl.
  apply V.
Qed.

Definition image_hsubtype {X Y : UU} (U : hsubtype X) (f : X → Y)
  : hsubtype Y := λ y : Y, (∃ x : X, f x = y × U x).

Lemma image_hsubtype_emptyhsubtype {X Y : UU} (f : X → Y)
  : image_hsubtype (emptysubtype X) f = emptysubtype Y.
Proof.
  apply funextsec ; intro y.
  apply hPropUnivalence.
  - intro yinfEmpty.
    use (factor_through_squash _ _ yinfEmpty).
    { apply emptysubtype. }
    intro x.
    apply (pr22 x).
  - intro yinEmpty.
    apply fromempty.
    exact (yinEmpty).
Qed.

Definition image_hsubtype_id {X : UU} (U : hsubtype X)
  : image_hsubtype U (idfun X) = U.
Proof.
  apply funextsec ; intro x.
  apply hPropUnivalence.
  - intro xinIdU.
    use (factor_through_squash _ _ xinIdU).
    { apply U. }
    intro u0.
    assert (p0 : U (pr1 u0) = U x).
    {
      apply maponpaths.
      apply (pr12 u0).
    }
    induction p0.
    apply (pr22 u0).
  - intro xinU.
    apply hinhpr.
    exact (x,, idpath x,, xinU).
Qed.

Definition image_hsubtype_comp {X Y Z : UU} (U : hsubtype X)
           (f : X → Y) (g : Y → Z)
  : image_hsubtype U (funcomp f g) = image_hsubtype (image_hsubtype U f) g.
Proof.
  apply funextsec ; intro z.
  apply hPropUnivalence.
  - intro zinCompU.
    use (factor_through_squash _ _ zinCompU).
    { apply ishinh. }
    intro x.
    apply hinhpr.
    exists (f (pr1 x)).
    exists (pr12 x).
    apply hinhpr.
    exact (pr1 x,, maponpaths f (idpath (pr1 x)),, pr22 x).
  - intro zinCompU.
    use (factor_through_squash _ _ zinCompU).
    { apply ishinh. }
    intro y.
    use (factor_through_squash _ _ (pr22 y)).
    { apply ishinh. }
    intro x.
    apply hinhpr.
    exists (pr1 x).
    split.
    + refine (_ @ (pr12 y)).
      unfold funcomp.
      unfold funcomp.
      apply maponpaths.
      exact (pr12 x).
    + exact (pr22 x).
Qed.

Definition hsubtype_preserving {X Y : UU} (U : hsubtype X) (V : hsubtype Y) (f : X → Y)
  : UU := subtype_containedIn (image_hsubtype U f) V.

Lemma isaprop_hsubtype_preserving {X Y : UU} (U : hsubtype X) (V : hsubtype Y) (f : X → Y)
  : isaprop (hsubtype_preserving U V f).
Proof.
  apply impred_isaprop ; intro.
  apply isapropimpl.
  apply V.
Qed.

Lemma id_hsubtype_preserving {X : UU} (U : hsubtype X) : hsubtype_preserving U U (idfun X).
Proof.
  intros x xinU.
  rewrite image_hsubtype_id in xinU.
  exact xinU.
Qed.

Lemma comp_hsubtype_preserving {X Y Z : UU}
      {U : hsubtype X} {V : hsubtype Y} {W : hsubtype Z}
      {f : X → Y} {g : Y → Z}
      (fsp : hsubtype_preserving U V f) (gsp : hsubtype_preserving V W g)
  : hsubtype_preserving U W (funcomp f g).
Proof.
  intros z zinU.
  rewrite image_hsubtype_comp in zinU.
  apply (gsp _).
  unfold image_hsubtype.
  use (factor_through_squash _ _ zinU).
  { apply ishinh. }
  intro y.
  apply hinhpr.
  exists (pr1 y).
  exists (pr12 y).
  apply (fsp _).
  exact (pr22 y).
Qed.

Lemma empty_hsubtype_preserving {X Y : UU} (f : X → Y)
  : hsubtype_preserving (emptysubtype X) (emptysubtype Y) f.
Proof.
  unfold hsubtype_preserving.
  rewrite image_hsubtype_emptyhsubtype.
  apply subtype_containment_isrefl.
Qed.

Lemma total_hsubtype_preserving {X Y : UU} (f : X → Y)
  : hsubtype_preserving (totalsubtype X) (totalsubtype Y) f.
Proof.
  exact (λ _ _, tt).
Qed.

Section singletons.
  Definition singleton {X : UU} (x : X) : hsubtype X
    := λ (a : X), ∥ a = x ∥.

  (* The canonical element of the singleton subtype. *)
  Definition singleton_point {X : UU} {x : X} : singleton x
    := (x ,, hinhpr (idpath x)).

  Definition iscontr_singleton {X : hSet} (x : X) : iscontr (singleton x).
  Proof.
    use make_iscontr.
    - exact singleton_point.
    - intros t.
      apply subtypePath_prop.
      apply(squash_to_prop (pr2 t)).
      apply setproperty.
      intro ; assumption.
  Defined.

  Definition singleton_is_in {X : UU} (A : hsubtype X) (a : A)
    : (singleton (pr1 a)) ⊆ A.
  Proof.
    intro y.
    use hinhuniv.
    exact(λ (p : y = (pr1 a)), transportb A p (pr2 a)).
  Defined.
End singletons.

(* Map from the coproduct of carriers to the carrier of the binary union. *)
Definition coprod_carrier_binary_union {X}
  (A B : hsubtype X)
  : A ⨿ B -> A ∪ B.
Proof.
  apply sumofmaps; apply subtype_inc.
  - apply subtype_binaryunion_leq1.
  - apply subtype_binaryunion_leq2.
Defined.

Lemma issurjective_coprod_carrier_binary_union {X}
  (A B : hsubtype X)
  : issurjective (coprod_carrier_binary_union A B).
Proof.
  intros [x aub].
  use(hinhfun _ aub).
  apply sumofmaps
  ; (intro y; use make_hfiber)
  ; try (apply subtypePath_prop).
  - exact(inl (x ,, y)).
  - apply idpath.
  - exact(inr (x ,, y)).
  - apply idpath.
Qed.


Require Import Coq.Classes.EquivDec.
Require Import CertiGraph.lib.List_ext.

Section FIND_NOT_IN.
Context {V: Type}.
Context {EDV: EqDec V eq}.

Fixpoint findNotIn (l1 l2 l3: list V) : (option V * (list V * list V)) :=
  match l1 with
    | nil => (None, (nil, nil))
    | x :: l => if (in_dec equiv_dec x l2) then findNotIn l l2 (x :: l3) else (Some x, (rev l3, l))
  end.

Lemma find_not_in_none: forall l1 l2 l3, fst (findNotIn l1 l2 l3) = None -> Forall (fun m => In m l2) l1.
Proof.
  induction l1; intros. apply Forall_nil. simpl in H. destruct (in_dec equiv_dec a l2).
  apply Forall_cons. auto. apply IHl1 with (a :: l3); auto. inversion H.
Qed.

Lemma find_not_in_some_explicit:
  forall l1 l2 l3 x li1 li2,
    findNotIn l1 l2 l3 = (Some x, (li1, li2)) -> (Forall (fun m => In m l2) l3) ->
    (~ In x li1) /\ (~ In x l2) /\ exists l4, li1 = rev l3 ++ l4 /\ Forall (fun m => In m l2) l4 /\ l1 = l4 ++ x :: li2.
Proof.
  induction l1; intros; simpl in H. inversion H. destruct (in_dec equiv_dec a l2).
  assert (Forall (fun m : V => In m l2) (a :: l3)) by (apply Forall_cons; auto).
  specialize (IHl1 l2 (a :: l3) x li1 li2 H H1). destruct IHl1 as [? [? [l4 [? [? ?]]]]]. split; auto. split; auto.
  exists (a :: l4). repeat split; auto. simpl in H4. rewrite <- app_assoc in H4. rewrite <- app_comm_cons in H4.
  rewrite app_nil_l in H4. auto. rewrite H6; apply app_comm_cons. inversion H. split. intro; apply n.
  rewrite Forall_forall in H0. apply (H0 a). rewrite H2. rewrite in_rev. auto. split. rewrite <- H2. auto.
  exists nil. repeat split; auto. rewrite app_nil_r. auto.
Qed.

Lemma find_not_in_some:
  forall l1 l2 x li1 li2,
    findNotIn l1 l2 nil = (Some x, (li1, li2)) ->
    Forall (fun m => In m l2) li1 /\ l1 = li1 ++ x :: li2 /\ ~ In x li1 /\ ~ In x l2.
Proof.
  intros. assert (Forall (fun m : V => In m l2) nil) by apply Forall_nil.
  destruct (find_not_in_some_explicit l1 l2 nil x li1 li2 H H0). destruct H2 as [? [l4 [? [? ?]]]].
  simpl in H3. rewrite H3 in *. repeat split; auto.
Qed.

End FIND_NOT_IN.


Require Import Coq.Classes.Morphisms.
Require Import CertiGraph.lib.Relation_ext.
Require Import CertiGraph.lib.Equivalence_ext.
Require Export Coq.Lists.List.

Local Open Scope equiv_scope.

Section ListFun2.

Context {A B: Type}.
Context {RA: relation A}.
Context {RB: relation B}.
Context {EqRA: Equivalence RA}.
Context {EqRB: Equivalence RB}.

#[export] Instance proper_fold_left: forall (f: A -> B -> A) {Proper_f: Proper (equiv ==> equiv ==> equiv) f}, Proper (Forall2 equiv ==> equiv ==> equiv) (fold_left f).
Proof.
  intros.
  hnf; intros.
  induction H; hnf; intros; simpl.
  + auto.
  + apply IHForall2.
    apply Proper_f; auto.
Qed.

Lemma monoid_fold_left_tail: forall {f: A -> B -> A} {Proper_f: Proper (equiv ==> equiv ==> equiv) f} (e: A) a l,
  fold_left f (l ++ a :: nil) e === f (fold_left f l e) a.
Proof.
  intros.
  simpl.
  pose proof (proper_fold_left f).
  revert e; induction l; intros; simpl.
  + reflexivity.
  + apply IHl.
Qed.

End ListFun2.

Section ListFun1.

Context {A: Type}.
Context {RA: relation A}.
Context {EqRA: Equivalence RA}.

Lemma monoid_fold_left_head: forall {f} {Proper_f: Proper (equiv ==> equiv ==> equiv) f} (e: A) a l,
  (forall x, f e x === x) ->
  (forall x, f x e === x) ->
  (forall x y z, f (f x y) z === f x (f y z)) ->
  fold_left f (a :: l) e === f a (fold_left f l e).
Proof.
  intros.
  simpl.
  pose proof (proper_fold_left f).
  rewrite H.
  revert a; induction l; intros; simpl.
  + symmetry; auto.
  + rewrite (IHl (f a0 a)), H, (IHl a).
    rewrite H1.
    reflexivity.
Qed.

Lemma monoid_fold_symm: forall {f} {Proper_f: Proper (equiv ==> equiv ==> equiv) f} (e: A) l,
  (forall x, f e x === x) ->
  (forall x, f x e === x) ->
  (forall x y z, f (f x y) z === f x (f y z)) ->
  fold_left f l e === fold_right f e l.
Proof.
  intros.
  pose proof (proper_fold_left f).
  destruct l.
  + simpl.
    reflexivity.
  + simpl.
    rewrite H.
    revert a; induction l; intros; simpl.
    - symmetry; auto.
    - rewrite <- H1.
      apply IHl.
Qed.

Lemma monoid_fold_left_app: forall {f} {Proper_f: Proper (equiv ==> equiv ==> equiv) f} (e: A) l l',
  (forall x, f e x === x) ->
  (forall x, f x e === x) ->
  (forall x y z, f (f x y) z === f x (f y z)) ->
  fold_left f (l ++ l') e === f (fold_left f l e) (fold_left f l' e).
Proof.
  intros.
  rewrite fold_left_app.
  generalize (fold_left f l e) as a; clear l; intros.
  pose proof @monoid_fold_left_head f _ e a l'.
  simpl in H2.
  pose proof (proper_fold_left f).
  rewrite H in H2.
  auto.
Qed.

End ListFun1.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Basic_Cons.CCC Basic_Cons.LCCC Basic_Cons.PullBack.
Require Import Ext_Cons.Comma.
Require Import Coq_Cats.Type_Cat.Type_Cat Coq_Cats.Type_Cat.PullBack.
Require Import Archetypal.Discr.Discr.
Require Import Functor.Functor_Ops Functor.Const_Func.

(** Type_Cat is locally cartesian closed. *)
Section CCC_Slice_A.
  Context {A : Type}.

  (** Notation for creating objects of slice out of arrows to A. *)
  Local Notation CO z :=
    (
      @Build_Comma_Obj
        Type_Cat
        Type_Cat
        1
        (Functor_id Type_Cat)
        (@Const_Func 1 Type_Cat A)
        _
        tt
        z
    ) (only parsing).

  (** The slice has products because Type_Cat has pullbacks. *)
  Definition Type_Cat_Slice_Prod :
    Has_Products (Slice Type_Cat A) :=
    @Has_PullBack_Slice_Has_Prod Type_Cat Type_Cat_Has_PullBacks A
  .

  (** Here we show that slices have exponentials. *)

  (**
Given two arrows f : Y → A and g : Y → A, the exponential gᶠ is an arrow
from {(z, u)| z : A, u : (f⁻¹ z) → (g⁻¹ z)} to A that maps a pair
(z, u) to z.

Intuitively, exponentials are representatives of the set of morphisms between
objects. Recall that in a slice, a morphism from f : X → A to g : Y → A is a
morphism h : X → Y that makes the following diagram commute.

         h
    X ——————–> Y
    |         /
    |       /
  f |     / g
    |   /
    ↓ ↙
    A

Therefore, for any element z : A, arrows from (f⁻¹ z) to (g⁻¹ z) are precisely
those that make the diagram commute.
*)

  Context (f g : Slice Type_Cat A).

  Definition Pre_Image {X : Type} (f : X → A) (z : A) := {y : X| f y = z}.

  Local Notation EXP :=
    (
      CO
        (
          fun m : {x : A & (Pre_Image (CMO_hom f) x) → (Pre_Image (CMO_hom g) x)}
          => projT1 m
        )
    ) (only parsing).

  Local Obligation Tactic := idtac.

  Program Definition Type_Cat_LExp :
    @Exponential (Slice Type_Cat A) Type_Cat_Slice_Prod f g :=
    {|
      exponential := EXP;
      eval :=
        @Build_Comma_Hom
          Type_Cat
          Type_Cat
          1
          (Functor_id Type_Cat)
          (@Const_Func 1 Type_Cat A)
          _
          _
          (fun w =>
             proj1_sig
               ((projT2 (fst (proj1_sig w))) (exist _ (snd (proj1_sig w)) _)))
          tt
          _
      ;
      Exp_morph_ex :=
        fun z h =>
          @Build_Comma_Hom
            Type_Cat
            Type_Cat
            1
            (Functor_id Type_Cat)
            (@Const_Func 1 Type_Cat A)
            z
            EXP
            (fun w =>
               existT
                 _
                 (CMO_hom z w)
                 (fun v => exist _ (CMH_left h (exist _ (w, proj1_sig v) _)) _)
            )
            tt
            _
    |}.

  Next Obligation.
  Proof.
    intros w.
    exact (eq_sym (proj2_sig w)).
  Qed.

  Next Obligation.
  Proof.
    extensionality w.
    destruct w as [[[x h] z] H]; cbn in *.
    match goal with
      [|- _ = CMO_hom g (proj1_sig ?A)] =>
      destruct A as [a H1]; cbn; auto
    end.
  Qed.

  Next Obligation.
  Proof.
    intros z h w v.
    symmetry.
    apply (proj2_sig v).
  Qed.

  Next Obligation.
  Proof.
    intros z h w v.
    symmetry.
    exact (equal_f
             (CMH_com h)
             (exist _ (w, proj1_sig v) (Type_Cat_LExp_obligation_3 z h w v))).
  Qed.

  Next Obligation.
  Proof.
    trivial.
  Qed.

  Next Obligation.
  Proof.
    intros z h.
    apply Comma_Hom_eq_simplify;
      [
        extensionality x |
        match goal with
          [|- ?A = ?B] =>
          destruct A; destruct B; trivial
        end
      ].
    cbn in *.
    apply f_equal.
    destruct x as [x H].
    apply sig_proof_irrelevance; trivial.
  Qed.

  Next Obligation.
  Proof.
    intros z h u u' H1 H2.
    rewrite H1 in H2; clear H1.
    apply Comma_Hom_eq_simplify;
      [extensionality x|
       match goal with
         [|- ?A = ?B] =>
         destruct A; destruct B; trivial
       end
      ].
    set (Hp1 :=
           equal_f
             (eq_trans (eq_sym (CMH_com u)) (CMH_com u'))
             x
        ); clearbody Hp1; cbn in Hp1.
    match goal with
      [|- ?A = ?B] =>
      cut (match Hp1 in _ = y return
                 Pre_Image (CMO_hom f) y → Pre_Image (CMO_hom g) y
           with
             eq_refl => projT2 A
           end = projT2 B
          );
        [intros Hp2; destruct A as [za Fa]; destruct B as [zb Fb]|]
    end.
    {
      cbn in Hp1, Hp2.
      destruct Hp1; destruct Hp2; trivial.
    }
    {
      extensionality v.
      transitivity
        (match Hp1 in _ = y return
               Pre_Image (CMO_hom g) y
         with
           eq_refl =>
           projT2
             (CMH_left u x)
             (match eq_sym Hp1 in _ = y return
                    Pre_Image (CMO_hom f) y
              with
                eq_refl => v
              end)
         end
        ).
      {
        destruct Hp1; trivial.
      }
      set (M :=
             exist
               (fun w => CMO_hom z (fst w) = CMO_hom f (snd w))
               (x, proj1_sig v)
               (eq_trans
                  (equal_f (CMH_com u') x)
                  (eq_sym (proj2_sig v))
               )
          ).
      set (H2' := (equal_f (f_equal CMH_left H2) M));clearbody H2'; clear H2.
      cbn in H2'.
      match type of H2' with
        proj1_sig (projT2 (CMH_left u x) ?w) =
        proj1_sig (projT2 (CMH_left u' x) ?w') =>
        cutrewrite
          (w =
           (
             match eq_sym Hp1 in _ = y return
                   Pre_Image (CMO_hom f) y
             with
               eq_refl => v
             end
           )
          ) in H2'; [cutrewrite (w' = v) in H2' |]
      end.
      {
        apply sig_proof_irrelevance.
        etransitivity; [|apply H2'].
        generalize (
            (
              match eq_sym Hp1 in (_ = y) return
                    (Pre_Image (CMO_hom f) y)
              with
                eq_refl => v
              end
            )
          ) as p.
        intros p.
        clear.
        destruct Hp1.
        trivial.
      }
      {
        clear.
        apply sig_proof_irrelevance; trivial.
      }
      {
        clear.
        apply sig_proof_irrelevance; cbn.
        destruct (eq_sym Hp1); trivial.
      }
    }
  Qed.

End CCC_Slice_A.

(** Type_Cat is locally cartesian closed. *)
Instance Type_Cat_LCCC : LCCC Type_Cat :=
  fun A =>
    {|
      CCC_term := Slice_Terminal Type_Cat A;
      CCC_HP := Type_Cat_Slice_Prod;
      CCC_HEXP := Type_Cat_LExp
    |}.


Require Import Coq.Logic.ProofIrrelevance.
Require Import RamifyCoq.lib.Ensembles_ext.
Require Import RamifyCoq.lib.EquivDec_ext.
Require Import RamifyCoq.lib.List_ext.
Require Import RamifyCoq.lib.relation_list.
Require Import RamifyCoq.lib.Equivalence_ext.
Require Import Relations.
Require Import Classical.
Require Import RamifyCoq.graph.graph_model.
Require Import RamifyCoq.graph.reachable_ind.
Require Import RamifyCoq.graph.path_lemmas.

Module DFSproof.

Section DFSplayground.

Context {Vertex Edge: Type}.
Context {EV: EqDec Vertex eq}.
Context {EE: EqDec Edge eq}.
Context {pg: PreGraph Vertex Edge}.
Context {st: Vertex}.

Definition state : Type := (list Vertex) * (list Vertex).
Definition empty_state : state := pair nil nil.

Print relation.

Inductive DFS_step: relation state :=
  | DFS_nil_start:
      vvalid pg st -> DFS_step empty_state (pair (st :: nil) (st :: nil))
  | DFS_forward: forall v v' l vl,
      ~ In v' vl -> edge pg v v' ->
      DFS_step (pair (v :: l) vl) (pair (v' :: v :: l) (v' :: vl))
  | DFS_backward: forall v l vl,
      (forall v', edge pg v v' -> In v' vl) ->
      DFS_step (pair (v :: l) vl) (pair l vl).

Print clos_refl_trans.

Definition DFS: state -> state -> Prop :=
  clos_refl_trans state DFS_step.

Definition DFSn1: state -> state -> Prop :=
  clos_refl_trans_n1 state DFS_step.

Definition DFS1n: state -> state ->  Prop :=
  clos_refl_trans_1n state DFS_step.

Search clos_refl_trans_1n.

Lemma DFS_eq_DFS1n: forall s1 s2, DFS s1 s2 <-> DFS1n s1 s2.
Proof. split; [apply clos_rt_rt1n | apply clos_rt1n_rt]. Qed.

Lemma DFS_eq_DFSn1: forall s1 s2, DFS s1 s2 <-> DFSn1 s1 s2.
Proof. split; [apply clos_rt_rtn1 | apply clos_rtn1_rt]. Qed.

(**************************** state eq_dec ******************************)
Lemma list_eq_dec: forall (l1 l2: list Vertex),
  {l1 = l2} + {l1 <> l2}.
Proof. decide equality; apply EV. Qed.

Lemma state_eq_dec: forall (s1 s2: state),
  {s1 = s2} + {s1 <> s2}.
Proof. decide equality; apply list_eq_dec. Qed.

(*************************** step change ********************************)
Lemma list_add_not_eq: forall (A: Type) (v: A) (l: list A),
  v :: l <> l.
Proof.
  induction l; unfold not; intros; inversion H; subst; auto.
Qed.

Lemma step_change: forall s1 s2,
  DFS_step s1 s2 -> s1 <> s2.
Proof.
  intros.
  induction H as [H1 | v v' l m H1 H2 | v v' l m];
    unfold not; intros; inversion H; try apply (list_add_not_eq Vertex v' l);
    try apply (list_add_not_eq Vertex v v') in H1; auto.
Qed.

(********************** vis list not empty ******************************)
Lemma vis_list_not_empty: forall s,
  s <> empty_state -> DFS empty_state s -> length (snd s) > 0.
Proof.
  intros s Hne H.
  rewrite DFS_eq_DFSn1 in H.
  induction H; [exfalso; auto | ].
  inversion H; simpl in *; [auto | apply Gt.gt_Sn_O | ].
  symmetry in H2. subst; simpl in *.
  apply IHclos_refl_trans_n1.
  unfold not. intros.
  subst. inversion H2.
Qed.

(********************** vis list length increasing **********************)
Lemma vis_list_length_incr: forall s1 s2,
  DFS s1 s2 -> length (snd s2) >= length (snd s1).
Proof.
  intros.
  induction H; [ induction H; simpl | | ]; auto.
  unfold ge in *.
  apply PeanoNat.Nat.le_trans with (m := length (snd y)); auto.
Qed.

(*************************** vis list adding ****************************)
Lemma vis_list_add_step: forall s1 s2,
  DFS_step s1 s2 ->
    (forall v, In v (snd s1) -> In v (snd s2)).
Proof.
  intros.
  induction H; simpl in *; auto.
Qed.

Lemma vis_list_add: forall s1 s2,
  DFS s1 s2 ->
    (forall v, In v (snd s1) -> In v (snd s2)).
Proof.
  intros.
  induction H; auto.
  induction H; simpl; auto.
Qed.

(*************** start vertex must be in vis list ***********************)
Lemma st_in_vis_list: forall s,
  s <> empty_state -> DFS empty_state s -> In st (snd s).
Proof.
  intros.
  apply DFS_eq_DFSn1 in H0.
  induction H0; [exfalso; auto | ].
  assert (K: {y = empty_state} + {y <> empty_state}); [apply state_eq_dec | ].
  destruct K.
  - subst. inversion H0; simpl in *; auto.
  - apply (vis_list_add y z). constructor. auto. auto.
Qed.

(*************** Vertex in stack must be in vis list ********************)
Lemma in_stack_in_vis_list: forall s,
  DFS empty_state s ->
    (forall v, In v (fst s) -> In v (snd s)).
Proof.
  intros s H.
  rewrite DFS_eq_DFSn1 in H.
  induction H; auto; intros.
  inversion H; simpl in *.
  - symmetry in H3, H4; subst; simpl in *; auto.
  - symmetry in H4, H5; subst; simpl in *.
    destruct H1 as [H1 | H1]; auto.
  - symmetry in H3, H4; subst; simpl in *; auto.
Qed.

(******************* Vertex in vis list all reachable *******************)
Theorem vis_list_all_reachable: forall s,
  DFS empty_state s ->
    (forall v, In v (snd s) -> reachable pg st v).
Proof.
  intros s H.
  rewrite DFS_eq_DFSn1 in H.
  induction H; [ intros; exfalso; auto | ].
  assert (K: forall v, {In v (snd y)} + {~ In v (snd y)});
    [intros; apply ListDec.In_dec, EV | ].
  assert (K': forall v, {In v (snd y)} + {~ In v (snd y)}); auto.
  intros.
  specialize K with (v := v).
  destruct K; auto.
  inversion H; simpl in *.
  - symmetry in H3, H4; subst; simpl in *.
    destruct H1; [subst | exfalso; auto].
    apply reachable_ind_reachable; constructor; auto.
  - symmetry in H4, H5; subst; simpl in *.
    destruct H1 as [H1 | H1]; [subst | exfalso; auto].
    clear n. specialize K' with (v := v0).
    destruct K' as [K' | K'].
    specialize IHclos_refl_trans_n1 with (v := v0).
    apply reachable_ind2_reachable.
    apply reachable_ind2_reachable in IHclos_refl_trans_n1; auto.
    apply ind2.reachable_cons with (y := v0); auto.
    assert (J: DFS empty_state (v0 :: l, vl)); [rewrite DFS_eq_DFSn1; auto | ].
    apply in_stack_in_vis_list with (v := v0) in J; simpl in *; [exfalso | ]; auto.
  - symmetry in H3, H4; subst. simpl in *.
    exfalso; auto.
Qed.

(***************** vertex in vis list once get in stack *****************)
(** it may seems useless in the following proof,
    but it provides me a method to proof the next lemma **)
Lemma in_vis_list_once_in: forall v l vl,
  DFS empty_state (l, vl) -> In v vl ->
    (exists l' vl', DFS empty_state (v :: l', v :: vl') /\ DFS (v :: l', v :: vl') (l, vl)).
Proof.
  intros v l vl H Hin.
  remember (l, vl) eqn: Hs.
  revert l vl Hs Hin.
  apply DFS_eq_DFSn1 in H.
  induction H; intros; [inversion Hs; subst; exfalso; auto | ].
  subst. inversion H; subst.
  - inversion Hin; [ | exfalso; auto]. symmetry in H1. subst. clear Hin.
    exists nil. exists nil. split; [repeat constructor; auto | apply rt_refl].
  - inversion Hin; subst.
    + clear Hin.
      exists (v0 :: l0), (vl0).
      split. apply rt_trans with (y := (v0 :: l0, vl0)).
      apply DFS_eq_DFSn1; auto. constructor; constructor; auto.
      apply rt_refl.
    + specialize IHclos_refl_trans_n1 with (l := v0 :: l0) (vl := vl0).
      assert (exists l' vl' : list Vertex,
                         DFS empty_state (v :: l', v :: vl') /\
                         DFS (v :: l', v :: vl') (v0 :: l0, vl0)); auto.
      destruct H2 as [l' [vl' [?H ?H]]].
      exists l', vl'. split. auto. apply rt_trans with (y := (v0 :: l0, vl0)); auto.
      constructor; constructor; auto.
  - specialize IHclos_refl_trans_n1 with (l0 := v0 :: l) (vl0 := vl).
    assert (exists l' vl' : list Vertex,
                         DFS empty_state (v :: l', v :: vl') /\
                         DFS (v :: l', v :: vl') (v0 :: l, vl)); auto.
    destruct H1 as [l' [vl' [?H ?H]]].
    exists l', vl'. split; auto.
    apply rt_trans with (y := (v0 :: l, vl)); auto.
    constructor; constructor; auto.
Qed.

(***************** vertex in vis list once go backward ******************)
Lemma in_vis_list_once_out: forall v l vl,
  DFS empty_state (l, vl) -> In v vl -> ~ (In v l) ->
    (exists l' vl', DFS empty_state (v :: l', vl') /\ DFS_step (v :: l', vl') (l', vl') /\ DFS (l', vl') (l, vl)).
Proof.
  intros v l vl H Hin1 Hin2.
  remember (l, vl) eqn: Hs.
  revert l vl Hs Hin1 Hin2.
  apply DFS_eq_DFSn1 in H.
  induction H; intros; [inversion Hs; subst; exfalso; auto | ].
  inversion H.
  - subst. inversion H3. subst. exfalso; auto.
  - subst. inversion H4. subst. clear H4.
    inversion Hin1; subst.
    + exfalso. apply Hin2. simpl. left. auto.
    + specialize IHclos_refl_trans_n1 with (l := v0 :: l0) (vl := vl0).
      assert (exists l' vl' : list Vertex,
                         DFS empty_state (v :: l', vl') /\
                         DFS_step (v :: l', vl') (l', vl') /\
                         DFS (l', vl') (v0 :: l0, vl0)). {
        apply IHclos_refl_trans_n1; auto.
        unfold not. intros. simpl in H4, Hin2. apply Hin2. tauto.
      }
      destruct H4 as [l' [vl' [?H [?H ?H]]]].
      exists l', vl'. split; [auto | split; auto].
      apply rt_trans with (y := (v0 :: l0, vl0)); auto.
      constructor. constructor; auto.
  - subst. inversion H3. subst. clear H3.
    assert (K: {v = v0} + {v <> v0}); [apply EV | ].
    destruct K as [K | K].
    + subst. exists l, vl.
      split. apply DFS_eq_DFSn1. auto.
      split. auto. apply rt_refl.
    + specialize IHclos_refl_trans_n1 with (l0 := v0 :: l) (vl0 := vl).
      assert (exists l' vl' : list Vertex,
                         DFS empty_state (v :: l', vl') /\
                         DFS_step (v :: l', vl') (l', vl') /\
                         DFS (l', vl') (v0 :: l, vl)). {
        apply IHclos_refl_trans_n1; auto.
        simpl in *. unfold not. intros.
        unfold not in Hin2, K.
        destruct H2; auto.
      }
      destruct H2 as [l' [vl' [?H [?H ?H]]]].
      exists l', vl'. split; auto.
      split; auto.
      apply rt_trans with (y := (v0 :: l, vl)); auto.
      constructor. constructor. auto.
Qed.

(****************** reachable vis list strong edge **********************)
(** when backward from vertex v1, vertex v2, which is linked to vertex v1
    by edge, must be visited. **)
Lemma reachable_vis_list_strong_edge: forall v1 v2 l vl evl,
  DFS empty_state (l, vl) -> DFS (l, vl) (nil, evl) ->
    ~ (In v1 l) -> In v1 vl -> edge pg v1 v2 -> In v2 evl.
Proof.
  intros.
  assert (exists l' vl', DFS empty_state (v1 :: l', vl') /\ DFS_step (v1 :: l', vl') (l', vl') /\ DFS (l', vl') (l, vl)); [apply in_vis_list_once_out; auto | ].
  destruct H4 as [l' [vl' [?H [?H ?H]]]].
  inversion H5.
  - subst. assert (v' :: vl' <> vl'); [apply list_add_not_eq; auto | ].
    exfalso; auto.
  - subst. specialize H8 with (v' := v2).
    assert (In v2 vl'); auto.
    apply (vis_list_add (l', vl') (nil, evl)).
    apply rt_trans with (y := (l, vl)); auto.
    simpl. auto.
Qed.

(********************* reachable vis list strong ************************)
(** when backward from vertex v1, vertex v2, which is reachable from vertex v1
    by edge, must be visited. **)
Lemma reachable_vis_list_strong: forall v1 v2 l vl evl,
  DFS empty_state (l, vl) -> DFS (l, vl) (nil, evl) ->
    ~ (In v1 l) -> In v1 vl -> reachable pg v1 v2 -> In v2 evl.
Proof.
  intros.
  apply reachable_ind2_reachable in H3.
  induction H3; [apply (vis_list_add (l, vl) (nil, evl)); auto | ].
  unfold edge in *.
  assert (In y evl); [apply IHreachable; auto | ].
  apply (reachable_vis_list_strong_edge y z nil evl evl); auto.
  - apply rt_trans with (y := (l, vl)); auto.
  - apply rt_refl.
Qed.

(******************* the definition of end_state ************************)
Definition end_state (s: state) : Prop := forall s', ~ (DFS_step s s').

(*************** Some usefull lemmas about end_state ********************)
(** if s is an end state, then its stack must be empty **)
Lemma end_state_stack_empty: forall s,
  DFS empty_state s -> end_state s -> (fst s) = nil.
Proof.
  intros s H He.
  unfold end_state in He.
  destruct s as [l vl]; simpl in *.
  destruct l; auto.
  assert ((forall v', edge pg v v' -> In v' vl) \/ ~ (forall v', edge pg v v' -> In v' vl)); [apply classic | ].
  destruct H0.
  - specialize He with (s' := (l, vl)). exfalso.
    apply He. constructor. auto.
  - apply not_all_ex_not in H0.
    destruct H0 as [n ?H].
    apply imply_to_and in H0.
    specialize He with (s' := (n :: v :: l, n :: vl)).
    exfalso. apply He. destruct H0. constructor; auto.
Qed.

(** if s is an end state, then its vis list must be empty (if st is valid) **)
Lemma end_state_vis_list_not_empty: forall s, vvalid pg st ->
  DFS empty_state s -> end_state s -> (snd s) <> nil.
Proof.
  intros.
  unfold end_state in *.
  destruct s as [l vl]; simpl in *.
  assert (l = nil); [apply (end_state_stack_empty (l, vl)); auto | subst].
  destruct vl.
  - specialize H1 with (s' := (st :: nil, st :: nil)). exfalso.
    apply H1. constructor. auto.
  - unfold not in *; intros ?H. inversion H2.
Qed.

(************** Vertex reachable in endstate's vis list *****************)
Theorem reachable_vis_list: forall v s, vvalid pg st ->
  DFS empty_state s ->
    end_state s ->
      reachable pg st v -> In v (snd s).
Proof.
  intros.
  destruct s as [l vl]. simpl in *.
  unfold end_state in *.
  assert (l = nil); [apply (end_state_stack_empty (l, vl)); auto | subst].
  assert (vl <> nil); [apply (end_state_vis_list_not_empty (nil, vl)); auto | ].
  apply (reachable_vis_list_strong st v nil vl vl); auto.
  - apply rt_refl.
  - apply (st_in_vis_list (nil, vl)); auto.
    unfold not in *. intros. inversion H4. auto.
Qed.

(** the end of the proof of DFS's correctness *)
(************************************************************************)

End DFSplayground.

End DFSproof.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.BaseFormats
        Fiat.Narcissus.Formats.WordOpt.
Require Import
        Coq.ZArith.ZArith
        Bedrock.Word.

Section Nat.
  Variable sz : nat.

  Context {T : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {monoid : Monoid T}.
  Context {monoidUnit : QueueMonoidOpt monoid bool}.

  Definition format_nat (n : nat) (ce : CacheFormat)
    : Comp (T * CacheFormat) :=
    format_word (natToWord sz n) ce.

  Open Scope vector_scope.

  Definition encode_nat (n : nat) (ce : CacheFormat) : T * CacheFormat :=
    encode_word (natToWord sz n) ce.

  Lemma refine_format_nat :
    forall n ce,
      refine (format_nat n ce) (ret (encode_nat n ce)).
  Proof.
    reflexivity.
  Qed.

  Definition decode_nat (b : T) (cd : CacheDecode) : option (nat * T * CacheDecode) :=
    `(w, b, cd) <- decode_word (sz:=sz) b cd;
      Some (wordToNat w, b, cd).

  Local Open Scope nat.
  Theorem Nat_decode_correct
          {P : CacheDecode -> Prop}
          (P_OK : cache_inv_Property P (fun P => forall b cd, P cd -> P (addD cd b)))
    : CorrectDecoder monoid (fun n => n < pow2 sz)
                     (fun n => n < pow2 sz)
                     eq format_nat decode_nat P
                     format_nat.
  Proof.
    apply_bijection_rule;
      intuition eauto using Word_decode_correct, wordToNat_bound, natToWord_wordToNat.
    apply wordToNat_natToWord_idempotent.
    apply Nomega.Nlt_in. rewrite Npow2_nat. rewrite Nnat.Nat2N.id. auto.

    derive_decoder_equiv.
  Qed.
End Nat.