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

Copyright (C) 2010-2013 Sylvie Boldo
#<br />#
Copyright (C) 2010-2013 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.
*)

(** * Relative error of the roundings *)
Require Import Fcore.

Section Fprop_relative.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Section Fprop_relative_generic.

Variable fexp : Z -> Z.
Context { prop_exp : Valid_exp fexp }.

Section relative_error_conversion.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Lemma relative_error_lt_conversion' :
  forall x b, (0 < b)%R ->
  (x <> 0 -> Rabs (round beta fexp rnd x - x) < b * Rabs x)%R ->
  exists eps,
  (Rabs eps < b)%R /\ round beta fexp rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x b Hb0 Hxb.
destruct (Req_dec x 0) as [Hx0|Hx0].
(* *)
exists R0.
split.
now rewrite Rabs_R0.
rewrite Hx0, Rmult_0_l.
apply round_0...
(* *)
specialize (Hxb Hx0).
exists ((round beta fexp rnd x - x) / x)%R.
split. 2: now field.
unfold Rdiv.
rewrite Rabs_mult.
apply Rmult_lt_reg_r with (Rabs x).
now apply Rabs_pos_lt.
rewrite Rmult_assoc, <- Rabs_mult.
rewrite Rinv_l with (1 := Hx0).
now rewrite Rabs_R1, Rmult_1_r.
Qed.

(* TODO: remove *)
Lemma relative_error_lt_conversion :
  forall x b, (0 < b)%R ->
  (Rabs (round beta fexp rnd x - x) < b * Rabs x)%R ->
  exists eps,
  (Rabs eps < b)%R /\ round beta fexp rnd x = (x * (1 + eps))%R.
Proof.
intros x b Hb0 Hxb.
apply relative_error_lt_conversion'.
exact Hb0.
now intros _.
Qed.

Lemma relative_error_le_conversion :
  forall x b, (0 <= b)%R ->
  (Rabs (round beta fexp rnd x - x) <= b * Rabs x)%R ->
  exists eps,
  (Rabs eps <= b)%R /\ round beta fexp rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x b Hb0 Hxb.
destruct (Req_dec x 0) as [Hx0|Hx0].
(* *)
exists R0.
split.
now rewrite Rabs_R0.
rewrite Hx0, Rmult_0_l.
apply round_0...
(* *)
exists ((round beta fexp rnd x - x) / x)%R.
split. 2: now field.
unfold Rdiv.
rewrite Rabs_mult.
apply Rmult_le_reg_r with (Rabs x).
now apply Rabs_pos_lt.
rewrite Rmult_assoc, <- Rabs_mult.
rewrite Rinv_l with (1 := Hx0).
now rewrite Rabs_R1, Rmult_1_r.
Qed.

End relative_error_conversion.

Variable emin p : Z.
Hypothesis Hmin : forall k, (emin < k)%Z -> (p <= k - fexp k)%Z.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Theorem relative_error :
  forall x,
  (bpow emin <= Rabs x)%R ->
  (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs x)%R.
Proof.
intros x Hx.
apply Rlt_le_trans with (ulp beta fexp x)%R.
now apply ulp_error.
unfold ulp, canonic_exp.
assert (Hx': (x <> 0)%R).
intros H.
apply Rlt_not_le with (2 := Hx).
rewrite H, Rabs_R0.
apply bpow_gt_0.
destruct (ln_beta beta x) as (ex, He).
simpl.
specialize (He Hx').
apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R.
rewrite <- bpow_plus.
apply bpow_le.
assert (emin < ex)%Z.
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := proj2 He).
exact Hx.
generalize (Hmin ex).
omega.
apply Rmult_le_compat_l.
apply bpow_ge_0.
apply He.
Qed.

(** 1+#ε# property in any rounding *)
Theorem relative_error_ex :
  forall x,
  (bpow emin <= Rabs x)%R ->
  exists eps,
  (Rabs eps < bpow (-p + 1))%R /\ round beta fexp rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error_lt_conversion...
apply bpow_gt_0.
now apply relative_error.
Qed.

Theorem relative_error_F2R_emin :
  forall m, let x := F2R (Float beta m emin) in
  (x <> 0)%R ->
  (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs x)%R.
Proof.
intros m x Hx.
apply relative_error.
unfold x.
rewrite <- F2R_Zabs.
apply bpow_le_F2R.
apply F2R_lt_reg with beta emin.
rewrite F2R_0, F2R_Zabs.
now apply Rabs_pos_lt.
Qed.

Theorem relative_error_F2R_emin_ex' :
  forall m, let x := F2R (Float beta m emin) in
  exists eps,
  (Rabs eps < bpow (-p + 1))%R /\ round beta fexp rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros m x.
apply relative_error_lt_conversion'...
apply bpow_gt_0.
now apply relative_error_F2R_emin.
Qed.

(* TODO: remove *)
Theorem relative_error_F2R_emin_ex :
  forall m, let x := F2R (Float beta m emin) in
  (x <> 0)%R ->
  exists eps,
  (Rabs eps < bpow (-p + 1))%R /\ round beta fexp rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros m x _.
apply relative_error_F2R_emin_ex'.
Qed.

Theorem relative_error_round :
  (0 < p)%Z ->
  forall x,
  (bpow emin <= Rabs x)%R ->
  (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs (round beta fexp rnd x))%R.
Proof with auto with typeclass_instances.
intros Hp x Hx.
apply Rlt_le_trans with (ulp beta fexp x)%R.
now apply ulp_error.
assert (Hx': (x <> 0)%R).
intros H.
apply Rlt_not_le with (2 := Hx).
rewrite H, Rabs_R0.
apply bpow_gt_0.
unfold ulp, canonic_exp.
destruct (ln_beta beta x) as (ex, He).
simpl.
specialize (He Hx').
assert (He': (emin < ex)%Z).
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := proj2 He).
exact Hx.
apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R.
rewrite <- bpow_plus.
apply bpow_le.
generalize (Hmin ex).
omega.
apply Rmult_le_compat_l.
apply bpow_ge_0.
generalize He.
apply round_abs_abs...
clear rnd valid_rnd x Hx Hx' He.
intros rnd valid_rnd x Hx.
rewrite <- (round_generic beta fexp rnd (bpow (ex - 1))).
now apply round_le.
apply generic_format_bpow.
ring_simplify (ex - 1 + 1)%Z.
generalize (Hmin ex).
omega.
Qed.

Theorem relative_error_round_F2R_emin :
  (0 < p)%Z ->
  forall m, let x := F2R (Float beta m emin) in
  (x <> 0)%R ->
  (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs (round beta fexp rnd x))%R.
Proof.
intros Hp m x Hx.
apply relative_error_round.
exact Hp.
unfold x.
rewrite <- F2R_Zabs.
apply bpow_le_F2R.
apply F2R_lt_reg with beta emin.
rewrite F2R_0, F2R_Zabs.
now apply Rabs_pos_lt.
Qed.

Variable choice : Z -> bool.

Theorem relative_error_N :
  forall x,
  (bpow emin <= Rabs x)%R ->
  (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs x)%R.
Proof.
intros x Hx.
apply Rle_trans with (/2 * ulp beta fexp x)%R.
now apply ulp_half_error.
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply Rlt_le.
apply Rinv_0_lt_compat.
now apply (Z2R_lt 0 2).
assert (Hx': (x <> 0)%R).
intros H.
apply Rlt_not_le with (2 := Hx).
rewrite H, Rabs_R0.
apply bpow_gt_0.
unfold ulp, canonic_exp.
destruct (ln_beta beta x) as (ex, He).
simpl.
specialize (He Hx').
apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R.
rewrite <- bpow_plus.
apply bpow_le.
assert (emin < ex)%Z.
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := proj2 He).
exact Hx.
generalize (Hmin ex).
omega.
apply Rmult_le_compat_l.
apply bpow_ge_0.
apply He.
Qed.

(** 1+#ε# property in rounding to nearest *)
Theorem relative_error_N_ex :
  forall x,
  (bpow emin <= Rabs x)%R ->
  exists eps,
  (Rabs eps <= /2 * bpow (-p + 1))%R /\ round beta fexp (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error_le_conversion...
apply Rlt_le.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
now apply (Z2R_lt 0 2).
apply bpow_gt_0.
now apply relative_error_N.
Qed.

Theorem relative_error_N_F2R_emin :
  forall m, let x := F2R (Float beta m emin) in
  (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros m x.
destruct (Req_dec x 0) as [Hx|Hx].
(* . *)
rewrite Hx, round_0...
unfold Rminus.
rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0.
rewrite Rmult_0_r.
apply Rle_refl.
(* . *)
apply relative_error_N.
unfold x.
rewrite <- F2R_Zabs.
apply bpow_le_F2R.
apply F2R_lt_reg with beta emin.
rewrite F2R_0, F2R_Zabs.
now apply Rabs_pos_lt.
Qed.

Theorem relative_error_N_F2R_emin_ex :
  forall m, let x := F2R (Float beta m emin) in
  exists eps,
  (Rabs eps <= /2 * bpow (-p + 1))%R /\ round beta fexp (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros m x.
apply relative_error_le_conversion...
apply Rlt_le.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
now apply (Z2R_lt 0 2).
apply bpow_gt_0.
now apply relative_error_N_F2R_emin.
Qed.

Theorem relative_error_N_round :
  (0 < p)%Z ->
  forall x,
  (bpow emin <= Rabs x)%R ->
  (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs (round beta fexp (Znearest choice) x))%R.
Proof with auto with typeclass_instances.
intros Hp x Hx.
apply Rle_trans with (/2 * ulp beta fexp x)%R.
now apply ulp_half_error.
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply Rlt_le.
apply Rinv_0_lt_compat.
now apply (Z2R_lt 0 2).
assert (Hx': (x <> 0)%R).
intros H.
apply Rlt_not_le with (2 := Hx).
rewrite H, Rabs_R0.
apply bpow_gt_0.
unfold ulp, canonic_exp.
destruct (ln_beta beta x) as (ex, He).
simpl.
specialize (He Hx').
assert (He': (emin < ex)%Z).
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := proj2 He).
exact Hx.
apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R.
rewrite <- bpow_plus.
apply bpow_le.
generalize (Hmin ex).
omega.
apply Rmult_le_compat_l.
apply bpow_ge_0.
generalize He.
apply round_abs_abs...
clear rnd valid_rnd x Hx Hx' He.
intros rnd valid_rnd x Hx.
rewrite <- (round_generic beta fexp rnd (bpow (ex - 1))).
now apply round_le.
apply generic_format_bpow.
ring_simplify (ex - 1 + 1)%Z.
generalize (Hmin ex).
omega.
Qed.

Theorem relative_error_N_round_F2R_emin :
  (0 < p)%Z ->
  forall m, let x := F2R (Float beta m emin) in
  (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs (round beta fexp (Znearest choice) x))%R.
Proof with auto with typeclass_instances.
intros Hp m x.
destruct (Req_dec x 0) as [Hx|Hx].
(* . *)
rewrite Hx, round_0...
unfold Rminus.
rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0.
rewrite Rmult_0_r.
apply Rle_refl.
(* . *)
apply relative_error_N_round with (1 := Hp).
unfold x.
rewrite <- F2R_Zabs.
apply bpow_le_F2R.
apply F2R_lt_reg with beta emin.
rewrite F2R_0, F2R_Zabs.
now apply Rabs_pos_lt.
Qed.

End Fprop_relative_generic.

Section Fprop_relative_FLT.

Variable emin prec : Z.
Variable Hp : Zlt 0 prec.

Lemma relative_error_FLT_aux :
  forall k, (emin + prec - 1 < k)%Z -> (prec <= k - FLT_exp emin prec k)%Z.
Proof.
intros k Hk.
unfold FLT_exp.
generalize (Zmax_spec (k - prec) emin).
omega.
Qed.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

(* TODO: remove *)
Theorem relative_error_FLT_F2R_emin :
  forall m, let x := F2R (Float beta m (emin + prec - 1)) in
  (x <> 0)%R ->
  (Rabs (round beta (FLT_exp emin prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros m x Hx.
apply relative_error_F2R_emin...
apply relative_error_FLT_aux.
Qed.

Theorem relative_error_FLT :
  forall x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  (Rabs (round beta (FLT_exp emin prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error with (emin + prec - 1)%Z...
apply relative_error_FLT_aux.
Qed.

Theorem relative_error_FLT_F2R_emin' :
  forall m, let x := F2R (Float beta m emin) in
  (x <> 0)%R ->
  (Rabs (round beta (FLT_exp emin prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros m x Zx.
destruct (Rlt_or_le (Rabs x) (bpow (emin + prec - 1))) as [Hx|Hx].
rewrite round_generic...
unfold Rminus.
rewrite Rplus_opp_r, Rabs_R0.
apply Rmult_lt_0_compat.
apply bpow_gt_0.
now apply Rabs_pos_lt.
apply generic_format_FLT_FIX...
apply Rlt_le.
apply Rlt_le_trans with (1 := Hx).
apply bpow_le.
apply Zle_pred.
apply generic_format_FIX.
now exists (Float beta m emin).
now apply relative_error_FLT.
Qed.

Theorem relative_error_FLT_F2R_emin_ex' :
  forall m, let x := F2R (Float beta m emin) in
  exists eps,
  (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros m x.
apply relative_error_lt_conversion'...
apply bpow_gt_0.
now apply relative_error_FLT_F2R_emin'.
Qed.

(* TODO: remove *)
Theorem relative_error_FLT_F2R_emin_ex :
  forall m, let x := F2R (Float beta m (emin + prec - 1)) in
  (x <> 0)%R ->
  exists eps,
  (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros m x _.
apply relative_error_lt_conversion'...
apply bpow_gt_0.
now apply relative_error_FLT_F2R_emin.
Qed.

(** 1+#ε# property in any rounding in FLT *)
Theorem relative_error_FLT_ex :
  forall x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  exists eps,
  (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error_lt_conversion...
apply bpow_gt_0.
now apply relative_error_FLT.
Qed.

Variable choice : Z -> bool.

Theorem relative_error_N_FLT :
  forall x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error_N with (emin + prec - 1)%Z...
apply relative_error_FLT_aux.
Qed.

(** 1+#ε# property in rounding to nearest in FLT *)
Theorem relative_error_N_FLT_ex :
  forall x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  exists eps,
  (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error_le_conversion...
apply Rlt_le.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
now apply (Z2R_lt 0 2).
apply bpow_gt_0.
now apply relative_error_N_FLT.
Qed.

Theorem relative_error_N_FLT_round :
  forall x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs (round beta (FLT_exp emin prec) (Znearest choice) x))%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error_N_round with (emin + prec - 1)%Z...
apply relative_error_FLT_aux.
Qed.

Theorem relative_error_N_FLT_F2R_emin' :
  forall m, let x := F2R (Float beta m emin) in
  (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros m x.
destruct (Rlt_or_le (Rabs x) (bpow (emin + prec - 1))) as [Hx|Hx].
rewrite round_generic...
unfold Rminus.
rewrite Rplus_opp_r, Rabs_R0.
apply Rmult_le_pos.
apply Rmult_le_pos.
apply Rlt_le.
apply (RinvN_pos 1).
apply bpow_ge_0.
apply Rabs_pos.
apply generic_format_FLT_FIX...
apply Rlt_le.
apply Rlt_le_trans with (1 := Hx).
apply bpow_le.
apply Zle_pred.
apply generic_format_FIX.
now exists (Float beta m emin).
now apply relative_error_N_FLT.
Qed.

(* TODO: remove *)
Theorem relative_error_N_FLT_F2R_emin :
  forall m, let x := F2R (Float beta m (emin + prec - 1)) in
  (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros m x.
apply relative_error_N_F2R_emin...
apply relative_error_FLT_aux.
Qed.

Theorem relative_error_N_FLT_F2R_emin_ex' :
  forall m, let x := F2R (Float beta m emin) in
  exists eps,
  (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros m x.
apply relative_error_le_conversion...
apply Rmult_le_pos.
apply Rlt_le.
apply (RinvN_pos 1).
apply bpow_ge_0.
now apply relative_error_N_FLT_F2R_emin'.
Qed.

(* TODO: remove *)
Theorem relative_error_N_FLT_F2R_emin_ex :
  forall m, let x := F2R (Float beta m (emin + prec - 1)) in
  exists eps,
  (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros m x.
apply relative_error_le_conversion...
apply Rlt_le.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
now apply (Z2R_lt 0 2).
apply bpow_gt_0.
now apply relative_error_N_FLT_F2R_emin.
Qed.

Theorem relative_error_N_FLT_round_F2R_emin' :
  forall m, let x := F2R (Float beta m emin) in
  (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs (round beta (FLT_exp emin prec) (Znearest choice) x))%R.
Proof with auto with typeclass_instances.
intros m x.
destruct (Rlt_or_le (Rabs x) (bpow (emin + prec - 1))) as [Hx|Hx].
rewrite round_generic...
unfold Rminus.
rewrite Rplus_opp_r, Rabs_R0.
apply Rmult_le_pos.
apply Rmult_le_pos.
apply Rlt_le.
apply (RinvN_pos 1).
apply bpow_ge_0.
apply Rabs_pos.
apply generic_format_FLT_FIX...
apply Rlt_le.
apply Rlt_le_trans with (1 := Hx).
apply bpow_le.
apply Zle_pred.
apply generic_format_FIX.
now exists (Float beta m emin).
apply relative_error_N_round with (emin := (emin + prec - 1)%Z)...
apply relative_error_FLT_aux.
Qed.

(* TODO: remove *)
Theorem relative_error_N_FLT_round_F2R_emin :
  forall m, let x := F2R (Float beta m (emin + prec - 1)) in
  (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs (round beta (FLT_exp emin prec) (Znearest choice) x))%R.
Proof with auto with typeclass_instances.
intros m x.
apply relative_error_N_round_F2R_emin...
apply relative_error_FLT_aux.
Qed.

Lemma error_N_FLT_aux :
  forall x,
  (0 < x)%R ->
  exists eps, exists  eta,
  (Rabs eps <= /2 * bpow (-prec + 1))%R /\
  (Rabs eta <= /2 * bpow (emin))%R      /\
  (eps*eta=0)%R /\
  round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps) + eta)%R.
Proof.
intros x Hx2.
case (Rle_or_lt (bpow (emin+prec)) x); intros Hx.
(* *)
destruct relative_error_N_ex with (FLT_exp emin prec) (emin+prec)%Z prec choice x
  as (eps,(Heps1,Heps2)).
now apply FLT_exp_valid.
intros; unfold FLT_exp.
rewrite Zmax_left; omega.
rewrite Rabs_right;[assumption|apply Rle_ge; now left].
exists eps; exists 0%R.
split;[assumption|split].
rewrite Rabs_R0; apply Rmult_le_pos.
auto with real.
apply bpow_ge_0.
split;[apply Rmult_0_r|idtac].
now rewrite Rplus_0_r.
(* *)
exists 0%R; exists (round beta (FLT_exp emin prec) (Znearest choice) x - x)%R.
split.
rewrite Rabs_R0; apply Rmult_le_pos.
auto with real.
apply bpow_ge_0.
split.
apply Rle_trans with (/2*ulp beta (FLT_exp emin prec) x)%R.
apply ulp_half_error.
now apply FLT_exp_valid.
apply Rmult_le_compat_l; auto with real.
unfold ulp.
apply bpow_le.
unfold FLT_exp, canonic_exp.
rewrite Zmax_right.
omega.
destruct (ln_beta beta x) as (e,He); simpl.
assert (e-1 < emin+prec)%Z.
apply (lt_bpow beta).
apply Rle_lt_trans with (2:=Hx).
rewrite <- (Rabs_right x).
apply He; auto with real.
apply Rle_ge; now left.
omega.
split;ring.
Qed.

End Fprop_relative_FLT.

Lemma error_N_FLT :
  forall (emin prec : Z), (0 < prec)%Z ->
  forall (choice : Z -> bool),
  forall (x : R),
  exists eps eta : R,
  (Rabs eps <= /2 * bpow (-prec + 1))%R /\
  (Rabs eta <= /2 * bpow emin)%R /\
  (eps * eta = 0)%R /\
  (round beta (FLT_exp emin prec) (Znearest choice) x
   = x * (1 + eps) + eta)%R.
Proof.
intros emin prec Pprec choice x.
destruct (Rtotal_order x 0) as [Nx|[Zx|Px]].
{ assert (Pmx : (0 < - x)%R).
  { now rewrite <- Ropp_0; apply Ropp_lt_contravar. }
  destruct (error_N_FLT_aux emin prec Pprec
                            (fun t : Z => negb (choice (- (t + 1))%Z))
                            (- x)%R Pmx)
    as (d,(e,(Hd,(He,(Hde,Hr))))).
  exists d; exists (- e)%R; split; [exact Hd|split; [|split]].
  { now rewrite Rabs_Ropp. }
  { now rewrite Ropp_mult_distr_r_reverse, <- Ropp_0; apply f_equal. }
  rewrite <- (Ropp_involutive x), round_N_opp.
  now rewrite Ropp_mult_distr_l_reverse, <- Ropp_plus_distr; apply f_equal. }
{ assert (Ph2 : (0 <= / 2)%R).
  { apply (Rmult_le_reg_l 2 _ _ Rlt_0_2).
    rewrite Rmult_0_r, Rinv_r; [exact Rle_0_1|].
    apply Rgt_not_eq, Rlt_gt, Rlt_0_2. }
  exists R0; exists R0; rewrite Zx; split; [|split; [|split]].
  { now rewrite Rabs_R0; apply Rmult_le_pos; [|apply bpow_ge_0]. }
  { now rewrite Rabs_R0; apply Rmult_le_pos; [|apply bpow_ge_0]. }
  { now rewrite Rmult_0_l. }
  now rewrite Rmult_0_l, Rplus_0_l, round_0; [|apply valid_rnd_N]. }
now apply error_N_FLT_aux.
Qed.

Section Fprop_relative_FLX.

Variable prec : Z.
Variable Hp : Zlt 0 prec.

Lemma relative_error_FLX_aux :
  forall k, (prec <= k - FLX_exp prec k)%Z.
Proof.
intros k.
unfold FLX_exp.
omega.
Qed.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Theorem relative_error_FLX :
  forall x,
  (x <> 0)%R ->
  (Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros x Hx.
destruct (ln_beta beta x) as (ex, He).
specialize (He Hx).
apply relative_error with (ex - 1)%Z...
intros k _.
apply relative_error_FLX_aux.
apply He.
Qed.

(** 1+#ε# property in any rounding in FLX *)
Theorem relative_error_FLX_ex' :
  forall x,
  exists eps,
  (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLX_exp prec) rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x.
apply relative_error_lt_conversion'...
apply bpow_gt_0.
now apply relative_error_FLX.
Qed.

(* TODO: remove *)
Theorem relative_error_FLX_ex :
  forall x,
  (x <> 0)%R ->
  exists eps,
  (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLX_exp prec) rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x _.
apply relative_error_FLX_ex'.
Qed.

Theorem relative_error_FLX_round :
  forall x,
  (x <> 0)%R ->
  (Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs (round beta (FLX_exp prec) rnd x))%R.
Proof with auto with typeclass_instances.
intros x Hx.
destruct (ln_beta beta x) as (ex, He).
specialize (He Hx).
apply relative_error_round with (ex - 1)%Z...
intros k _.
apply relative_error_FLX_aux.
apply He.
Qed.

Variable choice : Z -> bool.

Theorem relative_error_N_FLX :
  forall x,
  (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros x.
destruct (Req_dec x 0) as [Hx|Hx].
(* . *)
rewrite Hx, round_0...
unfold Rminus.
rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0.
rewrite Rmult_0_r.
apply Rle_refl.
(* . *)
destruct (ln_beta beta x) as (ex, He).
specialize (He Hx).
apply relative_error_N with (ex - 1)%Z...
intros k _.
apply relative_error_FLX_aux.
apply He.
Qed.

(** 1+#ε# property in rounding to nearest in FLX *)
Theorem relative_error_N_FLX_ex :
  forall x,
  exists eps,
  (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLX_exp prec) (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x.
apply relative_error_le_conversion...
apply Rlt_le.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
now apply (Z2R_lt 0 2).
apply bpow_gt_0.
now apply relative_error_N_FLX.
Qed.

Theorem relative_error_N_FLX_round :
  forall x,
  (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs (round beta (FLX_exp prec) (Znearest choice) x))%R.
Proof with auto with typeclass_instances.
intros x.
destruct (Req_dec x 0) as [Hx|Hx].
(* . *)
rewrite Hx, round_0...
unfold Rminus.
rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0.
rewrite Rmult_0_r.
apply Rle_refl.
(* . *)
destruct (ln_beta beta x) as (ex, He).
specialize (He Hx).
apply relative_error_N_round with (ex - 1)%Z.
now apply FLX_exp_valid.
intros k _.
apply relative_error_FLX_aux.
exact Hp.
apply He.
Qed.

End Fprop_relative_FLX.

End Fprop_relative.


Set Implicit Arguments.

From mathcomp Require Import all_ssreflect all_algebra all_field all_real_closed.
Local Open Scope ring_scope.
Import Num.Theory GRing.Theory.

Require Import other_stuff.
Require Import IMonad quantum_monad.
Require Import quantum.

Lemma zero_qubitP:
  \sum_(i < 2^1) `|('M{[:: [:: 1]; [:: 0]]}: 'cV[complex_stuff.R[i]]_(2^1)) i 0| ^+ 2 == 1.
Proof.
  intros; rewrite big_ord_recl; rewrite big_ord1;
  rewrite !mxE; rewrite !normc_def; rewrite !expr0n !expr1n;
  rewrite !addr0; rewrite !sqrtr0 !sqrtr1; rewrite !expr0n !expr1n;
  rewrite !addr0 //.
Qed.
Canonical zero_qubit := QubitVector zero_qubitP.

Lemma one_qubitP:
  \sum_(i < 2^1) `|('M{[:: [::0]; [:: 1]]}: 'cV[complex_stuff.R[i]]_(2^1)) i 0| ^+ 2 == 1.
Proof.
  intros. rewrite big_ord_recl. rewrite big_ord1.
  rewrite !mxE; rewrite !normc_def; rewrite !expr0n !expr1n;
  rewrite !addr0; rewrite !sqrtr0 !sqrtr1; rewrite !expr0n !expr1n; rewrite !add0r //.
Qed.
Canonical one_qubit := QubitVector one_qubitP.

Program Definition coinflip :=
  qio_bind
  (MkQbit (A:=bool) (i:=0) (o:=1) zero_qubit (QReturn true))
  (fun q => ApplyU hadamard_gate (QReturn true)).

Time Let x := Eval native_compute in (evalQIO coinflip (cons (1%:R, quantum.zero_qubit) nil)).
Print x.

Let y := Eval compute in length x.
Print y.


From mathcomp.ssreflect Require Import ssreflect eqtype.
Require Import Common Functor.
Require Import Coq.Logic.FunctionalExtensionality.

Inductive exprf a :=
| add : a -> a -> exprf a
| lit: nat -> exprf a.

Definition Algebra (F:functor) (a:Type)  := F a -> a.
Definition CoAlgebra (F:functor) (a:Type)  := F a -> a.

Definition exprf_fmap {A B} (f: A->B) (e: exprf A) :exprf B :=
  match e with
                 | add x x0 => add _ (f x) (f x0)
                 | lit x => lit _ x
  end.

Definition functor_exprf_mixin : Functor.mixin_of exprf.  refine ( FunctorMixin exprf (@exprf_fmap) _ _ ).  done.  move=> A B C f g.  extensionality e.  elim: e f g; by intros.  Defined.

Canonical ExprFFunctor := Functor exprf functor_exprf_mixin.

Definition eval: Algebra ExprFFunctor nat :=
  fun e=> match e with
            | add x y => x + y
            | lit x => x
          end.

(* I can't think of another way of expressing fixpoint *)

Inductive expr := In { Out: exprf expr }.
Definition Expr := In.
Definition ex := Expr ( add _ (Expr $ lit _ 4) (Expr $ lit _ 8)).

Definition expr_cata {T} (e: expr) (alg:Algebra ExprFFunctor T) : T :=


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

Require Import List.

Import ListNotations.

Require Import Undecidability.Synthetic.Undecidability.
Require Import Undecidability.Synthetic.ReducibilityFacts.

From Undecidability.Shared.Libs.DLW
  Require Import utils.

From Undecidability.PCP
  Require Import PCP.

From Undecidability.StackMachines
  Require Import BSM iPCPb_to_BSM_HALTING.

From Undecidability.MinskyMachines
  Require Import MM BSM_MM.

Import ReductionChainNotations UndecidabilityNotations.

Lemma iBPCP_chain_MM : ⎩iPCPb ⪯ₘ BSM_HALTING ⪯ₘ MM_HALTS_ON_ZERO⎭.
Proof.
  msplit 1.
  + apply iPCPb_to_BSM_HALTING.
  + apply BSM_MM_HALTS_ON_ZERO.
Qed.

Lemma iBPCP_to_MM : iPCPb ⪯ MM_HALTS_ON_ZERO.
Proof.
  reduce with chain iBPCP_chain_MM.
Qed.


From mathcomp Require Import all_ssreflect div.
Require Import PreOrders.
Require Import Types.
Require Import Cover.
Require Import FCL.
Require Import Coq.Lists.Streams.

Set Bullet Behavior "Strict Subproofs".
Import EqNotations.

Section TreeGrammarEnumeration.
  Variable Constructor: ctor.
  Variable Combinator: finType.

  Record FinSolutions : Type :=
    mkFS { card : nat;
           solutions : forall n, n < card -> @Term Combinator }.

  Definition fempty: FinSolutions :=
    mkFS 0 (fun n devil => False_rect _ (notF (rew (ltn0 n) in devil))).

  Lemma shiftsub: forall m n o, ~~(o < m) -> o < m + n -> o - m < n.
  Proof.
    move => m n o disprf prf.
    rewrite -(ltn_add2r m) addnC [X in _ < X]addnC subnKC => //.
    move: disprf.
      by rewrite -leqNgt.
  Qed.

  Definition fcat (fs1 fs2: FinSolutions): FinSolutions :=
    mkFS (card fs1 + card fs2)
         (fun n prf =>
            match (boolP (n < card fs1)) with
            | AltTrue prf' => solutions fs1 n prf'
            | AltFalse disprf => solutions fs2 (n - (card fs1)) (shiftsub _ _ _ disprf prf)
            end).

  Lemma shiftdiv: forall m n o, o < m * n -> (o %/ n) < m.
  Proof.
    move => m n o.
    case m0: (m == 0).
    - move: m0 => /eqP ->.
        by rewrite mul0n.
    - case n0: (n == 0).
      + move: n0 => /eqP ->.
          by rewrite muln0.
      + move => prf.
        rewrite ltn_divLR => //.
        move: n0 m0 prf.
          by case: n.
  Qed.

  Lemma shiftmod: forall m n o, o < m * n -> o %% n < n.
  Proof.
    move => m n o.
    case n0: (n == 0).
    - move: n0 => /eqP ->.
        by rewrite muln0.
    - rewrite ltn_pmod => //.
      move: n0.
        by case: n.
  Qed.

  Definition fapp (fs1 fs2: FinSolutions): FinSolutions :=
    mkFS (card fs1 * card fs2)
         (fun n prf =>
            (App (solutions fs1 (n %/ (card fs2)) (shiftdiv _ _ _ prf))
                 (solutions fs2 (n %% (card fs2)) (shiftmod _ _ _ prf)))).

  Definition Solutions := Stream FinSolutions.

  CoFixpoint sempty: Solutions := Cons fempty sempty.

  Fixpoint sofSeq (xss: seq FinSolutions): Solutions :=
    if xss is [:: xs & xss]
    then Cons xs (sofSeq xss)
    else sempty.

  CoFixpoint sreversals_corec
             (revss: seq FinSolutions)
             (xss: Solutions): Stream (seq FinSolutions) :=
    let withHead := [:: (hd xss) & revss] in
    Cons withHead (sreversals_corec withHead (tl xss)).

  Definition sreversals (xss: Solutions): Stream (seq FinSolutions) :=
    sreversals_corec [::] xss.

  Fixpoint sconvApp (xss: Solutions) (yss: seq FinSolutions): FinSolutions :=
    if yss is [:: ys & yss]
    then fcat (sconvApp (tl xss) yss) (fapp (hd xss) ys)
    else fempty.

  CoFixpoint sapp_corec (xss: Solutions) (yss: Stream (seq FinSolutions)) :=
    Cons (sconvApp xss (hd yss)) (sapp_corec xss (tl yss)).

  Definition sapp (xss: Solutions) (yss: Solutions) :=
    sapp_corec xss (sreversals yss).

  Definition fsingleton (t: @Term Combinator) : FinSolutions :=
    mkFS 1 (fun n prf => t).

  Definition ssingleton (t: @Term Combinator) : Solutions :=
    Cons (fsingleton t) sempty.

  Definition pay (s: Solutions): Solutions := Cons fempty s.

  CoFixpoint scat (xss yss: Solutions): Solutions :=
    Cons (fcat (hd xss) (hd yss)) (scat (tl xss) (tl yss)).

  Fixpoint sofSize (n: nat) (xss: Solutions): FinSolutions :=
    if n is n.+1 then sofSize n (tl xss) else hd xss.

  CoFixpoint addRule
             (r: @Rule Combinator Constructor)
             (xss: Stream (@IT Constructor -> FinSolutions)): Stream (@IT Constructor -> FinSolutions) :=
    match r with
    | RuleCombinator B c =>
      let: Cons xs xss := xss in
      Cons (fun A => if A == B then fcat (xs A) (fsingleton (Var c)) else (xs A)) xss
    | RuleApply B C D =>
      let xss' :=(addRule r (tl xss)) in
      let css := map (fun xs => xs C) xss' in
      let dss := map (fun xs => xs D) xss' in
      let bss := sapp css dss in
      Cons (hd xss) (zipWith (fun xs bs A => if A == B then fcat (xs A) bs else (xs A)) xss' bss)
    | _ => xss
    end.

  Fixpoint enumerate (G: @TreeGrammar Combinator Constructor): Stream (@IT Constructor -> FinSolutions) :=
    match G with
    | [:: RuleCombinator B c & G] =>
      let: Cons xs xss := enumerate G
      Cons (fun A => if  A == B then fcat (hd (enumerate A G)) (fsingleton (Var c)) else hd (enumerate A G)) (tl (enumerate A G))
    |
    | _ => sempty
    end.

End TreeGrammarEnumeration.

Section TestEnum.
  Definition Combinator := [finType of 'I_3].

  Definition t0 : @Term Combinator := Var (inord 0).
  Definition t1 : @Term Combinator := Var (inord 1).
  Definition t2 : @Term Combinator := Var (inord 2).

  Eval native_compute in (solutions _ (hd (scat _ (ssingleton _ t2) (sapp _ (ssingleton _ t0) (ssingleton _ t1)))) 0 isT).
End TestEnum.

*)


(** * Connexity *)

From DEZ.Is Require Export
  Commutative.

(** ** Connected Binary Relation *)
(** ** Connex Binary Relation *)
(** ** Total Binary Relation *)

(** This has the same shape as [Z.le_ge_cases]. *)

Class IsConnex (A : Type) (X : A -> A -> Prop) : Prop :=
  connex (x y : A) : X x y \/ X y x.

Section Context.

Context (A : Type) (X : A -> A -> Prop).

(** Connexity is a special case of commutativity up to disjunction. *)

#[local] Instance connex_is_comm_form_or `{!IsConnex X} : IsCommForm _\/_ X.
Proof. auto. Qed.

#[local] Instance comm_form_or_is_connex `{!IsCommForm _\/_ X} : IsConnex X.
Proof. auto. Qed.

End Context.

(** ** Complete Binary Relation *)
(** ** Strictly Connex Binary Relation *)
(** ** Strongly Connected Binary Relation *)

(** This has the same shape as [Z.lt_trichotomy]. *)

Class IsStrConnex (A : Type) (Xeq Xle : A -> A -> Prop) : Prop :=
  str_connex (x y : A) : Xle x y \/ Xeq x y \/ Xle y x.

Section Context.

Context (A : Type) (Xeq Xle : A -> A -> Prop).

(** A connex relation is strictly connex. *)

#[export] Instance connex_is_str_connex `{!IsConnex Xle} : IsStrConnex Xeq Xle.
Proof.
  intros x y. destruct (connex x y) as [a | b].
  - auto.
  - auto.
Qed.

End Context.


From Coq.Unicode Require Import Utf8.
From Coq.micromega Require Import Lia.
From trace_program_logic.prelude Require Import classical sigma.

Definition injective {A B} (f : A → B) := ∀ x y, f x = f y → x = y.

Lemma injective_compose {A B C} (f : A → B) (g : B → C) :
  injective f → injective g → injective (λ x, g (f x)).
Proof. intros Hf Hg x y Hxy; apply Hf, Hg; trivial. Qed.

Definition smaller_card A B := ∀ f : B → A, ¬ injective f.

Section quantifiers.
  Context (A : Type) (R : A → A → Prop)
          (Htotal : ∀ x y, R x y ∨ R y x)
          (Htrans : ∀ x y z, R x y → R y z → R x z).

  Definition subset := A → Prop.

  Definition subset_type (S : subset) : Type := sig S.

  Definition cofinal (S : subset) := ∀ x, ∃ y, S y ∧ R x y.

  Definition regular :=
    ∀ (S : subset), cofinal S → ∃ f : A → (subset_type S), injective f.

  Lemma not_cofinal_smaller S :
    ¬ cofinal S → ∃ x, ∀ y, S y → ¬ R x y.
  Proof.
    intros Hncf.
    apply not_forall_exists_not in Hncf as [x Hncf]; eauto 10.
  Qed.

  Definition union {I : Type} (fam : I → subset) : subset := λ x, ∃ i, fam i x.

  Lemma regular_union_of_smaller (I : Type) (fam : I → subset) :
    regular →
    smaller_card I A →
    (∀ i, ¬ cofinal (fam i)) →
    ¬ (cofinal (union fam)).
  Proof.
    intros Hreg HI Hfam Hcnf.
    pose proof (Hreg _ Hcnf) as [f Hf].
    assert (∀ i, ∃ x, ∀ y, fam i y → ¬ R x y) as Hmax.
    { intros i. apply not_cofinal_smaller; auto. }
    apply Choice in Hmax as [g Hg].
    set (Img := λ x, ∃ i, g i = x).
    assert (∀ x : subset_type Img, ∃ i : I, proj1_sig x = g i) as Himgback.
    { intros [? [? ?]]; eauto. }
    apply Choice in Himgback as [h Hh].
    assert (injective h).
    { intros x y Hxy.
      apply sig_eq; rewrite !Hh, Hxy; trivial. }
    assert (¬ cofinal Img) as Himgncnf.
    { intros Himgcnf.
      destruct (Hreg _ Himgcnf) as [h' Hh'].
      apply (HI (λ x, h (h' x))).
      apply injective_compose; auto. }
    apply not_cofinal_smaller in Himgncnf as [z Hz].
    destruct (Hcnf z) as [u [[i Hu1] Hu2]].
    assert (R z (g i)) as Hzgi.
    { pose proof (Hg i _ Hu1).
      destruct (Htotal (g i) u); [tauto|].
      eapply Htrans; eauto. }
    apply Hz in Hzgi; [|unfold Img]; eauto.
  Qed.

  Lemma regular_union_biger (I : Type) (fam : I → subset) :
    regular →
    smaller_card I A →
    (cofinal (union fam)) →
    ∃ i, cofinal (fam i).
  Proof.
    intros Hreg HI Hcnf.
    cut (∃ i, ¬ ¬ cofinal (fam i)).
    { intros [? ?]; eexists; apply NNP_P; eauto. }
    apply not_forall_exists_not.
    intros Hfam.
    eapply regular_union_of_smaller; eauto.
  Qed.

  Context (B : Type) (P : A → B → Prop).

  Definition fiber (b : B) : subset := λ x, P x b.

  Context (Hmono : ∀ x y z, R x y → P y z → P x z).

  Lemma cofinal_fiber_forall (b : B) : cofinal (fiber b) → ∀ x, P x b.
  Proof.
    intros Hb x.
    destruct (Hb x) as (y & Hy1 & Hy2).
    eapply Hmono; eauto.
  Qed.

  Context (Hrefl : ∀ x, R x x).

  Lemma forall_exists_swap :
    regular →
    smaller_card B A →
    (∀ x : A, ∃ y : B, P x y) → ∃ y, ∀ x, P x y.
  Proof.
    intros Hreg HB Hfe.
    destruct (regular_union_biger _ fiber) as [y Hy]; [trivial|trivial| |].
    { intros x. destruct (Hfe x) as [y Hy].
      exists x; split; [|apply Hrefl].
      eexists; eauto. }
    exists y; apply cofinal_fiber_forall; trivial.
  Qed.

End quantifiers.

Example nat_regular : regular nat le.
Proof.
  intros St HS.
  pose proof (Choice _ _ _ HS) as [f Hf].
  set (g :=
         fix g n :=
         match n with
         | 0 => f 0
         | S n' => f (S (g n'))
         end).
  assert (∀ n, St (g n)) as Hg.
  { destruct n; apply Hf. }
  assert (∀ x y, x < y → g x < g y) as Hglt.
  { intros x y; revert x.
    induction y as [|y IHy]; simpl; [lia|].
    intros x Hx.
    destruct (PeanoNat.Nat.eq_dec x y) as [->|].
    - pose proof (Hf (S (g y))) as [_ ?].
      lia.
    - pose proof (Hf (S (g y))) as [_ ?].
      assert (g x < g y).
      { apply IHy; lia. }
      lia. }
  set (G n := exist _ _ (Hg n)).
  exists G.
  intros x y Hxy.
  assert (proj1_sig (G x) = proj1_sig (G y)) by (rewrite Hxy; auto); simpl in *.
  destruct (Compare_dec.lt_eq_lt_dec x y) as [[|]|]; [|trivial; fail|].
  - assert (g x < g y) by (apply Hglt; lia); lia.
  - assert (g y < g x) by (apply Hglt; lia); lia.
Qed.


(* Dependencies *)
Require Export Coq.Bool.Bool.
Require Export Coq.omega.Omega.
Require Export Coq.Lists.List.
Export ListNotations.
Require Export Permutation.
Require Export Coq.Classes.RelationClasses.

Section SEARCH.

(*
Vertex:
  A Vertex contains a natural value,
  representing which Vertex it is.
*)
Inductive Vertex : Type :=
  v : nat -> Vertex.

Compute (v 3).

(*
vertex_eq_dec:
  Given two Vertices 'v1' and 'v2', they
  must have the same value or have
  different values.
*)
Lemma vertex_eq_dec :
  forall (v1 v2 : Vertex),
  v1 = v2 \/ v1 <> v2.
Proof.
  intros v1 v2.
  destruct v1 as [n1].
  destruct v2 as [n2].
  case (eq_nat_dec n1 n2).
  - intros H1. left.
    rewrite H1. reflexivity.
  - intros H1. right.
    injection as H2. contradiction.
Qed.

(*
beq_vertex:
  Given two Vertices 'a' and 'b',
  calculates if they have the same value.
*)
Fixpoint beq_vertex
 (v1 v2 : Vertex)
 : bool :=
  match v1 with v n1 =>
    match v2 with v n2 => beq_nat n1 n2
    end
  end.

(*
b_vertex_eq:
  For all Vertex 'v', it is always
  equal to itself.
*)
Lemma b_vertex_eq :
  forall (v : Vertex),
  beq_vertex v v = true.
Proof. Admitted.

Lemma vertex_noteq :
  forall (v1 v2 : Vertex),
  v1 <> v2 -> beq_vertex v1 v2 = false.
Proof. Admitted.

Lemma vertex_noteq_symmetry :
  forall (v1 v2 : Vertex),
  v1 <> v2 -> v2 <> v1.
Proof. Admitted.

(*
VertexList:
  A VertexList is a list of Vertices.
*)
Definition VertexList := list Vertex.

Compute ([v 3; v 5; v 10]).

(*
b_vl_contains_vertex:
  Given a Vertex 'v' and a VertexList 'vl',
  checks if 'vl' has a Vertex 'v'.
*)
Fixpoint b_vl_contains_vertex
 (v : Vertex)
 (vl : VertexList)
 : bool :=
  match vl with
  | [] => false
  | vlh :: vlt =>
    if beq_vertex v vlh
    then true
    else b_vl_contains_vertex v vlt
  end.

Example b_vl_contains_vertex_test_1:
  b_vl_contains_vertex (v 1) [v 2; v 3; v 4] = false.
Proof. simpl. reflexivity. Qed.
Example b_vl_contains_vertex_test_2:
  b_vl_contains_vertex (v 4) [v 2; v 3; v 4] = true.
Proof. simpl. reflexivity. Qed.

(*
b_vl_contains_repetition:
  Given a VertexList 'vl', checks if
  'vl' has a repeated Vertex.
*)
Fixpoint b_vl_contains_repetition
 (vl : VertexList)
 : bool :=
  match vl with
  | [] => false
  | v' :: vlt =>
      if b_vl_contains_vertex v' vlt
      then true
      else b_vl_contains_repetition vlt
  end.

Example b_vl_contains_repetition_test_1:
  b_vl_contains_repetition [v 1; v 3; v 5] = false.
Proof. simpl. reflexivity. Qed.
Example b_vl_contains_repetition_test_2:
  b_vl_contains_repetition [v 1; v 3; v 3] = true.
Proof. simpl. reflexivity. Qed.

(*
remove_vertex:
  Given a Vertex 'v' and a VertexList 'vl',
  removes 'v' from 'vl', if 'v' exists in
  'vl'.
*)
Fixpoint remove_vertex
 (v : Vertex)
 (vl : VertexList)
 : VertexList :=
  match vl with
  | [] => []
  | vlh :: vlt =>
      if beq_vertex v vlh
      then remove_vertex v vlt
      else vlh :: (remove_vertex v vlt)
  end.

(*
diff_vertex_lists:
  Given two VertexList 'a' and 'b', removes
  all Vertices from 'a' which exists in 'b'.
*)
Fixpoint diff_vertex_lists
 (vl1 vl2 : VertexList)
 : VertexList :=
  match vl2 with
  | [] => vl1
  | vl2h :: vl2t =>
      diff_vertex_lists
        (remove_vertex vl2h vl1) vl2t
  end.

Example diff_vertex_lists_test_1:
  diff_vertex_lists
    [v 2; v 3; v 1; v 1] [v 1; v 4]
    = [v 2; v 3].
Proof. simpl. reflexivity. Qed.

(*
  A AdjacencyList represents all the vertices
  (VertexList) that are pointed by an specific
  Vertex.
*)
Inductive AdjacencyList : Type :=
  al : Vertex -> VertexList -> AdjacencyList.

Compute (al (v 1) [v 3; v 5; v 10]).

(*
  Syntactic sugar for representing a
  NeighborsList.
*)
Notation "a -> [ b ; .. ; c ]" :=
  (al (v a) (cons (v b) .. (cons (v c) nil) ..))
  (at level 60, right associativity).
Notation "a -> [ ]" :=
  (al (v a) nil)
  (at level 60, right associativity).

(*
  A Graph is a list of AdjacencyList.
*)
Notation Graph := (list AdjacencyList).

Compute ([1 -> [2; 3; 4]; 2 -> [1; 3; 5]]).

(*
get_vertex_list:
  Given an Graph 'g', returns a
  VertexList containing the Vertex of all
  AdjacencyList in 'g'.
*)
Fixpoint get_vertex_list
 (g : Graph)
 : VertexList :=
  match g with
  | [] => []
  | (al v' vl) :: gt =>
      v' :: get_vertex_list gt
  end.

Example get_vertex_list_test_1:
  get_vertex_list
    [1 -> [2; 3; 4]; 2 -> [1; 3; 5]]
    = [v 1; v 2].
Proof. simpl. reflexivity. Qed.

(*
get_adjacency_list:
  Given a Graph 'g' and a Vertex 'v',
  returns the AdjacencyList of 'v' in 'g'.
*)
Fixpoint get_adjacency_list
 (v : Vertex)
 (g : Graph)
 : VertexList :=
  match g with
  | [] => []
  | (al v' vl) :: gt =>
      if beq_vertex v v'
      then vl
      else get_adjacency_list v gt
  end.

Example get_adjacency_list_test_1:
  get_adjacency_list
    (v 2)
    [1 -> [2; 3; 4]; 2 -> [1; 3; 5]]
    = [v 1; v 3; v 5].
Proof. simpl. reflexivity. Qed.

(*
n_vertices:
  Given a Graph 'g', returns the
  number of vertices in 'g'.
*)
Fixpoint n_vertices
 (g : Graph)
 : nat :=
  length g.

Example n_vertices_test_1:
  n_vertices
   [1 -> [2; 3; 4]; 2 -> [1; 3; 5]] = 2.
Proof. simpl. reflexivity. Qed.

(*
n_vertices:
  Given a Graph 'g', returns the
  number of edges in 'g'.
*)
Fixpoint n_edges
 (g : Graph)
 : nat :=
  match g with
  | [] => 0
  | (al v' vl) :: gt =>
      (length vl) + (n_edges gt)
  end.

Example n_edges_test_1:
  n_edges
   [1 -> [2; 3; 4]; 2 -> [1; 3; 5]] = 6.
Proof. simpl. reflexivity. Qed.

(*
b_well_formed:
  Given a Graph 'g', checks if:
  - 'g' does not contain repeated
    Vertices in its Vertex list;
  - each AdjacencyList of 'g' does
    not contain repeated Vertices
    in its Vertex list.
*)
Fixpoint b_well_formed
 (g : Graph)
 : bool :=
  if b_vl_contains_repetition (get_vertex_list g)
  then false
  else
    match g with
    | [] => true
    | (al v' vl) :: gt =>
        if b_vl_contains_repetition vl
        then false
        else b_well_formed gt
  end.

Example b_well_formed_test_1:
  b_well_formed
    [1 -> [2; 3; 4]; 2 -> [1; 3; 5]] = true.
Proof. simpl. reflexivity. Qed.
Example b_well_formed_test_2:
  b_well_formed
    [1 -> [2; 3; 4]; 1 -> [1; 3; 5]] = false.
Proof. simpl. reflexivity. Qed.
Example b_well_formed_test_3:
  b_well_formed
    [1 -> [2; 3; 4]; 2 -> [1; 3; 3]] = false.
Proof. simpl. reflexivity. Qed.

(*
well_formed:
  Same as b_well_formed, but returns
  a Prop.
*)
Fixpoint well_formed
 (g : Graph)
 : Prop :=
  if b_well_formed g
  then True
  else False.

(*
g_well_formed_add:
  For all Graph 'g', if 'g' plus an
  AdjacencyList with Vertex 'v' and
  its adjacenct vertices in 'vl' is
  a well formed Graph, then 'g' is
  also a well formed Graph.
*)
Lemma g_well_formed_add :
  forall (g : Graph) (vl : VertexList) (v : Vertex),
  well_formed ((al v vl) :: g) -> well_formed g.
Proof. Admitted.

(*
DFS:
*)

(*
# DFS definition in python:
# https://eddmann.com/posts/depth-first-search-and-breadth-first-search-in-python/

def dfs(graph, start):
  visited, stack = set(), [start]
  while stack:
    vertex = stack.pop()
    if vertex not in visited:
      visited.add(vertex)
      stack.extend(
        graph[vertex] - visited
      )
  return visited
*)

Fixpoint dfs_stack
 (g : Graph)
 (visited stack : VertexList)
 (calls : nat)
 : VertexList :=
  match calls with
  | 0 => rev visited
  | S calls' =>
      match stack with
      | [] => rev visited
      | vertex :: stack_pop =>
          if b_vl_contains_vertex vertex visited
          then dfs_stack g visited stack_pop calls'
          else dfs_stack g ([vertex] ++ visited)
            ((diff_vertex_lists (get_adjacency_list vertex g) visited) ++ stack_pop)
            calls'
      end
  end.

Fixpoint dfs
 (g : Graph)
 (start : Vertex)
 : VertexList :=
  if b_vl_contains_vertex start (get_vertex_list g)
  then dfs_stack g [] [start] ((n_vertices g) + (n_edges g))
  else [].

Example dfs_test_1:
  dfs
    ([0 -> [1; 2]; 1 -> [2]; 2 -> [0; 3]; 3 -> []]) (v 2)
    = [v 2; v 0; v 1; v 3].
Proof. simpl. reflexivity. Qed.
Example dfs_test_2:
  dfs
    ([0 -> [1; 2]; 1 -> [2]; 2 -> [0; 3]; 3 -> []]) (v 6)
    = [].
Proof. simpl. reflexivity. Qed.

(*
BFS:
*)

(*
# BFS definition in python:
# https://eddmann.com/posts/depth-first-search-and-breadth-first-search-in-python/

def bfs(graph, start):
  visited, queue = set(), [start]
  while queue:
    vertex = queue.pop(0)
    if vertex not in visited:
      visited.add(vertex)
      queue.extend(
        graph[vertex] - visited
      )
  return visited
*)

Fixpoint bfs_queue
 (g : Graph)
 (visited queue : VertexList)
 (calls : nat)
 : VertexList :=
  match calls with
  | 0 => rev visited
  | S calls' =>
      match queue with
      | [] => rev visited
      | vertex :: queue_pop =>
          if b_vl_contains_vertex vertex visited
          then bfs_queue g visited queue_pop calls'
          else bfs_queue g ([vertex] ++ visited)
            (queue_pop ++ (diff_vertex_lists (get_adjacency_list vertex g) visited))
            calls'
      end
  end.

Fixpoint bfs
 (g : Graph)
 (start : Vertex)
 : VertexList :=
  if b_vl_contains_vertex start (get_vertex_list g)
  then bfs_queue g [] [start] ((n_vertices g) + (n_edges g))
  else [].

Example bfs_test_1:
  bfs
    ([0 -> [1; 2]; 1 -> [2]; 2 -> [0; 3]; 3 -> []]) (v 2)
    = [v 2; v 0; v 3; v 1].
Proof. simpl. reflexivity. Qed.
Example bfs_test_2:
  bfs
    ([0 -> [1; 2]; 1 -> [2]; 2 -> [0; 3]; 3 -> []]) (v 5)
    = [].
Proof. simpl. reflexivity. Qed.

Example bfs_test_3:
  bfs
    ([0 -> [1; 2]]) (v 0)
    = [v 0; v 1; v 2].
Proof. simpl. reflexivity. Qed.

(*
DFS = BFS:
*)

(*
vg: start vertex in g
val : start vertex in al
vt: target vertex
*)

(*
dfs_add_al_val:
  For all well formed Graph 'g', if a Vertex
  'val' is found at the 'dfs' of 'g' plus an
  AdjacencyList with Vertex 'v' and its
  adjacenct vertices in 'vl' (starting from
  Vertex 'val'), then 'v' is equal to 'val'
  or 'val' is found at the 'dfs' of 'g'
  (also starting from Vertex 'val').
*)
(* Lemma dfs_add_al_val :
  forall (g : Graph) (vl : VertexList) (v val : Vertex),
  well_formed g ->
  (In val (dfs ((al v vl) :: g) val) <->
  (v = val) \/ In val (dfs g val)).
Proof. Admitted. *)
(*
bfs_add_al_val:
  For all well formed Graph 'g', if a Vertex
  'val' is found at the 'bfs' of 'g' plus an
  AdjacencyList with Vertex 'v' and its
  adjacenct vertices in 'vl' (starting from
  Vertex 'val'), then 'v' is equal to 'val'
  or 'val' is found at the 'bfs' of 'g'
  (also starting from Vertex 'val').
*)
(* Lemma bfs_add_al_val :
  forall (g : Graph) (vl : VertexList) (v val : Vertex),
  well_formed g ->
  (In val (bfs ((al v vl) :: g) val) <->
  (v = val) \/ In val (bfs g val)).
Proof. Admitted. *)

(*
dfs_stack_val:
  For all Vertex 'val', if it already
  exists inside VertexList 'visited', then
  'val' will continue existing inside
  'visited' while 'dfs_stack' is computed',
  once there are only insertions in
  'visited' inside 'dfs_stack' computation.
*)
(* Lemma dfs_stack_val :
  forall (g : Graph) (visited stack : VertexList) (calls : nat) (val : Vertex),
  In val visited -> In val (dfs_stack g visited stack calls).
Proof. Admitted. *)

(*
bfs_queue_val:
  For all Vertex 'val', if it already
  exists inside VertexList 'visited', then
  'val' will continue existing inside
  'visited' while 'bfs_queue' is computed',
  once there are only insertions in
  'visited' inside 'bfs_queue' computation.
*)
(* Lemma bfs_queue_val :
  forall (g : Graph) (visited queue : VertexList) (calls : nat) (val : Vertex),
  In val visited -> In val (bfs_queue g visited queue calls).
Proof. Admitted. *)

(*
dfs_val_al_val_true:
  Forall well formed Graph 'g' plus an
  AdjacencyList with Vertex 'val' and its
  adjacenct vertices in 'vl', 'val' is
  always found at the 'dfs' of 'g' with
  this AdjacencyList (once the 'dfs' would
  start from 'val' shortly).
*)
(* Lemma dfs_val_al_val_true :
  forall (g : Graph) (vl : VertexList) (val : Vertex),
  well_formed (al val vl :: g) ->
  In val (dfs (al val vl :: g) val).
Proof.
  intros.
  unfold dfs.
  simpl.
  rewrite (b_vertex_eq val).
  apply (
    dfs_stack_val
      (al val vl :: g)
      [val]
      (vl ++ [])
      (length g + (length vl + n_edges g))
      val
  ).
  simpl.
  left.
  reflexivity.
Qed. *)

(*
bfs_val_al_val_true:
  Forall well formed Graph 'g' plus an
  AdjacencyList with Vertex 'val' and its
  adjacenct vertices in 'vl', 'val' is
  always found at the 'bfs' of 'g' with
  this AdjacencyList (once the 'bfs' would
  start from 'val' shortly).
*)
(* Lemma bfs_val_al_val_true :
  forall (g : Graph) (vl : VertexList) (val : Vertex),
  well_formed (al val vl :: g) ->
  In val (bfs (al val vl :: g) val).
Proof.
  intros.
  unfold bfs.
  simpl.
  rewrite (b_vertex_eq val).
  apply (
    bfs_queue_val
      (al val vl :: g)
      [val]
      vl
      (length g + (length vl + n_edges g))
      val
  ).
  simpl.
  left.
  reflexivity.
Qed. *)

(*
dfs_extend_val_val:
  For all well formed Graph 'g', if a Vertex
  'val' is found at the 'dfs' of 'g'
  (starting from 'val'), then 'val' is still
  found by the 'dfs' when we add a
  AdjacencyList into 'g'.
*)
(* Lemma dfs_extend_val_val :
  forall (g : Graph) (vl : VertexList) (v val : Vertex),
  well_formed g ->
  (In val (dfs g val) -> In val (dfs (al v vl :: g) val)).
Proof.
  intros.
  apply (dfs_add_al_val g vl v0 val).
  - assumption.
  - right.
    assumption.
Qed. *)

(*
bfs_extend_val_val:
  For all well formed Graph 'g', if a Vertex
  'val' is found at the 'bfs' of 'g'
  (starting from the same Vertex 'val'),
  then 'val' is still found by the 'bfs'
  when we add a AdjacencyList into 'g'.
*)
(* Lemma bfs_extend_val_val :
  forall (g : Graph) (vl : VertexList) (v val : Vertex),
  well_formed g ->
  (In val (bfs g val) -> In val (bfs (al v vl :: g) val)).
Proof.
  intros.
  apply (bfs_add_al_val g vl v0 val).
  - assumption.
  - right.
    assumption.
Qed. *)

(*
dfs_bfs_equal_val_val:
  For all well formed Graph 'g', if a Vertex
  'val' is found at the 'dfs' of 'g' (starting
  from the same Vertex 'val'), then 'val' is
  also found at the bfs of 'g' (also starting
  from Vertex 'val'), and vice versa.
*)
(* Lemma dfs_bfs_equal_val_val :
  forall (g : Graph) (val : Vertex),
  well_formed g ->
  (In val (dfs g val) <-> In val (bfs g val)).
Proof.
  intros.
  split.
  - intros.
    induction g.
    + simpl in H0.
      contradiction.
    + destruct a.
      assert (H1 := H).
      apply g_well_formed_add in H.
      assert (H2 := IHg H).
      clear IHg.
      apply dfs_add_al_val in H0.
      * destruct H0.
        {
          rewrite H0.
          rewrite H0 in H1.
          clear H0.
          apply bfs_val_al_val_true.
          assumption.
        }
        {
          assert (H3 := H2 H0).
          clear H2.
          apply bfs_extend_val_val.
          {
            assumption.
          }
          {
            assumption.
          }
        }
      * assumption.
  - intros.
    induction g.
    + simpl in H0.
      contradiction.
    + destruct a.
      assert (H1 := H).
      apply g_well_formed_add in H.
      assert (H2 := IHg H).
      clear IHg.
      apply bfs_add_al_val in H0.
      * destruct H0.
        {
          rewrite H0.
          rewrite H0 in H1.
          clear H0.
          apply dfs_val_al_val_true.
          assumption.
        }
        {
          assert (H3 := H2 H0).
          clear H2.
          apply dfs_extend_val_val.
          {
            assumption.
          }
          {
            assumption.
          }
        }
      * assumption.
Qed. *)

Lemma dfs_stack_not_started_from_al :
  forall (g : Graph) (stack : VertexList) (calls : nat) (vl : VertexList) (v0 v1 : Vertex),
  v1 <> v0 ->
  In v0 (dfs_stack (al v1 vl :: g) [v0] stack calls) ->
  In v0 (dfs g v0).
Proof. Admitted.

Lemma bfs_queue_not_started_from_al :
  forall (g : Graph) (queue : VertexList) (calls : nat) (vl : VertexList) (v0 v1 : Vertex),
  v1 <> v0 ->
  In v0 (bfs_queue (al v1 vl :: g) [v0] queue calls) ->
  In v0 (bfs g v0).
Proof. Admitted.

Lemma dfs_extend_already_found_al :
  forall (g : Graph) (vl : VertexList) (v1 v2 : Vertex),
  In v2 (dfs g v1) -> In v2 (dfs (al v2 vl :: g) v1).
Proof. Admitted.

Lemma bfs_extend_already_found_al :
  forall (g : Graph) (vl : VertexList) (v1 v2 : Vertex),
  In v2 (bfs g v1) -> In v2 (bfs (al v2 vl :: g) v1).
Proof. Admitted.

Lemma dfs_stack_ignore_calls :
  forall (g : Graph) (visited stack : VertexList) (v : Vertex) (calls : nat),
  In v (dfs_stack g visited stack (S calls)) ->
  In v (dfs_stack g visited stack calls).
Proof. Admitted.

Lemma bfs_queue_ignore_calls :
  forall (g : Graph) (visited queue : VertexList) (v : Vertex) (calls : nat),
  In v (bfs_queue g visited queue (S calls)) ->
  In v (bfs_queue g visited queue calls).
Proof. Admitted.

(*
dfs_v_in_g:
  For all well formed Graph 'g', if a Vertex
  'v' is found at the 'dfs' of 'g' (starting
  from the same Vertex 'v'), then 'v' belongs
  to the list of Vertices of 'g', and vice
  versa.
*)
Lemma dfs_v_in_g :
  forall (g : Graph) (v : Vertex),
  well_formed g ->
  (In v (dfs g v) -> In v (get_vertex_list g)).
Proof.
  intros.
  induction g.
  - simpl in H0.
    contradiction.
  - destruct a.
    assert (H1 := H).
    apply g_well_formed_add in H1.
    assert (IHg := IHg H1).
    case (vertex_eq_dec v1 v0).
    + intros.
      simpl.
      left.
      assumption.
    + intros.
      simpl.
      right.
      simpl in H0.
      rewrite vertex_noteq in H0.
      * induction b_vl_contains_vertex in H0.
        {
          assert (H3 :=
            dfs_stack_not_started_from_al
              g
              (get_adjacency_list v0 g ++ [])
              (length g + (length v2 + n_edges g))
              v2 v0 v1).
          assert (H4 := H3 H2 H0).
          assert (H5 := IHg H4).
          assumption.
        }
        {
          simpl in H0.
          contradiction.
        }
      * apply vertex_noteq_symmetry.
        assumption.
Qed.

(*
bfs_v_in_g:
  For all well formed Graph 'g', if a Vertex
  'v' is found at the 'bfs' of 'g' (starting
  from the same Vertex 'v'), then 'v' belongs
  to the list of Vertices of 'g', and vice
  versa.
*)
Lemma bfs_v_in_g :
  forall (g : Graph) (v : Vertex),
  well_formed g ->
  (In v (bfs g v) -> In v (get_vertex_list g)).
Proof.
  intros.
  induction g.
  - simpl in H0.
    contradiction.
  - destruct a.
    assert (H1 := H).
    apply g_well_formed_add in H1.
    assert (IHg := IHg H1).
    case (vertex_eq_dec v1 v0).
    + intros.
      simpl.
      left.
      assumption.
    + intros.
      simpl.
      right.
      simpl in H0.
      rewrite vertex_noteq in H0.
      * induction b_vl_contains_vertex in H0.
        {
          assert (H3 :=
            bfs_queue_not_started_from_al
              g
              (get_adjacency_list v0 g)
              (length g + (length v2 + n_edges g))
              v2 v0 v1).
          assert (H4 := H3 H2 H0).
          assert (H5 := IHg H4).
          assumption.
        }
        {
          simpl in H0.
          contradiction.
        }
      * apply vertex_noteq_symmetry.
        assumption.
Qed.

(*
g_not_contains_val:
  For all well formed Graph 'g' plus an
  AdjacencyList with Vertex 'val' and its
  adjacenct vertices in 'vl', Vertex 'v'
  does not belong to the list of Vertices
  of 'g'.
*)
Lemma g_not_contains_v :
  forall (g : Graph) (vl : VertexList) (v : Vertex),
  well_formed (al v vl :: g) -> ~ In v (get_vertex_list g).
Proof.
  intros.
  assert (H0 := H).
  apply g_well_formed_add in H0.
  unfold well_formed in H.
  unfold b_well_formed in H.
  destruct (b_vl_contains_repetition (get_vertex_list (al v0 vl :: g))).
  - contradiction.
  - destruct (b_vl_contains_repetition vl).
    + contradiction.
    +
Admitted.

(*
dfs_transitivity:
  For all well formed Graph 'g', if a Vertex
  'val' is found at the 'dfs' of 'g' (starting
  from a Vertex 'vg') and a Vertex 'vt' is
  found at the 'dfs' of 'g' plus an
  AdjacencyList with Vertex 'val' and its
  adjacenct vertices in 'vl' (starting from
  Vertex 'vl'), then Vertex 'vt' is found at
  the 'dfs' of 'g' plus an AdjacencyList with
  Vertex 'val' and its adjacenct vertices in
  'vl' (starting from Vertex 'vg'), and vice
  versa.
*)
Lemma dfs_transitivity :
  forall (g : Graph) (vl : VertexList) (vg val vt : Vertex),
  well_formed g ->
  (In val (dfs g vg) /\ In vt (dfs ((al val vl) :: g) val)  <->
  In vt (dfs ((al val vl) :: g) vg)).
Proof.
  split.
  - intros.
    destruct H0.
    unfold dfs in H1.
    simpl in H1.
    rewrite (b_vertex_eq val) in H1.
    induction (length g + (length vl + n_edges g)) in H1.
    + simpl in H1.
      destruct H1.
      {
        rewrite H1.
        rewrite H1 in H0.
        clear H1.
        apply dfs_extend_already_found_al.
        assumption.
      }
      {
        contradiction.
      }
    + apply dfs_stack_ignore_calls in H1.
      assert (H2 := IHn H1).
      assumption.
  - intros.
    simpl in H0.
    case (vertex_eq_dec vg val).
    + intros.
      rewrite H1.
      rewrite H1 in H0.
      clear H1.
      rewrite (b_vertex_eq val) in H0.
      induction (length g + (length vl + n_edges g)) in H0.
      {
        simpl in H0.
        destruct H0.
        {
          rewrite H0.
          clear H0.

        }
      }
Admitted.

(*
bfs_transitivity:
  For all well formed Graph 'g', if a Vertex
  'val' is found at the 'dfs' of 'g' (starting
  from a Vertex 'vg') and a Vertex 'vt' is
  found at the 'dfs' of 'g' plus an
  AdjacencyList with Vertex 'val' and its
  adjacenct vertices in 'vl' (starting from
  Vertex 'vl'), then Vertex 'vt' is found at
  the 'dfs' of 'g' plus an AdjacencyList with
  Vertex 'val' and its adjacenct vertices in
  'vl' (starting from Vertex 'vg'), and vice
  versa.
*)
Lemma bfs_transitivity :
  forall (g : Graph) (vl : VertexList) (vg val vt : Vertex),
  well_formed g ->
  (In val (bfs g vg) /\ In vt (bfs ((al val vl) :: g) val)  <->
  In vt (bfs ((al val vl) :: g) vg)).
Proof. Admitted.

(*
dfs_bfs_equal:
  For all well formed Graph 'g', if a Vertex
  'vt' is found at the 'dfs' of 'g' (starting
  from Vertex 'vg'), then 'vt' is also found
  at the bfs of 'g' (also starting from Vertex
  'vg'), and vice versa.
*)
Theorem dfs_bfs_equal :
  forall (g : Graph) (vg vt : Vertex),
  well_formed g -> (In vt (dfs g vg) <-> In vt (bfs g vg)).
Proof.
  intros g vg vt wf.
  split.
  - induction g as [| al g].
    + intros.
      simpl in H.
      contradiction.
    + intros.
      destruct al as [val vl].
      apply (bfs_transitivity g vl vg val vt).
      * apply g_well_formed_add in wf.
        assumption.
      * apply (dfs_transitivity g vl vg val vt) in H.
        {
          destruct H.
          apply (dfs_transitivity g vl val val vt) in H0.
          {
            destruct H0.
            apply dfs_v_in_g in H0.
            {
              apply g_not_contains_v in wf.
              contradiction.
            }
            {
              apply g_well_formed_add in wf.
              assumption.
            }
          }
          {
            apply g_well_formed_add in wf.
            assumption.
          }
        }
        {
          apply g_well_formed_add in wf.
          assumption.
        }
  - induction g as [| al g].
    + intros.
      simpl in H.
      contradiction.
    + intros.
      destruct al as [val vl].
      apply (dfs_transitivity g vl vg val vt).
      * apply g_well_formed_add in wf.
        assumption.
      * apply (bfs_transitivity g vl vg val vt) in H.
        {
          destruct H.
          apply (bfs_transitivity g vl val val vt) in H0.
          {
            destruct H0.
            apply bfs_v_in_g in H0.
            {
              apply g_not_contains_v in wf.
              contradiction.
            }
            {
              apply g_well_formed_add in wf.
              assumption.
            }
          }
          {
            apply g_well_formed_add in wf.
            assumption.
          }
        }
        {
          apply g_well_formed_add in wf.
          assumption.
        }
Qed.

End SEARCH.


Require Export prosa.analysis.facts.transform.edf_opt.

(** * Optimality of EDF on Ideal Uniprocessors *)

(** This module provides the famous EDF optimality theorem: if there
    is any way to meet all deadlines (assuming an ideal uniprocessor
    schedule), then there is also an (ideal) EDF schedule in which all
    deadlines are met. *)

(** The following results assume ideal uniprocessor schedules... *)
Require prosa.model.processor.ideal.
(** ... and the basic (i.e., Liu & Layland) readiness model under which any
    pending job is always ready. *)
Require prosa.model.readiness.basic.

(** ** Optimality Theorem *)

Section Optimality.
  (** For any given type of jobs, each characterized by execution
      costs, an arrival time, and an absolute deadline,... *)
  Context {Job : JobType} `{JobCost Job} `{JobDeadline Job} `{JobArrival Job}.

  (** ... and any valid job arrival sequence. *)
  Variable arr_seq: arrival_sequence Job.
  Hypothesis H_arr_seq_valid: valid_arrival_sequence arr_seq.

  (** We observe that EDF is optimal in the sense that, if there exists
     any schedule in which all jobs of arr_seq meet their deadline,
     then there also exists an EDF schedule in which all deadlines are
     met. *)
  Theorem EDF_optimality:
    (exists any_sched : schedule (ideal.processor_state Job),
        valid_schedule any_sched arr_seq /\
        all_deadlines_of_arrivals_met arr_seq any_sched) ->
    exists edf_sched : schedule (ideal.processor_state Job),
        valid_schedule edf_sched arr_seq /\
        all_deadlines_of_arrivals_met arr_seq edf_sched /\
        EDF_schedule edf_sched.
  Proof.
    move=> [sched [[COME READY] DL_ARR_MET]].
    have ARR  := jobs_must_arrive_to_be_ready sched READY.
    have COMP := completed_jobs_are_not_ready sched READY.
    move: (all_deadlines_met_in_valid_schedule _ _ COME DL_ARR_MET) => DL_MET.
    set sched' := edf_transform sched.
    exists sched'. split; last split.
    - by apply edf_schedule_is_valid.
    - by apply edf_schedule_meets_all_deadlines_wrt_arrivals.
    - by apply edf_transform_ensures_edf.
  Qed.

End Optimality.

(** ** Weak Optimality Theorem *)

(** We further state a weaker notion of the above optimality result
    that avoids a dependency on a given arrival
    sequence. Specifically, it establishes that, given a reference
    schedule without deadline misses, there exists an EDF schedule of
    the same jobs in which no deadlines are missed. *)
Section WeakOptimality.

  (** For any given type of jobs, each characterized by execution
      costs, an arrival time, and an absolute deadline,... *)
  Context {Job : JobType} `{JobCost Job} `{JobDeadline Job} `{JobArrival Job}.

  (** ... if we have a well-behaved reference schedule ... *)
  Variable any_sched: schedule (ideal.processor_state Job).
  Hypothesis H_must_arrive: jobs_must_arrive_to_execute any_sched.
  Hypothesis H_completed_dont_execute: completed_jobs_dont_execute any_sched.

  (**  ... in which no deadlines are missed, ... *)
  Hypothesis H_all_deadlines_met: all_deadlines_met any_sched.

  (** ...then there also exists an EDF schedule in which no deadlines
      are missed (and in which exactly the same set of jobs is
      scheduled, as ensured by the last clause). *)
  Theorem weak_EDF_optimality:
    exists edf_sched : schedule (ideal.processor_state Job),
      jobs_must_arrive_to_execute edf_sched /\
      completed_jobs_dont_execute edf_sched /\
      all_deadlines_met edf_sched /\
      EDF_schedule edf_sched /\
      forall j,
          (exists t,  scheduled_at any_sched j t) <->
          (exists t', scheduled_at edf_sched j t').
  Proof.
    set sched' := edf_transform any_sched.
    exists sched'. repeat split.
    - by apply edf_transform_jobs_must_arrive.
    - by apply edf_transform_completed_jobs_dont_execute.
    - by apply edf_transform_deadlines_met.
    - by apply edf_transform_ensures_edf.
    - by move=> [t SCHED_j]; apply edf_transform_job_scheduled' with (t0 := t).
    - by move=> [t SCHED_j]; apply edf_transform_job_scheduled with (t0 := t).
  Qed.

End WeakOptimality.


(*interface (d) to show the difference
between SME-NI and the extended SIR-NNI*)

Require Export refine.
Require Export parser.
Require Import subsetconst.

Definition expr2d: IA := parse
"IA [s1,s2,s3,s4] (s1) [m1,m2] [m2_,m1_] [] [s1->(m1)s2, s1->(m2)s3, s2->(m2_)s4, s3->(m1_)s4]".

(*at m1: false*)
Definition expr2d_m1_rep: IA :=
 IAutomaton.hiding
  ( IAutomaton.replacement expr2d (&"tau") (ASet.GenActs [&"m2"]) )
  (ASet.GenActs [&"m2_"]).

Definition expr2d_m1_hid: IA :=
  IAutomaton.hiding expr2d (ASet.GenActs [&"m2",&"m2_"]).

Eval compute in SMENI_refinement expr2d_m1_rep expr2d_m1_hid.

(*at m2: false*)
Definition expr2d_m2_rep: IA :=
  IAutomaton.hiding
  ( IAutomaton.replacement expr2d (&"tau") (ASet.GenActs [&"m1"]) )
  (ASet.GenActs [&"m1_"]).

Definition expr2d_m2_hid: IA :=
  IAutomaton.hiding expr2d (ASet.GenActs [&"m1",&"m1_"]).

Eval compute in SMENI_refinement expr2d_m2_rep expr2d_m2_hid.

(*at l: true*)
Definition expr2d_l_rep: IA :=
 subset_construction
 ( IAutomaton.hiding
 ( IAutomaton.replacement expr2d (&"tau") (ASet.GenActs [&"m1",&"m2"]) )
 (ASet.GenActs [&"m1_",&"m2_"]) ).
(*Eval compute in IAutomaton.display expr2d_l_rep.*)

Definition expr2d_l_hid: IA :=
  IAutomaton.hiding expr2d (ASet.GenActs [&"m1",&"m2",&"m1_",&"m2_"]).

Eval compute in SMENI_refinement expr2d_l_rep expr2d_l_hid.


(* Test suite for [vpl_auto].
*)

Require Import QArith.
Require Export ZArith.
Require Import Tactic.

Parameter v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15 v16: Qc.

Lemma triv0: True.
Proof.
  vpl_auto.
Qed.

Lemma triv1: (55 # 33) < 2.
Proof.
  vpl_auto.
Qed.

Lemma triv2:  2 < (55 # 33) -> v1 < 1.
Proof.
  vpl_auto.
Qed.

Lemma decide1: v1 < 1 -> v1 <= 1.
Proof.
  vpl_auto.
Qed.

Lemma decide2: v1 < v2 -> v2 <= v3 -> v1 < v3.
Proof.
  vpl_auto.
Qed.

Lemma decide3: v1 <= (v2 + v3) -> v1 <= 3*(v3 -v2) -> 2*v1 <= 3*v3 (* failure: (2*v1 <= 3*v3)%Q *).
Proof.
  (* vpl_grab. intros; apply Input.goal_le. *)
  vpl_auto.
Qed.

Lemma decide4: 2 * v1 <= v2 -> 3 * v3 = 2 * (v1 + v2) -> v3 >= 2 * v1.
Proof.
  vpl_auto.
Qed.

Lemma decide5: v1 < v2 -> v3 > v2 -> (v3 < v4)%Q -> (v5 > v4)%Q -> v1 < v5.
Proof.
  vpl_auto.
Qed.

Lemma decide6: v1 <= v2 -> v3 >= v2 -> (v3 <= v4)%Q -> (v5 > v4)%Q -> v1 <> v5.
Proof.
  vpl_auto.
Qed.

Lemma decide7: v1 < v2 -> v3 >= v2 -> (v3 <= v4)%Q -> (v5 >= v4)%Q -> v5 > v1.
Proof.
  vpl_auto.
Qed.

Lemma decide8: v1 < v2 -> v3 > v2 -> (v3 < v4)%Q -> (v5 > v4)%Q -> (v5 > v1)%Q.
Proof.
  vpl_auto.
Qed.

Lemma decide9: v1 < v2 -> v3 > v2 -> (v3 < v4)%Q -> (v5 > v4)%Q -> (v1 < v5)%Q.
Proof.
  vpl_auto.
Qed.

Lemma decide10: v1 < v2 -> v3 >= v2 -> (v3 <= v4)%Q -> (v5 >= v4)%Q -> v5 >= v1.
Proof.
  vpl_auto.
Qed.

Lemma decide11: v1 < v2 -> v3 >= v2 -> (v3 <= v4)%Q -> (v5 >= v4)%Q -> (v5 >= v1)%Q.
Proof.
  vpl_auto.
Qed.

Lemma decide12: v1 <= v2 -> v2 <= v3 -> v3 <= v4 -> v4 <= v5 -> v5 <= v6 ->
                v6 <= v7 -> v7 < v8 -> v8 <= v9 -> v9 <= v10 -> v10 <= v11 ->
                v11 <= v12 -> v12 <= v13 -> v13 <= v14 -> v14 <= v15 -> v15 <= v16
                -> v1 < v16.
Proof.
  vpl_auto.
Qed.

Parameter sq: Qc -> Qc.

Lemma decideX: (2*((sq v1)+1)-2*(sq v1))*(sq v1) <= v2 -> 3 * v3 = 2 * ((sq v1) + v2) -> v3 <= v2.
Proof.
  vpl_auto.
Qed.

Lemma decideX_omega (sq: Z-> Z) (v1 v2 v3: Z): (2*(sq v1) <= v2 -> 3 * v3 = 2 * ((sq v1) + v2) -> v3 <= v2)%Z.
Proof.
  omega.
Qed.

Lemma decideX_omega_abort (v1 v2 v3: Z): ((2*(v1+1)-2*v1)*v1 <= v2 -> 3 * v3 = 2 * (v1 + v2) -> v3 <= v2)%Z.
Proof.
  try omega.
Abort.

Require Import Psatz.
Lemma decideX_lia (v1 v2 v3: Z): ((2*(v1+1)-2*v1)*v1 <= v2 -> 3 * v3 = 2 * (v1 + v2) -> v3 <= v2)%Z.
Proof.
  lia.
Qed.

Parameter A: Type.
Parameter f g: Qc -> A.

Lemma simpl1: v1 <= 1 -> (f v1) <> (f 1) -> v1 < 1.
Proof.
  vpl_auto.
Qed.

Lemma simpl1_omega (v1: Z) (A: Type) (f: Z -> A): (v1 <= 1 -> (f v1) <> (f 1) -> v1 < 1)%Z.
Proof.
  intros. try omega. idtac.
Abort.

Lemma simpl1_lia (v1: Z) (A: Type) (f: Z -> A): (v1 <= 1 -> (f v1) <> (f 1) -> v1 < 1)%Z.
Proof.
  intros. try lia. idtac.
Abort.

Lemma simpl1_lia (v1: Z) (A: Type) (f: Z -> A): (v1 <= 1 -> (f v1) <> (f 1) -> v1 >= 1  -> False)%Z.
Proof.
  intros. try lia. idtac.
Abort.

Lemma simpl2: v1 <= v2+v3 -> v2+v3 <= v4 -> ((f v1) = (f v4) -> (g (v3+v2)) <> (g v4))-> v1 < v4.
Proof.
  vpl_auto.
Qed.

Lemma simpl3: f v2 <> f ((1#2) * v3) -> v1 <= (v2 + v3) -> v1 <= 3*(v3-v2) -> 2*v1 < 3*v3.
Proof.
  vpl_auto.
Qed.

Lemma simpl4: 2*v1 <= v2 -> f v2 <> f v3 -> 3*v3 = 2*(v1+v2) -> 2*v1 < v3.
Proof.
  vpl_auto.
Qed.

Lemma simpl5:
 (f v3) <> (f v13) ->
  v1 <= v2 -> v2 <= v3 -> v3 <= v4 -> v4 <= v5 -> v5 <= v6 ->
  v6 <= v7 -> v7 <= v8 -> v8 <= v9 -> v9 <= v10 -> v10 <= v11 ->
  v11 <= v12 -> v12 <= v13 -> v13 <= v14 -> v14 <= v15 -> v15 <= v16 ->
  v1 < v16.
Proof.
  vpl_auto.
Qed.

Lemma simpl6 (f: Qc -> Qc):
  v1 <= v2 -> v2 <= v1 -> (f v1) <= (f v3) -> (f v3) <= (f v2) -> (f v3) = (f v1).
Proof.
  vpl_auto.
  vpl_auto.
Qed.


(** Author: Christian Doczkal *)
From mathcomp Require Import all_ssreflect.
From RegLang Require Import misc languages nfa two_way.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** ** Vardi Construction *)

Definition bsimp := (andbT,andbF,andTb,andFb,orbT,orbF,orTb,orFb).

(** Translation from 2NFAs to NFAs for the complement language *)

Section Vardi.
  Variables (char : finType) (M : nfa2 char).
  Implicit Types (x y z w v : word char) (U V W : {set M}) (X Y : {set M} * {set M}).

  Definition reject_cert x (T : pos x -> {set M}) :=
    [/\ nfa2_s M \in T ord1,
        [disjoint (nfa2_f M) & (T ord_max)] &
        forall i p j q, p \in T i -> step M x (p,i) (q,j) -> q \in T j ].

  Definition run_table x (i : pos x) := [set q | connect (step M x) (nfa2_s M, ord1) (q,i)].
  Arguments run_table x i : clear implicits.

  Lemma sub_run x C (i : pos x) : reject_cert C -> {subset run_table x i <= C i}.
  Proof.
    case => T1 T2 T3 p. rewrite inE. case/connectP => cs.
    elim/last_ind: cs p i => /= [p i _|cs c IH p i]; first by case => -> ->.
    rewrite rcons_path last_rcons [last _ _]surjective_pairing => /andP [pth stp] E. subst.
    apply: T3 stp. by apply: IH; rewrite -?surjective_pairing.
  Qed.

  Lemma dfa2Pn x : reflect (exists T, @reject_cert x T) (x \notin nfa2_lang M).
  Proof. apply: introP => [H|].
    - exists (run_table x) ; split; first by rewrite inE ?connect0.
      + apply/pred0P => q. rewrite !inE. apply: contraNF H => C.
        by apply/existsP; exists q.
      + move => i p j q. rewrite !inE => ? S. exact: connect_trans (connect1 S).
    - move/negPn => /exists_inP [q Hq1 Hq2] [c C].
      have/(sub_run C) H : q \in run_table x ord_max by rewrite inE.
      case: C => _ /disjoint_setI0 C _. move: C. move/setP/(_ q). by rewrite !inE Hq1 H.
  Qed.

  Section Completeness.
    Variables (a : char) (U V W : {set M}).

    Definition compL := [forall p in U, forall q, (q \in nfa2_transL p) ==> (q \in V)].

    Definition compR := [forall p in V, forall q, (q \in nfa2_transR p) ==> (q \in U)].

    Definition comp := [forall p in V, forall q,
      (((q,L) \in nfa2_trans p a) ==> (q \in U)) && (((q,R) \in nfa2_trans p a) ==> (q \in W))].

  End Completeness.

  Definition nfa_of :=
    {| nfa_s   := [set X : {set M} * {set M} | (nfa2_s M \in X.2) & compL X.1 X.2];
       nfa_fin := [set X : {set M} * {set M} | [disjoint (nfa2_f M) & X.2] & compR X.1 X.2];
       nfa_trans X a Y := (X.2 == Y.1) && comp a X.1 X.2 Y.2 |}.

  Lemma nfa_ofP x : reflect (exists T, @reject_cert x T) (x \in nfa_lang nfa_of).
  Proof. apply: (iffP nfaP).
    - move => [s] [r] [Hp Hr].
      pose T (i : pos x) := if i:nat is i'.+1 then (nth s (s::r) i').2 else (nth s (s::r) 0).1.
      have T_comp (j : 'I_(size x)) :
          comp (tnth (tape x) j) (T (inord j)) (T (inord j.+1)) (T (inord j.+2)).
        case: j => /= m Hm. move: (run_trans Hm Hr) => /andP [_].
        have -> : (nth s (s :: r) m).1 = T (inord m).
          case: m Hm => [|m] Hm; first by rewrite -inord0.
          rewrite /T inordK ?ltnS // 2?ltnW //.
          move/ltnW : Hm => Hm. by case/andP : (run_trans Hm Hr) => /eqP-> ?.
        have -> : (nth s (s :: r) m).2 = T (inord m.+1) by rewrite /T inordK // ltnS ltnW.
        have -> // : (nth s r m).2 = T (inord m.+2). by rewrite /T inordK // ltnS.
      exists T. split => //.
      + rewrite /T /=. move: Hp. rewrite inE. by case/andP.
      + rewrite /T /= (run_size Hr) -last_nth.
        move/run_last : (Hr). rewrite inE. by case/andP.
      + move => i p j q H. rewrite /step /read.
        case: (ord2P _) => [/eqP ?|/eqP ?|i' Hi']; subst => //=.
        * rewrite [_ == 0]eqn_leq ltn0 !bsimp => /andP [q1 q2].
          rewrite /T (eqP q2) /= in H *.
          move: Hp. rewrite !inE => /andP [_ /forall_inP /(_ _ H) /forall_inP].
          apply. by rewrite !inE eqxx andbT /= in q1.
        * rewrite [_ == _.+2](ltn_eqF) // !bsimp eqSS => /andP [q1 q2].
          rewrite /T /= (run_size Hr) -[size r]/((size (s :: r)).-1) nth_last in H.
          move: (run_last Hr). rewrite inE. rewrite !inE eqxx andbT /= in q1.
          move => /andP [_ /forall_inP /(_ p H) /forall_inP /(_ q q1)].
          rewrite /T (eqP q2) (run_size Hr). case e : (size r) => [|m] ; first by rewrite (size0nil e).
          have Hm : m < size x by rewrite -e (run_size Hr).
          rewrite -nth_last e /=. by case/andP: (run_trans Hm Hr) => /eqP ->.
        - move: (T_comp i') => /= /forall_inP /(_ p). rewrite Hi' inord_val => /(_ H) /forallP /(_ q).
          case/andP => q1 q2.
          case/orP; case/andP => Ht e; rewrite ?Ht /= in q1 q2.
          -- move: q2. by rewrite /T (eqP e) inordK // -Hi' ?ltnS.
          -- move: q1. rewrite -Hi' eqSS in e. by rewrite -(eqP e) -{2}[j]inord_val.
    - move => [T] [T1 T2 T3].
      set s := (T ord0, T ord1). exists s.
      set r := [tuple (T (inord i.+1), T (inord i.+2)) | i < (size x)]. exists r.
      have E m : m <= size x -> nth s (s :: r) m = (T (inord m), T (inord m.+1)).
        case: m => m; first by rewrite nth0 /= -inord0 -inord1.
        move => H. by rewrite [r]lock /= -lock -[m]/(val (Ordinal H)) -tnth_nth tnth_mktuple.
      split.
      + rewrite inE /= T1 /=. apply/forall_inP => p /T3 H. apply/forall_inP => q Hq.
        apply: H. by rewrite /step /read ord2P0 !inE Hq eqxx.
      + apply: runI.
        * by rewrite size_map size_enum_ord.
        * rewrite -nth_last [nth _ _ _](_ : _ = nth s (s::r) (size r)); last by case: (tval r).
          rewrite size_tuple E // -inord_max inE /= T2 /=.
          apply/forall_inP => p /T3 H. apply/forall_inP => q Hq.
          apply H. by rewrite /step /read ord2PM !inE Hq inordK // eqxx !bsimp.
        * move => i. rewrite unfold_in. rewrite !E //= 1?ltnW // eqxx /=.
          apply/forall_inP => p /T3 H. apply/forallP => q.
          have Hi : i.+1 = (inord i.+1 : pos x). by rewrite inordK // !ltnS 1?ltnW //.
          apply/andP ; split; apply/implyP => Ht; apply H; rewrite /step /read /= (ord2PC Hi) Ht.
          - by rewrite !inordK ?eqxx ?bsimp // !(ltn_ord,ltnS,ltnW).
          - by rewrite !inordK ?eqxx ?bsimp // !(ltn_ord,ltnS,ltnW).
  Qed.

  Lemma nfa_of_correct : nfa_lang nfa_of =i [predC (nfa2_lang M) ].
  Proof. move => w. rewrite !inE. apply/idP/dfa2Pn; by move/nfa_ofP. Qed.
End Vardi.