(** Formalization of generic properties of complex
  numbers, complex vectors and complex matrices *)

Require Import Reals Psatz R_sqrt R_sqr.
From mathcomp Require Import all_algebra all_ssreflect ssrnum bigop.
From mathcomp.analysis Require Import boolp Rstruct classical_sets posnum
     topology normedtype landau sequences.
Require Import Coquelicot.Lim_seq.
Require Import Coquelicot.Rbar.
Require Import Coquelicot.Hierarchy Coquelicot.Lub.
From mathcomp Require Import mxalgebra matrix all_field.
From canonical_forms Require Import jordan similar closed_poly frobenius_form.
From CoqEAL Require Import mxstructure ssrcomplements.

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

Open Scope R_scope.
Open Scope ring_scope.

Delimit Scope ring_scope with Ri.
Delimit Scope R_scope with Re.

Import Order.TTheory GRing.Theory Num.Def Num.Theory.

Open Scope classical_set_scope.

From mathcomp Require Import complex.
Import ComplexField.

(** Define the modulus of a complex number **)
Definition C_mod (x: R[i]):=
   sqrt ( (Re x)^+2 + (Im x)^+2).

(** Properties of the modulus of a complex number **)
Lemma C_mod_0: C_mod 0 = 0%Re.
Proof.
by rewrite /C_mod /= expr2 mul0r Rplus_0_r sqrt_0.
Qed.

Lemma C_mod_ge_0:
  forall (x: complex R), (0<= C_mod x)%Re.
Proof.
intros. unfold C_mod. apply sqrt_pos.
Qed.

Lemma Re_complex_prod: forall (x y: complex R),
  Re (x * y) = Re x * Re y - Im x * Im y.
Proof.
intros. destruct x. destruct y. simpl. by [].
Qed.

Lemma Im_complex_prod: forall (x y:complex R),
  Im (x * y) = Re x * Im y + Im x * Re y.
Proof.
intros. destruct x. destruct y. simpl. by [].
Qed.

Lemma C_mod_prod: forall (x y: complex R),
  C_mod (x * y) = C_mod x * C_mod y.
Proof.
intros. rewrite /C_mod -[RHS]RmultE -sqrt_mult.
+ assert ( Re (x * y) ^+ 2 + Im (x * y) ^+ 2 =
            ((Re x ^+ 2 + Im x ^+ 2) * (Re y ^+ 2 + Im y ^+ 2))).
  { rewrite Re_complex_prod Im_complex_prod.
    rewrite -!RpowE -!RmultE -!RplusE -!RoppE. nra.
  } by rewrite !RplusE H.
+ apply Rplus_le_le_0_compat;rewrite -RpowE; nra.
+ apply Rplus_le_le_0_compat;rewrite -RpowE; nra.
Qed.

Lemma Re_complex_div: forall (x y: complex R),
  Re (x / y) = (Re x * Re y + Im x * Im y) / ((Re y)^+2 + (Im y)^+2).
Proof.
intros. destruct x, y.
by rewrite /= mulrDl mulrN opprK !mulrA.
Qed.

Lemma Im_complex_div: forall (x y: complex R),
  Im (x / y) = ( - (Re x * Im y) + Im x * Re y) / ((Re y)^+2 + (Im y)^+2).
Proof.
intros. destruct x, y.
by rewrite /= mulrDl mulrN mulNr !mulrA.
Qed.

Lemma complex_not_0 (x: complex R) :
  (Re x +i* Im x)%C != 0 -> Re x != 0 \/ Im x != 0.
Proof.
rewrite eq_complex /=. intros. by apply /nandP.
Qed.

Lemma sqr_complex_not_zero: forall (x: complex R),
  x <> 0 -> (Re x)^+2 + (Im x)^+2 <> 0.
Proof.
intros.
assert ( x !=0). { by apply /eqP. }
rewrite -!RpowE -RplusE.
assert ( ( 0< Re x ^ 2 + Im x ^ 2)%Re ->
          (Re x ^ 2 + Im x ^ 2)%Re <> 0%Re).
{ nra. } apply H1.
assert ( (Re x <> 0)%Re \/ ( Im x <> 0)%Re ->
          (0 < Re x ^ 2 + Im x ^ 2)%Re). { nra. }
apply H2.
assert ( (Re x <> 0)  <-> (Re x !=0)).
{ split.
  + intros. by apply /eqP.
  + intros. by apply /eqP.
} rewrite H3.
assert ( (Im x <> 0)  <-> (Im x !=0)).
{ split.
  + intros. by apply /eqP.
  + intros. by apply /eqP.
} rewrite H4.
apply complex_not_0. clear H H1 H2 H3 H4.
move : H0. destruct x. by [].
Qed.

Lemma div_prod: forall (x:R),
  x <> 0 -> x / (x * x) = x^-1.
Proof.
intros. rewrite -RdivE.
assert ( (x / (x * x)%Ri)%Re  = (x * (/ (x*x)))%Re).
{ by []. } rewrite H0.
+ rewrite Rinv_mult_distr.
  - rewrite -Rmult_assoc. rewrite Rinv_r.
    * assert ( (1 * / x)%Re = (1/x)%Re). { nra. }
      rewrite H1. rewrite RdivE.
      { apply div1r. }
      { by apply /eqP. }
    * exact H.
  - exact H.
  - exact H.
+ apply /eqP. auto.
Qed.

Lemma C_mod_div: forall (x y: complex R),
  y <> 0 -> C_mod (x / y) = (C_mod x) / (C_mod y).
Proof.
intros. rewrite /C_mod -[RHS]RdivE.
+ rewrite -sqrt_div.
  - assert ( (Re (x / y) ^+ 2 + Im (x / y) ^+ 2) =
      ((Re x ^+ 2 + Im x ^+ 2) / (Re y ^+ 2 + Im y ^+ 2))).
    { rewrite Re_complex_div Im_complex_div !expr_div_n -mulrDl sqrrD.
      assert ( (- (Re x * Im y) + Im x * Re y) =
                Im x * Re y - (Re x * Im y)).
      { by rewrite addrC. } rewrite H0. clear H0.
      rewrite sqrrB //= !addrA !mulrA.
      assert ( ((Re x * Re y) ^+ 2 + Re x * Re y * Im x * Im y +
             Re x * Re y * Im x * Im y + (Im x * Im y) ^+ 2 +
             (Im x * Re y) ^+ 2 - Im x * Re y * Re x * Im y *+ 2 +
             (Re x * Im y) ^+ 2) =
              (Re x ^+ 2 + Im x ^+ 2) * (Re y ^+ 2 + Im y ^+ 2)).
      { rewrite !expr2 mulr2n !mulrA.
        rewrite -!RmultE -!RplusE -!RoppE Rmult_comm. nra.
      } rewrite H0. clear H0. rewrite -mulrA.
      assert ( ((Re y ^+ 2 + Im y ^+ 2) / (Re y ^+ 2 + Im y ^+ 2) ^+ 2)=
                (Re y ^+ 2 + Im y ^+ 2)^-1).
      { assert ( (Re y ^+ 2 + Im y ^+ 2) ^+ 2 =
                (Re y ^+ 2 + Im y ^+ 2) * (Re y ^+ 2 + Im y ^+ 2)).
        { by rewrite expr2. }
        rewrite H0. clear H0. apply div_prod.
        by apply sqr_complex_not_zero.
      } by rewrite H0.
    } rewrite !RplusE.
    rewrite RdivE.
    * by rewrite H0.
    * apply /eqP. by apply sqr_complex_not_zero.
  - apply Rplus_le_le_0_compat;rewrite -RpowE; nra.
  - assert ( (Re y ^ 2 + Im y ^ 2)%Re <> 0%Re ->
            (0 < Re y ^ 2 + Im y ^ 2)%Re). { nra. }
    rewrite -!RpowE. apply H0. rewrite !RpowE.
    by apply sqr_complex_not_zero.
+ apply /eqP. rewrite -!RpowE.
  assert ( (0< sqrt (Re y ^ 2 + Im y ^ 2))%Re ->
          sqrt (Re y ^ 2 + Im y ^ 2) <> 0%Re).  { nra. }
  apply H0. apply sqrt_lt_R0.
  assert ( (Re y ^ 2 + Im y ^ 2)%Re <> 0%Re ->
            (0 < Re y ^ 2 + Im y ^ 2)%Re). { nra. }
  apply H1. rewrite !RpowE.
  by apply sqr_complex_not_zero.
Qed.

Lemma C_mod_not_zero: forall (x: complex R),
  x <> 0 -> C_mod x <> 0.
Proof.
intros. rewrite /C_mod.
have H1: forall x:R, (0 < x)%Re -> sqrt x <> 0%Re.
  move => a Ha.
  assert ( (0< sqrt a)%Re ->  sqrt a <> 0%Re). { nra. }
  apply H0. apply sqrt_lt_R0; nra.
apply H1. rewrite -!RpowE.
assert ( (Re x ^ 2 + Im x ^ 2)%Re <> 0%Re ->
            (0 < Re x ^ 2 + Im x ^ 2)%Re). { nra. }
apply H0. rewrite !RpowE.
by apply sqr_complex_not_zero.
Qed.

Lemma C_mod_1: C_mod 1 = 1.
Proof.
by rewrite /C_mod /= !expr2 mul1r mul0r Rplus_0_r sqrt_1.
Qed.

Lemma C_mod_pow: forall (x: complex R) (n:nat),
  C_mod (x^+ n) = (C_mod x)^+n.
Proof.
intros. induction n.
+ by rewrite !expr0 C_mod_1.
+ by rewrite !exprS C_mod_prod IHn.
Qed.

Lemma C_destruct: forall (x: complex R), x = (Re x +i* Im x)%C.
Proof.
by move => [a b].
Qed.

Lemma C_mod_minus_x: forall (x: complex R),
  C_mod (-x) = C_mod x.
Proof.
intros. rewrite /C_mod //=.
assert (x = (Re x +i* Im x)%C).
{ by rewrite -C_destruct. } rewrite H //=.
rewrite !expr2. by rewrite !mulrNN.
Qed.

Lemma complex_not_0_sym: forall (x : complex R),
  Re x != 0 \/ Im x != 0 -> (Re x +i* Im x)%C != 0.
Proof.
intros. rewrite eq_complex /=. by apply /nandP.
Qed.

(** Define a coercion from real to complex **)
Definition RtoC (x:R):= (x +i* 0)%C.

(** Compatibilty between C_mod and normc in the mathcomp/complex
  libary **)
Lemma C_modE y : C_mod y = normc y.
Proof.
rewrite /C_mod RsqrtE /normc; case: y => [ry iy] //=.
by rewrite RplusE addr_ge0 // sqr_ge0.
Qed.

Lemma normcV (y : complex R) : y != 0 -> normc (y^-1) = (normc y)^-1.
Proof.
move=> yn0.
have normyn0 : normc y != 0 by apply/eqP=> /eq0_normc /eqP; apply/negP.
apply: (mulfI normyn0); rewrite mulfV // -normcM mulfV //.
by rewrite /normc /= expr0n /= addr0 expr1n sqrtr1.
Qed.

Lemma C_mod_invE (y : complex R) : C_mod (y ^-1) = (C_mod y) ^-1.
Proof.
have [/eqP y0 | yn0] := boolP (y == 0); last by rewrite !C_modE normcV.
rewrite y0 /C_mod /= !mul0r oppr0 expr0n /= RplusE mulr0n add0r RsqrtE //.
by rewrite sqrtr0 invr0.
Qed.

Lemma C_mod_eq_0: forall (x: complex R),
  C_mod x = 0 -> x = 0.
Proof.
intros. rewrite /C_mod in H.
assert ((Re x ^+ 2 + Im x ^+ 2) = 0).
{ apply sqrt_eq_0.
  + rewrite -!RpowE -RplusE. nra.
  + apply H.
} clear H.
assert ((Re x ^+ 2 =0) /\ (Im x ^+ 2 = 0)).
{ apply Rplus_eq_R0.
  + rewrite -RpowE. nra.
  + rewrite -RpowE. nra.
  + apply H0.
} destruct H.
assert (Re x = 0 /\ Im x = 0).
{ rewrite -RpowE in H. rewrite -RpowE in H1.
  split.
  + apply Rsqr_0_uniq. rewrite /Rsqr.
    assert ((Re x ^ 2)%Re = (Re x * Re x)%Re). { nra. }
    by rewrite -H2.
  + apply Rsqr_0_uniq. rewrite /Rsqr.
    assert ((Im x ^ 2)%Re = (Im x * Im x)%Re). { nra. }
    by rewrite -H2.
} destruct H2.
assert (x = (Re x +i* Im x)%C). { apply C_destruct. }
rewrite H4. apply /eqP. rewrite eq_complex //=.
apply /andP. by split; apply /eqP.
Qed.

Lemma C_mod_gt_0: forall (x: complex R),
  x <> 0  <->  0 < C_mod x.
Proof.
intros x ; split => Hx.
destruct (C_mod_ge_0 x) => //.
by apply /RltbP.
contradict Hx. by apply C_mod_eq_0.
assert ((0 < C_mod x)%Re). { by apply /RltbP. }
contradict H.
apply Rle_not_lt, Req_le.
by rewrite H C_mod_0.
Qed.

Lemma C_mod_inv : forall x : complex R,
  x <> 0 -> C_mod (invc x) = Rinv (C_mod x).
Proof.
intros x Zx.
apply Rmult_eq_reg_l with (C_mod x).
rewrite -[LHS]C_mod_prod.
rewrite Rinv_r. rewrite mulrC.
assert (invc x * x = 1).
{ rewrite [LHS]mulVc. by rewrite /RtoC.  by apply /eqP. }
by rewrite H C_mod_1.
assert ( (0 < C_mod x)%Re -> C_mod x <> 0%Re). { nra. }
apply H. apply /RltbP. by apply C_mod_gt_0.
assert ( (0 < C_mod x)%Re -> C_mod x <> 0%Re). { nra. }
apply H. apply /RltbP. by apply C_mod_gt_0.
Qed.

Lemma C_mod_gt_not_zero: forall x: complex R,
  C_mod x <> 0 -> 0 < C_mod x.
Proof.
intros. rewrite /C_mod. rewrite /C_mod in H. apply /RltP.
apply sqrt_lt_R0.
assert (Re x = 0%Re \/ (Re x <> 0)%Re).
{ nra. }
assert (Im x = 0%Re \/ (Im x <> 0)%Re).
{ nra. } destruct H0.
+ destruct H1.
  - rewrite H0 H1 in H.
    by rewrite expr2 mulr0 Rplus_0_r sqrt_0 in H.
  - rewrite H0 expr2 mulr0 Rplus_0_l -RpowE.
    assert ((Im x ^ 2)%Re = Rsqr (Im x)). { rewrite /Rsqr. nra. }
    rewrite H2. by apply Rsqr_pos_lt.
+ destruct H1.
  - rewrite H1. assert ( (0 ^+ 2)%Re = 0%Re). { by rewrite expr2 mulr0. }
    rewrite H2 Rplus_0_r -RpowE.
    assert ((Re x ^ 2)%Re = Rsqr (Re x)). { rewrite /Rsqr. nra. }
    rewrite H3. by apply Rsqr_pos_lt.
  - apply Rplus_lt_0_compat.
    * rewrite -RpowE.
      assert ((Re x ^ 2)%Re = Rsqr (Re x)). { rewrite /Rsqr. nra. }
      rewrite H2. by apply Rsqr_pos_lt.
    * rewrite -RpowE.
      assert ((Im x ^ 2)%Re = Rsqr (Im x)). { rewrite /Rsqr. nra. }
      rewrite H2. by apply Rsqr_pos_lt.
Qed.

Lemma Cinv_not_0:
  forall x:complex R, x <> 0 -> (invc x)%C <> 0.
Proof.
intros. apply C_mod_gt_0.
rewrite C_mod_inv. apply /RltbP. apply Rinv_0_lt_compat.
apply /RltbP. apply C_mod_gt_0. apply H. apply H.
Qed.

Lemma Im_add: forall (x y: complex R),
  Im (x+y)%C = Im x + Im y.
Proof.
move => [a b] [c d] //=.
Qed.

Lemma Re_add: forall (x y: complex R),
  Re (x+y)%C = Re x + Re y.
Proof.
move => [a b] [c d] //=.
Qed.

(** Some trivial proprties of the reals **)
Lemma posreal_cond: forall (x:posreal), (0< x)%Re.
Proof.
intros. destruct x. auto.
Qed.

Lemma real_sub_0r : forall (x: R), (x-0)%Re = x.
Proof.
intros. by rewrite RminusE subr0.
Qed.

Lemma Rsqr_ge_0: forall (x:R), (0<=x)%Re -> (0<= Rsqr x)%Re.
Proof.
intros. unfold Rsqr. assert (0%Re = (0*0)%Re). { nra. }
rewrite H0. apply Rmult_le_compat;nra.
Qed.

Lemma x_pow_n_not_0: forall (x:R) (n:nat), x <> 0 -> x^+n <> 0.
Proof.
move => x n H. induction n.
+ rewrite expr0. by apply /eqP.
+ rewrite exprS. by apply Rmult_integral_contrapositive.
Qed.

Lemma Rmult_le_compat_0: forall (x y :R),
  (0 <= x)%Re -> (0<=y)%Re  -> (0 <= x*y)%Re.
Proof.
intros. assert (0%Re = (0 * 0)%Re). { nra. } rewrite H1.
apply Rmult_le_compat; nra.
Qed.

(** define a complex matrix **)
Definition RtoC_mat (n:nat) (A: 'M[R]_n): 'M[complex R]_n :=
  \matrix_(i<n, j<n) ((A i j) +i* 0)%C.

(** Define L2 norm of a vector **)
Definition vec_norm (n:nat) (x: 'cV[R]_n.+1)  :=
  sqrt (\big[+%R/0]_l (Rsqr (x l 0))).

(** Define vector norm for a complex vector **)
Definition vec_norm_C (n:nat) (x: 'cV[complex R]_n.+1):=
  sqrt (\big[+%R/0]_l (Rsqr (C_mod (x l 0)))).

(** Define a non-zero vector **)
Definition vec_not_zero (n:nat) (x: 'cV[complex R]_n.+1):=
  exists i:'I_n.+1,  x i 0 <> 0.

(** Define a coercion from the real vector to a complex vector **)
Definition RtoC_vec (n:nat) (v: 'cV[R]_n.+1) : 'cV[complex R]_n.+1:=
  \col_i ((v i 0) +i* 0)%C.

(** Define vector norm for a complex vector **)
Definition vec_norm_rowv (n:nat) (x: 'rV[complex R]_n.+1):=
  sqrt (\big[+%R/0]_l (Rsqr (C_mod (x 0 l)))).

(** Define a non-zero row vector **)
Definition vec_not_zero_row (n:nat) (x: 'rV[complex R]_n.+1):=
  exists i:'I_n.+1,  x 0 i <> 0.

Lemma vec_norm_R_C: forall (n:nat) (v: 'cV[R]_n.+1),
  vec_norm_C (RtoC_vec  v) = vec_norm v.
Proof.
intros. rewrite /vec_norm_C /vec_norm.
have H1: \big[+%R/0]_l (C_mod (RtoC_vec v l 0))² = \big[+%R/0]_l (v l 0)².
{ apply eq_big. by []. intros. rewrite mxE /C_mod /=.
  assert (0^+2 = 0%Re). { by rewrite expr2 mul0r. } rewrite H0 Rplus_0_r.
  rewrite Rsqr_sqrt.
  + rewrite -RpowE /Rsqr. nra.
  + assert (((v i 0) ^+ 2) = Rsqr (v i 0)).
    { rewrite -RpowE /Rsqr. nra. } rewrite H1.
    apply Rle_0_sqr.
} by rewrite H1.
Qed.

(** \sum_j (Re ((u j) * (v j)) = Re (\sum_j ((u j) * (v j))) **)
Lemma eq_big_Re_C: forall (n:nat) (u v: 'I_n.+1 -> complex R),
   (\big[+%R/0]_(j<n.+1) Re ((u j) * (v j))%C) = Re (\big[+%R/0]_(j<n.+1) ((u j)* (v j))).
Proof.
intros.
induction n.
+ by rewrite !big_ord_recr //= !big_ord0 !add0r.
+ rewrite big_ord_recr //=. rewrite IHn -Re_add.
  rewrite [in RHS]big_ord_recr //=.
Qed.

(** \sum_j (Im ((u j) * (v j)) = Im (\sum_j ((u j) * (v j))) **)
Lemma eq_big_Im_C: forall (n:nat) (u v: 'I_n.+1 -> complex R),
   (\big[+%R/0]_(j<n.+1) Im ((u j) * (v j))%C) = Im (\big[+%R/0]_(j<n.+1) ((u j)* (v j))).
Proof.
intros.
induction n.
+ by rewrite !big_ord_recr //= !big_ord0 !add0r.
+ rewrite big_ord_recr //=. rewrite IHn -Im_add.
  rewrite [in RHS]big_ord_recr //=.
Qed.

(** \sum_j 0 = 0 **)
Lemma big_0_sum: forall (n:nat),
  \big[+%R/0]_(j<n.+1) 0%Re = 0%Re.
Proof.
intros. induction n.
+ by rewrite !big_ord_recr //= big_ord0 add0r.
+ rewrite big_ord_recr //=. rewrite IHn. apply add0r.
Qed.

Lemma mat_vec_unfold: forall (n:nat) (A: 'M[R]_n.+1 ) (v: 'cV[R]_n.+1),
    RtoC_vec (mulmx A v) = mulmx (RtoC_mat A) (RtoC_vec v).
Proof.
intros. apply matrixP. unfold eqrel. intros. rewrite !mxE.
rewrite [RHS]C_destruct. apply /eqP. rewrite eq_complex /=.
apply /andP. split.
+ apply /eqP. rewrite -eq_big_Re_C. apply eq_big. by [].
  intros. by rewrite /RtoC_mat /RtoC_vec !mxE /= mul0r subr0.
+ apply /eqP. rewrite -eq_big_Im_C. rewrite -[LHS](big_0_sum n).
  apply eq_big. by []. intros.
  by rewrite /RtoC_mat /RtoC_vec !mxE //= mul0r mulr0 add0r.
Qed.

Lemma sum_n_ge_0: forall (n:nat) (u: 'I_n.+1 ->R),
    (forall i:'I_n.+1, 0<= (u i)) ->
    0 <= \big[+%R/0]_i (u i).
Proof.
intros. induction n.
+ by rewrite big_ord_recr //= big_ord0 add0r.
+ rewrite big_ord_recr //=. apply /RleP.
  apply Rplus_le_le_0_compat. apply /RleP. apply IHn.
  intros. apply H. apply /RleP. apply H.
Qed.

(** 0 <= ||v|| **)
Lemma vec_norm_C_ge_0: forall (n:nat) (v: 'cV[complex R]_n.+1),
  (0<= vec_norm_C v)%Re.
Proof.
intros.
unfold vec_norm_C.
apply sqrt_positivity. apply /RleP.
apply sum_n_ge_0. intros.
assert (0 = Rsqr 0). { symmetry. apply Rsqr_0. } rewrite H. apply /RleP.
apply Rsqr_incr_1. apply C_mod_ge_0.
nra. apply C_mod_ge_0.
Qed.

Lemma vec_norm_rowv_ge_0: forall (n:nat) (v: 'rV[complex R]_n.+1),
  (0<= vec_norm_rowv v)%Re.
Proof.
intros.
unfold vec_norm_rowv.
apply sqrt_positivity. apply /RleP.
apply sum_n_ge_0. intros.
assert (0 = Rsqr 0). { symmetry. apply Rsqr_0. } rewrite H. apply /RleP.
apply Rsqr_incr_1. apply C_mod_ge_0.
nra. apply C_mod_ge_0.
Qed.

Lemma sum_gt_0: forall (n:nat) (u: 'I_n.+1 -> R),
   (forall l:'I_n.+1, 0 < (u l) )->
      \big[+%R/0]_l (u l) >0.
Proof.
intros. induction  n.
+ simpl. rewrite big_ord_recr //=. rewrite !big_ord0.
  rewrite add0r. apply H.
+ simpl. rewrite big_ord_recr //=.
  apply /RltbP. apply Rplus_lt_0_compat.
  apply /RltbP. apply IHn.
  intros. apply H. apply /RltbP. apply H.
Qed.

(** Generic property of big operator for reals. Missing
  in the mathcomp. **)
Lemma big_ge_0_ex_abstract I r (P: pred I) (E : I -> R):
  (forall i, P i -> (0 <= E i)) ->
  (0 <= \big[+%R/0]_(i <-r | P i) E i).
Proof.
move => leE. apply big_ind.
+ apply /RleP. apply Rle_refl.
+ intros. apply /RleP.
  rewrite -RplusE. apply Rplus_le_le_0_compat.
  - by apply /RleP.
  - by apply /RleP.
+ apply leE.
Qed.

(** v <> 0 --> 0 < ||v|| **)
Lemma non_zero_vec_norm: forall (n:nat) (v: 'cV[complex R]_n.+1),
  vec_not_zero v -> (vec_norm_C v <> 0)%Re.
Proof.
intros.
unfold vec_not_zero in H.
assert ((0< vec_norm_C v)%Re -> (vec_norm_C v <> 0)%Re).
{ nra. } apply H0. unfold vec_norm_C.
apply sqrt_lt_R0. destruct H as [i H].
rewrite (bigD1 i) //=.
rewrite -RplusE.
apply Rplus_lt_le_0_compat.
+ assert (0%Re = Rsqr 0). { by rewrite Rsqr_0. }
  rewrite H1. apply Rsqr_incrst_1.
  - apply /RltP. by apply C_mod_gt_0.
  - nra.
  - apply C_mod_ge_0.
+ apply /RleP. apply big_ge_0_ex_abstract.
  intros. apply /RleP. apply Rle_0_sqr.
Qed.

Lemma non_zero_vec_norm_row: forall (n:nat) (v: 'rV[complex R]_n.+1),
 v != 0 -> (vec_norm_rowv v <> 0)%Re.
Proof.
intros.
assert (exists i, v 0 i != 0). { by apply /rV0Pn. }
assert ((0< vec_norm_rowv v)%Re -> (vec_norm_rowv v <> 0)%Re).
{ nra. } apply H1. unfold vec_norm_rowv.
apply sqrt_lt_R0. destruct H0 as [i H0].
rewrite (bigD1 i) //=.
rewrite -RplusE.
apply Rplus_lt_le_0_compat.
+ assert (0%Re = Rsqr 0). { by rewrite Rsqr_0. }
  rewrite H2. apply Rsqr_incrst_1.
  - apply /RltP. apply C_mod_gt_0. by apply /eqP.
  - nra.
  - apply C_mod_ge_0.
+ apply /RleP. apply big_ge_0_ex_abstract.
  intros. apply /RleP. apply Rle_0_sqr.
Qed.

Lemma vec_norm_eq: forall (n:nat) (x y: 'cV[R]_n.+1),
   x=y -> vec_norm x = vec_norm y.
Proof.
intros.
rewrite H. reflexivity.
Qed.

Lemma RtoC_Mone: forall n:nat, @RtoC_mat n 1%:M = 1%:M.
Proof.
intros. rewrite /RtoC_mat. apply matrixP. unfold eqrel.
intros. rewrite !mxE.
case: (x == y); simpl;apply /eqP;rewrite eq_complex /=;by apply /andP.
Qed.

Lemma C_equals: forall (x y: complex R),
  (Re x = Re y) /\ (Im x = Im y) -> x = y.
Proof.
move =>[a b] [c d] //= H. destruct H. rewrite H H0 //=.
Qed.

Lemma RtoC_mat_prod: forall (n:nat) (A B: 'M[R]_n.+1),
  mulmx (RtoC_mat A) (RtoC_mat B) = RtoC_mat (mulmx A B).
Proof.
intros. apply matrixP. unfold eqrel. intros.
rewrite !mxE. apply C_equals. split.
+ simpl. rewrite -eq_big_Re_C. apply eq_big. by [].
  intros. by rewrite /RtoC_mat !mxE //= mul0r subr0.
+ rewrite //= -eq_big_Im_C -[RHS](big_0_sum n). apply eq_big.
  by []. intros. by rewrite /RtoC_mat !mxE //= mul0r mulr0 add0r.
Qed.

Lemma RtoC_mat_add: forall (n:nat) (A B: 'M[R]_n.+1),
  RtoC_mat (addmx A B) = addmx (RtoC_mat A) (RtoC_mat B).
Proof.
intros. apply matrixP. unfold eqrel. intros. rewrite !mxE.
apply /eqP. rewrite eq_complex //= add0r. apply /andP.
split; by apply /eqP.
Qed.

(** Properties of scale operation of vectors and matrices **)

(** define the scale operation for a complex vector **)
Definition scal_vec_C (n:nat) (l:complex R) (v: 'cV[complex R]_n.+1):=
  \col_(i<n.+1) (l * (v i 0))%C.

(** define the scale operation for a complex vector **)
Definition scal_vec_rowC (n:nat) (l:complex R) (v: 'rV[complex R]_n.+1):=
  \row_(i<n.+1) (l * (v 0 i))%C.

(** ||scale c v|| = |c| * ||v|| **)
Lemma ei_vec_ei_compat: forall (n:nat) (x:complex R) (v: 'cV[complex R]_n.+1),
  vec_norm_C (scal_vec_C x v) = C_mod x * vec_norm_C v.
Proof.
intros. unfold vec_norm_C.
have H1: sqrt (Rsqr (C_mod x)) = C_mod x.
  { apply sqrt_Rsqr. apply C_mod_ge_0. }
rewrite -H1 -RmultE -sqrt_mult_alt.
have H2: (\big[+%R/0]_l (C_mod (scal_vec_C x v l 0))²) =
           ((C_mod x)² *  \big[+%R/0]_l (C_mod (v l 0))²).
{ rewrite mulr_sumr. apply eq_big. by []. intros.
  rewrite mxE C_mod_prod -RmultE. apply Rsqr_mult.
} by rewrite H2.
assert (0%Re = Rsqr 0). { symmetry. apply Rsqr_0. } rewrite H.
apply Rsqr_incr_1. apply C_mod_ge_0. nra. apply C_mod_ge_0.
Qed.

(** ||scale c v|| = |c| * ||v|| **)
Lemma ei_vec_ei_compat_row: forall (n:nat) (x:complex R) (v: 'rV[complex R]_n.+1),
  vec_norm_rowv (scal_vec_rowC x v) = C_mod x * vec_norm_rowv v.
Proof.
intros. unfold vec_norm_rowv.
have H1: sqrt (Rsqr (C_mod x)) = C_mod x.
  { apply sqrt_Rsqr. apply C_mod_ge_0. }
rewrite -H1 -RmultE -sqrt_mult_alt.
have H2: (\big[+%R/0]_l (C_mod (scal_vec_rowC x v 0 l))²) =
           ((C_mod x)² *  \big[+%R/0]_l (C_mod (v 0 l))²).
{ rewrite mulr_sumr. apply eq_big. by []. intros.
  rewrite mxE C_mod_prod -RmultE. apply Rsqr_mult.
} by rewrite H2.
assert (0%Re = Rsqr 0). { symmetry. apply Rsqr_0. } rewrite H.
apply Rsqr_incr_1. apply C_mod_ge_0. nra. apply C_mod_ge_0.
Qed.

(** v = scale 1 v **)
Lemma scal_vec_1: forall (n:nat) (v: 'cV[complex R]_n.+1),
  v= scal_vec_C (1%C) v.
Proof.
intros. apply matrixP. unfold eqrel. intros. rewrite mxE.
symmetry. assert (y=0).  { apply ord1. } by rewrite H mul1r.
Qed.

Lemma scal_vec_1_row: forall (n:nat) (v: 'rV[complex R]_n.+1),
  v= scal_vec_rowC (1%C) v.
Proof.
intros. apply matrixP. unfold eqrel. intros. rewrite mxE.
symmetry. assert (x=0).  { apply ord1. } by rewrite H mul1r.
Qed.

(** scale x (scale l v) = scale (l*v) v **)
Lemma scal_of_scal_vec :
 forall (n:nat) (x l:complex R) (v: 'cV[complex R]_n.+1),
  scal_vec_C x (scal_vec_C l v) = scal_vec_C (x* l)%C v.
Proof.
intros. unfold scal_vec_C. apply matrixP. unfold eqrel. intros.
by rewrite !mxE /= mulrA.
Qed.

Lemma scal_of_scal_vec_row :
 forall (n:nat) (x l:complex R) (v: 'rV[complex R]_n.+1),
  scal_vec_rowC x (scal_vec_rowC l v) = scal_vec_rowC (x* l)%C v.
Proof.
intros. unfold scal_vec_rowC. apply matrixP. unfold eqrel. intros.
by rewrite !mxE /= mulrA.
Qed.

(** scale x (scale l v) = scale l (scale x v) **)
Lemma scal_vec_C_comm :
forall (n:nat) (x l:complex R) (v: 'cV[complex R]_n.+1),
  scal_vec_C x (scal_vec_C l v) = scal_vec_C l (scal_vec_C x v).
Proof.
intros.
unfold scal_vec_C. apply matrixP. unfold eqrel. intros.
rewrite !mxE /=.
have H1: (x * (l * v x0 0))%C  = ((x* l) * (v x0 0))%C.
{ apply mulrA. } rewrite H1.
have H2: (l * (x * v x0 0))%C = ((l* x) * (v x0 0))%C.
{ apply mulrA. } rewrite H2.
assert ((x* l)%C = (l* x)%C). { apply mulrC. } by rewrite H.
Qed.

Lemma scal_vec_C_row_comm :
forall (n:nat) (x l:complex R) (v: 'rV[complex R]_n.+1),
  scal_vec_rowC x (scal_vec_rowC l v) = scal_vec_rowC l (scal_vec_rowC x v).
Proof.
intros.
unfold scal_vec_rowC. apply matrixP. unfold eqrel. intros.
rewrite !mxE /=.
have H1: (x * (l * v 0 y))%C  = ((x* l) * (v 0 y))%C.
{ apply mulrA. } rewrite H1.
have H2: (l * (x * v 0 y))%C = ((l* x) * (v 0 y))%C.
{ apply mulrA. } rewrite H2.
assert ((x* l)%C = (l* x)%C). { apply mulrC. } by rewrite H.
Qed.

Lemma scale_vec_mat_conv_C:
  forall (n:nat) (l:complex R) (v: 'cV[complex R]_n.+1) (A: 'M[complex R]_n.+1),
  scal_vec_C l (A *m v) =  A *m (scal_vec_C l v).
Proof.
intros. apply matrixP. unfold eqrel. intros.
rewrite !mxE.
assert (y = 0). { by apply ord1. } rewrite H.
rewrite /scal_vec_C //=.
assert (\big[+%R/0]_(j < n.+1) (A x j *(\col_i (l * v i 0)) j 0)=
      \big[+%R/0]_(j < n.+1) ((l * v j 0) * A x j)).
{ apply eq_big. by []. intros. rewrite !mxE. by rewrite mulrC -mulrA. }
rewrite H0. rewrite big_distrr //=. apply eq_big.
by []. intros. rewrite -mulrA.
assert ((A x i * v i 0) = (v i 0 * A x i)).
{ by rewrite mulrC. } by rewrite H2.
Qed.

Lemma scale_vec_mat_conv:
  forall (n:nat) (l:complex R) (v: 'rV[complex R]_n.+1) (A: 'M[complex R]_n.+1),
  scal_vec_rowC l (v *m A) = (scal_vec_rowC l v) *m A.
Proof.
intros. apply matrixP. unfold eqrel. intros.
rewrite !mxE.
assert (x = 0). { by apply ord1. } rewrite H.
rewrite /scal_vec_rowC //=.
assert (\big[+%R/0]_(j < n.+1) ((\row_i (l * v 0 i)) 0
                          j * A j y)=
      \big[+%R/0]_(j < n.+1) ((l * v 0 j) * A j y)).
{ apply eq_big. by []. intros. by rewrite !mxE. }
rewrite H0. rewrite big_distrr //=. apply eq_big.
by []. intros. by rewrite mulrA.
Qed.

Lemma scal_vec_mathcomp_compat_col:
  forall (n:nat) (l: complex R) (v: 'cV[complex R]_n.+1),
  l *: v = (scal_vec_C l v).
Proof.
intros. apply matrixP. unfold eqrel. intros.
rewrite !mxE.
assert (y = 0). { by apply ord1. } by rewrite H.
Qed.

Lemma scal_vec_mathcomp_compat:
  forall (n:nat) (l: complex R) (v: 'rV[complex R]_n.+1),
  l *: v = (scal_vec_rowC l v).
Proof.
intros. apply matrixP. unfold eqrel. intros.
rewrite !mxE.
assert (x = 0). { by apply ord1. } by rewrite H.
Qed.

(** x * \sum_j (u j) = \sum_j (x * (u j)) **)
Lemma big_scal: forall (n:nat) (u: 'I_n.+1 -> complex R) (x:complex R),
  (x* \big[+%R/0]_j (u j))%C = \big[+%R/0]_j (x* (u j))%C.
Proof.
intros. induction n.
+ by rewrite !big_ord_recr //= !big_ord0 !add0r.
+ rewrite big_ord_recr //= mulrDr IHn [RHS]big_ord_recr //=.
Qed.

(** Define scale operation for a complex matrix **)
Definition scal_mat_C (m n :nat) (l:complex R) (x: 'M[complex R]_(m,n)):=
    \matrix_(i<m,j<n) (l* (x i j))%C.

Lemma big_scal_com:
  forall (n:nat) (x: complex R) (u : 'I_n.+1 -> complex R),
  x * (\big[+%R/0]_j (u j)) = \big[+%R/0]_j (x * (u j)).
Proof.
intros. induction n.
+ by rewrite !big_ord_recr //= !big_ord0 //= !add0r.
+ rewrite big_ord_recr //= [RHS]big_ord_recr //=.
  by rewrite -IHn mulrDr.
Qed.

Lemma scal_mat_to_vec:
  forall (m : nat) (l:complex R) (v: 'cV[complex R]_m.+1),
  scal_mat_C l v = scal_vec_C l v.
Proof.
intros. apply matrixP. unfold eqrel. intros. rewrite !mxE.
assert (y=0). { apply ord1. } by rewrite H.
Qed.

(** scale x v + scale y v = scale (x+y) v **)
Lemma scal_vec_add_xy:
  forall (n:nat) (x y:complex R) (v: 'cV[complex R]_n.+1),
  addmx (scal_vec_C x v) (scal_vec_C y v) = scal_vec_C (x+y)%C v.
Proof.
intros. unfold addmx. unfold scal_vec_C. apply matrixP. unfold eqrel.
intros. by rewrite !mxE /= mulrDl.
Qed.

Lemma scal_vec_eq:
  forall (n:nat) (x:complex R) (v1 v2: 'cV[complex R]_n.+1),
   x <> 0 -> scal_vec_C x v1 = scal_vec_C x v2 -> v1 = v2.
Proof.
intros. apply colP. unfold eqfun.
intros. unfold scal_vec_C in H0. apply matrixP in H0.
unfold eqrel in H0. specialize (H0 x0 0).
rewrite !mxE in H0. rewrite <- mul1r.
have H1: v1 x0 0 = (1 * v1 x0 0)%C.
{ by rewrite mul1r. }
have H2: (invc x * x)%C = 1. { apply mulVc. by apply /eqP. }
rewrite <-H2. rewrite -!mulrA.
rewrite H0. by rewrite mulrA mulrC H2 mulr1.
Qed.

(** scale x v1 + scale x v2 = scale x (v1 + v2) **)
Lemma scal_vec_add:
  forall (n:nat) (x: complex R) (v1 v2: 'cV[complex R]_n.+1),
  addmx (scal_vec_C x v1) (scal_vec_C x v2) =  scal_vec_C x (addmx v1 v2).
Proof.
intros. rewrite /addmx /scal_vec_C. apply matrixP. unfold eqrel.
intros. rewrite !mxE/=. by rewrite mulrDr.
Qed.

(** -(scale x v)  =  scale (-x) v **)
Lemma scal_vec_C_Mopp: forall (n:nat) (x:complex R) (v: 'cV[complex R]_n.+1),
  oppmx (scal_vec_C x v) = scal_vec_C (-x)%C v.
Proof.
intros. rewrite /scal_vec_C /oppmx. apply matrixP. unfold eqrel.
intros. by rewrite !mxE /= mulNr.
Qed.

Definition scal_of_mat0 (A: 'cV[complex R]_1):= A 0 0.

Lemma scal_conv_scal_vec: forall (x:complex R) (v: 'M[complex R]_1),
  scal_of_mat0 (scal_vec_C x v) = (x* (scal_of_mat0 v))%C.
Proof.
intros. by rewrite /scal_of_mat0 /scal_vec_C !mxE.
Qed.

(** Define transpose of a complex matrix  **)
Definition transpose_C (m n:nat) (A: 'M[complex R]_(m,n)):=
  \matrix_(i<n,j<m) A j i.

(** Define conjugate of a complex matrix **)
Definition conjugate (m n:nat) (A: 'M[complex R]_(m,n)):=
  \matrix_(i<m,j<n) conjc (A i j).

(** Define conjugate tranpose of a complex matrix **)
Definition conjugate_transpose (m n:nat) (A: 'M[complex R]_(m,n)):=
  transpose_C (conjugate A).

(** Generic properties of complex conjugates **)

(** x* conj x = ||x||^2 :> complex **)
Lemma conj_mag:
  forall x:complex R, (x* conjc x)%C = RtoC (Rsqr (C_mod x)).
Proof.
intros. rewrite /conjc /RtoC /C_mod.
assert ( x = (Re x +i* Im x)%C). { apply C_destruct. }
rewrite H //=. apply /eqP. rewrite eq_complex //=.
apply /andP. split.
+ apply /eqP. rewrite -mulN1r mulrN mulrNN mul1r.
  rewrite Rsqr_sqrt.
  - rewrite -!RpowE -RplusE -!RmultE. nra.
  - rewrite -!RpowE. nra.
+ apply /eqP. rewrite mulrN mulrC //=.
  rewrite -!RmultE -RplusE. apply Rplus_opp_l.
Qed.

Lemma Cconj_prod: forall (x y: complex R),
  conjc (x*y)%C = (conjc x * conjc y)%C.
Proof.
move => [a b] [c d]. apply /eqP. rewrite eq_complex //=.
apply /andP. split.
+ apply /eqP. by rewrite mulrNN.
+ apply /eqP. by rewrite mulrN mulNr opprD.
Qed.

Lemma conj_mag_re:
  forall x:complex R, Re (x* conjc x)%C = Rsqr (C_mod x).
Proof.
intros.
assert ( (x* conjc x)%C = RtoC (Rsqr (C_mod x))).
{ by rewrite conj_mag. } by rewrite H.
Qed.

Lemma C_mod_sqr: forall (x y : complex R),
  Rsqr (C_mod (x * y)) = (Rsqr (C_mod x)) * (Rsqr (C_mod y)).
Proof.
intros. rewrite -!conj_mag_re. rewrite Cconj_prod.
assert ((x * y * ((x^*)%C * (y^*)%C))%C =
        ((x * (x^*)%C) * (y * (y^*)%C))%C).
{ rewrite mulrC.
  assert ((x * y)%C = (y * x)%C). { by rewrite mulrC. }
  rewrite H.
  assert (((x^*)%C * (y^*)%C * (y * x))%C =
            ((x^*)%C *( (y^*)%C * (y * x)))%C).
  { by rewrite -mulrA. } rewrite H0.
  assert (((y^*)%C * (y * x))%C = ( x * (y * (y^*)%C))%C).
  { rewrite mulrA. rewrite mulrC.
    assert (((y^*)%C * y)%C = (y * (y^*)%C)%C).
    { by rewrite mulrC. } by rewrite H1.
  } rewrite H1. rewrite mulrA.
  rewrite mulrC.
  assert (((x^*)%C * x)%C = (x * (x^*)%C)%C).
  { by rewrite mulrC. } rewrite H2. by rewrite mulrC.
} rewrite H. rewrite Re_complex_prod.
assert (Im (x * (x^*)%C) * Im (y * (y^*)%C) = 0).
{ rewrite !conj_mag //=. by rewrite mulr0. } rewrite H0.
by rewrite subr0.
Qed.

(** conj (scale l x) = scale (conj l) x^* **)
Lemma conj_scal_mat_mul:
  forall (m n : nat) (l:complex R) (x: 'M[complex R]_(m,n)),
  conjugate_transpose (scal_mat_C l x) = scal_mat_C (conjc l) (conjugate_transpose x).
Proof.
intros.
rewrite /conjugate_transpose /transpose_C /scal_mat_C /conjugate.
apply matrixP. unfold eqrel. intros.
rewrite !mxE /=. apply Cconj_prod.
Qed.

Lemma Ceq_dec: forall (x: complex R),
  (x==0) || (x != 0).
Proof.
move => [a b]. rewrite eq_complex //=.
assert ( a = 0 \/ a <> 0). { by apply Req_dec. }
assert ( b = 0 \/ b <> 0). { by apply Req_dec. }
destruct H.
+ rewrite H //=.
  destruct H0.
  - rewrite H0 //=. apply /orP. left.
    apply /andP. by split; apply /eqP.
  - apply /orP. right. apply /nandP. by right; apply /eqP.
+ apply /orP. right. apply /nandP. left. by apply /eqP.
Qed.

Lemma Cmult_neq_0 (z1 z2 : complex R) :
  z1 <> 0 -> z2 <> 0 -> z1 * z2 <> 0.
Proof.
  intros Hz1 Hz2 => Hz.
  assert (C_mod (z1 * z2) = 0).
  by rewrite Hz C_mod_0.
  rewrite C_mod_prod in H.
  apply Rmult_integral in H ; destruct H.
  now apply Hz1, C_mod_eq_0.
  now apply Hz2, C_mod_eq_0.
Qed.

Lemma prod_not_zero: forall (x y: complex R) ,
  (x*y)%C <>0 <-> (x <> 0) /\ (y <> 0).
Proof.
intros.
split.
+ intros.
  split.
  - assert ( (x==0) \/ (x!=0)).
    { have H1: (x==0) || (x != 0). apply Ceq_dec.
      intros. by apply /orP.
    } destruct H0.
    * assert (x=0). { by apply /eqP. } rewrite H1 in H.
      by rewrite mul0r in H.
    * by apply /eqP.
  - assert ( (y==0) \/ (y!=0)).
    { have H1: (y==0) || (y != 0). apply Ceq_dec.
      intros. by apply /orP.
    } destruct H0.
    * assert (y=0). { by apply /eqP. } rewrite H1 in H.
      by rewrite mulr0 in H.
    * by apply /eqP.
+ intros. destruct H.
  apply Cmult_neq_0. apply H. apply H0.
Qed.

Lemma Cconj_add: forall (x y: complex R),
  conjc (x+y) = conjc x + conjc y.
Proof.
move => [a b] [c d]. rewrite /conjc //=. apply /eqP.
rewrite eq_complex //=. apply /andP. split.
+ by apply /eqP.
+ apply /eqP. by rewrite opprD.
Qed.

Lemma conj_prod:
  forall (x:complex R), ((conjc x)*x)%C = RtoC (Rsqr (C_mod x)).
Proof.
move => [a b]. rewrite /conjc /C_mod //= /RtoC.
apply /eqP. rewrite eq_complex //=. apply /andP.
split.
+ apply /eqP. rewrite Rsqr_sqrt.
  - rewrite -!RpowE -!RmultE -!RoppE -RplusE. nra.
  - rewrite -!RpowE. nra.
+ apply /eqP. by rewrite mulNr mulrC addrN.
Qed.

(** conj (\sum_j (x j)) = \sum_j (conj (x j)) **)
Lemma Cconj_sum: forall (p:nat) (x: 'I_p -> complex R),
  conjc (\big[+%R/0]_(j < p) x j)= \big[+%R/0]_(j < p) conjc (x j).
Proof.
intros.
induction p.
+ by rewrite !big_ord0 conjc0 //=.
+ rewrite !big_ord_recl.
  rewrite <-IHp. apply Cconj_add.
Qed.

Lemma conj_of_conj_C: forall (x: complex R),
  x = conjc (conjc x).
Proof.
intros.
assert (x = (Re x +i* Im x)%C).
{ by rewrite -C_destruct. } rewrite H.
rewrite /conjc //=. apply /eqP. rewrite eq_complex //=.
apply /andP. split.
+ by [].
+ by rewrite opprK.
Qed.

Lemma double_r: forall (x:R),
  (2 * x)%Re = (x + x)%Re.
Proof.
intros. nra.
Qed.

Lemma Re_conjc_add: forall (x: complex R),
  Re x + Re (conjc x) = 2 * (Re x).
Proof.
intros.
assert (x = (Re x +i* Im x)%C).
{ by rewrite -C_destruct. } rewrite H //=.
rewrite -RmultE -RplusE.
by rewrite double_r.
Qed.

Lemma Cconjc_mod: forall (a: complex R),
  C_mod a = C_mod (conjc a).
Proof.
intros.
assert (a = (Re a +i* Im a)%C).
{ by rewrite -C_destruct. } rewrite H.
rewrite /C_mod //=. by rewrite sqrrN.
Qed.

Lemma Re_C_le_C_mod: forall (x : complex R),
  Re x <= C_mod x.
Proof.
intros. apply /RleP. rewrite /C_mod.
assert ((Re x < 0)%Re \/ (0 <= Re x)%Re). { nra. }
destruct H.
+ apply Rle_trans with 0%Re.
  - by apply Rlt_le.
  - apply sqrt_pos.
+ apply Rsqr_incr_0.
  - rewrite Rsqr_sqrt.
    * unfold Rsqr. rewrite !expr2 -!RmultE. nra.
    * apply Rplus_le_le_0_compat;rewrite -RpowE;nra.
    * nra.
    * apply sqrt_pos.
Qed.

Lemma C_mod_add_leq : forall (a b: complex R),
  C_mod (a + b) <= C_mod a + C_mod b.
Proof.
intros. apply /RleP. rewrite -!RplusE. apply Rsqr_incr_0.
+ rewrite -conj_mag_re. rewrite Cconj_add.
  rewrite !mulrDr !mulrDl. rewrite !Re_add.
  rewrite -!RplusE. rewrite !conj_mag_re.
  rewrite Rsqr_plus.
  assert (((C_mod a)² + Re (b * (a^*)%C)%Ri +
              (Re (a * (b^*)%C)%Ri + (C_mod b)²))%Re =
          (((C_mod a)² + (C_mod b)²) +
            ( Re (b * (a^*)%C)%Ri + Re (a * (b^*)%C)%Ri))%Re).
  { nra. } rewrite H.
  apply Rplus_le_compat.
  - nra.
  - assert ((a * (b^*)%C) = conjc (b * conjc a)).
    { rewrite Cconj_prod. rewrite -conj_of_conj_C. by rewrite mulrC. }
    rewrite H0. apply /RleP. rewrite RplusE. rewrite Re_conjc_add.
    apply /RleP. rewrite -RmultE.
    assert (C_mod a = C_mod (conjc a)).
    { by rewrite Cconjc_mod. } rewrite H1.
    assert ((2 * C_mod (conjc a) * C_mod b)%Re = (2 * (C_mod b * C_mod (conjc a)))%Re).
    { nra. } rewrite H2. apply /RleP. rewrite !RmultE. rewrite -C_mod_prod.
    apply /RleP. rewrite -!RmultE. apply Rmult_le_compat_l.
    * nra.
    * remember ((b * (a^*)%C)%Ri) as c.
      apply /RleP. apply Re_C_le_C_mod.
  - apply C_mod_ge_0.
  - apply Rplus_le_le_0_compat; apply C_mod_ge_0.
Qed.

Lemma C_mod_sum_rel: forall (n:nat) (u : 'I_n.+1 -> (complex R)),
  (C_mod (\big[+%R/0]_j (u j))) <= \big[+%R/0]_j ((C_mod (u j))).
Proof.
intros. induction n.
+ simpl. rewrite !big_ord_recl //= !big_ord0.
  by rewrite !addr0.
+ simpl. rewrite big_ord_recr //=.
  assert ( \big[+%R/0]_(j < n.+2) (C_mod (u j)) =
            \big[+%R/0]_(j < n.+1) (C_mod (u (widen_ord (leqnSn n.+1) j))) +
              (C_mod (u ord_max))).
  { by rewrite big_ord_recr //=. } rewrite H.
  apply /RleP.
  apply Rle_trans with
    (C_mod (\big[+%R/0]_(i < n.+1) u (widen_ord (leqnSn n.+1) i)) +
      C_mod (u ord_max)).
  - apply /RleP. apply C_mod_add_leq.
  - rewrite -!RplusE. apply Rplus_le_compat.
    * apply /RleP. apply IHn.
    * nra.
Qed.

(** (A B)^* = B^* A^* **)
Lemma conj_matrix_mul :
  forall (m n p:nat) (A: 'M[complex R]_(m,p)) (B: 'M[complex R]_(p,n)),
    conjugate_transpose (mulmx A B) = mulmx
      (conjugate_transpose B) (conjugate_transpose A).
Proof.
intros.
rewrite /conjugate_transpose /transpose_C /conjugate.
apply matrixP. unfold eqrel. intros.
rewrite !mxE /=.
have H: conjc (\big[+%R/0]_(j < p) (A y j * B j x)) =
            \big[+%R/0]_(j < p) conjc (A y j * B j x).
{ apply Cconj_sum. }
rewrite H. apply eq_big. by [].
intros. by rewrite !mxE Cconj_prod //= mulrC.
Qed.

(** x^* ^* = x**)
Lemma conj_of_conj: forall (m n:nat) (x: 'M[complex R]_(m,n)),
  conjugate_transpose (conjugate_transpose x) = x.
Proof.
intros. rewrite /conjugate_transpose /transpose_C /conjugate.
apply matrixP. unfold eqrel. intros. rewrite !mxE.
assert ( x x0 y = (Re (x x0 y) +i* Im (x x0 y))%C).
{ apply C_destruct. } rewrite H /conjc //=. apply /eqP.
rewrite eq_complex //=. apply /andP. split.
+ by apply /eqP.
+ apply /eqP. by rewrite opprK.
Qed.

(** conjugate transpose of a real matrix is the matrix itself **)
Lemma conj_transpose_A: forall (n:nat) (A : 'M[R]_n.+1),
  (forall i j:'I_n.+1,   A i j = A j i) ->
  conjugate_transpose (RtoC_mat A) = RtoC_mat A.
Proof.
intros.
rewrite /conjugate_transpose /RtoC_mat /transpose_C /conjugate.
apply matrixP. unfold eqrel. intros. rewrite !mxE.
rewrite /conjc. apply /eqP. rewrite eq_complex //=. apply /andP.
split.
+ apply /eqP. apply H.
+ apply /eqP. apply oppr0.
Qed.

Lemma Re_eq: forall (x y:complex R), x= y -> Re x = Re y.
Proof.
intros. by rewrite /Re H.
Qed.

Lemma Re_prod:
  forall (x:R) (y:complex R), Re (RtoC x * y)%C = Re (RtoC x) * Re y.
Proof.
by move => x [a b]; rewrite /RtoC //= mul0r subr0.
Qed.

Lemma Rsqr_le_add: forall (x y:R),
  (0 <= y)%Re ->
  (Rsqr x <= Rsqr x + y)%Re.
Proof.
intros.
assert (Rsqr x = (Rsqr x + 0)%Re). { nra. } rewrite H0.
assert ( (x² + 0 + y)%Re = (Rsqr x + y)%Re). { nra. } rewrite H1.
apply Rplus_le_compat; nra.
Qed.

Lemma big_sum_1_const: forall (n:nat),
  \big[+%R/0]_(l < n.+1) 1 = n.+1%:R :> R.
Proof.
intros. induction n.
+ by rewrite big_ord_recl //= big_ord0 addr0.
+ rewrite big_ord_recr //=. rewrite IHn. rewrite -addn2.
  rewrite natrD. rewrite -addn1. rewrite natrD. rewrite -addrA.
  by rewrite -natrD.
Qed.

Lemma n_plus_1_gt_0: forall n:nat,
  (0 < n.+1%:R)%Re.
Proof.
intros. induction n.
+ apply Rlt_0_1.
+ assert (n.+2%:R = n.+1%:R + 1%:R :> R).
  { rewrite -addn2.
    rewrite natrD. rewrite -addn1. rewrite natrD.
    assert (n.+1%:R = n%:R + 1%R :> R).
    { by rewrite -addn1 natrD. } rewrite H.
    by rewrite -addrA.
  } rewrite H. rewrite -RplusE.
  apply Rplus_lt_0_compat.
  - by [].
  - apply Rlt_0_1.
Qed.

Lemma sqrt_n_neq_0: forall n:nat,
  sqrt n.+1%:R != 0.
Proof.
intros. apply /eqP.
apply Rgt_not_eq. apply Rlt_gt.
apply sqrt_lt_R0. apply n_plus_1_gt_0.
Qed.

(*** existence of right eigen vector **)
Lemma matrix_vec_transpose (n:nat) (A: 'M[complex R]_n.+1) (v: 'rV[complex R]_n.+1):
  A^T *m v^T = (v *m A)^T.
Proof.
apply matrixP. unfold eqrel. intros.
rewrite !mxE. apply eq_big. by [].
intros. rewrite !mxE. by rewrite mulrC.
Qed.

Lemma scal_vec_transpose (n:nat) (l : complex R) (v: 'rV[complex R]_n.+1):
  l *: v^T = (l *: v)^T.
Proof.
apply matrixP. unfold eqrel. intros. by rewrite !mxE.
Qed.

Lemma char_poly_A_A_tr:
  forall (n:nat) (A: 'M[complex R]_n.+1),
  char_poly A = char_poly A^T.
Proof.
intros. rewrite /char_poly /char_poly_mx.
rewrite -det_tr.
rewrite /determinant //=. apply eq_big.
+ by [].
+ intros.
  assert (\big[ *%R/1]_(i0 < succn n) ('X%:M - map_mx polyC A)^T
                              i0
                              (perm.PermDef.fun_of_perm
                                 i i0) =
          \big[ *%R/1]_(i0 < succn n) ('X%:M - map_mx polyC A^T)
                              i0
                              (perm.PermDef.fun_of_perm
                                 i i0)).
  { apply eq_big. by []. intros.
    rewrite !mxE.
    by rewrite eq_sym.
  } by rewrite H0.
Qed.

Lemma eigen_val_mat_transpose:
  forall (n:nat) (l: complex R) (A: 'M[complex R]_n.+1),
  @eigenvalue (complex_fieldType _) n.+1 A l =
  @eigenvalue (complex_fieldType _) n.+1 A^T l.
Proof.
intros. rewrite !eigenvalue_root_char.
assert ((char_poly A) = (char_poly A^T)).
{ apply char_poly_A_A_tr. } by rewrite H.
Qed.

Lemma A_tr_tr: forall (n:nat) (A: 'M[complex R]_n.+1),
  A = (A^T)^T.
Proof.
intros. apply matrixP. unfold eqrel. intros.
by rewrite !mxE.
Qed.

Lemma A_v_tr:
  forall (n:nat) (A: 'M[complex R]_n.+1) (v: 'rV[complex R]_n.+1),
  A *m v^T = (v *m A^T)^T.
Proof.
intros. apply matrixP. unfold eqrel. intros. rewrite !mxE.
apply eq_big. by [].
intros. rewrite !mxE. by rewrite mulrC.
Qed.

Lemma v_l_tr:
  forall (n:nat) (l: complex R) (v: 'rV[complex R]_n.+1),
  l *: v^T = (l *: v)^T.
Proof.
intros. apply matrixP. unfold eqrel. intros.
by rewrite !mxE.
Qed.

Lemma right_eigen_vector_exists:
  forall (n:nat) (i: 'I_n.+1) (A: 'M[complex R]_n.+1) (l : complex R),
  @eigenvalue (complex_fieldType _) n.+1 A l ->
   exists v: 'cV_n.+1, (mulmx A v = l *: v) /\ (v !=0).
Proof.
intros.
assert ( @eigenvalue (complex_fieldType _) n.+1 A^T l).
{ by rewrite -eigen_val_mat_transpose. }
assert (exists v : 'rV_(succn n),
           v *m A^T = l *: v /\ v != 0).
{ assert (exists2 v : 'rV_n.+1, v *m A^T = l *: v & v != 0).
  { by apply /eigenvalueP. } destruct H1. exists x. by split.
} destruct H1 as [v H1].
exists v^T. destruct H1.
split.
+ rewrite [in LHS]A_v_tr. rewrite v_l_tr. by rewrite H1.
+ apply /cV0Pn.
  assert (exists i, v 0 i != 0).
  { by apply /rV0Pn. } destruct H3 as [k H3].
  exists k. by rewrite mxE.
Qed.


Require Import prosa.util.epsilon.
Require Import prosa.util.tactics.
Require Import prosa.model.task.concept.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq path fintype bigop.

(** * Reduction of the search space for Abstract RTA *)
(** In this file, we prove that in order to calculate the worst-case response time
    it is sufficient to consider only values of [A] that lie in the search space defined below. *)

Section AbstractRTAReduction.

  (** The response-time analysis we are presenting in this series of documents is based on searching
     over all possible values of [A], the relative arrival time of the job respective to the beginning
     of the busy interval. However, to obtain a practically useful response-time bound, we need to
     constrain the search space of values of [A]. In this section, we define an approach to
     reduce the search space. *)

  Context {Task : TaskType}.

  (** First, we provide a constructive notion of equivalent functions. *)
  Section EquivalentFunctions.

    (** Consider an arbitrary type [T]... *)
    Context {T : eqType}.

    (**  ...and two function from [nat] to [T]. *)
    Variables f1 f2 : nat -> T.

    (** Let [B] be an arbitrary constant. *)
    Variable B : nat.

    (** Then we say that [f1] and [f2] are equivalent at values less than [B] iff
       for any natural number [x] less than [B] [f1 x] is equal to [f2 x].  *)
    Definition are_equivalent_at_values_less_than :=
      forall x, x < B -> f1 x = f2 x.

    (** And vice versa, we say that [f1] and [f2] are not equivalent at values
       less than [B] iff there exists a natural number [x] less than [B] such
       that [f1 x] is not equal to [f2 x].  *)
    Definition are_not_equivalent_at_values_less_than :=
      exists x, x < B /\ f1 x <> f2 x.

  End EquivalentFunctions.

  (** Let [tsk] be any task that is to be analyzed *)
  Variable tsk : Task.

  (** To ensure that the analysis procedure terminates, we assume an upper bound [B] on
     the values of [A] that must be checked. The existence of [B] follows from the assumption
     that the system is not overloaded (i.e., it has bounded utilization). *)
  Variable B : duration.

  (** Instead of searching for the maximum interference of each individual job, we
     assume a per-task interference bound function [IBF(tsk, A, x)] that is parameterized
     by the relative arrival time [A] of a potential job (see abstract_RTA.definitions.v file). *)
  Variable interference_bound_function : Task -> duration -> duration -> duration.

  (** Recall the definition of [ε], which defines the neighborhood of a point in the timeline.
     Note that [ε = 1] under discrete time. *)
  (** To ensure that the search converges more quickly, we only check values of [A] in the interval
     <<[0, B)>> for which the interference bound function changes, i.e., every point [x] in which
     [interference_bound_function (A - ε, x)] is not equal to [interference_bound_function (A, x)]. *)
  Definition is_in_search_space A :=
    A = 0 \/
    0 < A < B /\ are_not_equivalent_at_values_less_than
                  (interference_bound_function tsk (A - ε)) (interference_bound_function tsk A) B.

  (** In this section we prove that for every [A] there exists a smaller [A_sp]
     in the search space such that [interference_bound_function(A_sp,x)] is
     equal to [interference_bound_function(A, x)]. *)
  Section ExistenceOfRepresentative.

    (** Let [A] be any constant less than [B]. *)
    Variable A : duration.
    Hypothesis H_A_less_than_B : A < B.

    (** We prove that there exists a constant [A_sp] such that:
       (a) [A_sp] is no greater than [A], (b) [interference_bound_function(A_sp, x)] is
       equal to [interference_bound_function(A, x)] and (c) [A_sp] is in the search space.
       In other words, either [A] is already inside the search space, or we can go
       to the "left" until we reach [A_sp], which will be inside the search space. *)
    Lemma representative_exists:
      exists A_sp,
        A_sp <= A /\
        are_equivalent_at_values_less_than (interference_bound_function tsk A)
                                           (interference_bound_function tsk A_sp) B /\
        is_in_search_space A_sp.
    Proof.
      induction A as [|n].
      - exists 0; repeat split.
          by rewrite /is_in_search_space; left.
      - have ALT:
          all (fun t => interference_bound_function tsk n t == interference_bound_function tsk n.+1 t) (iota 0 B)
          \/ has (fun t => interference_bound_function tsk n t != interference_bound_function tsk n.+1 t) (iota 0 B).
        { apply/orP.
          rewrite -[_ || _]Bool.negb_involutive Bool.negb_orb.
          apply/negP; intros CONTR.
          move: CONTR => /andP [NALL /negP NHAS]; apply: NHAS.
            by rewrite -has_predC /predC in NALL.
        }
        feed IHn; first by apply ltn_trans with n.+1.
        move: IHn => [ASP [NEQ [EQ SP]]].
        move: ALT => [/allP ALT| /hasP ALT].
        { exists ASP; repeat split; try done.
          { by apply leq_trans with n. }
          { intros x LT.
            move: (ALT x) => T. feed T; first by rewrite mem_iota; apply/andP; split.
            move: T => /eqP T.
              by rewrite -T EQ.
          }
        }
        { exists n.+1; repeat split; try done.
          rewrite /is_in_search_space; right.
          split; first by  apply/andP; split.
          move: ALT => [y IN N].
          exists y.
          move: IN; rewrite mem_iota add0n. move => /andP [_ LT].
          split; first by done.
          rewrite subn1 -pred_Sn.
          intros CONTR; move: N => /negP N; apply: N.
            by rewrite CONTR.
        }
    Qed.

  End ExistenceOfRepresentative.

  (** In this section we prove that any solution of the response-time recurrence for
     a given point [A_sp] in the search space also gives a solution for any point
     A that shares the same interference bound. *)
  Section FixpointSolutionForAnotherA.

    (** Suppose [A_sp + F_sp] is a "small" solution (i.e. less than [B]) of the response-time recurrence. *)
    Variables A_sp F_sp : duration.
    Hypothesis H_less_than : A_sp + F_sp < B.
    Hypothesis H_fixpoint : A_sp + F_sp = interference_bound_function tsk A_sp (A_sp + F_sp).

    (** Next, let [A] be any point such that: (a) [A_sp <= A <= A_sp + F_sp] and
       (b) [interference_bound_function(A, x)] is equal to
       [interference_bound_function(A_sp, x)] for all [x] less than [B]. *)
    Variable A : duration.
    Hypothesis H_bounds_for_A : A_sp <= A <= A_sp + F_sp.
    Hypothesis H_equivalent :
      are_equivalent_at_values_less_than
        (interference_bound_function tsk A)
        (interference_bound_function tsk A_sp) B.

    (** We prove that there exists a constant [F] such that [A + F] is equal to [A_sp + F_sp]
       and [A + F] is a solution for the response-time recurrence for [A]. *)
    Lemma solution_for_A_exists:
      exists F,
        A_sp + F_sp = A + F /\
        F <= F_sp /\
        A + F = interference_bound_function tsk A (A + F).
    Proof.
      move: H_bounds_for_A => /andP [NEQ1 NEQ2].
      set (X := A_sp + F_sp) in *.
      exists (X - A); split; last split.
      - by rewrite subnKC.
      - by rewrite leq_subLR /X leq_add2r.
      - by rewrite subnKC // H_equivalent.
    Qed.

  End FixpointSolutionForAnotherA.

End AbstractRTAReduction.


Require Import Relations.
Require Import Ensembles.
Require Import ClassicalFacts.
Require Import Classical_Prop.
Require Import Classical_Pred_Type.
Require Import ClassicalChoice.

Definition choice_cond :
    forall (A B : Type) (R : A->B->Prop) (P : A -> Prop),
   inhabited B ->
   (forall x : A, P x -> exists y : B, R x y) ->
    exists f : A->B, (forall x : A, P x -> R x (f x)).
Proof.
intro.
intro.
intro.
intro.
intro Bin.
intro.
apply (choice (fun (a : A) (b : B) => P a -> R a b)).
intro.
assert (H0 := H x).
case (classic (P x)).
intro.
destruct (H0 H1).
exists x0.
intro.
trivial.
intro.
destruct Bin.
exists X.
intro.
apply False_ind.
apply H1.
trivial.
Qed.

(* connexity *)
Definition connex (A : Type) (R : relation A) (sub : Ensemble A) :=
  (forall x y : A, sub x -> sub y -> R x y \/ R y x).

(* every nonempty subset has least element *)
Definition wellord (A : Type) (R : relation A) :=
  forall e : Ensemble A, (exists a, e a) ->
  (exists x, e x /\ forall y, e y -> R x y).

Definition wellord_ens (A : Type) (R : relation A) (E : Ensemble A) :=
  forall e : Ensemble A, Included _ e E -> (exists a, e a) ->
  (exists x, e x /\ forall y, e y -> R x y).

Definition transfinite_induction : forall
  (A : Type)
  (R : relation A)
  (anti : antisymmetric A R)
  (well : wellord A R)
  (P : A -> Prop),
  (forall (a : A), (forall (b : A), (R b a /\ b <> a) -> P b) -> P a)
  -> (forall c : A, P(c)).
Proof.
intros.
unfold antisymmetric in anti.
assert (~ (exists t, ~(P t))).
intro.
destruct H0.
rename x into t.
assert (well0 := well (fun x => ~(P x))).
simpl in well0.
assert (exists x : A, ~ P x /\ (forall y : A, ~ P y -> R x y)).
apply well0.
exists t.
trivial.
destruct H1.
destruct H1.
apply H1.
apply H.
intros.
destruct H3.
apply NNPP.
intro.
assert (H6 := H2 b H5).
apply H4.
apply anti.
trivial.
trivial.
assert (H1 := not_ex_all_not _ _ H0).
apply NNPP.
apply H1.
Qed.

Definition Small (A : Type) (R : relation A)
  (f : Ensemble A -> A) (sub : Ensemble A) :=
    connex A R sub /\
    wellord_ens A R sub /\
    (forall x, sub x -> x = f (fun t => sub t /\ R t x /\ t <> x)).

Definition Big (A : Type) (R : relation A) (f : Ensemble A -> A) :=
  (fun s => exists sub : Ensemble A, Small _ R f sub /\ sub s).

Definition Seg (A : Type) (R : relation A)
  (sub : Ensemble A) (x : A) :=
    (fun t => sub t /\ R t x /\ t <> x).

Definition StrictUpperBoundFunc (A : Type) (R : relation A) (f : Ensemble A -> A) :=
  forall sub : Ensemble A,
       connex A R sub ->
       forall z : A, sub z -> R z (f sub) /\ z <> f sub.

Definition small_combine : forall
  (A : Type)
  (R : relation A)
  (Ord : order A R)
  (f : Ensemble A -> A)
  (bound : StrictUpperBoundFunc A R f)
  (sub1 : Ensemble A)
  (sub2 : Ensemble A)
  (noteq : sub1 <> sub2)
  (Hsub1 : Small A R f sub1)
  (Hsub2 : Small A R f sub2),
    (Included _ sub1 sub2 /\ exists x, sub1 = Seg A R sub2 x) \/
    (Included _ sub2 sub1 /\ exists x, sub2 = Seg A R sub1 x).
Proof.
intros.
unfold Seg.
unfold StrictUpperBoundFunc in bound.
assert (refl := ord_refl A R Ord).
assert (trans := ord_trans A R Ord).
assert (anti := ord_antisym A R Ord).
unfold reflexive in refl.
unfold transitive in trans.
unfold antisymmetric in anti.
destruct Hsub1.
destruct H0.
destruct Hsub2.
destruct H3.
unfold connex in H, H2.
unfold wellord_ens in H0, H3.
rename H into Hcon1.
rename H0 into Hweo1.
rename H1 into Hboa1.
rename H2 into Hcon2.
rename H3 into Hweo2.
rename H4 into Hboa2.
assert (Hbob1 := bound _ Hcon1).
assert (Hbob2 := bound _ Hcon2).

case (classic (Included A sub1 sub2)).
intro.

left.
split.
trivial.
unfold Included in *.
unfold In in *.
assert (let e := (fun t => (~ sub1 t) /\ sub2 t)
  in exists x : A, e x /\
  (forall y : A, e y -> R x y)).
apply Hweo2.
intros.
destruct H0.
trivial.
apply NNPP.
intro.
assert (H1 := not_ex_all_not _ _ H0).
simpl in H1.
assert (sub1 = sub2).
apply Extensionality_Ensembles.
split.
intro.
intro.
apply H.
trivial.
intro.
intro.
assert (H3 := not_and_or _ _ (H1 x)).
case H3.
intro.
apply NNPP.
trivial.
intro.
contradiction.
contradiction.

simpl in H0.
destruct H0.
destruct H0.
destruct H0.

rename x into rem.
rename H0 into Hrem0.
rename H2 into Hrem2.
rename H1 into Hrem1.

assert (forall x y,
  sub1 x ->
  ~ sub1 y ->
  sub2 y ->
  R x y).
intros.
assert (H3 := H _ H0).
assert (R x rem).

Admitted.

Definition small_big : forall
  (A : Type)
  (R : relation A)
  (Ord : order A R)
  (f : Ensemble A -> A)
  (bound : StrictUpperBoundFunc A R f),
    Small A R f (Big A R f).
Admitted.

(*
assert (connex A R (Big A R f)).
unfold connex.
unfold Big.
intros.
destruct H.
destruct H0.
destruct H.
destruct H0.
rename x0 into subx.
rename x1 into suby.
assert (SC := small_combine A R Ord f Hfun subx suby H H0).
case SC.
intro.
destruct H3.
destruct H4.
destruct H0.
apply H0.
apply H3.
trivial.
trivial.
intro.
destruct H3.
destruct H4.
destruct H.
apply H.
trivial.
apply H3.
trivial.
*)

Definition zorn : forall
  (A : Type)
  (R : relation A)
  (Ord : order A R),
    (forall sub : Ensemble A,
      (connex A R sub ->
       (exists x, forall y, sub y -> R y x)))
    -> exists x, ~ (exists y, R x y /\ x <> y).
Proof.
intro.
intro.
intro.
assert (refl := ord_refl A R Ord).
assert (trans := ord_trans A R Ord).
assert (anti := ord_antisym A R Ord).
unfold reflexive in refl.
unfold transitive in trans.
unfold antisymmetric in anti.
intro.

(* proof of inhabited A *)
unfold connex in H.
assert (exists x : A, forall y : A, False -> R y x).
apply H.
intros.
apply False_ind.
trivial.
destruct H0.
clear H0.
rename x into inh.
rename H into Hsub.

(* change goal and hypothesis *)
apply NNPP.
intro.
assert (H0 := not_ex_all_not _ _ H).
simpl in H0.
assert (forall n : A, exists y : A, R n y /\ n <> y).
intro.
apply NNPP.
apply (H0 n).
clear H.
clear H0.
rename H1 into Hex.

(* find some excluded and larger element for all subsets *)
assert (forall sub : Ensemble A,
  connex A R sub ->
  exists g : A, forall z : A, sub z -> R z g /\ z <> g).
intros.
assert (H1 := Hsub sub H).
destruct H1.
assert (H1 := Hex x).
destruct H1.
destruct H1.
exists x0.
intros.
split.
apply (trans _ x _).
apply H0.
trivial.
trivial.
intro.
apply H2.
apply anti.
trivial.
apply H0.
rewrite <- H4.
trivial.
rename H into Hgre.
clear Hsub.

(* apply axiom of choice *)
assert (exists f : (Ensemble A)->A, StrictUpperBoundFunc A R f).
apply (choice_cond (Ensemble A) A (fun (sub : Ensemble A) (x : A) =>
  forall z : A, sub z -> R z x /\ z <> x)).
exists.
trivial.
intros.
rename H into Hchn.
apply (Hgre x).
trivial.
destruct H.
rename H into Hfun.
rename x into f.
clear Hgre.
clear Hex.

(* create some big ensemble and use
   it to get a contradiction *)

(* First, prove Big is connex. *)
assert (H := small_big A R Ord f Hfun).
destruct H.
destruct H0.
rename H into Hcon.
rename H0 into Hwel.
rename H1 into Hbon.
assert (Hdec := Hfun (Big A R f) Hcon).

(* Second, proof Big (f Big) *)

(* connex *)
assert (Big A R f (f (Big A R f))).
unfold Big.
exists (fun t => Big A R f t \/ t = f (Big A R f)).
split.
split.
intro.
intros.
case H.
case H0.
intros.
apply Hcon.
trivial.
trivial.
intros.
left.
rewrite H1.
assert (H3 := Hdec x H2).
destruct H3.
trivial.
intro.
case H0.
intro.
right.
rewrite H1.
assert (H3 := Hdec y H2).
destruct H3.
trivial.
intro.
left.
rewrite H1.
rewrite H2.
apply refl.

(* wellord *)
split.
intro.
intros.
unfold Included in H.
unfold In in H.
case (classic (exists t, e t /\ Big A R f t)).
intro.
assert (exists x : A, (e x /\ Big A R f x) /\
  (forall y : A, e y /\ Big A R f y -> R x y)).
apply (Hwel).
intro.
intro.
destruct H2.
trivial.
trivial.
destruct H2.
destruct H2.
destruct H2.
exists x.
split.
trivial.
intros.
assert (H6 := H y H5).
case H6.
intro.
apply H3.
split.
trivial.
trivial.
intro.
assert (H8 := Hdec _ H4).
destruct H8.
rewrite H7.
trivial.

intro.
assert (forall t, e t -> t = f (Big A R f)).
intros.
assert (H3 := not_ex_all_not _ _ H1).
assert (H4 := not_and_or _ _ (H3 t)).
case H4.
intro.
contradiction.
intro.
assert (H6 := H t H2).
case H6.
intro.
contradiction.
intro.
auto.
destruct H0.
exists x.
split.
trivial.
intros.
rewrite (H2 _ H0).
rewrite (H2 _ H3).
auto.

(* bound condition *)
intros.
case H.
intro.
assert (H1 := Hbon x H0).
rewrite H1 at 1.
apply f_equal.
apply Extensionality_Ensembles.
split.
intro.
intro.
destruct H2.
destruct H3.
split.
left.
trivial.
split.
trivial.
trivial.

intro.
intro.
destruct H2.
destruct H3.
split.
assert (H5 := Hdec _ H0).
destruct H5.
assert (x0 <> f (Big A R f)).
intro.
rewrite H7 in H4.
rewrite H7 in H3.
apply H6.
apply anti.
trivial.
trivial.
case H2.
intro.
trivial.
intro.
contradiction.
split.
trivial.
trivial.

intros.
rewrite H0.
apply f_equal.
apply Extensionality_Ensembles.
split.
intro.
intro.
split.
left.
trivial.
apply Hdec.
trivial.
intro.
intro.
destruct H1.
destruct H2.
case H1.
intro.
trivial.
intro.
contradiction.
right.
reflexivity.

(* make a contradiction *)
assert (H0 := Hdec _ H).
destruct H0.
contradiction.
Qed.


Module NinetyNine.

  (*
   *  H-99: Ninety-Nine Haskell Problems
   *
   *  An Attempt in Coq
   *  Pascal Sommer, Feb. 2018
   *
   *  https://wiki.haskell.org/H-99:_Ninety-Nine_Haskell_Problems
   *)

  Require Import Coq.Arith.Plus.
  Require Import Coq.Arith.Arith.
  Require Import Coq.Arith.EqNat.

  (*
   *  Some datatypes, because we're cool like that
   *  and don't just use the standard library for
   *  everything. (this might be a big mistake)
   *)

  Inductive maybe (X : Type) :=
  | nothing : maybe X
  | just : X -> maybe X.

  Arguments nothing {X}.
  Arguments just {X} _.

  Inductive list (X : Type) :=
  | nil : list X
  | cons : X -> list X -> list X.

  Arguments nil {X}.
  Arguments cons {X} _ _.

  Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) .. ).
  Notation "[ ]" := nil.
  Notation "x :: xs" := (cons x xs).

  Fixpoint beq_natlist (a b : list nat) : bool :=
    match a, b with
    | nil, nil => true
    | x::xs, y::ys => andb (beq_nat x y) (beq_natlist xs ys)
    | _, _ => false
    end.

  Theorem beq_natlist_refl :
    forall l : list nat,
      beq_natlist l l = true.
  Proof.
    induction l.
    - reflexivity.
    - simpl.
      rewrite <- beq_nat_refl.
      rewrite -> IHl.
      reflexivity.
  Qed.

  (*
   *  ######## Problem 1
   *)

  Fixpoint myLast {X : Type} (l : list X) : maybe X :=
    match l with
    | [] => nothing
    | [x] => just x
    | x::xs => myLast xs
    end.

  Example ex_myLast_1 :
    myLast [1;2;3;4] = just 4.
  Proof. reflexivity. Qed.

  Example ex_myLast_2 :
    myLast [] = @nothing nat.
  Proof. reflexivity. Qed.

  (*
   *  ######## Problem 2
   *)

  Fixpoint myButLast {X : Type} (l : list X) : maybe X :=
    match l with
    | [] => nothing
    | [x] => nothing
    | [x;y] => just x
    | x::xs => myButLast xs
    end.

  Example ex_myButLast_1 :
    myButLast [1;2;3;4] = just 3.
  Proof. reflexivity. Qed.

  Example ex_myButLast_2 :
    myButLast [1] = nothing.
  Proof. reflexivity. Qed.

  (*
   *  ######## Problem 3
   *)

  Fixpoint elementAt {X : Type} (l : list X) (n : nat) : maybe X :=
    match n, l with
    | _, [] => nothing
    | 0, x::_ => just x
    | S n', _::xs => elementAt xs n'
    end.

  Example ex_elementAt_1 :
    elementAt [1;2;3;4] 2 = just 3.
  Proof. reflexivity. Qed.

  Example ex_elementAt_2 :
    elementAt [1;2;3] 3 = nothing.
  Proof. reflexivity. Qed.

  (*
   *  Problem 4
   *)

  Fixpoint myLength {X : Type} (l : list X) : nat :=
    match l with
    | nil => 0
    | x::xs => S (myLength xs)
    end.

  Example ex_myLength_1 :
    myLength [1;2;3] = 3.
  Proof. reflexivity. Qed.

  Example ex_myLength_2 :
    myLength (@nil nat) = 0.
  Proof. reflexivity. Qed.

  Theorem cons_increases_length :
    forall (l : list nat) (n : nat),
      myLength (n :: l) = S (myLength l).
  Proof. reflexivity. Qed.

  Print myLength.

  (*
   *  ######## Problem 5
   *
   *  It would be possible to define list reversion without
   *  append in linear time, but then it's a lot harder to
   *  prove that the length is preserved.
   *)

  Fixpoint append {X : Type} (a b : list X) : list X :=
    match a with
    | nil => b
    | x::xs => x :: (append xs b)
    end.

  Notation "a ++ b" := (append a b).

  Theorem append_preserves_length :
    forall (a b : list nat),
      myLength (a ++ b) = myLength a + myLength b.
  Proof.
    induction a.
    - reflexivity.
    - simpl. intros b.
      rewrite IHa.
      reflexivity.
  Qed.

  Theorem append_neutral_l :
    forall (X : Type) (a : list X),
      a = [] ++ a.
  Proof. reflexivity. Qed.

  Theorem append_neutral_r :
    forall (X : Type) (a : list X),
      a = a ++ [].
  Proof.
    induction a.
    - reflexivity.
    - simpl. rewrite <- IHa.
      reflexivity.
  Qed.

  Theorem append_assoc :
    forall (X : Type) (a b c : list X),
      a ++ (b ++ c) = (a ++ b) ++ c.
  Proof.
    intros X a b c.
    induction a.
    - reflexivity.
    - simpl. rewrite <- IHa.
      reflexivity.
  Qed.

  Fixpoint myReverse {X : Type} (l : list X) : list X :=
    match l with
    | nil => nil
    | x :: xs => (myReverse xs) ++ [x]
    end.

  Example ex_myReverse_1 :
    myReverse [] = @nil nat.
  Proof. reflexivity. Qed.

  Theorem reverse_preserves_length :
    forall (l : list nat),
      myLength l = myLength (myReverse l).
  Proof.
    induction l.
    - reflexivity.
    - simpl.
      rewrite -> append_preserves_length.
      rewrite <- IHl.
      rewrite plus_comm.
      reflexivity.
  Qed.

  Theorem reverse_append :
    forall (X : Type) (a b : list X),
      myReverse (a ++ b) = myReverse b ++ myReverse a.
  Proof.
    induction a.
    - simpl. intros b. rewrite <- append_neutral_r.
      reflexivity.
    - simpl. intros b. rewrite IHa, append_assoc.
      reflexivity.
  Qed.

  Theorem reverse_involution :
    forall (X : Type) (l : list X),
      myReverse (myReverse l) = l.
  Proof.
    induction l.
    - reflexivity.
    - simpl. rewrite reverse_append, IHl.
      reflexivity.
  Qed.

  (*
   *  ######## Problem 6
   *)

  Definition isPalindrome (l : list nat) : bool :=
    beq_natlist (myReverse l) l.

  Example ex_isPalindrome_1 :
    isPalindrome [1;2;3;2;1] = true.
  Proof. reflexivity. Qed.

  Theorem rev_append_is_palindrome :
    forall l : list nat,
      isPalindrome (l ++ myReverse l) = true.
  Proof.
    induction l.
    - reflexivity.
    - simpl.

End NinetyNine.


Require Import A1_Plan A2_Orientation A4_Droite A5_Cercle A7_Tactics .
Require Import C1_Distance.

Section CIRCLE_AND_DISTANCE.

Definition Radius := fun c : Circle => let (_, A, B) := c in Distance A B.

Definition OnCircle (c : Circle) := let (C, A, B) := c in (fun M : Point => Distance C M = Distance A B).

Lemma OnCircle1OnCircle : forall c : Circle, forall M : Point,
	OnCircle1 c M -> OnCircle c M.
Proof.
	unfold OnCircle1, OnCircle in |- *; destruct c; simpl in |- *; intros.
	apply DistanceEq; trivial.
Qed.

Lemma OnCircleOnCircle1 : forall c : Circle, forall M : Point,
	OnCircle c M -> OnCircle1 c M.
Proof.
	unfold OnCircle1, OnCircle in |- *; destruct c; simpl in |- *; intros.
	apply EqDistance; trivial.
Qed.

Lemma InterDiameterPointDef : forall (l : Line) (c : Circle),
	Diameter l c ->
	let f := (fun M : Point => OnCircle c M /\ EquiOriented (Center c) M (LineA l) (LineB l)) in
	{M : Point |  f M /\ Unicity M f}.
Proof.
	intros.
	setInterDiameter1 l c ipattern:(P).
	 exists P; unfold f in |- *; simpl in |- *; intuition.
	  apply OnCircle1OnCircle; trivial.
	  unfold Unicity in *; intuition.
	    apply Hun; intuition.
	    apply OnCircleOnCircle1; trivial.
Defined.

End CIRCLE_AND_DISTANCE.


Require Import QuickSort.
Require Import Prelude.
Require Import HsToCoq.DeferredFix.

Require Import Coq.Lists.List.
Import ListNotations.

Inductive AlreadySorted {a} `{Ord a} : list a -> Prop :=
 | ASNil: AlreadySorted []
 | ASCons: forall x xs,
     AlreadySorted xs ->
     Forall (fun y => (op_zl__ y x) = false) xs ->
     AlreadySorted (x::xs).

Axiom unroll_deferred_fix: forall a r `{Default r} (f : (a -> r) -> (a -> r)),
  deferredFix1 f = f (deferredFix1 f).

Lemma Forall_partition:
  forall a p (xs : list a),
  Forall (fun y => (p y) = false) xs ->
  OldList.partition p xs = ([], xs).
Proof.
  intros.
  induction H.
  * reflexivity.
  * unfold OldList.partition in *.
    simpl in *. rewrite IHForall.
    unfold OldList.select.
    rewrite H. reflexivity.
Qed.

Theorem quicksort_already_sorted:
  forall a `(Ord a) (xs : list a),
  AlreadySorted xs -> quicksort xs = xs.
Proof.
  intros.
  induction H1.
  * unfold quicksort.
    rewrite unroll_deferred_fix. reflexivity.
  * change (quicksort (x :: xs) = [] ++ [x] ++ xs).
    unfold quicksort.
    rewrite unroll_deferred_fix.
    rewrite Forall_partition by assumption.
    f_equal;[|f_equal].
    + rewrite unroll_deferred_fix. reflexivity.
    + apply IHAlreadySorted.
Qed.

Require Import Coq.Sorting.Permutation.

Lemma partition_permutation:
  forall a p (xs ys zs : list a),
  OldList.partition p xs = (ys, zs) ->
  Permutation xs (ys ++ zs).
Proof.
  induction xs; intros.
  * simpl in *. inversion_clear H. constructor.
  * simpl in *. unfold OldList.select in *.
    destruct (p a0).
    - destruct (OldList.partition p xs) eqn:?.
      inversion H.
      apply Permutation_cons; [reflexivity|].
      apply IHxs.
      congruence.
    - destruct (OldList.partition p xs) eqn:?.
      inversion H.
      apply Permutation_cons_app.
      apply IHxs.
      congruence.
Qed.

Lemma Forall_partition_l:
  forall a p (xs ys zs : list a),
  OldList.partition p xs = (ys, zs) ->
  Forall (fun y => (p y) = true) ys.
Proof.
  induction xs; intros.
  * simpl in H. inversion H. auto.
  * simpl in *. unfold OldList.select in *.
    destruct (p a0) eqn:?.
    - destruct (OldList.partition p xs) eqn:?.
      inversion H. simpl.
      constructor; try assumption.
      apply (IHxs l zs).
      congruence.
    - destruct (OldList.partition p xs) eqn:?.
      inversion H. simpl.
      destruct zs. try congruence.
      apply (IHxs ys zs).
      congruence.
Qed.

Lemma Forall_partition_r:
  forall a p (xs ys zs : list a),
  OldList.partition p xs = (ys, zs) ->
  Forall (fun y => (p y) = false) zs.
Proof.
  induction xs; intros.
  * simpl in H. inversion H. auto.
  * simpl in *. unfold OldList.select in *.
    destruct (p a0) eqn:?.
    - destruct (OldList.partition p xs) eqn:?.
      inversion H. simpl.
      destruct ys. try congruence.
      apply (IHxs ys zs).
      congruence.
    - destruct (OldList.partition p xs) eqn:?.
      inversion H. simpl.
      constructor; try assumption.
      apply (IHxs ys l0).
      congruence.
Qed.

Lemma partition_length_l:
  forall a p (xs ys zs : list a),
  OldList.partition p xs = (ys, zs) ->
  Peano.le (length ys) (length xs).
Proof.
  induction xs; intros.
  * simpl in *. inversion_clear H. constructor.
  * simpl in *. unfold OldList.select in *.
    destruct (p a0).
    - destruct (OldList.partition p xs) eqn:?.
      inversion H.
      simpl.
      apply le_n_S.
      apply (IHxs l zs).
      congruence.
    - destruct (OldList.partition p xs) eqn:?.
      inversion H.
      destruct zs. try congruence.
      inversion H2.
      simpl.
      rewrite (IHxs ys zs).
      omega.
      congruence.
Qed.

Lemma partition_length_r:
  forall a p (xs ys zs : list a),
  OldList.partition p xs = (ys, zs) ->
  Peano.le (length zs) (length xs).
Proof.
  induction xs; intros.
  * simpl in *. inversion_clear H. constructor.
  * simpl in *. unfold OldList.select in *.
    destruct (p a0).
    - destruct (OldList.partition p xs) eqn:?.
      inversion H.
      destruct ys. try congruence.
      inversion H2.
      simpl.
      rewrite (IHxs ys zs).
      omega.
      congruence.
    - destruct (OldList.partition p xs) eqn:?.
      inversion H.
      simpl.
      apply le_n_S.
      apply (IHxs ys l0).
      congruence.
Qed.

Theorem quicksort_permutation:
  forall a `(Ord a) (xs : list a),
  Permutation  (quicksort xs) xs.
Proof.
  intros.
  remember (length xs) as n.
  generalize dependent xs.
  induction n using lt_wf_ind.
  intros.
  unfold quicksort.
  rewrite unroll_deferred_fix.
  destruct xs.
  * apply perm_nil.
  * destruct (OldList.partition (fun arg_1__ : a => _<_ arg_1__ a0) xs) eqn:?.
    simpl app.
    rewrite <- Permutation_middle.
    apply Permutation_cons; [reflexivity|].
    rewrite (partition_permutation _ _ _ _ _ Heqp).
    apply Permutation_app.
    - apply (H1 (length l)).
      + pose (partition_length_l _ _ _ _ _  Heqp).
        subst n. simpl.
        omega.
      + reflexivity.
    - apply (H1 (length l0)).
      + pose (partition_length_r _ _ _ _ _  Heqp).
        subst n. simpl.
        omega.
      + reflexivity.
Qed.

Require Import Coq.Sorting.Sorted.
Require Import Coq.Sets.Relations_1.
Require Import Coq.Lists.List.

Lemma Forall_app:
  forall a P (xs ys : list a),
  Forall P xs -> Forall P ys ->
  Forall P (xs ++ ys).
Proof.
  intros. induction xs; try assumption. constructor.
  inversion H; assumption.
  apply IHxs. inversion H; assumption.
Qed.

Lemma Forall_Permutation:
  forall a P (xs ys : list a),
  Forall P ys -> Permutation xs ys ->
  Forall P xs.
Proof.
  intros.
  induction H0.
  * auto.
  * constructor.
    + inversion_clear H. assumption.
    + apply IHPermutation. inversion_clear H. assumption.
  * inversion_clear H. inversion_clear H1.
    repeat (constructor; try assumption).
  * auto.
Qed.

Section sorted.
 Variable a : Type.
 Variable eq : Eq_ a.
 Variable ord : Ord a.

 Definition R x y := x < y = true.

 Variable trans : Transitive R.
 Variable total : forall a b, R a b \/ R b a.

Lemma StronglySorted_app_cons:
  forall (xs ys : list a) p,
  StronglySorted R xs ->
  StronglySorted R ys ->
  Forall (fun x => R x p) xs ->
  Forall (fun y => R p y) ys ->
  StronglySorted R (xs ++ p :: ys).
Proof.
  intros.
  induction xs.
  * simpl.
    apply SSorted_cons.
    - assumption.
    - assumption.
  * simpl. apply SSorted_cons.
    - apply IHxs.
      + inversion H; assumption.
      + inversion H1; assumption.
    - apply Forall_app.
      inversion_clear H; assumption.
      constructor.
      inversion_clear H1; assumption.
      refine (Forall_impl _ _ H2). intros.
      refine (trans _ _ _ _ H3).
      inversion_clear H1; assumption.
Qed.

Theorem quicksort_sorted:
  forall (xs : list a), StronglySorted R (quicksort xs).
Proof.
  intros.
  remember (length xs) as n.
  generalize dependent xs.
  induction n using lt_wf_ind.
  intros.
  unfold quicksort.
  rewrite unroll_deferred_fix.
  destruct xs.
  * apply SSorted_nil.
  * destruct (OldList.partition (fun arg_1__ : a => _<_ arg_1__ a0) xs) eqn:?.
    simpl app.
    apply StronglySorted_app_cons.
    - apply (H (length l)).
      + pose (partition_length_l _ _ _ _ _  Heqp).
        subst n. simpl.
        omega.
      + reflexivity.
    - apply (H (length l0)).
      + pose (partition_length_r _ _ _ _ _  Heqp).
        subst n. simpl.
        omega.
      + reflexivity.
    - refine (Forall_Permutation _ _ _ _ _ (quicksort_permutation _ _ _)).
      apply (Forall_partition_l _ _ _ _ _  Heqp).
    - refine (Forall_Permutation _ _ _ _ _ (quicksort_permutation _ _ _)).
      specialize (Forall_partition_r _ _ _ _ _  Heqp).
      apply Forall_impl.
      intros.
      destruct (total a0 a1); [assumption|congruence].
Qed.
End sorted.

Print Assumptions quicksort_sorted.


Require Import Classical.

Parameters P Q R S: Prop.

Section example0.

Hypothesis p1: P->Q.
Hypothesis p2: ~Q.
Goal ~P.
Proof.
  unfold not in p2.
  unfold not in |- *.
  intros H1.
  pose proof (p1 H1) as H2.
  pose proof (p2 H2) as H3.
  exact H3.
Qed.

End example0.


subset_transitive < Undo 2.
1 subgoal

  ============================
   forall x y z : set, subset x y -> subset y z -> subset x z

subset_transitive < unfold subset at 2.
1 subgoal

  ============================
   forall x y z : set,
   subset x y -> (forall x0 : U, element x0 y -> element x0 z) -> subset x z

subset_transitive < intros.
1 subgoal

  x : set
  y : set
  z : set
  H : subset x y
  H0 : forall x0 : U, element x0 y -> element x0 z
  ============================
   subset x z

subset_transitive < unfold subset in H.
1 subgoal

  x : set
  y : set
  z : set
  H : forall x0 : U, element x0 x -> element x0 y
  H0 : forall x0 : U, element x0 y -> element x0 z
  ============================
   subset x z

subset_transitive < red.
1 subgoal

  x : set
  y : set
  z : set
  H : forall x0 : U, element x0 x -> element x0 y
  H0 : forall x0 : U, element x0 y -> element x0 z
  ============================
   forall x0 : U, element x0 x -> element x0 z

subset_transitive < auto.
No more subgoals.

subset_transitive < Qed.
unfold transitive.
unfold subset at 2.
intros.
unfold subset in H.
red.
auto.

subset_transitive is defined

Coq <


Require Export ZArith.
(*Require Export Bmc.Logic.*)

Open Scope nat_scope.

Set Implicit Arguments.

(**)

Definition state : Type := Z.
Definition sseq : Type := nat -> state.

Definition nth (n : nat) (ss : sseq) : state :=
  ss n.

Notation "ss .[ n ] " := (nth n ss)
                         (at level 0).

Definition skipn (n : nat) (ss : sseq) : sseq :=
  fun i => ss (i+n).

Lemma skipn_nth: forall (ss : sseq) (n m : nat),
  (skipn n ss).[m] = ss.[n+m].
Proof.
  intros.
  unfold skipn.
  rewrite plus_comm.
  reflexivity.
Qed.

Lemma state_sseq :
  forall (s:state), (fun _ => s).[0] = s.
Proof.
  intros. unfold nth. reflexivity.
Qed.

Lemma prop_state_sseq :
  forall (p : state -> Prop),
    (forall (ss:sseq), p ss.[0]) ->
    (forall (s:state), p s).
Proof.
  intros.
  rewrite <- state_sseq. apply H.
Qed.

(**)

Definition trans : Type := state -> state -> Prop.
Definition prop : Type := state -> Prop.

Fixpoint path (T : trans) (ss : sseq) (o len : nat) : Prop :=
  match len with
  | O => True
  | S len' => path T ss o len' /\ T ss.[o+len'] ss.[o+len]
  end.

Fixpoint invariance (P : prop) (ss : sseq) (len : nat) : Prop :=
  match len with
  | O => P ss.[0]
  | S len' => invariance P ss len' /\ P ss.[len]
  end.

Fixpoint no_loop' (ss : sseq) (o m n : nat) : Prop :=
  match n with
  | O => ss.[o+m] <> ss.[o]
  | S n' => no_loop' ss o m n' /\ ss.[o+m] <> ss.[o+n]
  end.

Fixpoint no_loop (ss : sseq) (o k : nat) : Prop :=
  match k with
  | O => True
  | S k' => no_loop' ss o k k' /\ no_loop ss o k'
  end.

Definition loop (ss : sseq) (o m n : nat) : Prop :=
  exists i, i <= n /\ ss.[o+m] = ss.[o+i].

Definition loop_free (T : trans) (ss : sseq) (o k: nat) : Prop :=
  path T ss o k /\ no_loop ss o k.

Definition lasso_fwd (I : prop) (T : trans) (k : nat) : Prop :=
  forall ss : sseq,
  I ss.[0] -> ~loop_free T ss 0 k.

Definition lasso_bwd (T : trans) (P : prop) (k: nat) : Prop :=
  forall ss : sseq,
  loop_free T ss 0 k -> P ss.[k].

Definition lasso_bwd' (T : trans) (P : prop) (k: nat) : Prop :=
  forall ss : sseq,
  ~P ss.[k] -> ~loop_free T ss 0 k.

Definition prop_nth_init (I : prop) (T : trans) (P : prop) (n : nat) : Prop :=
  forall ss : sseq,
  I ss.[0] -> path T ss 0 n -> P ss.[n].

Fixpoint safety_nth (I : prop) (T : trans) (P : prop) (n : nat) : Prop :=
  match n with
  | O => prop_nth_init I T P n
  | S n' => safety_nth I T P n' /\ prop_nth_init I T P n
  end.

Definition prop_nth_init_lf  (I : prop) (T : trans) (P : prop) (n : nat) : Prop :=
  forall ss : sseq,
  I ss.[0] -> loop_free T ss 0 n -> P ss.[n].

Fixpoint safety_nth_offset (P : prop) (ss : sseq) (o n: nat) : Prop :=
  match n with
  | O => True
  | S n' => safety_nth_offset P ss o n' /\ P ss.[o+n']
  end.

(**)

Lemma safety_path_lf :
  forall (I:prop) (T:trans) (P:prop),
  forall (i:nat),
    prop_nth_init I T P i ->
    prop_nth_init_lf I T P i.
Proof.
  intros.
  unfold prop_nth_init in H.
  unfold prop_nth_init_lf.
  unfold loop_free.
  intros.
  destruct H1.
  apply H.
  apply H0.
  apply H1.
Qed.

Lemma bounded_safety :
  forall (i k : nat) (I : prop) (T : trans) (P : prop),
  i <= k -> safety_nth I T P k -> prop_nth_init I T P i.
Proof.
  intros.
  apply Nat.lt_eq_cases in H.
  destruct H.
  - induction k.
    + easy.
    + destruct (Nat.lt_ge_cases i k).
      * assert (H2 : safety_nth I T P k /\ prop_nth_init I T P k).
        destruct k; firstorder; now rewrite <- plus_n_O in H0.
        apply IHk.
        auto.
        tauto.
      * apply gt_S_le in H.
        assert (H2 : i = k) by omega.
        destruct k ;rewrite H2; firstorder.
  - subst.
    destruct k; firstorder.
Qed.

(**)

Lemma skipn_path : forall (T : trans) (i j : nat),
  forall ss : sseq,
  path T ss j i  -> path T (skipn j ss) 0 i.
Proof.
  intros.
  induction i.
  - auto.
  - assert ( path T (skipn j ss) 0 (S i) <->
      path T (skipn j ss) 0 i /\
        T (skipn j ss).[i] (skipn j ss).[S i] ).
    {
      destruct i. firstorder.
      unfold path; fold path.
      simpl.
      (*rewrite <- plus_n_O.*)
      tauto.
    }
    apply H0.
    clear H0.

    split.
    apply IHi.
    destruct i; firstorder.
    + clear IHi.
      rewrite skipn_nth.
      rewrite skipn_nth.
      simpl in *.
      decompose [and] H. clear H.
      destruct i.
      * simpl in *.
        auto.
      * auto.
Qed.

Lemma skipn_no_loop' : forall (i j k : nat),
  forall ss : sseq,
  no_loop' ss j k i ->
  no_loop' (skipn j ss) 0 k i.
Proof.
  intros.
  destruct i.
  - simpl in *.
    do 2 rewrite skipn_nth.
    rewrite -> Nat.add_0_r.
    apply H.
  - induction i.
    + simpl in *.
      do 3 rewrite skipn_nth.
      rewrite -> Nat.add_0_r.
      apply H.
    + simpl.
      split.
      * do 2 rewrite skipn_nth.
        firstorder.
      * simpl in H.
        do 2 rewrite skipn_nth.
        tauto.
Qed.

Lemma skipn_no_loop : forall (i j : nat),
  forall ss : sseq,
  no_loop ss j i -> no_loop (skipn j ss) 0 i.
Proof.
  intros.
  induction i.
  - auto.

  - assert (H1 : no_loop ss j i /\ no_loop' ss j (S i) i)
      by ( destruct i; firstorder; rewrite <- plus_n_O in *).
    clear H.

    assert ( H :no_loop (skipn j ss) 0 i /\
      no_loop' (skipn j ss) 0 (S i) i ->
      no_loop (skipn j ss) 0 (S i) ).
    intros.
    destruct i; firstorder; rewrite <- plus_n_O in *.
    apply H.
    clear H.
    split.
    apply IHi.
    tauto.
    destruct H1.
    clear H.
    apply skipn_no_loop' in H0.
    tauto.
Qed.

Lemma skipn_prop : forall (P : prop) (i k : nat),
  forall ss : sseq,
  i >= k -> ~ P ss.[i] -> ~ P (skipn (i - k) ss).[k].
Proof.
  intros.
  rewrite skipn_nth.
  replace (i - k + k) with i.
  auto.
  omega.
Qed.

(**)

Lemma cons_path : forall (ss : sseq) (T : trans) (i j : nat),
  T ss.[i] ss.[S i] /\ path T ss (S i) j <->
  path T ss i (S j).
Proof.
  destruct j.
  - unfold path.
    rewrite Nat.add_0_r.
    rewrite Nat.add_1_r.
    tauto.
  - induction j.
    + simpl.
      rewrite Nat.add_1_r.
      do 2 rewrite Nat.add_succ_r.
      rewrite Nat.add_0_r.
      tauto.
    + simpl.
      split; firstorder;
      now do 5 rewrite Nat.add_succ_r in *.
Qed.

Lemma snoc_path : forall (ss : sseq) (T : trans) (i j: nat),
  path T ss i (S j) <->
  path T ss i j /\ T ss.[i+j] ss.[S (i+j)].
Proof.
  intros.
  simpl.
  replace (i + S j) with (S (i + j)).
  tauto.
  auto.
Qed.

Lemma skip1_path : forall (T : trans) (i j : nat),
  forall ss : sseq,
  path T ss (S i) j -> path T (skipn 1 ss) i j.
Proof.
  intros.
  induction j.
  - simpl. intuition.
  - rewrite -> snoc_path in H.
    destruct H.
    rewrite -> snoc_path.
    split.
    * apply IHj.
      apply H.
    * do 2 rewrite skipn_nth.
      replace (1+(i+j)) with (S i + j).
      replace (1+S (i+j)) with (S (S i + j)).
      apply H0.
      auto.
      auto.
Qed.

Lemma shift_path : forall (ss : sseq) (T : trans) (i j : nat),
  path T ss 0 i /\ path T ss i (S j) <->
  path T ss 0 (S i) /\ path T ss (S i) j .
Proof.
  intros.
  rewrite snoc_path with (i:=0).
  rewrite and_assoc.
  rewrite cons_path.
  reflexivity.
Qed.

Lemma split_path : forall (ss : sseq) (T : trans) (i j: nat),
  path T ss 0 (i+j) <-> path T ss 0 i /\ path T ss i j.
Proof.
  induction i.
  - simpl.
    tauto.
  - split.
    + intros.
      rewrite -> Nat.add_succ_comm in H.
      apply IHi in H.
      apply shift_path.
      apply H.
    + intros.
      apply shift_path in H.
      apply IHi in H.
      rewrite <- Nat.add_succ_comm in H.
      apply H.
Qed.

Lemma split_no_loop' : forall (ss:sseq) (o i k j:nat),
  no_loop' ss o i (j+k) -> no_loop' ss o i j.
Proof.
  induction k.
  - intros.
    rewrite -> plus_0_r in H.
    apply H.
  - intros.
    rewrite <- Nat.add_succ_comm in H.
    apply IHk in H.
    simpl in H.
    destruct H.
    apply H.
Qed.

Lemma split_no_loop_former : forall (ss : sseq) (j i : nat),
  no_loop ss 0 (i+j) -> no_loop ss 0 i.
Proof.
  induction j.
  - intros.
    now rewrite <- plus_n_O in H.
  - intros.
    rewrite <- Nat.add_succ_comm in H.
    apply IHj in H.
    simpl in H.
    destruct H.
    apply H0.
Qed.

Local Lemma split_no_loop_latter'' :
  forall (ss : sseq) (i j k : nat),
  no_loop' ss i (S k) (S j) <->
    ss.[(i + (S k))] <> ss.[i] /\
    no_loop' ss (S i) k j.
Proof.
  destruct j.
  - simpl.
    intros.
    now rewrite <- Nat.add_succ_l;
      rewrite Nat.add_succ_comm; rewrite Nat.add_1_r.
  - induction j.
    + simpl.
      intros.
      do 2 rewrite <- Nat.add_succ_r.
      do 1 rewrite ->  Nat.add_1_r.
      tauto.
    + intros.
      simpl in *.
      assert (forall (p1 p2 p3 p4 p5:Prop),
        (p1 <-> (p2 /\ p3 /\ p4) /\ p5) <->
        (p1 <-> p2 /\ (p3 /\ p4) /\ p5)) by tauto.
      rewrite <- H.
      rewrite <- IHj.
      do 2 rewrite <- Nat.add_succ_r.
      tauto.
Qed.

Local Lemma split_no_loop_latter' : forall (ss : sseq) (j i : nat),
  no_loop ss i (S j) -> no_loop ss (S i) j.
Proof.
  induction j.
  intros.
  - destruct i; firstorder.
  - intros.
    assert (no_loop ss (S i) (S j) <->
      no_loop' ss (S i) (S j) j /\ no_loop ss (S i) j)
      by (destruct j; firstorder).
    apply H0.
    assert (no_loop ss i (S (S j)) <->
      no_loop' ss i (S (S j)) (S j) /\
      no_loop ss i (S j))
      by (destruct j; firstorder).
    apply -> H1 in H.
    destruct H.
    split.
    now apply split_no_loop_latter'' in H.
    now apply IHj in H2.
Qed.

Lemma split_no_loop_latter : forall (ss : sseq) (i j : nat),
  no_loop ss 0 (i+j) -> no_loop ss i j.
Proof.
  induction i.
  - easy.
  - intros.
    rewrite Nat.add_succ_comm in H.
    apply IHi in H.
    now apply split_no_loop_latter' in H.
Qed.

Lemma split_no_loop : forall (ss : sseq) (i j: nat),
    no_loop ss 0 (i+j) ->
    no_loop ss 0 i /\ no_loop ss i j.
Proof.
  intros.
  split.
  - now apply split_no_loop_former in H.
  - now apply split_no_loop_latter in H.
Qed.

Lemma split_loop_free : forall  (ss : sseq) (T : trans) (i j : nat),
  loop_free T ss 0 (i+j) ->
  loop_free T ss 0 i /\ loop_free T ss i j.
Proof.
  unfold loop_free.
  intros.
  destruct H.
  apply split_path in H.
  apply split_no_loop in H0.
  tauto.
Qed.

Lemma split_path_lf :
  forall (T:trans) (ss:sseq) (m n:nat),
    loop_free T ss 0 m /\ path T ss m n ->
    path T ss 0 (m+n).
Proof.
  induction m.
  - intros.
    unfold loop_free in H.
    decompose [and] H; clear H.
    tauto.
  - intros.
    unfold loop_free in H.
    decompose [and] H; clear H.
    assert (path T ss 0 (S m) /\ path T ss (S m) n) by auto.
    clear H1 H2.
    apply shift_path in H.
    destruct H.
    rewrite <- Nat.add_1_r in H3.
    apply split_no_loop_former in H3.
    assert (loop_free T ss 0 m /\ path T ss m (S n)) by (unfold loop_free; tauto).
    clear H3 H H0.
    apply IHm in H1.
    rewrite <- Nat.add_succ_comm in H1.
    apply H1.
Qed.

Lemma split_lf_path :
  forall (T:trans) (ss:sseq) (n:nat),
    path T ss 0 (n+1) ->
    ss.[n+1] <> ss.[n] ->
    path T ss 0 n /\ loop_free T ss n 1.
Proof.
  induction n.
  - intros.
    unfold path.
    unfold loop_free.
    unfold no_loop.
    unfold no_loop'.
    rewrite -> Nat.add_0_l in *.
    tauto.
  - intros.
    split.
    + rewrite -> Nat.add_1_r in H.
      rewrite -> snoc_path in H.
      destruct H.
      apply H.
    + unfold loop_free.
      split.
      * rewrite -> split_path in H.
        destruct H.
        apply H1.
      * unfold no_loop.
        unfold no_loop'.
        (*rewrite -> Nat.add_0_r.*)
        tauto.
Qed.

(**)

Lemma lf_path :
  forall (T:trans) (ss:sseq) (i:nat),
  loop_free T ss 0 i ->
  path T ss 0 i.
Proof.
  intros.
  induction i.
  - simpl. intuition.
  - simpl.
    rewrite <- Nat.add_1_r in H.
    apply split_loop_free in H.
    destruct H.
    split.
    + apply IHi in H.
      apply H.
    + unfold loop_free in H0.
      destruct H0.
      unfold path in H0.
      destruct H0.
      rewrite -> Nat.add_0_r in H2.
      rewrite -> Nat.add_1_r in H2.
      apply H2.
Qed.

Lemma no_loop'_neq' :
  forall (ss:sseq) (o i j:nat),
  i >= j -> no_loop' ss o (S i) (i-j) ->
  ss.[o + S i] <> ss.[o+(i-j)].
Proof.
  intros.
  destruct j.
  - destruct i.
    + rewrite -> Nat.sub_0_r in *.
      rewrite -> Nat.add_0_r.
      simpl in H0.
      apply H0.
    + rewrite -> Nat.sub_0_r in *.
      simpl in H0.
      destruct H0.
      apply H1.
  - remember (i - S j) as k.
    destruct k.
    + simpl in H0.
      rewrite -> Nat.add_0_r.
      apply H0.
    + simpl in H0.
      destruct H0.
      apply H1.
Qed.

Lemma no_loop'_neq :
  forall (ss:sseq) (o i j:nat),
  no_loop' ss o (S i) i ->
  i > j -> ss.[o + S i] <> ss.[o+j].
Proof.
  intros.
  remember (i-j) as k.
  replace j with (i-k).
  apply no_loop'_neq'.
  omega.
  assert (j = i - k) by omega.
  rewrite <- H1.
  assert (i = j + k) by omega.
  rewrite -> H2 in H.
  apply split_no_loop' in H.
  rewrite <- H2 in H.
  apply H.
  omega.
Qed.

Lemma neq_states_no_loop' :
  forall (ss:sseq) (o i j:nat),
  i > j ->
  no_loop' ss o (S i) j -> ss.[o + S i] <> ss.[o+(S j)] ->
  no_loop' ss o (S i) (S j).
Proof.
  intros.
  destruct j.
  - simpl.
    split.
    + simpl in H0.
      apply H0.
    + apply H1.
  - simpl.
    split.
    + simpl in H0.
      apply H0.
    + apply H1.
Qed.

Lemma eq_states_not_no_loop' :
  forall (ss:sseq) (o i j:nat),
  i > j -> ss.[o + S i] = ss.[o+j] ->
  ~ no_loop' ss o (S i) i.
Proof.
  intros.
  assert (~(ss.[o + S i] <> ss.[o+j])) by tauto.
  contradict H1.
  apply no_loop'_neq.
  apply H1.
  apply H.
Qed.

Lemma lf_loop_path :
  forall (T:trans) (i j:nat) (ss:sseq),
  loop_free T ss 0 i ->
  path T ss 0 j -> ~ no_loop ss 0 j ->
  (* i <= j *) ~ i > j.
Proof.
  intros.
  contradict H1.

  unfold loop_free in H.
  destruct H.

  remember (i-j) as k.
  assert (i = j+k) by omega.

  rewrite -> H3 in H2.
  apply split_no_loop in H2.
  destruct H2.
  apply H2.
Qed.

Lemma lf_loop_path' :
  forall (T:trans) (i j:nat) (ss:sseq),
  loop_free T ss 0 i ->
  i > j ->
  ~no_loop ss 0 j -> ~path T ss 0 j.
Proof.
  intros.
  assert (~~(i > j)) by omega.
  contradict H2.
  revert H H2 H1.
  apply lf_loop_path.
Qed.

(*
Lemma lf_loop_path'' :
  forall (T:trans) (i j:nat) (ss:sseq),
  loop_free T ss 0 i ->
  path T ss 0 j -> i > j ->
  no_loop ss 0 j.
Proof.
  intros.
  apply NNPP.
  contradict H1.
  revert H H0 H1.
  apply lf_loop_path.
Qed.
*)

Lemma split_skipn :
  forall (m n i : nat) (ss : sseq),
  (skipn (m+n) ss).[i] = (skipn m (skipn n ss)).[i].
Proof.
  intros.
  do 3 rewrite -> skipn_nth.
  assert (m + n + i = n + (m + i)) by omega.
  rewrite -> H.
  reflexivity.
Qed.

(* eof *)


(** * Ternary logic exercise *)

Module ternary_unknown.

Inductive bool3 : Set :=
| true : bool3
| false : bool3
| unknown : bool3.

Definition andb3 (b1 b2 : bool3) : bool3 :=
match b1, b2 with
| true, true => true
| false, _ => false
| _, false => false
| _, _ => unknown
end.

Definition orb3 (b1 b2 : bool3) : bool3 :=
match b1, b2 with
| false, false => false
| true, _ => true
| _, true => true
| _, _ => unknown
end.

Definition negb3 (b : bool3) : bool3 :=
match b with
| true => false
| false => true
| unknown => unknown
end.

Ltac solve_bool3 := intros;
match reverse goal with
| b : bool3 |- _ => destruct b; solve_bool3
| _ => cbn; reflexivity
end.

Notation "b1 & b2" := (andb3 b1 b2) (at level 40).
Notation "b1 | b2" := (orb3 b1 b2) (at level 40).

Lemma andb3_comm :
  forall b1 b2 : bool3, b1 & b2 = b2 & b1.
Proof. solve_bool3. Qed.

Lemma orb3_comm :
  forall b1 b2 : bool3, b1 | b2 = b2 | b1.
Proof. solve_bool3. Qed.

Lemma andb3_dist_orb3 :
  forall b1 b2 b3 : bool3,
    b1 & (b2 | b3) = (b1 & b2) | (b1 & b3).
Proof. solve_bool3. Qed.

Lemma orb3_dist_andb3 :
  forall b1 b2 b3 : bool3,
    b1 | (b2 & b3) = (b1 | b2) & (b1 | b3).
Proof. solve_bool3. Qed.

Lemma andb3_true_neutral_l :
  forall b : bool3, andb3 true b = b.
Proof. solve_bool3. Qed.

Lemma andb3_true_neutral_r :
  forall b : bool3, andb3 b true = b.
Proof. solve_bool3. Qed.

End ternary_unknown.


From Coq Require Import Nat.
From Coq Require Import Program.Equality.

Set Maximal Implicit Insertion.

Module Stlc.

  (** Use the same reified type for the whole development *)
  Inductive type : Type :=
  | TNum: type
  | TArrow : type -> type -> type.

  Declare Custom Entry stlc_ty.
  Notation "<{{ e }}>" := e (e custom stlc_ty at level 99).
  Notation "( x )" := x (in custom stlc_ty, x at level 99).
  Notation "x" := x (in custom stlc_ty at level 0, x constr at level 0).
  Notation "S -> T" := (TArrow S T) (in custom stlc_ty at level 2, right associativity).
  Notation "'Num'" := TNum (in custom stlc_ty at level 0).

  (* begin typeDenote *)
  Fixpoint typeDenote (t : type) : Set :=
    match t with
    | <{{ Num }}> => nat
    | <{{ t1 -> t2 }}> => typeDenote t1 -> typeDenote t2
    end.
  (* end typeDenote *)

  (* begin syntax *)
  Section vars.
    Variable var : type -> Type.

    Inductive Term: type -> Type :=
    | NUM: nat -> Term <{{ Num }}>
    | ADD: Term <{{ Num }}> -> Term <{{ Num }}> -> Term <{{ Num }}>
    | APP: forall a b, Term <{{ a -> b }}> -> Term a -> Term b
    | RET: forall a, var a -> Term a
    | LAM: forall a b, (var a -> Term b) -> Term <{{ a ->  b }}>.
  End vars.
  (* end syntax *)

  Arguments RET {var a}.
  Arguments NUM {var}.
  Arguments ADD {var}.
  Arguments APP {var a b}.
  Arguments LAM {var a b}.

  (* Syntax *)
  Declare Custom Entry stlc.
  Notation "<{ e }>" := e (e custom stlc at level 99).
  Notation "( x )" := x (in custom stlc, x at level 99).
  Notation "x" := x (in custom stlc at level 0, x constr at level 0).
  Notation "x y" := (APP x y) (in custom stlc at level 2, left associativity).
  Notation "x + y" := (ADD x y) (in custom stlc at level 2, left associativity).
  Notation "\ x , y" :=
    (LAM (fun x => y)) (in custom stlc at level 90,
                        x constr,
                        y custom stlc at level 80,
                        left associativity).
  Notation "\_ , y" :=
    (LAM (fun _ => y)) (in custom stlc at level 90,
                        y custom stlc at level 80,
                        left associativity).

  Notation "# n" := (NUM n) (in custom stlc at level 0).
  Notation "@ n" := (RET n) (in custom stlc at level 0, n custom stlc at level 1).
  Notation "{ x }" := x (in custom stlc at level 1, x constr).

  Class Denotation (v: type -> Type) := {
      denote{t}(e: Term v t): v t;
                                      }.

  (* begin termDenote *)
  Fixpoint termDenote {t: type} (e : Term typeDenote t) : typeDenote t :=
    match e in (Term _ t) return (typeDenote t) with
    | RET v => v
    | ADD l r => (termDenote l) + (termDenote r)
    | NUM f => f
    | APP e1 e2 => (termDenote e1) (termDenote e2)
    | LAM e' => fun x => termDenote (e' x)
    end.
  (* end termDenote *)

  Fixpoint termFlatten {t: type} {v: type -> Type} (e: Term (Term v) t): Term v t :=
    match e with
    | RET v => v
    | NUM f => NUM f
    | ADD l r => ADD (termFlatten l) (termFlatten r)
    | APP e1 e2 => APP (termFlatten e1) (termFlatten e2)
    | LAM e' => LAM (fun x => termFlatten (e' (RET x)))
    end.

  Instance baseDenotation: Denotation typeDenote := {
      denote t e := termDenote e
    }.

  Instance stepDenotation v `{Denotation v}: Denotation (Term v) := {
      denote t e := termFlatten e
    }.

  (** Demo *)
  Fixpoint add1 {t: type} {v: type -> Type} (e: Term v t): Term v t :=
    match e with
    | NUM f => NUM (f+1)
    | APP e1 e2 => APP (add1 e1) (add1 e2)
    | ADD e1 e2 => ADD (add1 e1) (add1 e2)
    | LAM e' => LAM (fun x => add1 (e' x))
    | RET v => RET v
    end.

  Tactic Notation "meta" uconstr(x) := refine x; exact typeDenote.

  Definition l3 :=
    ltac:(meta <{ \x, @x + #1 + (@ (#3 + (@( #1)))) }>).

  Check l3.

  Compute add1 l3.          (* = <{ \ x, @ x + #2 + @ (#3) + @ (#1) }> *)
  Compute denote (add1 l3). (* = <{ \ x, @ x + #2 + (#3 + @ (#1)) }> *)
  Compute denote (add1 (denote (add1 l3))).
                            (* = <{ \ x, @ x + #3 + #4 + #1 }> *)
  Compute denote (denote (add1 (denote (add1 l3)))).
                            (* = <{ \x, 5 }> *)
  Compute denote (denote (add1 l3)).
  Compute denote (denote (denote (add1 l3))).

  (* Normalization via reify/reflect Danvy et al. *)
  (* begin nbe *)
  Class Nbe (t: type) := {
    reify: typeDenote t -> Term typeDenote t;
    reflect: Term typeDenote t -> typeDenote t
    }.

  Instance Nbe_lam {a b: type} `{Nbe a} `{Nbe b}: Nbe <{{ a -> b }}> := {
    reify v :=
      LAM (fun x => reify (v (reflect (RET x))));
    reflect e :=
      fun x => reflect (APP e (reify x))
    }.

  Instance Nbe_int : Nbe <{{ Num }}> := {
    reify v := NUM v;
    reflect v := termDenote v;
    }.
  (* end nbe *)

  Fixpoint resolver(t: type): Nbe t :=
    match t with
    | <{{ Num }}> => Nbe_int
    | <{{ a -> b }}> => Nbe_lam
    end.

  Arguments Nbe {t}.
  Arguments Nbe_lam [a b].

  Definition normalize {t: type} (e: Term typeDenote t): Term typeDenote t :=
    @reify t (resolver t) (@reflect t (resolver t) e).

  Compute normalize <{ ((\x, @x + #1) #2) + #1 }>.

  (* begin fof *)
  Inductive fof: type -> Prop :=
  | fo_num: fof <{{ Num }}>
  | fof_num: forall a,
      fof <{{ a }}> ->
      fof <{{ Num -> a }}>.

  Hint Constructors fof: core.
  (* end fof *)

  Inductive value: forall {t: type}, Term typeDenote t -> Prop :=
  | Value_var: forall x, @value <{{ Num }}> (@RET typeDenote <{{ Num }}> x)
  | Value_const: forall (x: nat), @value <{{ Num }}> (NUM x).

  Hint Constructors value: core.

  (* begin hnff *)
  Inductive hnff: forall (t: type), Term typeDenote t -> Prop :=
  | HNF_num_ar: forall a f,
      (forall (arg: typeDenote <{{ Num }}>), hnff <{{ a }}> (f arg)) ->
      hnff <{{ Num -> a }}> (LAM f)
  | HNF_num: forall e,
      value e ->
      hnff <{{ Num }}> e.

  Hint Constructors hnff: core.
  (* end hnff *)

  (* begin correct *)
  Theorem normalize_correct: forall (t: type) (e: Term typeDenote t),
      fof t  ->
      hnff t (normalize e).
  Proof with eauto.
    induction t; dependent destruction e; inversion 1; subst; cbn...
  Defined.
  (* end correct *)

End Stlc.