Require Import Reals Psatz.
Require Import Coquelicot.Hierarchy.
Require Import Coquelicot.Rbar.
Require Import Top.linear_map.
Require Import Top.continuous_linear_map.
Require Import Omega Init.Nat Arith.EqNat.
Require Import Coq.Arith.PeanoNat.
Require Import Ah_properties.
Require Import Eigen_system.

Variable h:R. (* h is the discretization step *)
Hypothesis h_gt_0: 0<h. (* assumption that the discretization step > 0 *)

Lemma inv_sqr_h_ge_0: 0 <= 1 * / (h * h).
Proof.
assert( 0< h -> 0 <= 1 * / (h * h)). { intros. apply Rlt_le. assert( 0<h -> 0<(h*h)). { nra. }
assert(0 < h * h->0 < 1 * / (h * h)).
assert(1 * / (h * h)= /(h*h)). { nra. } rewrite H1.  apply (Rinv_0_lt_compat (h*h)).
apply H1. nra. } apply H. apply h_gt_0.
Qed.

Lemma N_not_zero: forall N:nat, (2<N)%nat -> INR (N+1) <> 0.
Proof.
intros.
assert ( 0 < INR (N+1) -> INR (N+1) <> 0). { nra. } apply H0.
apply lt_0_INR. omega.
Qed.

Require Import R_sqrt Rpower.

(** This is where we instatiate the eigen value for Ah(a, b, a) with a= (1/h^2), b= -2 / (h^2) **)
Lemma lambda : forall (m N:nat) , (2<N)%nat -> (0<=m<N)%nat ->
  coeff_mat 0 (Lambda m N (1/(h^2)) (-2/ (h^2)) (1/(h^2))) 0%nat 0%nat= - (4/ (h^2))* (sin ( (INR (m+1) * PI)*/(2* INR (N+1))))^2.
Proof.
intros. unfold Lambda.
assert (coeff_mat 0
        (mk_matrix 1 1
           (fun _ _ : nat =>
            -2 / h ^ 2 + 2 * sqrt (1 / h ^ 2 * (1 / h ^ 2)) * cos (INR (m + 1) * PI * / INR (N + 1)))) 0 0=(fun _ _ : nat =>
            -2 / h ^ 2 + 2 * sqrt (1 / h ^ 2 * (1 / h ^ 2)) * cos (INR (m + 1) * PI * / INR (N + 1))) 0%nat 0%nat).
{ apply (coeff_mat_bij 0 (fun _ _ : nat =>
            -2 / h ^ 2 + 2 * sqrt (1 / h ^ 2 * (1 / h ^ 2)) * cos (INR (m + 1) * PI * / INR (N + 1))) 0%nat 0%nat).
  omega. omega.
} rewrite H1.
assert (sqrt (1 / h ^ 2 * (1 / h ^ 2))= (1 / h ^ 2)). { apply sqrt_square. assert (h^2 = h* h). { nra. } rewrite H2. apply inv_sqr_h_ge_0. }
rewrite H2.
assert (-2 / h ^ 2 + 2 * (1 / h ^ 2) * cos (INR (m + 1) * PI * / INR (N + 1))=
          (2 / h ^ 2) * (-1+  cos (INR (m + 1) * PI * / INR (N + 1)))). { nra. } rewrite H3.
cut((-1 + cos (INR (m+1) * PI * / INR (N + 1)))= -2* sin (INR (m+1) * PI * / (2 * INR (N + 1))) ^ 2).
+ intros. rewrite H4. nra.
+ assert(cos (INR (m+1) * PI * / INR (N + 1))= cos (2* ((INR (m+1) * PI)*/(2* INR (N+1))))).
  { assert((INR (m+1) * PI * / INR (N + 1))= (2 * (INR (m+1) * PI * / (2 * INR (N + 1))))).
    { assert(/ (2 * INR (N + 1))= (/2)* (/ INR (N+1))). { apply Rinv_mult_distr. nra. apply N_not_zero. omega. } rewrite H4. nra. }
      rewrite H4. reflexivity.
    } rewrite H4.
  assert (-2 * sin (INR (m+1) * PI * / (2 * INR (N + 1))) ^ 2= -1 + (1-2 * sin (INR (m+1) * PI * / (2 * INR (N + 1))) ^ 2)).
  { nra. } rewrite H5.
  apply Rplus_eq_compat_l.
  assert (sin (INR (m+1) * PI * / (2 * INR (N + 1))) ^ 2= sin (INR (m+1) * PI * / (2 * INR (N + 1)))* sin (INR (m+1) * PI * / (2 * INR (N + 1)))). { nra. } rewrite H6.
  assert (2 * (sin (INR (m+1) * PI * / (2 * INR (N + 1))) * sin (INR (m+1) * PI * / (2 * INR (N + 1))))=
                2 * sin (INR (m+1) * PI * / (2 * INR (N + 1))) * sin (INR (m+1) * PI * / (2 * INR (N + 1)))). { nra. } rewrite H7.
  apply cos_2a_sin.
Qed.

(*** Proving the uniform boundedness of 1/ | lambda_min| for Ah (1/h^2, -2/h^2, 1/h^2) **)

(* Define a real valued concae function *)
Definition concave (f:R->R) (x y c:R):= 0<=c<=1 ->f(c*x + (1-c) * y) >= c* f x + (1-c) * f y.

Lemma inverse_a_b: forall (a b:R), (a <> 0) /\ (b<>0)-> a/b= 1/(b/a).
Proof.
intros.
assert ( 1 / (b / a)= /(b * /a)). { nra. } rewrite H0.
assert (/ (b * / a)= /b * //a). { apply Rinv_mult_distr. nra. apply Rinv_neq_0_compat. nra. }
rewrite H1. assert ( / / a= a). { apply Rinv_involutive. nra. } rewrite H2. nra.
Qed.

Definition g (f:R-> R)(pr:derivable f) (x:R):= derive_pt f x (pr x).

(** Stating the property of a concave function that in the interval [a,b], the 2nd derivative of a differentiable function g is <=0 ***)
Hypothesis concave_def: forall (f:R->R) (g:R->R) (a b c x:R) (pr: derivable f) (pr1:derivable g), a<=x<=b -> concave f a b c<->
      derive_pt g x (pr1 x) <=0.

Lemma sin_concave_1 (x:R) : 0<=x<=PI/2 -> concave sin 0 (PI / 2) (1-(2/PI)*x).
Proof.
intros.
assert (concave sin 0 (PI/2) (1-(2/PI)*x)<-> derive_pt cos x (derivable_pt_cos x) <=0). { apply (concave_def sin  cos 0 (PI/2) (1-(2/PI)*x) x  ( derivable_pt_sin) (derivable_pt_cos )).  nra. }
destruct H0.
apply H1.
assert (derive_pt cos x (derivable_pt_cos x)= -sin x). { apply derive_pt_cos. } rewrite H2.
assert ( 0 = -0). { nra. } rewrite H3.
apply Ropp_le_contravar.
apply sin_ge_0. nra. nra.
Qed.

Lemma sin_concave (x:R):0<=x<=PI/2 ->  sin x >= 2 / PI * x <-> concave sin 0 (PI/2) (1-(2/PI)*x).
Proof.
split.
+ intros. unfold concave.
  intros.
  assert(sin 0 = 0). { apply sin_0. } rewrite H2.
  assert (sin (PI/2) =1). { apply sin_PI2. } rewrite H3.
  assert ((1 - 2 / PI * x) * 0=0). { nra. } rewrite H4.
  assert ((1 - (1 - 2 / PI * x)) * 1= (2/PI)*x). { nra. } rewrite H5.
  assert ((1 - (1 - 2 / PI * x)) * (PI / 2)=x).
  { assert ((1 - (1 - 2 / PI * x))= (2/PI)*x). { nra. } rewrite H6.
    assert (2 / PI * x * (PI / 2)= ((2/PI)* (PI/2))*x). { nra. } rewrite H7.
    assert (2 / PI * (PI / 2)=1).
    { assert (2 / PI= 1/ (PI/2)).  apply (inverse_a_b 2 PI).
      split.
      - nra.
      - apply PI_neq0.
      rewrite H8.
      assert (1 / (PI / 2)= / (PI / 2)). { nra. } rewrite H9.
      symmetry. apply Rinv_l_sym .
      assert (0 < (PI/2) -> PI / 2 <> 0). { nra. } apply H10. apply PI2_RGT_0.
    } rewrite H8. nra.
  }
  assert (0 + (1 - (1 - 2 / PI * x)) * (PI / 2)= x). { nra. } rewrite H7.
  assert (0 + 2 / PI * x= 2 / PI * x). { nra. } rewrite H8. apply H0.
+ intros.
  unfold concave in H0.
    assert ( 0 <= 1 - 2 / PI * x <= 1).
    { split.
      - assert ( 0 = 1-1). { nra. } rewrite H1.
        apply Rplus_le_compat_l. apply Ropp_ge_le_contravar.
        assert ( 1= (/ (PI /2)) * (PI/2)). { apply Rinv_l_sym.
        assert (0 < (PI/2) -> PI / 2 <> 0). { nra. } apply H2. apply PI2_RGT_0. }
       rewrite H2.
        assert ( 2/ PI = /(PI/2)).
        { assert (/ (PI / 2)= 1/ (PI/2)).  { nra. } rewrite H3. apply inverse_a_b.
          split. nra. apply PI_neq0. } rewrite H3.
        apply Rmult_ge_compat_l. nra.  nra.
      - assert (1= 1-0). { nra. } rewrite H1.
        assert ( 1 - 0 - 2 / PI * x= 1 - 2 / PI * x). { nra. } rewrite H2.
        apply Rplus_le_compat. nra.
        apply Ropp_ge_le_contravar.
        assert (0 =(2/PI)*0). { nra. } rewrite H3. apply Rmult_ge_compat_l.
        apply Rle_ge. apply Rlt_le.
        assert (2 / PI= 1/ (PI/2)). { apply inverse_a_b. split. nra. apply PI_neq0. } rewrite H4.
        assert (1 / (PI / 2)= / (PI/2)). { nra. } rewrite H5. apply Rinv_0_lt_compat. apply PI2_RGT_0. nra.
    }
    specialize (H0 H1).
    assert(sin 0 = 0). { apply sin_0. } rewrite H2 in H0.
    assert (sin (PI/2) =1). { apply sin_PI2. } rewrite H3 in H0.
    assert ((1 - 2 / PI * x) * 0=0). { nra. } rewrite H4 in H0.
    assert ((1 - (1 - 2 / PI * x)) * 1= (2/PI)*x). { nra. } rewrite H5 in H0.
    assert ((1 - (1 - 2 / PI * x)) * (PI / 2)=x).
    { assert ((1 - (1 - 2 / PI * x))= (2/PI)*x). { nra. } rewrite H6.
      assert (2 / PI * x * (PI / 2)= ((2/PI)* (PI/2))*x). { nra. } rewrite H7.
      assert (2 / PI * (PI / 2)=1).
      { assert (2 / PI= 1/ (PI/2)).  apply (inverse_a_b 2 PI).
        split.
        - nra.
        - apply PI_neq0.
        rewrite H8.
        assert (1 / (PI / 2)= / (PI / 2)). { nra. } rewrite H9.
        symmetry. apply Rinv_l_sym .
        assert (0 < (PI/2) -> PI / 2 <> 0). { nra. } apply H10. apply PI2_RGT_0.
      } rewrite H8. nra.
    }
    assert (0 + (1 - (1 - 2 / PI * x)) * (PI / 2)= x). { nra. } rewrite H7 in H0.
    assert (0 + 2 / PI * x= 2 / PI * x). { nra. } rewrite H8 in H0. apply H0.
Qed.

Lemma limit_trigo : forall x:R, 0<=x<=(PI/2) -> (2* x)/PI <= sin x.
Proof.
intros.
apply Rge_le.
assert (sin x >= 2 / PI * x <-> concave sin 0 (PI/2) (1-(2/PI)*x)). { apply sin_concave. nra. }
destruct H0.
assert (2 * x / PI= 2 / PI * x). { nra. } rewrite H2. apply H1. apply sin_concave_1. nra.
Qed.

Lemma spectral_intermed: forall x:R, 0<x<=PI/2 -> (x^2)/ (sin x)^2 <= (PI^2)/4.
Proof.
intros.
assert (x ^ 2 / sin x ^ 2= Rsqr ( x / sin x)).
{ assert ( x^2 = Rsqr x). { simpl. unfold Rsqr. nra. } rewrite H0.
  assert (sin x ^ 2= Rsqr (sin x)). { simpl. unfold Rsqr. nra. } rewrite H1.
  symmetry. apply Rsqr_div.
  assert (0< sin x -> sin x <> 0). { nra. } apply H2. apply sin_gt_0. nra. nra.
} rewrite H0.
assert (PI ^ 2 / 4= Rsqr (PI/2)).
{ assert (PI^2 = Rsqr PI). { simpl. unfold Rsqr. nra. } rewrite H1.
  assert (4 = Rsqr 2). { auto. } rewrite H2. symmetry. apply Rsqr_div. auto. }
  rewrite H1.
  apply Rsqr_incr_1.
  apply Rmult_le_reg_r with (2/PI).
  assert ( 2/ PI = 1/ (PI/2)). { apply inverse_a_b. nra. } rewrite H2.
  assert (1 / (PI / 2)= / (PI/2)). { nra. } rewrite H3. apply Rinv_0_lt_compat. nra.
  assert (PI / 2 * (2 / PI)=1).
  { assert ((2 / PI)= 1/ (PI/2)). { apply inverse_a_b. nra. } rewrite H2.
    assert ((1 / (PI / 2))= / (PI/2)). { nra. } rewrite H3. apply Rinv_r. nra.
  }   rewrite H2.
  apply Rmult_le_reg_r with (sin x).
  apply sin_gt_0. nra. nra.
  assert (x / sin x * (2 / PI) * sin x= (x * 2/PI) * (/sin x * sin x)). { nra. } rewrite H3.
  assert ((/ sin x * sin x)= 1). { symmetry. apply Rinv_l_sym. assert ( 0< sin x -> sin x <> 0). { nra. } apply H4.
  apply sin_gt_0. nra. nra. }
  rewrite H4.
  assert ( (2* x)/PI= x * 2 / PI * 1). { nra. } rewrite <- H5.
  assert (1 * sin x= sin x). { nra. } rewrite H6. apply limit_trigo. nra.
  apply Rlt_le. assert (x / sin x= x* (/sin x)). { nra. } rewrite H2.
  apply Rmult_lt_0_compat. nra. apply Rinv_0_lt_compat. apply sin_gt_0. nra. nra. nra.
Qed.

(*** Define the minimum eigen value for Ah (1/h^2, -2/(h^2), 1/h^2). m=1 ***)
Definition Lambda_min (N:nat):= (-2/(h^2)) + 2 * (1/(h^2)) * cos (INR 1 * PI * / INR (N + 1)).

Variable L:R. (* L is the length of the domain *)
Hypothesis L_ge_0: 0< L.

Lemma L_PI_gt_0 (L:R): 0 < L /\ 0 < PI -> 0 < L / PI.
Proof.
intros.
assert ( L / PI= L * (/PI)). { nra. } rewrite H0.
apply Rmult_lt_0_compat. nra. apply Rinv_0_lt_compat. nra.
Qed.

Hypothesis h_L: forall (N:nat), h = L/ INR (N+1).

Lemma inv_gt_0: forall a b:R, 0<a /\ 0< b -> 0< a/b.
Proof.
intros.
assert (a / b= a * (/b)). { nra. } rewrite H0. apply Rmult_lt_0_compat.
+ nra.
+ apply Rinv_0_lt_compat. nra.
Qed.

(*** Proof that 1/|lambda_min| for Ah (1/h^2, -2/h^2, 1/h^2) is uniformly bounded by L^2/4 **)
Lemma spectral : forall N:nat , (2<N)%nat -> 1/ Rabs( Lambda_min N) <= L^2 / 4.
Proof.
intros.
cut ( 1 / Rabs (Lambda_min  N)= (L^2/ (PI^2)) * ( (PI/ (2* INR (N+1)))^2 / (sin (PI/ (2* INR (N+1))))^2)).
+ intros. rewrite H0.
  assert (( (PI/ (2* INR (N+1)))^2 / (sin (PI/ (2* INR (N+1))))^2)<= (PI^2)/4).
  { apply spectral_intermed.
    split.
    + assert ( 0< PI /\ 0<(2 * INR (N + 1)) -> 0 < PI / (2 * INR (N + 1))). { apply inv_gt_0. }
      apply H1.
      split.
      - apply PI_RGT_0.
      - apply Rmult_lt_0_compat. nra. apply lt_0_INR. omega.
    + assert (PI / (2 * INR (N + 1))= PI * /(2 * INR (N + 1))). { nra. } rewrite H1.
      assert (PI / 2= PI * (/2)). { nra. } rewrite H2.
      apply Rmult_le_compat_l. apply Rlt_le. apply PI_RGT_0.
      apply Rlt_le. apply Rinv_1_lt_contravar. nra.
      assert (2= 2* 1). { nra. } rewrite H3.
      assert (2 * 1 * INR (N + 1)= 2* (INR (N+1))). { nra. } rewrite H4.
      apply Rmult_lt_compat_l. nra.
      apply lt_1_INR. omega.
  }
  assert (L ^ 2 / 4= (L^2 /(PI^2)) * (PI^2/4)).
  {  assert ( L ^ 2 / PI ^ 2 * (PI ^ 2 / 4)= (L^2/4) * ( / (PI^2) * (PI^2))). { nra. } rewrite H2.
     assert ( 1= ( / (PI^2) * (PI^2))). { apply Rinv_l_sym. assert ( PI <> 0 -> PI ^ 2 <> 0). { nra. } apply H3. apply PI_neq0. }
  rewrite <-H3. nra.
  } rewrite H2.
  apply Rmult_le_compat_l.  apply Rlt_le.
  assert (0< L/PI ->  0 <L ^ 2 / PI ^ 2).
  { intros.
    assert (L ^ 2 = Rsqr L). { simpl. unfold Rsqr. nra. } rewrite H4.
    assert (PI ^ 2= Rsqr PI). { simpl. unfold Rsqr. nra. } rewrite H5.
    assert (Rsqr (L/PI) = L² / PI²). { apply Rsqr_div. apply PI_neq0. } rewrite <- H6.
    apply Rsqr_pos_lt.
    assert (0 < L/PI -> L / PI <> 0). { nra. } apply H7. apply L_PI_gt_0. split. apply L_ge_0. apply PI_RGT_0.
  }
  apply H3.
  apply L_PI_gt_0. split. apply L_ge_0. apply PI_RGT_0. apply H1.
+ assert ( (Lambda_min  N)<0 -> Rabs (Lambda_min  N)= - (Lambda_min  N)).
  { apply Rabs_left. } rewrite H0.
  unfold Lambda_min.
  cut ((-2/(h^2))  + 2 * (1/(h^2))* cos (INR 1 * PI * / INR (N + 1))= (2*/ (h^2))* (-1+ cos (INR 1 * PI * / INR (N + 1)))).
  - intros. rewrite H1.
    assert ((-1 + cos (INR 1 * PI * / INR (N + 1)))= -2 *sin (PI / (2 * INR (N + 1))) ^ 2).
    { assert (INR 1 * PI * / INR (N + 1)= 2* (PI/ (2* INR (N+1)))).
      { assert (INR 1= 1). { reflexivity. } rewrite H2.
      assert (1=2* (/2)). { nra. } rewrite H3.
      assert (2 * / 2 * PI * / INR (N + 1)= (2* PI) * (/2 * / INR (N+1))). { nra. } rewrite H4.
      assert (2 * (PI / (2 * INR (N + 1)))= (2* PI) * (/ (2* INR (N+1)))). { nra. } rewrite H5.
      apply Rmult_eq_compat_l. symmetry. apply Rinv_mult_distr. nra.
      assert (0 < INR (N+1) -> INR (N + 1) <> 0). { nra. } apply H6.
      apply lt_0_INR. omega.
    } rewrite H2.
    assert ( -2 * sin (PI / (2 * INR (N + 1))) ^ 2= -1 + (1 -2 * sin (PI / (2 * INR (N + 1))) ^ 2)). { nra. } rewrite H3.
    apply Rplus_eq_compat_l.
    assert (1 - 2 * sin (PI / (2 * INR (N + 1))) ^ 2= 1 - 2 * sin (PI / (2 * INR (N + 1)))* sin (PI / (2 * INR (N + 1)))). { nra. } rewrite H4.
    apply cos_2a_sin.
    }
    rewrite H2.
    assert (-(2 * / h ^ 2 * (-2 * sin (PI / (2 * INR (N + 1))) ^ 2))= (4* / (h^2)) * sin (PI / (2 * INR (N + 1)))^2). { nra. }
    rewrite H3.
    assert (1 /(4 * / h ^ 2 * sin (PI / (2 * INR (N + 1))) ^ 2)= / ((4* / (h^2)) * (sin (PI / (2 * INR (N + 1))) ^ 2))).
    { nra. } rewrite H4.
    assert (/ ((4* / (h^2)) * (sin (PI / (2 * INR (N + 1))) ^ 2))= / (4/ (h^2)) * /(sin (PI / (2 * INR (N + 1))) ^ 2)).
    { apply Rinv_mult_distr.
      assert (0 < 4/ (h^2) -> 4 / h ^ 2 <> 0). { nra. } apply H5.
      assert ( 4 / h ^ 2= 4 * (/ h^2)). { nra. } rewrite H6.
      apply Rmult_lt_0_compat. nra. apply Rinv_0_lt_compat.
      assert (0< h -> 0 < h ^ 2). { nra. } apply H7. apply h_gt_0.
      assert (sin (PI / (2 * INR (N + 1))) <> 0 -> sin (PI / (2 * INR (N + 1))) ^ 2 <> 0). { nra. } apply H5.
      assert (0 < sin (PI / (2 * INR (N + 1))) -> sin (PI / (2 * INR (N + 1))) <> 0). { nra. } apply H6.
      assert ( sin 0 = 0). { apply sin_0. } rewrite <- H7.
      apply sin_increasing_1. assert (0=-0). { nra. } rewrite H8.
      apply Ropp_ge_le_contravar. apply Rgt_ge. apply PI2_RGT_0. apply Rlt_le. apply PI2_RGT_0.
      apply Rle_trans with 0. assert (0=-0). { nra. } rewrite H8.
      apply Ropp_ge_le_contravar. apply Rgt_ge. apply PI2_RGT_0. apply Rlt_le. assert (0 = PI * 0). { nra. } rewrite H8.
      assert (PI / (2 * INR (N + 1))= PI * (/ (2 * INR (N + 1)))). { nra. } rewrite H9. apply Rmult_lt_compat_l.
      apply PI_RGT_0. apply Rinv_0_lt_compat. assert (0=2* 0). { nra. } rewrite H10. apply Rmult_lt_compat_l. nra. apply lt_0_INR. omega.
      apply Rlt_le. assert (PI / (2 * INR (N + 1))= PI * (/ (2* INR (N+1)))). { nra. } rewrite H8.
      assert (PI / 2= PI * (/2)). { nra. } rewrite H9. apply Rmult_lt_compat_l. apply PI_RGT_0. apply Rinv_1_lt_contravar. nra.
      assert (2= 2 * 1). { nra. } rewrite H10.
      assert (2 * 1 * INR (N + 1)= 2* INR (N+1)). { nra. } rewrite H11. apply Rmult_lt_compat_l.
      nra. apply lt_1_INR. omega.
      assert ( 0 = PI * 0). { nra. } rewrite H8.
      assert ( PI / (2 * INR (N + 1))= PI * (/ (2* INR (N+1)))). { nra. } rewrite H9.
      apply Rmult_lt_compat_l. apply PI_RGT_0. apply Rinv_0_lt_compat. assert (0=2* 0). { nra. } rewrite H10.
      apply Rmult_lt_compat_l. nra. apply lt_0_INR. omega.
    }
    rewrite H5.
    assert (/ (4 / h ^ 2) = 1/ (4 / h ^ 2)). { nra. } rewrite H6.
    assert ( (h^2)/4 = 1 / (4 / h ^ 2)). { apply inverse_a_b. split.
     assert (0<h -> h ^ 2 <> 0). { nra. } apply H7. apply h_gt_0. nra. }
    rewrite <-H7.
    assert (h ^ 2 / 4= L ^ 2 / PI ^ 2 * (PI / (2 * INR (N + 1))) ^ 2).
    { assert (h= L/ INR (N+1)). { apply h_L. } rewrite H8.
      assert ((L / INR (N + 1)) ^ 2= (L^2) / (INR (N+1))^2).
      { assert ((L / INR (N + 1)) ^ 2= Rsqr (L/ INR (N+1))). { simpl. unfold Rsqr. nra. } rewrite H9.
        assert (L ^ 2 = Rsqr L). { simpl. unfold Rsqr. nra. } rewrite H10.
        assert (INR (N + 1) ^ 2= Rsqr (INR (N+1))). { simpl. unfold Rsqr. nra. } rewrite H11.
        apply Rsqr_div. assert ( 0< INR (N+1) -> INR (N + 1) <> 0). { nra. } apply H12. apply lt_0_INR. omega.
      }
      assert ( 4= Rsqr 2). { auto. } rewrite H10.
      assert ((L / INR (N + 1)) ^ 2= Rsqr ( L/ INR (N+1))).
      { simpl. unfold Rsqr. nra. } rewrite H11.
      assert (Rsqr ((L / INR (N + 1))/ 2)= (L / INR (N + 1))² / 2²). { apply Rsqr_div. nra. } rewrite <-H12.
      assert (L / INR (N + 1) / 2= L * (/INR (N+1)) * /2). { nra. } rewrite H13.
      assert (L * (/INR (N+1)) * /2= L * (/ INR (N+1) * /2)). { nra. } rewrite H14.
      assert ( / (INR (N+1) * 2) =(/ INR (N+1) * /2)). { apply Rinv_mult_distr.
        assert (0< INR (N+1) -> INR (N + 1) <> 0). { nra. } apply H15. apply lt_0_INR. omega. nra. }
      rewrite<- H15.
      assert ((INR (N + 1) * 2) = 2* INR (N+1)). { apply Rmult_comm. } rewrite H16.
      assert (PI * / (2* INR (N+1)) * (L */ PI) = L * / (2 * INR (N + 1))). { apply Rinv_mult_simpl. apply PI_neq0. } rewrite <-H17.
      assert ((L * / PI)= L/ PI). { nra. } rewrite H18.
      assert (PI * / (2 * INR (N + 1))= PI/ (2* INR (N+1))). { nra. } rewrite H19.
      assert ((PI / (2 * INR (N + 1)) * (L / PI))² = Rsqr (PI/ (2* INR (N+1))) * Rsqr (L/PI)). { apply Rsqr_mult. } rewrite H20.
      assert (L ^ 2 / PI ^ 2= Rsqr (L/PI)).
      { assert (L ^ 2= Rsqr L). { simpl. unfold Rsqr. nra. } rewrite H21.
        assert (PI ^ 2= Rsqr PI). { simpl. unfold Rsqr. nra. } rewrite H22.
        symmetry.  apply Rsqr_div. apply PI_neq0.
      } rewrite H21.
      assert ((PI / (2 * INR (N + 1))) ^ 2= Rsqr (PI/ (2* INR (N+1)))).
      { simpl. unfold Rsqr. nra. } rewrite H22. nra.
     } rewrite H8. nra.
  - nra.
unfold Lambda_min.
assert (-2 / h ^ 2 +2 * (1 / h ^ 2) *cos (INR 1 * PI * / INR (N + 1))= (2/ h^2) * (-1 + cos (INR 1 * PI * / INR (N + 1)))).
{ nra. } rewrite H1.
assert (0= (2/ h^2) * 0). { nra. } rewrite H2.
apply Rmult_lt_compat_l. assert ( 0 = 2* 0). { nra. } rewrite H3.
assert ( 2 / h ^ 2= 2* (/ h^2)). { apply Rmult_eq_compat_l. reflexivity. } rewrite H4. apply Rmult_lt_compat_l. nra.
apply Rinv_0_lt_compat. assert ( 0 < h -> 0< h ^ 2). { nra. } apply H5. apply h_gt_0.
assert (0=-1+1). { nra. } rewrite H3.
apply Rplus_lt_compat_l.
assert ((INR 1 * PI * / INR (N + 1))= PI / INR (N + 1)).
{ assert (INR 1 = 1). { reflexivity. } rewrite H4. nra. } rewrite H4.
assert (cos 0 =1). { apply cos_0. } rewrite <- H5.
apply cos_decreasing_1. nra. apply Rlt_le. apply PI_RGT_0. apply Rlt_le.
assert (0 = PI * 0). { nra. } rewrite H6.
assert (PI / INR (N + 1)= PI * (/ INR (N+1))). { nra. } rewrite H7.
apply Rmult_lt_compat_l. apply PI_RGT_0. apply Rinv_0_lt_compat. apply lt_0_INR. omega.
apply Rlt_le. assert (PI= PI * 1). { nra. } rewrite H6.
assert (PI * 1 / INR (N + 1)= PI * (/INR (N+1))). { nra. } rewrite H7.
apply Rmult_lt_compat_l. apply PI_RGT_0. assert (1 = /1). { nra. } rewrite H8. apply Rinv_1_lt_contravar. nra.
apply lt_1_INR. omega.
assert (0= PI * 0). { nra. } rewrite H6.
assert ( PI / INR (N + 1)= PI * (/ INR (N+1))). { nra. } rewrite H7.
apply Rmult_lt_compat_l. apply PI_RGT_0. apply Rinv_0_lt_compat. apply lt_0_INR. omega.
Qed.

(* Proof that for any vector v , y^{T} * \Lambda ^{-2} y = \sum y_{i}^2/ \lambda_{i} *)

Definition lam (j N:nat) (a b c:R):= 1/(coeff_mat 0 (Lambda j N a b c) 0%nat 0%nat).

(* Proof on boundedness of eigen values *)
Lemma inverse_rel: forall (a b:R), (0<a /\ 0< b) -> (b<=a) -> 1/a <= 1/b.
Proof.
intros.
apply Rmult_le_reg_r with a.
+ nra.
+ assert (1 / a * a= 1). { assert (1 / a= / a). { nra. } rewrite H1. symmetry. apply Rinv_l_sym. nra. } rewrite H1.
apply Rmult_le_reg_r with b.
+ nra.
+  assert (1 / b * a * b= ( / b *b) * a). { nra. } rewrite H2.
   assert (/ b * b =1). { symmetry. apply Rinv_l_sym. nra. } rewrite H3.
   apply Rmult_le_compat_l.
   - nra.
   - apply H0.
Qed.

(** Proof that all eigen values of Ah (1/h^2, -2/h^2, 1/h^2) are negative ***)

Lemma eig_0: forall (i N:nat), (2<N)%nat -> (0<= i < N)%nat -> (-2/(h^2)) + 2 * sqrt ((1/(h^2))* (1/(h^2))) * cos (INR (i+1) * PI * / INR (N + 1)) < 0.
Proof.
intros.
assert (sqrt (1 / h ^ 2 * (1 / h ^ 2))=1 / h ^ 2 ). { apply sqrt_square. assert (h ^ 2= h* h). { nra. } rewrite H1. apply inv_sqr_h_ge_0. } rewrite H1.
assert (-2 / h ^ 2 + 2 * (1 / h ^ 2) * cos (INR (i + 1) * PI * / INR (N + 1))=
          (2/ (h^2)) * (- 1 +  cos (INR (i + 1) * PI * / INR (N + 1)))). { nra. } rewrite H2.
assert ( 0 = (2/ (h^2))*0). { nra. } rewrite H3.
apply Rmult_lt_compat_l.
+ assert ( 0 < 1/ (h^2) ->0 < 2 / h ^ 2). { nra. } apply H4. assert (1 / h ^ 2= / (h^2)). { nra. } rewrite H5.
  apply Rinv_0_lt_compat. assert ( 0< h -> 0 < h ^ 2). { nra. } apply H6. apply h_gt_0.
+ assert (0 = -1 +1). { nra. } rewrite H4.
  apply Rplus_lt_compat_l.
  assert ( cos 0 = 1). { apply cos_0. } rewrite <- H5.
  apply cos_decreasing_1.
  - nra.
  - apply Rlt_le. apply PI_RGT_0.
  - assert (INR (i + 1) * PI * / INR (N + 1)= (INR (i+1)) * (PI * / INR (N + 1))). { nra. } rewrite H6.
    apply Rlt_le. apply Rmult_lt_0_compat. apply lt_0_INR. omega. apply Rmult_lt_0_compat. apply PI_RGT_0. apply Rinv_0_lt_compat. apply lt_0_INR. omega.
  - apply Rmult_le_reg_r with (INR (N+1)). apply lt_0_INR. omega.
    assert (INR (i + 1) * PI * / INR (N + 1) * INR (N + 1)= PI * INR (i+1) * ( / INR (N+1) * INR (N+1))). { nra. } rewrite H6.
    assert (( / INR (N+1) * INR (N+1))=1). { symmetry. apply Rinv_l_sym. assert ( 0< INR (N+1) -> INR (N+1) <> 0). { nra. } apply H7. apply lt_0_INR. omega. }
    rewrite H7.
    assert (PI * INR (i + 1) * 1= PI * INR (i+1)). { nra. } rewrite H8.
    apply Rmult_le_compat_l. apply Rlt_le. apply PI_RGT_0. apply le_INR. omega.
  - assert (INR (i + 1) * PI * / INR (N + 1)= (INR (i+1)) * (PI * / INR (N + 1))). { nra. } rewrite H6.
    apply Rmult_lt_0_compat. apply lt_0_INR. omega. apply Rmult_lt_0_compat. apply PI_RGT_0. apply Rinv_0_lt_compat. apply lt_0_INR. omega.
Qed.

(** Proof that all eigen values of Ah(1/h^2, -2/h^2, 1/h^2) are non-zero ***)
Lemma eig_1: forall (i N:nat) , (2< N)%nat /\ (0<=i<N)%nat-> coeff_mat 0 (Lambda i N (1/(h^2)) (-2/(h^2)) (1/(h^2))) 0 0 <> 0.
Proof.
intros.
unfold Lambda.
assert (coeff_mat 0
          (mk_matrix 1 1
             (fun _ _ : nat =>
              (-2/(h^2))  +
              2 * sqrt (1 / h ^ 2 * (1 / h ^ 2)) * cos (INR (i+1) * PI * / INR (N + 1))))
          0 0= (fun _ _ : nat =>
              (-2/(h^2)) +
              2 *  sqrt (1 / h ^ 2 * (1 / h ^ 2)) * cos (INR (i+1) * PI * / INR (N + 1))) 0%nat 0%nat).
{ apply (coeff_mat_bij 0 (fun _ _ : nat =>
              (-2/(h^2)) +
              2 * sqrt (1 / h ^ 2 * (1 / h ^ 2)) * cos (INR (i+1) * PI * / INR (N + 1))) 0%nat 0%nat). omega. omega. } rewrite H0.
assert (-2 / h ^ 2  + 2 *sqrt (1 / h ^ 2 * (1 / h ^ 2)) * cos (INR (i+1) * PI * / INR (N + 1)) < 0  ->
              -2 / h ^ 2  + 2 * sqrt (1 / h ^ 2 * (1 / h ^ 2))* cos (INR (i+1) * PI * / INR (N + 1)) <>0).
{ nra. } apply H1. apply eig_0. destruct H. apply H. destruct H. apply H2.
Qed.

(** proof that the minimum eigen value of Ah(1/h^2, -2/h^2, 1/h^2) is non-zero. ***)
Lemma eig_2: forall (N:nat), (2<N)%nat -> Lambda_min  N <> 0.
Proof.
intros.
unfold Lambda_min.
assert (sqrt (1 / h ^ 2 * (1 / h ^ 2))=1 / h ^ 2 ). { apply sqrt_square. assert (h ^ 2= h* h). { nra. } rewrite H0. apply inv_sqr_h_ge_0. } rewrite <-H0.
assert (-2 / h ^ 2 + 2 * sqrt (1 / h ^ 2 * (1 / h ^ 2)) * cos (INR 1 * PI * / INR (N + 1)) <0 ->
           -2 / h ^ 2 + 2 * sqrt (1 / h ^ 2 * (1 / h ^ 2)) * cos (INR 1 * PI * / INR (N + 1)) <> 0). { nra. } apply H1.
 assert (1%nat = (0+1)%nat).  { omega. } rewrite H2. apply eig_0. omega. omega.
Qed.

(** Proof that 1/|lambda_min| is the maximum absolute eigen value of the inverse A^{-1} (1/h^2, -2/h^2, 1/h^2) **)
Lemma eigen_relation: forall (i N:nat), (2<N)%nat -> (0<=i<N)%nat -> Rabs (lam i N (1/(h^2)) (-2/(h^2)) (1/(h^2)) ) <= 1/ Rabs( Lambda_min  N).
Proof.
intros.
unfold lam.
assert ((1 / coeff_mat 0 (Lambda i N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2)) 0 0)= (/ (coeff_mat 0 (Lambda i N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2)) 0 0))).
{ nra. } rewrite H1.
assert (Rabs (/ coeff_mat 0 (Lambda i N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2)) 0 0)= / Rabs ( coeff_mat 0 (Lambda i N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2)) 0 0)).
{  apply Rabs_Rinv. apply eig_1. omega. }
rewrite H2.
assert (/ Rabs (coeff_mat 0 (Lambda i N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2)) 0 0)= 1/ Rabs (coeff_mat 0 (Lambda i N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2)) 0 0)). { nra. } rewrite H3.
apply inverse_rel.
+ split.
  - apply Rabs_pos_lt. apply eig_1. omega.
  - apply Rabs_pos_lt. apply eig_2. omega.
+ unfold Lambda_min. unfold Lambda.
  assert (coeff_mat 0
             (mk_matrix 1 1
                (fun _ _ : nat =>
                 -2 / h ^ 2  +
                 2 * sqrt (1 / h ^ 2 * (1 / h ^ 2)) *
                 cos (INR (i+1) * PI * / INR (N + 1)))) 0 0=  (fun _ _ : nat =>
                 -2 / h ^ 2 +
                 2 * sqrt (1 / h ^ 2 * (1 / h ^ 2)) *
                 cos (INR (i+1) * PI * / INR (N + 1))) 0%nat 0%nat).
  { apply (coeff_mat_bij 0 (fun _ _ : nat =>
                 -2 / h ^ 2  +
                 2 * sqrt (1 / h ^ 2 * (1 / h ^ 2)) *
                 cos (INR (i+1) * PI * / INR (N + 1))) 0%nat 0%nat). omega. omega. } rewrite H4.
  assert (i=0%nat \/ (0< i < N)%nat). { omega. }
  destruct H5.
  + rewrite H5. assert ( 1%nat = (0+1)%nat). { omega. } rewrite <-H6.
    assert (sqrt (1 / h ^ 2 * (1 / h ^ 2)) =(1 / h ^ 2)). { apply sqrt_square. assert (h^2 = h*h). { nra. } rewrite H7. apply inv_sqr_h_ge_0. } rewrite H7. nra.
  + assert (sqrt (1 / h ^ 2 * (1 / h ^ 2)) =(1 / h ^ 2)). { apply sqrt_square. assert (h^2 = h*h). { nra. } rewrite H6. apply inv_sqr_h_ge_0. }
    assert (Rabs (-2 / h ^ 2 + 2 * (1 / h ^ 2) * cos (INR 1 * PI * / INR (N + 1)))=Rabs  (-2 / h ^ 2+  2 * sqrt (1 / h ^ 2 * (1 / h ^ 2)) * cos (INR 1 * PI * / INR (N + 1)))).
    { rewrite H6. nra. } rewrite H7.
    assert (Rabs  (-2 / h ^ 2+  2 * sqrt (1 / h ^ 2 * (1 / h ^ 2)) * cos (INR 1 * PI * / INR (N + 1)))=
              -(-2 / h ^ 2  +  2 * sqrt (1 / h ^ 2 * (1 / h ^ 2)) * cos (INR 1 * PI * / INR (N + 1)))). { apply Rabs_left. assert (1%nat = (0+1)%nat). { omega. } rewrite H8. apply eig_0. omega. omega. }
    assert ( Rabs (-2 / h ^ 2  +  2 * sqrt (1 / h ^ 2 * (1 / h ^ 2)) * cos (INR (i+1) * PI * / INR (N + 1)))=
              - (-2 / h ^ 2  +  2 * sqrt (1 / h ^ 2 * (1 / h ^ 2)) * cos (INR (i+1) * PI * / INR (N + 1)))). { apply Rabs_left. apply eig_0. omega. omega. }
    rewrite H8. rewrite H9.
    apply Ropp_ge_le_contravar.
    apply (Rplus_ge_compat_l (-2 / h ^ 2 ) (2 * sqrt (1 / h ^ 2 * (1 / h ^ 2))* cos (INR 1 * PI * / INR (N + 1)))
                (2 *  sqrt (1 / h ^ 2 * (1 / h ^ 2)) * cos (INR (i+1) * PI * / INR (N + 1)))).
    apply Rmult_ge_compat_l.
    - assert ( 0 = 2 * 0). { nra. } rewrite H10. apply Rmult_ge_compat_l. nra.
      assert (0 <= sqrt (1 / h ^ 2 * (1 / h ^ 2)) -> sqrt (1 / h ^ 2 * (1 / h ^ 2)) >= 0). { nra. } apply H11. apply sqrt_pos.
    - assert (cos (INR (i+1) * PI * / INR (N + 1)) <= cos (INR 1 * PI * / INR (N + 1)) -> cos (INR 1 * PI * / INR (N + 1)) >=cos (INR (i+1) * PI * / INR (N + 1))).
      { nra. } apply H10. apply Rlt_le.
      apply cos_decreasing_1.
      * assert (INR 1 =1). { reflexivity. } rewrite H11. assert (1 * PI * / INR (N + 1) = PI * (/ INR (N+1))). { nra. } rewrite H12.
        apply Rlt_le. apply Rmult_lt_0_compat. apply PI_RGT_0. apply Rinv_0_lt_compat. apply lt_0_INR. omega.
      * assert (INR 1= 1). { reflexivity. } rewrite H11. assert (PI = PI * (/1)). { nra. } rewrite H12.
        assert (1 * (PI * / 1) * / INR (N + 1)= PI * (/ INR (N+1))). { nra. } rewrite H13.
        apply Rmult_le_compat_l. apply Rlt_le. apply PI_RGT_0. apply Rlt_le. apply Rinv_lt_contravar.
        assert (1 * INR (N + 1)= INR (N+1)). { nra. } rewrite H14. apply lt_0_INR. omega.
      * apply lt_1_INR. omega.
      * apply Rlt_le. assert (INR (i+1) * PI * / INR (N + 1) = (INR (i+1)) * ( PI * (/ INR (N+1)))). { nra. } rewrite H11.
        apply Rmult_lt_0_compat. apply lt_0_INR. omega. apply Rmult_lt_0_compat. apply PI_RGT_0.
        apply Rinv_0_lt_compat. apply lt_0_INR. omega.
      * assert (PI =1 * PI). { nra. } rewrite H11.
        assert (INR (i+1) * (1 * PI) * / INR (N + 1)= ((INR (i+1)) *(/ INR (N+1))) * PI). { nra. } rewrite H12.
        apply Rmult_le_compat.
        - apply Rlt_le. apply Rmult_lt_0_compat. apply lt_0_INR. omega. apply Rinv_0_lt_compat. apply lt_0_INR. omega.
        - apply Rlt_le. apply PI_RGT_0.
        - assert ( 1 = INR (N+1) */ (INR (N+1))). { apply Rinv_r_sym. assert ( 0 < INR (N+1) -> INR (N+1) <> 0). { nra. } apply H13. apply lt_0_INR. omega. } rewrite H13.
          apply Rmult_le_compat_r. apply Rlt_le. apply Rinv_0_lt_compat. apply lt_0_INR. omega.
          apply le_INR. omega.
        - nra.
      * assert (INR 1 * PI * / INR (N + 1) = (INR 1) * (PI * / INR (N + 1))). { nra. } rewrite H11.
        assert (INR (i+1) * PI * / INR (N + 1) = (INR (i+1)) * (PI * / INR (N + 1))). { nra. } rewrite H12.
        apply Rmult_lt_compat_r.
        { apply Rmult_lt_0_compat. apply PI_RGT_0. apply Rinv_0_lt_compat. apply lt_0_INR. omega. }
        { apply lt_INR. omega. }
Qed.

Lemma sum_n_m_le : forall (n m N:nat) (a: nat -> R) (b : nat -> R), (2<N)%nat -> (0<n<=m)%nat -> (n<N)%nat /\ (m<N)%nat ->  (forall i:nat , (0<=i<N)%nat -> a i <= b i) ->
    sum_n_m (fun l:nat => a l) n m <=sum_n_m (fun l:nat => b l) n m.
Proof.
intros.
induction m. contradict H. omega.
assert ( n= S m \/ (0<n<S m)%nat). { omega. } destruct H3.
+ rewrite H3.
  assert (sum_n_m (fun l : nat => a l) (S m) (S m)= (fun l : nat => a l) (S m)).
  { apply (sum_n_n (fun l : nat => a l) (S m)). } rewrite H4.
  assert (sum_n_m (fun l : nat => b l) (S m) (S m) = (fun l : nat => b l) (S m)).
  { apply (sum_n_n (fun l : nat => b l) (S m)). } rewrite H5.
  specialize (H2 (S m)). apply H2. omega.
+ clear H0.
   assert ((0 < n < S m)%nat -> (0 < n <= m)%nat). { omega. }  specialize (H0 H3). specialize (IHm H0).
    assert ( sum_n_m (fun l : nat => a l) n (S m) = sum_n_m (fun l : nat => a l) n m + (fun l : nat => a l) (S m)).
    { apply (sum_n_Sm (fun l : nat => a l)). omega. } rewrite H4.
    assert (sum_n_m (fun l : nat => b l) n (S m) =sum_n_m (fun l : nat => b l) n m + (fun l : nat => b l) (S m)).
    { apply (sum_n_Sm  (fun l : nat => b l)). omega. } rewrite H5.
    apply Rplus_le_compat. apply IHm. specialize (H2 (S m)). omega. apply H2. omega.
Qed.

Require Import linear_algebra.

Lemma max_spectral: forall (N:nat) (v: matrix N 1%nat),(2<N)%nat ->  vec_norm_2 N v =1 ->
    sqrt (sum_n_m (fun i:nat => (coeff_mat 0 v i 0%nat)^2 * (lam i N (1/(h^2)) (-2/(h^2)) (1/(h^2)))^2) 0%nat (pred N)) <= 1/ Rabs(Lambda_min  N).
Proof.
intros.
assert (1 / Rabs (Lambda_min  N) =sqrt (Rsqr ( 1 / Rabs (Lambda_min  N)))).
{ symmetry. apply sqrt_Rsqr. assert (1 / Rabs (Lambda_min  N)= / Rabs (Lambda_min  N)). { nra. } rewrite H1.
assert (Rabs (/(Lambda_min  N)) = / Rabs (Lambda_min  N)). { apply Rabs_Rinv. apply eig_2. omega. } rewrite <-H2. apply Rabs_pos. }
rewrite H1.  apply sqrt_le_1_alt.
assert ((1 / Rabs (Lambda_min  N))²= Rsqr (1) / Rsqr(Rabs (Lambda_min  N))).
{ apply Rsqr_div. apply Rabs_no_R0. apply eig_2. omega. } rewrite H2.
assert ( 1² / (Rabs (Lambda_min  N))²= Rsqr(vec_norm_2 N v)/ (Rabs (Lambda_min  N))²).
{ rewrite <- H0. reflexivity. } rewrite H3. unfold vec_norm_2.
assert ( (sqrt (sum_n_m (fun l : nat => coeff_mat 0 v l 0 ^ 2) 0  (pred N)))²= (sum_n_m (fun l : nat => coeff_mat 0 v l 0 ^ 2) 0  (pred N))).
{ apply Rsqr_sqrt.
  assert (sum_n_m (fun l : nat => coeff_mat 0 v l 0 ^ 2) 0 (pred N)= sum_n_m (fun l : nat => coeff_mat 0 v l 0 ^ 2) 0%nat 0%nat +
            sum_n_m (fun l : nat => coeff_mat 0 v l 0 ^ 2) 1%nat (pred N)).
  { apply (sum_n_m_Chasles (fun l : nat => coeff_mat 0 v l 0 ^ 2) 0%nat 0%nat (pred N)). omega. omega. } rewrite H4.
  apply Rplus_le_le_0_compat.
  + assert (sum_n_m (fun l : nat => coeff_mat 0 v l 0 ^ 2) 0 0= (fun l : nat => coeff_mat 0 v l 0 ^ 2) 0%nat).
    { apply (sum_n_n (fun l : nat => coeff_mat 0 v l 0 ^ 2) 0%nat). } rewrite H5. nra.
  + apply sum_elem_pos. omega.
    intros. nra.
} rewrite H4.
assert (sum_n_m (fun l : nat => coeff_mat 0 v l 0 ^ 2) 0 (pred N) /(Rabs (Lambda_min  N))²=
          sum_n_m (fun l:nat => (coeff_mat 0 v l 0)^2 * (1/ Rsqr (Rabs( Lambda_min  N)))) 0%nat (pred N)).
{ symmetry.
  assert (sum_n_m (fun l : nat => coeff_mat 0 v l 0 ^ 2) 0 (pred N) /(Rabs (Lambda_min  N))²=
            sum_n_m (fun l : nat => coeff_mat 0 v l 0 ^ 2) 0 (pred N) * (1/ Rsqr(Rabs (Lambda_min  N)))). { nra. } rewrite H5.
  apply (sum_n_m_mult_r (1 / (Rabs (Lambda_min  N))²)(fun l : nat => coeff_mat 0 v l 0 ^ 2) 0%nat (pred N)).
} rewrite H5.
assert (sum_n_m (fun i : nat => coeff_mat 0 v i 0 ^ 2 * lam i N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2) ^ 2  )  0 (pred N)= sum_n_m (fun i : nat => coeff_mat 0 v i 0 ^ 2 * lam i N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2) ^ 2 ) 0%nat 0%nat +
          sum_n_m (fun i : nat => coeff_mat 0 v i 0 ^ 2 * lam i N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2) ^ 2  ) 1%nat (pred N)).
{ apply (sum_n_m_Chasles (fun i : nat => coeff_mat 0 v i 0 ^ 2 * lam i N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2) ^ 2 ) 0%nat 0%nat (pred N)). omega. omega. } rewrite H6.
assert (sum_n_m  (fun l : nat =>   coeff_mat 0 v l 0 ^ 2 *   (1 / (Rabs (Lambda_min  N))²)) 0   (pred N)=
          sum_n_m  (fun l : nat =>   coeff_mat 0 v l 0 ^ 2 *   (1 / (Rabs (Lambda_min  N))²)) 0%nat 0%nat +
            sum_n_m  (fun l : nat =>   coeff_mat 0 v l 0 ^ 2 *   (1 / (Rabs (Lambda_min  N))²)) 1%nat (pred N)).
{ apply (sum_n_m_Chasles (fun l : nat =>   coeff_mat 0 v l 0 ^ 2 *   (1 / (Rabs (Lambda_min  N))²)) 0%nat 0%nat (pred N)). omega. omega. } rewrite H7.
apply Rplus_le_compat.
+ assert (sum_n_m (fun i : nat => coeff_mat 0 v i 0 ^ 2 * lam i N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2) ^ 2)  0 0= (fun i : nat => coeff_mat 0 v i 0 ^ 2 * lam i N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2) ^ 2) 0%nat).
  { apply (sum_n_n (fun i : nat => coeff_mat 0 v i 0 ^ 2 *lam i N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2) ^ 2) 0%nat). } rewrite H8.
  assert (sum_n_m  (fun l : nat =>   coeff_mat 0 v l 0 ^ 2 *   (1 / (Rabs (Lambda_min  N))²)) 0 0=
            (fun l : nat =>   coeff_mat 0 v l 0 ^ 2 *   (1 / (Rabs (Lambda_min  N))²)) 0%nat).
  { apply (sum_n_n  (fun l : nat =>   coeff_mat 0 v l 0 ^ 2 *   (1 / (Rabs (Lambda_min  N))²)) 0%nat). } rewrite H9.
  apply Rmult_le_compat_l. nra.
  assert (lam 0 N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2) ^ 2 = Rsqr (Rabs (lam 0 N (1/(h^2)) (-2/(h^2)) (1/(h^2)) ))).
  { assert (lam 0 N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2) ^ 2= Rsqr (lam 0 N (1/(h^2)) (-2/(h^2)) (1/(h^2)) )). { simpl. unfold Rsqr. nra. } rewrite H10. apply Rsqr_abs. }
  rewrite H10. assert ( Rsqr 1 = 1). { apply Rsqr_1. } rewrite <- H11.
  assert (Rsqr (1 / Rabs( Lambda_min  N)) = 1² / (Rabs (Lambda_min  N))²). { apply Rsqr_div. apply Rabs_no_R0. apply eig_2. omega. } rewrite <-H12.
  apply Rsqr_incr_1.  unfold lam.
  assert ( (1 / coeff_mat 0 (Lambda 0 N (1² / h ^ 2) (-2 / h ^ 2) (1² / h ^ 2)) 0 0)= / (coeff_mat 0 (Lambda 0 N (1² / h ^ 2) (-2 / h ^ 2) (1² / h ^ 2)) 0 0)). { nra. } rewrite H13.
  assert (Rabs (/ coeff_mat 0 (Lambda 0 N (1² / h ^ 2) (-2 / h ^ 2) (1² / h ^ 2) ) 0 0) = / Rabs (coeff_mat 0 (Lambda 0 N (1² / h ^ 2) (-2 / h ^ 2) (1² / h ^ 2) ) 0 0)). { apply Rabs_Rinv.  rewrite H11. apply eig_1. omega. } rewrite H14.
  assert (1 / Rabs (Lambda_min  N) = / Rabs (Lambda_min  N)). { nra. } rewrite H15. rewrite H11.
  apply Rmult_le_reg_r with (Rabs (coeff_mat 0 (Lambda 0 N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2) ) 0 0) *  Rabs (Lambda_min  N)).
  assert (Rabs ( (coeff_mat 0 (Lambda 0 N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2) ) 0 0) * (Lambda_min  N)) = Rabs (coeff_mat 0 (Lambda 0 N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2) ) 0 0) * Rabs (Lambda_min  N)). { apply Rabs_mult. } rewrite <- H16. apply Rabs_pos_lt.
  apply Rmult_integral_contrapositive_currified. apply eig_1. omega. apply eig_2. omega.
  assert (/ Rabs (coeff_mat 0 (Lambda 0 N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2)) 0 0) *(Rabs (coeff_mat 0 (Lambda 0 N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2) ) 0 0) * Rabs (Lambda_min  N))=
          (/ Rabs (coeff_mat 0 (Lambda 0 N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2)) 0 0) * (Rabs (coeff_mat 0 (Lambda 0 N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2) ) 0 0))) * Rabs (Lambda_min  N)). { nra. } rewrite H16.
  assert ( (/ Rabs (coeff_mat 0 (Lambda 0 N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2) ) 0 0) * (Rabs (coeff_mat 0 (Lambda 0 N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2) ) 0 0)))=1).
  { symmetry. apply Rinv_l_sym. apply Rabs_no_R0. apply eig_1. omega. } rewrite H17.
  assert (/ Rabs (Lambda_min  N) *(Rabs (coeff_mat 0 (Lambda 0 N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2)) 0 0) * Rabs (Lambda_min  N))=
          (/ Rabs (Lambda_min  N) *  Rabs (Lambda_min  N)) * Rabs (coeff_mat 0 (Lambda 0 N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2) ) 0 0)). { nra. } rewrite H18.
  assert ( (/ Rabs (Lambda_min  N) *  Rabs (Lambda_min  N))=1).
  { symmetry. apply Rinv_l_sym. apply Rabs_no_R0. apply eig_2. omega. } rewrite H19.
  apply Rmult_le_compat_l. nra. unfold Lambda_min. unfold Lambda.
  assert (coeff_mat 0
     (mk_matrix 1 1
        (fun _ _ : nat =>
        -2 / h ^ 2  +
         2 * sqrt (1 / h ^ 2 * (1 / h ^ 2))*
         cos (INR (0 + 1) * PI * / INR (N + 1)))) 0 0= (fun _ _ : nat =>
         -2 / h ^ 2  +
         2 * sqrt (1 / h ^ 2 * (1 / h ^ 2))*
         cos (INR (0 + 1) * PI * / INR (N + 1))) 0%nat 0%nat).
  { apply (coeff_mat_bij 0  (fun _ _ : nat =>
                  -2 / h ^ 2  +
                  2 * sqrt (1 / h ^ 2 * (1 / h ^ 2)) *
                  cos (INR (0 + 1) * PI * / INR (N + 1))) 0%nat 0%nat). omega. omega. }
  rewrite H20.
  assert ((0 + 1)%nat = 1%nat). { omega. } rewrite H21.
  assert (sqrt (1 / h ^ 2 * (1 / h ^ 2))= (1/(h^2))). { apply sqrt_square. assert (h^2= h*h). nra. rewrite H22. apply inv_sqr_h_ge_0. } rewrite H22.
  apply Rle_refl.
  apply Rabs_pos. apply Rlt_le.
  assert (1 / Rabs (Lambda_min  N)= /Rabs (Lambda_min  N)). { nra. } rewrite H13. apply Rinv_0_lt_compat. apply Rabs_pos_lt. apply eig_2. omega.
+ apply (sum_n_m_le 1%nat (pred N) N (fun i : nat => coeff_mat 0 v i 0 ^ 2 * lam i N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2) ^ 2) (fun l : nat =>
                          coeff_mat 0 v l 0 ^ 2 *   (1 / (Rabs (Lambda_min  N))²))). omega. omega. omega.
  intros. apply Rmult_le_compat_l. nra.
  assert (lam i N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2) ^ 2 = Rsqr (Rabs (lam i N (1/(h^2)) (-2/(h^2)) (1/(h^2))))).
  { assert (lam i N (1 / h ^ 2) (-2 / h ^ 2) (1 / h ^ 2) ^ 2= Rsqr (lam i N (1/(h^2)) (-2/(h^2)) (1/(h^2)) )). { simpl. unfold Rsqr. nra. } rewrite H9. apply Rsqr_abs. }
  rewrite H9. assert ( Rsqr 1 = 1). { apply Rsqr_1. } rewrite <- H10.
  assert (Rsqr (1 / Rabs( Lambda_min  N)) = 1² / (Rabs (Lambda_min  N))²). { apply Rsqr_div. apply Rabs_no_R0. apply eig_2. omega. } rewrite <-H11.
  apply Rsqr_incr_1. rewrite H10. apply eigen_relation. omega. omega. apply Rabs_pos. apply Rlt_le.
  assert ( 1 / Rabs (Lambda_min  N)= /  Rabs (Lambda_min  N)). { nra. } rewrite H12. apply Rinv_0_lt_compat. apply Rabs_pos_lt. apply eig_2. omega.
Qed.

(* Define matrix norm *)
Definition matrix_norm (N:nat):= 1/ Rabs(Lambda_min N ).

(* Applying the stability definition from the formalization of the Lax equivalence theorem to the numerical scheme *)

Require Import lax_equivalence.

Variable m:nat.
Hypothesis size: forall m:nat , (2<m)%nat. (* condition on the size of the matrix *)

Notation Xh:= lax_equivalence.Xh.
Notation X:= lax_equivalence.X.
Notation Y:= lax_equivalence.Y.
Notation Yh:= lax_equivalence.Yh.
Notation E:= lax_equivalence.E.
Notation F:= lax_equivalence.F.
Notation Aop:= lax_equivalence.Aop.
Notation Ah_op:= lax_equivalence.Ah_op.

Hypothesis mat_op_norm:
  forall (u:X) (f:Y) (h:R) (uh: Xh h) (rh: forall (h:R), X -> (Xh h)) (sh: forall (h:R), Y->(Yh h))
 (E: Y->X) (Eh:forall (h:R), (Yh h)->(Xh h)), operator_norm (Eh h) = matrix_norm m .

Theorem stability:
  forall (u:X) (f:Y) (h:R) (uh: Xh h) (rh: forall (h:R), X -> (Xh h)) (sh: forall (h:R), Y->(Yh h))
  (E: Y->X) (Eh:forall (h:R), (Yh h)->(Xh h)), exists K:R , forall (h:R), operator_norm(Eh h)<=K.
Proof.
intros.
exists (L^2 / 4).
intros.
assert  (operator_norm (Eh h1)= matrix_norm m ).
{ apply mat_op_norm. auto. auto. auto. auto. auto. auto. } rewrite H.
unfold matrix_norm. apply spectral.  apply size.
Qed.


From mathcomp
  Require Import ssreflect ssrbool ssrnat.

Print bool.

Print nat.

Fixpoint my_plus n m :=
 match n with
 | 0     => m
 | n'.+1 => let: tmp := my_plus n' m in tmp.+1
 end.

Definition sum_no_zero n :=
 let: P := (fun n => if n is 0 then unit else nat) in
 nat_rec P tt (fun n' (m: P n') =>
                 match n' return P n' -> _ with
                 | 0 => fun _ => 1
                 | n1.+1 => fun m => my_plus m (n'.+1)
                 end m) n.

About nat_rec.

Check sum_no_zero 0.
Check sum_no_zero 1.

Search "filt" (_ -> list _).

Search _ ((?X -> ?Y ) -> _ ?X -> _ ?Y ).
Search _ (?a * ?b : nat).
Search _ (?a * ?b : Type).

Locate "_ + _".

Inductive my_prod (A B : Type) : Type := my_pair of A & B.

Fail Check my_pair tt 1.

Arguments my_pair [A B].
Notation "X ** Y" := (my_prod X Y ) (at level 2).
Notation "( X ,, Y )" := (my_pair X Y ).

Check my_pair tt 1.

Theorem false_absutd: False -> (1 = 2).
Proof.
case.
Restart.
apply: False_ind.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** Properties of Square Root Function *)

Require Import NAxioms NSub NZSqrt.

Module NSqrtProp (Import A : NAxiomsSig')(Import B : NSubProp A).

 Module Import Private_NZSqrt := Nop <+ NZSqrtProp A A B.

 Ltac auto' := trivial; try rewrite <- neq_0_lt_0; auto using le_0_l.
 Ltac wrap l := intros; apply l; auto'.

 (** We redefine NZSqrt's results, without the non-negative hyps *)

Lemma sqrt_spec' : forall a, √a*√a <= a < S (√a) * S (√a).
Proof. wrap sqrt_spec. Qed.

Definition sqrt_unique : forall a b, b*b<=a<(S b)*(S b) -> √a == b
 := sqrt_unique.

Lemma sqrt_square : forall a, √(a*a) == a.
Proof. wrap sqrt_square. Qed.

Definition sqrt_le_mono : forall a b, a<=b -> √a <= √b
 := sqrt_le_mono.

Definition sqrt_lt_cancel : forall a b, √a < √b -> a < b
 := sqrt_lt_cancel.

Lemma sqrt_le_square : forall a b, b*b<=a <-> b <= √a.
Proof. wrap sqrt_le_square. Qed.

Lemma sqrt_lt_square : forall a b, a<b*b <-> √a < b.
Proof. wrap sqrt_lt_square. Qed.

Definition sqrt_0 := sqrt_0.
Definition sqrt_1 := sqrt_1.
Definition sqrt_2 := sqrt_2.

Definition sqrt_lt_lin : forall a, 1<a -> √a<a
 := sqrt_lt_lin.

Lemma sqrt_le_lin : forall a, √a<=a.
Proof. wrap sqrt_le_lin. Qed.

Definition sqrt_mul_below : forall a b, √a * √b <= √(a*b)
 := sqrt_mul_below.

Lemma sqrt_mul_above : forall a b, √(a*b) < S (√a) * S (√b).
Proof. wrap sqrt_mul_above. Qed.

Lemma sqrt_succ_le : forall a, √(S a) <= S (√a).
Proof. wrap sqrt_succ_le. Qed.

Lemma sqrt_succ_or : forall a, √(S a) == S (√a) \/ √(S a) == √a.
Proof. wrap sqrt_succ_or. Qed.

Definition sqrt_add_le : forall a b, √(a+b) <= √a + √b
 := sqrt_add_le.

Lemma add_sqrt_le : forall a b, √a + √b <= √(2*(a+b)).
Proof. wrap add_sqrt_le. Qed.

(** For the moment, we include stuff about [sqrt_up] with patching them. *)

Include NZSqrtUpProp A A B Private_NZSqrt.

End NSqrtProp.


Require Import Coq.micromega.Psatz.
Require Import PL.Imp.
Require Import PL.RTClosure.

Inductive aexp_halt: aexp -> Prop :=
  | AH_num : forall n, aexp_halt (ANum n).

Inductive astep : state -> aexp -> aexp -> Prop :=
  | AS_Id : forall st X,
      astep st
        (AId X) (ANum (st X))

  | AS_Plus1 : forall st a1 a1' a2,
      astep st
        a1 a1' ->
      astep st
        (APlus a1 a2) (APlus a1' a2)
  | AS_Plus2 : forall st a1 a2 a2',
      aexp_halt a1 ->
      astep st
        a2 a2' ->
      astep st
        (APlus a1 a2) (APlus a1 a2')
  | AS_Plus : forall st n1 n2,
      astep st
        (APlus (ANum n1) (ANum n2)) (ANum (n1 + n2))

  | AS_Minus1 : forall st a1 a1' a2,
      astep st
        a1 a1' ->
      astep st
        (AMinus a1 a2) (AMinus a1' a2)
  | AS_Minus2 : forall st a1 a2 a2',
      aexp_halt a1 ->
      astep st
        a2 a2' ->
      astep st
        (AMinus a1 a2) (AMinus a1 a2')
  | AS_Minus : forall st n1 n2,
      astep st
        (AMinus (ANum n1) (ANum n2)) (ANum (n1 - n2))

  | AS_Mult1 : forall st a1 a1' a2,
      astep st
        a1 a1' ->
      astep st
        (AMult a1 a2) (AMult a1' a2)
  | AS_Mult2 : forall st a1 a2 a2',
      aexp_halt a1 ->
      astep st
        a2 a2' ->
      astep st
        (AMult a1 a2) (AMult a1 a2')
  | AS_Mult : forall st n1 n2,
      astep st
        (AMult (ANum n1) (ANum n2)) (ANum (n1 * n2)).

Inductive bexp_halt: bexp -> Prop :=
  | BH_True : bexp_halt BTrue
  | BH_False : bexp_halt BFalse.

Inductive bstep : state -> bexp -> bexp -> Prop :=

  | BS_Eq1 : forall st a1 a1' a2,
      astep st
        a1 a1' ->
      bstep st
        (BEq a1 a2) (BEq a1' a2)
  | BS_Eq2 : forall st a1 a2 a2',
      aexp_halt a1 ->
      astep st
        a2 a2' ->
      bstep st
        (BEq a1 a2) (BEq a1 a2')
  | BS_Eq_True : forall st n1 n2,
      n1 = n2 ->
      bstep st
        (BEq (ANum n1) (ANum n2)) BTrue
  | BS_Eq_False : forall st n1 n2,
      n1 <> n2 ->
      bstep st
        (BEq (ANum n1) (ANum n2)) BFalse

  | BS_Le1 : forall st a1 a1' a2,
      astep st
        a1 a1' ->
      bstep st
        (BLe a1 a2) (BLe a1' a2)
  | BS_Le2 : forall st a1 a2 a2',
      aexp_halt a1 ->
      astep st
        a2 a2' ->
      bstep st
        (BLe a1 a2) (BLe a1 a2')
  | BS_Le_True : forall st n1 n2,
      n1 <= n2 ->
      bstep st
        (BLe (ANum n1) (ANum n2)) BTrue
  | BS_Le_False : forall st n1 n2,
      n1 > n2 ->
      bstep st
        (BLe (ANum n1) (ANum n2)) BFalse

  | BS_NotStep : forall st b1 b1',
      bstep st
        b1 b1' ->
      bstep st
        (BNot b1) (BNot b1')
  | BS_NotTrue : forall st,
      bstep st
        (BNot BTrue) BFalse
  | BS_NotFalse : forall st,
      bstep st
        (BNot BFalse) BTrue

  | BS_AndStep : forall st b1 b1' b2,
      bstep st
        b1 b1' ->
      bstep st
       (BAnd b1 b2) (BAnd b1' b2)
  | BS_AndTrue : forall st b,
      bstep st
       (BAnd BTrue b) b
  | BS_AndFalse : forall st b,
      bstep st
       (BAnd BFalse b) BFalse.

Definition multi_astep (st: state): aexp -> aexp -> Prop := clos_refl_trans (astep st).

Definition multi_bstep (st: state): bexp -> bexp -> Prop := clos_refl_trans (bstep st).

Theorem multi_congr_APlus1: forall st a1 a1' a2,
  multi_astep st a1 a1' ->
  multi_astep st (a1 + a2) (a1' + a2).
Proof.
  intros.
  induction_n1 H.
  + reflexivity.
  + etransitivity_n1.
    - apply IHrt.
    - apply AS_Plus1.
      exact H.
Qed.

Theorem multi_congr_APlus2: forall st a1 a2 a2',
  aexp_halt a1 ->
  multi_astep st a2 a2' ->
  multi_astep st (a1 + a2) (a1 + a2').
Proof.
  intros.
  induction_n1 H0.
  + reflexivity.
  + etransitivity_n1.
    - apply IHrt.
    - apply AS_Plus2.
      * exact H.
      * exact H0.
Qed.

Theorem multi_congr_AMinus1: forall st a1 a1' a2,
  multi_astep st a1 a1' ->
  multi_astep st (a1 - a2) (a1' - a2).
Proof.
  intros.
  induction_n1 H.
  + reflexivity.
  + etransitivity_n1.
    - apply IHrt.
    - apply AS_Minus1.
      exact H.
Qed.

Theorem multi_congr_AMinus2: forall st a1 a2 a2',
  aexp_halt a1 ->
  multi_astep st a2 a2' ->
  multi_astep st (a1 - a2) (a1 - a2').
Proof.
  intros.
  induction_n1 H0.
  + reflexivity.
  + etransitivity_n1.
    - apply IHrt.
    - apply AS_Minus2.
      * exact H.
      * exact H0.
Qed.

Theorem multi_congr_AMult1: forall st a1 a1' a2,
  multi_astep st a1 a1' ->
  multi_astep st (a1 * a2) (a1' * a2).
Proof.
  intros.
  induction_n1 H.
  + reflexivity.
  + etransitivity_n1.
    - apply IHrt.
    - apply AS_Mult1.
      exact H.
Qed.

Theorem multi_congr_AMult2: forall st a1 a2 a2',
  aexp_halt a1 ->
  multi_astep st a2 a2' ->
  multi_astep st (a1 * a2) (a1 * a2').
Proof.
  intros.
  induction_n1 H0.
  + reflexivity.
  + etransitivity_n1.
    - apply IHrt.
    - apply AS_Mult2.
      * exact H.
      * exact H0.
Qed.

Local Open Scope imp.
Inductive cstep : (com * state) -> (com * state) -> Prop :=
  | CS_AssStep : forall st X a a',
      astep st a a' ->
      cstep (CAss X a, st) (CAss X a', st)
  | CS_Ass : forall st1 st2 X n,
      st2 X = n ->
      (forall Y, X <> Y -> st1 Y = st2 Y) ->
      cstep (CAss X (ANum n), st1) (Skip, st2)
  | CS_SeqStep : forall st c1 c1' st' c2,
      cstep (c1, st) (c1', st') ->
      cstep (c1 ;; c2 , st) (c1' ;; c2, st')
  | CS_Seq : forall st c2,
      cstep (Skip ;; c2, st) (c2, st)
  | CS_IfStep : forall st b b' c1 c2,
      bstep st b b' ->
      cstep
        (If b  Then c1 Else c2 EndIf, st)
        (If b'  Then c1 Else c2 EndIf, st)
  | CS_IfTrue : forall st c1 c2,
      cstep (If BTrue Then c1 Else c2 EndIf, st) (c1, st)
  | CS_IfFalse : forall st c1 c2,
      cstep (If BFalse Then c1 Else c2 EndIf, st) (c2, st)
  | CS_While : forall st b c,
      cstep
        (While b Do c EndWhile, st)
        (If b Then (c;; While b Do c EndWhile) Else Skip EndIf, st).

(* ================================================================= *)
(** ** Multi-step Relation *)
Definition multi_cstep: com * state -> com * state -> Prop :=
  clos_refl_trans cstep.

Theorem multi_congr_CSeq: forall st1 c1 st1' c1' c2,
  multi_cstep (c1, st1) (c1', st1') ->
  multi_cstep (c1 ;; c2, st1) (c1';; c2, st1').
Proof.
  intros.
  induction_n1 H.
  + reflexivity.
  + etransitivity_n1.
    - apply IHrt.
    - apply CS_SeqStep.
      exact H.
Qed.

Theorem multi_congr_CIf: forall st b b' c1 c2,
  multi_bstep st b b' ->
  multi_cstep
    (If b Then c1 Else c2 EndIf, st)
    (If b' Then c1 Else c2 EndIf, st).
Proof.
  intros.
  induction_n1 H.
  + reflexivity.
  + etransitivity_n1.
    - exact IHrt.
    - apply CS_IfStep.
      exact H.
Qed.


Require Import Coq.Arith.EqNat.
Require Import Coq.Relations.Relations.
Require Import Coq.Sorting.Permutation.

Require Import Bitoychain.Coqlib.
Require Import Bitoychain.Integers.

Require Import Bitoychain.Coqlib2.
Require Export Bitoychain.eq_dec.

Lemma max_two_power_nat: forall n1 n2, Z.max (two_power_nat n1) (two_power_nat n2) = two_power_nat (Nat.max n1 n2).
Proof.
  intros.
  rewrite !two_power_nat_two_p.
  pose proof Zle_0_nat n1; pose proof Zle_0_nat n2.
  rewrite Nat2Z.inj_max.
  forget (Z.of_nat n1) as m1; forget (Z.of_nat n2) as m2.
  destruct (Z_le_dec m1 m2).
  + rewrite (Z.max_r m1 m2) by omega.
    apply Z.max_r.
    apply two_p_monotone; omega.
  + rewrite (Z.max_l m1 m2) by omega.
    apply Z.max_l.
    apply two_p_monotone; omega.
Qed.

Lemma Z_max_two_p: forall m1 m2, (exists n, m1 = two_power_nat n) -> (exists n, m2 = two_power_nat n) -> (exists n, Z.max m1 m2 = two_power_nat n).
Proof.
  intros ? ? [? ?] [? ?].
  subst.
  rewrite max_two_power_nat.
  eexists; reflexivity.
Qed.

Lemma power_nat_divide: forall n m, two_power_nat n <= two_power_nat m -> Z.divide (two_power_nat n) (two_power_nat m).
Proof.
  intros.
  repeat rewrite two_power_nat_two_p in *.
  unfold Zdivide.
  exists (two_p (Z.of_nat m - Z.of_nat n)).
  assert ((Z.of_nat m) = (Z.of_nat m - Z.of_nat n) + Z.of_nat n) by omega.
  rewrite H0 at 1.
  assert (Z.of_nat m >= 0) by omega.
  assert (Z.of_nat n >= 0) by omega.
  assert (Z.of_nat n <= Z.of_nat m).
    destruct (Z_le_gt_dec (Z.of_nat n) (Z.of_nat m)).
    exact l.
    assert (Z.of_nat m < Z.of_nat n) by omega.
    assert (two_p (Z.of_nat m) < two_p (Z.of_nat n)) by (apply two_p_monotone_strict; omega).
    omega.
  apply (two_p_is_exp (Z.of_nat m - Z.of_nat n) (Z.of_nat n)); omega.
Qed.

Lemma power_nat_divide_ge: forall n m: Z,
  (exists N, n = two_power_nat N) ->
  (exists M, m = two_power_nat M) ->
  (n >= m <-> (m | n)).
Proof.
  intros.
  destruct H, H0.
  split; intros.
  + subst.
    apply power_nat_divide.
    omega.
  + destruct H1 as [k ?].
    rewrite H1.
    pose proof two_power_nat_pos x0.
    pose proof two_power_nat_pos x.
    assert (k > 0).
    Focus 1. {
      eapply Zmult_gt_0_reg_l.
      + exact H2.
      + rewrite <- H0, Z.mul_comm; omega.
    } Unfocus.
    rewrite <- (Z.mul_1_l m) at 2.
    apply Zmult_ge_compat_r; omega.
Qed.

Lemma power_nat_divide_le: forall n m: Z,
  (exists N, n = two_power_nat N) ->
  (exists M, m = two_power_nat M) ->
  (m <= n <-> (m | n)).
Proof.
  intros.
  rewrite <- power_nat_divide_ge; auto.
  omega.
Qed.

Lemma two_p_max_divide: forall m1 m2 m, (exists n, m1 = two_power_nat n) -> (exists n, m2 = two_power_nat n) -> ((Z.max m1 m2 | m) <-> (m1 | m) /\ (m2 | m)).
Proof.
  intros.
  destruct (Z_le_dec m1 m2).
  + rewrite Z.max_r by omega.
    rewrite power_nat_divide_le in l by auto.
    pose proof Zdivides_trans m1 m2 m.
    tauto.
  + rewrite Z.max_l by omega.
    assert (m2 <= m1) by omega.
    rewrite power_nat_divide_le in H1 by auto.
    pose proof Zdivides_trans m2 m1 m.
    tauto.
Qed.

Lemma two_p_max_1: forall m1 m2, (exists n, m1 = two_power_nat n) -> (exists n, m2 = two_power_nat n) -> (Z.max m1 m2 = 1 <-> m1 = 1 /\ m2 = 1).
Proof.
  assert (forall x, (exists n : nat, x = two_power_nat n) -> (x = 1 <-> (x | 1))).
  + intros.
    split; intros.
    - subst.
      exists 1; auto.
    - rewrite <- power_nat_divide_le in H0 by (auto; exists 0%nat; auto).
      destruct H as [n ?]; subst x.
      pose proof two_power_nat_pos n.
      omega.
  + intros m1 m2 Hm1 Hm2.
    pose proof Z_max_two_p _ _ Hm1 Hm2 as Hmax.
    rewrite (H _ Hm1), (H _ Hm2), (H _ Hmax).
    apply two_p_max_divide; auto.
Qed.

Lemma two_power_nat_0: forall x, (exists n, x = two_power_nat n) -> x <> 0.
Proof.
  intros.
  destruct H.
  pose proof two_power_nat_pos x0.
  omega.
Qed.

Hint Rewrite andb_true_iff: align.
Hint Rewrite <- Zle_is_le_bool: align.
Hint Rewrite Z.eqb_eq: align.
Hint Rewrite power_nat_divide_le using (auto with align): align.
Hint Rewrite Z.mod_divide using (apply two_power_nat_0; auto with align): align.
Hint Rewrite two_p_max_divide using (auto with align): align.
Hint Rewrite two_p_max_1 using (auto with align): align.
Hint Resolve Z_max_two_p: align.

Lemma Z_of_nat_ge_O: forall n, Z.of_nat n >= 0.
Proof. intros.
change 0 with (Z.of_nat O).
apply inj_ge. clear; omega.
Qed.

Lemma nth_error_nth:
  forall A (al: list A) (z: A) i, (i < length al)%nat -> nth_error al i = Some (nth i al z).
Proof.
intros. revert al H; induction i; destruct al; simpl; intros; auto; try omega.
apply IHi. omega.
Qed.

Lemma nat_of_Z_eq: forall i, nat_of_Z (Z_of_nat i) = i.
Proof.
intros.
apply inj_eq_rev.
rewrite nat_of_Z_eq; auto.
omega.
Qed.

Lemma nth_error_length:
  forall {A} i (l: list A), nth_error l i = None <-> (i >= length l)%nat.
Proof.
induction i; destruct l; simpl; intuition.
inv H.
inv H.
rewrite IHi in H. omega.
rewrite IHi. omega.
Qed.

Lemma prop_unext: forall P Q: Prop, P=Q -> (P<->Q).
Proof. intros. subst; split; auto. Qed.

Lemma list_norepet_In_In: forall {K X} a x y (l:list (K*X)),
  list_norepet (map (@fst K X) l) -> In (a, x) l -> In (a, y) l -> x = y.
Proof.
  induction l; intros N Ix Iy.
   - inv Ix.
   - simpl in N; inv N.
     destruct Ix.
     + subst.
       simpl in Iy; destruct Iy as [|Iy]; [congruence|].
       exfalso; apply (in_map (@fst K X)) in Iy; tauto.
     + simpl in Iy; destruct Iy as [|Iy].
       subst. exfalso; apply (in_map (@fst K X)) in H; tauto.
       apply IHl; auto.
Qed.

Inductive sublist {A} : list A -> list A -> Prop :=
| sublist_nil : sublist nil nil
| sublist_cons a l1 l2 : sublist l1 l2 -> sublist (a :: l1) (a :: l2)
| sublist_drop a l1 l2 : sublist l1 l2 -> sublist l1 (a :: l2).

Lemma sublist_In {A} (a : A) l1 l2 : sublist l1 l2 -> In a l1 -> In a l2.
Proof.
  intros S; induction S; intros I.
  - inversion I.
  - simpl in I; destruct I.
    subst; left; auto.
    right; auto.
  - right; auto.
Qed.

Lemma sublist_norepet {A} (l1 l2 : list A) : sublist l1 l2 -> list_norepet l2 -> list_norepet l1.
Proof.
  intros S; induction S; intros N; auto.
  - inversion N; subst; constructor; auto.
    pose proof sublist_In a l1 l2; auto.
  - inversion N; auto.
Qed.

Require Import Coq.Sets.Ensembles.

Definition Ensemble_join {A} (X Y Z: Ensemble A): Prop :=
  (forall a, Z a <-> X a \/ Y a) /\ (forall a, X a -> Y a -> False).

Require Coq.Logic.ConstructiveEpsilon.

Lemma decidable_countable_ex_sig {A} (f : nat -> A)
      (Hf : forall a, exists n, a = f n)
      (P : A -> Prop)
      (Pdec : forall x, {P x} + {~ P x}) :
  (exists x : A, P x) -> {x : A | P x}.
Proof.
  intros E.
  cut ({n | P (f n)}). intros [n Hn]; eauto.
  apply ConstructiveEpsilon.constructive_indefinite_ground_description_nat.
  intro; apply Pdec.
  destruct E as [x Hx].
  destruct (Hf x) as [n ->].
  eauto.
Qed.

(** Additions to [if_tac]: when mature, move these upstream *)

Tactic Notation "if_tac" "eq:" simple_intropattern(E) :=
  match goal with
    |- context [if ?a then _ else _] =>
    destruct a as [?H | ?H] eqn:E
  end.

Tactic Notation "if_tac" simple_intropattern(H) "eq:" simple_intropattern(E):=
  match goal with
    |- context [if ?a then _ else _] =>
    destruct a as H eqn:E
  end.

Tactic Notation "if_tac" "in" hyp(H0) "eq:" simple_intropattern(E) :=
  match type of H0 with
    context [if ?a then _ else _] =>
    destruct a as [?H  | ?H] eqn:E
  end.

Tactic Notation "if_tac" simple_intropattern(H) "in" hyp(H1) "eq:" simple_intropattern(E) :=
  match type of H1 with
    context [if ?a then _ else _] =>
    destruct a as H eqn:E
  end.

(** Specializing a hypothesis with a newly created goal *)

Tactic Notation "assert_specialize" hyp(H) :=
  match type of H with
    forall x : ?P, _ =>
    let Htemp := fresh "Htemp" in
    assert P as Htemp; [ | specialize (H Htemp); try clear Htemp ]
  end.

Tactic Notation "assert_specialize" hyp(H) "by" tactic(tac) :=
  match type of H with
    forall x : ?P, _ =>
    let Htemp := fresh "Htemp" in
    assert P as Htemp by tac; specialize (H Htemp); try clear Htemp
  end.

Tactic Notation "assert_specialize" hyp(H) "as" simple_intropattern(Hnew) :=
  match type of H with
    forall x : ?P, _ =>
    assert P as Hnew; [ | specialize (H Hnew) ]
  end.

Tactic Notation "assert_specialize" hyp(H) "as" simple_intropattern(Hnew) "by" tactic(tac) :=
  match type of H with
    forall x : ?P, _ =>
    assert P as Hnew by tac;
    specialize (H Hnew)
  end.

(** Auto-specializing a hypothesis *)

Ltac autospec H := specialize (H ltac:(solve [eauto])).

(** When a hypothesis/term is provably equal, but not convertible, to
    your goal *)

Ltac exact_eq H :=
  revert H;
  match goal with
    |- ?p -> ?q => cut (p = q); [intros ->; auto | ]
  end.

(** Auto rewriting of a term *)

Tactic Notation "rewr" :=
  match goal with
  | H : ?f = _ |- context [?f] => rewrite H
  | H : ?f _ = ?f _ |- _ => try (injection H; repeat intros ->)
  end.

Tactic Notation "rewr" constr(e) :=
  match goal with
    E : e = _ |- _ => rewrite E
  | E : _ = e |- _ => rewrite <-E
  end.

Tactic Notation "rewr" constr(e) "in" "*" :=
  match goal with
    E : e = _ |- _ => rewrite E in *
  | E : _ = e |- _ => rewrite <-E in *
  end.

Tactic Notation "rewr" constr(e) "in" hyp(H) :=
  match goal with
    E : e = _ |- _ => rewrite E in H
  | E : _ = e |- _ => rewrite <-E in H
  end.

Lemma perm_search:
  forall {A} (a b: A) r s t,
     Permutation (a::t) s ->
     Permutation (b::t) r ->
     Permutation (a::r) (b::s).
Proof.
intros.
eapply perm_trans.
apply perm_skip.
apply Permutation_sym.
apply H0.
eapply perm_trans.
apply perm_swap.
apply perm_skip.
apply H.
Qed.

Lemma Permutation_concat: forall {A} (P Q: list (list A)),
  Permutation P Q ->
  Permutation (concat P) (concat Q).
Proof.
  intros.
  induction H.
  + apply Permutation_refl.
  + simpl.
    apply Permutation_app_head; auto.
  + simpl.
    rewrite !app_assoc.
    apply Permutation_app_tail.
    apply Permutation_app_comm.
  + eapply Permutation_trans; eauto.
Qed.

Lemma Permutation_app_comm_trans:
 forall (A: Type) (a b c : list A),
   Permutation (b++a) c ->
   Permutation (a++b) c.
Proof.
intros.
eapply Permutation_trans.
apply Permutation_app_comm.
auto.
Qed.

Ltac solve_perm :=
    (* solves goals of the form (R ++ ?i = S)
          where R and S are lists, and ?i is a unification variable *)
  try match goal with
       | |-  Permutation (?A ++ ?B) _ =>
            is_evar A; first [is_evar B; fail 1| idtac];
            apply Permutation_app_comm_trans
       end;
  repeat first [ apply Permutation_refl
       | apply perm_skip
       | eapply perm_search
       ].

Goal exists e, Permutation ((1::2::nil)++e) (3::2::1::5::nil).
eexists.
solve_perm.
Qed.

Lemma range_pred_dec: forall (P: nat -> Prop),
  (forall n, {P n} + {~ P n}) ->
  forall m,
    {forall n, (n < m)%nat -> P n} + {~ forall n, (n < m)%nat -> P n}.
Proof.
  intros.
  induction m.
  + left.
    intros; omega.
  + destruct (H m); [destruct IHm |].
    - left.
      intros.
      destruct (eq_dec n m).
      * subst; auto.
      * apply p0; omega.
    - right.
      intro.
      apply n; clear n.
      intros; apply H0; omega.
    - right.
      intro.
      apply n; clear n.
      apply H0.
      omega.
Qed.

Lemma Z2Nat_neg: forall i, i < 0 -> Z.to_nat i = 0%nat.
Proof.
  intros.
  destruct i; try reflexivity.
  pose proof Zgt_pos_0 p; omega.
Qed.

Lemma Zrange_pred_dec: forall (P: Z -> Prop),
  (forall z, {P z} + {~ P z}) ->
  forall l r,
    {forall z, l <= z < r -> P z} + {~ forall z, l <= z < r -> P z}.
Proof.
  intros.
  assert ((forall n: nat, (n < Z.to_nat (r - l))%nat -> P (l + Z.of_nat n)) <-> (forall z : Z, l <= z < r -> P z)).
  Focus 1. {
    split; intros.
    + specialize (H0 (Z.to_nat (z - l))).
      rewrite <- Z2Nat.inj_lt in H0 by omega.
      spec H0; [omega |].
      rewrite Z2Nat.id in H0 by omega.
      replace (l + (z - l)) with z in H0 by omega.
      auto.
    + apply H0.
      rewrite Nat2Z.inj_lt in H1.
      destruct (zlt (r - l) 0).
      - rewrite Z2Nat_neg in H1 by omega.
        simpl in H1.
        omega.
      - rewrite Z2Nat.id in H1 by omega.
        omega.
  } Unfocus.
  eapply sumbool_dec_iff; [clear H0 | eassumption].
  apply range_pred_dec.
  intros.
  apply H.
Qed.

Definition eqb_list {A: Type} (eqb_A: A -> A -> bool): list A -> list A -> bool :=
  fix eqb_list (l1 l2: list A): bool :=
    match l1, l2 with
    | nil, nil => true
    | a1 :: l1, a2 :: l2 => eqb_A a1 a2 && eqb_list l1 l2
    | _, _ => false
    end.

Lemma eqb_list_spec: forall {A: Type} (eqb_A: A -> A -> bool),
  (forall a1 a2, eqb_A a1 a2 = true <-> a1 = a2) ->
  (forall l1 l2, eqb_list eqb_A l1 l2 = true <-> l1 = l2).
Proof.
  intros.
  revert l2; induction l1 as [| a1 l1]; intros; destruct l2 as [| a2 l2].
  + simpl.
    tauto.
  + simpl.
    split; intros; congruence.
  + simpl.
    split; intros; congruence.
  + simpl.
    rewrite andb_true_iff.
    rewrite  H.
    rewrite IHl1.
    split; intros.
    - destruct H0; subst; auto.
    - inv H0; auto.
Qed.


(* Exercise 13 *)

Require Import BenB.

Variable D : Set.
Variables P Q S T : D -> Prop.
Variable R : D -> D -> Prop.

Theorem exercise_013 : (exists x : D, P x \/ Q x) -> (forall x : D, ~(Q x)) -> (exists x : D, P x).
Proof.
imp_i a1.
imp_i a2.
exi_e (exists x:D, P x \/ Q x) a a3.
hyp a1.
exi_i a.
dis_e (P a \/ Q a) a4 a4.
hyp a3.
hyp a4.
neg_e (Q a).
all_e (forall x:D, ~Q x) a.
hyp a2.
hyp a4.
Qed.


Require Export Coq.Strings.String.
Require Export Coq.Bool.Bool.
Require Export Compare_dec.
Require Export Coq.Lists.List.
Require Export DPLL.ExplicitName.
Export ListNotations.

(* ***************************************************************** *)
(*                                                                   *)
(*                                                                   *)
(*  Definition of DPLL                                               *)
(*                                                                   *)
(*                                                                   *)
(* ***************************************************************** *)

(* ***************************************************************** *)
(*                                                                   *)
(*  Definition of CNF propositions                                   *)
(*                                                                   *)
(* ***************************************************************** *)

(** PV is imported from ExplicitName. You do not need to read those
    details. It is about string and string comparisons. *)
Module PV := StringName.

(** ident:Type of variables. Here, _[PV.t]_ is just string. *)
Definition ident := PV.t.

(** clause: list of literals.
      - true: positive literal
      - false: negative literal *)
Definition clause := list (bool * ident).

Definition CNF := list clause.

(* ***************************************************************** *)
(*                                                                   *)
(*  Definition of Assignments                                        *)
(*                                                                   *)
(* ***************************************************************** *)

(** partial_asgn: list of variables and their values *)
Definition partial_asgn := list (ident * bool).

(** asgn: value of all variables, total function *)
Definition asgn:= ident-> bool.

(** PV.look_up: find the value of x in partial_asgn J *)
Print PV.look_up.

(* ***************************************************************** *)
(*                                                                   *)
(*  Unit Propagation                                                 *)
(*                                                                   *)
(* ***************************************************************** *)

(** We define _[unit_pro]_ to improve a partial assignment. The return
    value is _[None]_ is a conflict can be derived. *)

Inductive UP_result :=
| Conflict
| UP (x: ident) (b: bool)
| Nothing.

(** Construct UP_result from a clause c.
If all literals in c contradicts with J, return Conflict.
If there is only one literal (op, x) that is not assgined in J, return UP x op.
O.w., return Nothing. *)
Fixpoint find_unit_pro_in_clause (c: clause) (J: partial_asgn) (cont: UP_result): UP_result :=
  match c with
  | nil => cont
  | (op, x) :: c' =>
      match PV.look_up x J with
      | None => match cont with
                | Conflict => find_unit_pro_in_clause c' J (UP x op)
                | UP _ _ => Nothing
                | _ => Nothing
                end
      | Some b => if eqb op b then Nothing else find_unit_pro_in_clause c' J cont
      end
  end.

Definition unit_pro' (P: CNF) (J: partial_asgn): list UP_result :=
  map (fun c => find_unit_pro_in_clause c J Conflict) P.

 (* Type of fold_left: (A -> B -> A) -> list B -> A -> A.
Below, A is option partial_asgn and B is UP_res. *)
Check fold_left.
Print fold_left.
(** Construct partial asgn from a list of UP_result. *)
Definition fold_UP_result (rs: list UP_result): option partial_asgn :=
  fold_left (fun (o: option partial_asgn) (r: UP_result) =>
               match r, o with
               | _, None => None
               | Nothing, _ => o
               | Conflict, _ => None
               | UP x b, Some J => Some ((x, b) :: J)
               end) rs (Some nil).

(** Improve partial_asgn by unit propagation. *)
Definition unit_pro (P: CNF) (J: partial_asgn): option partial_asgn :=
  fold_UP_result (unit_pro' P J).

(* ***************************************************************** *)
(*                                                                   *)
(*  Filter                                                           *)
(*                                                                   *)
(* ***************************************************************** *)

(** Literal of value false will be eliminated by _[clause_filter]_ from
    a clause. Literals of value true and literals of an unknown value
    will be left. *)
Definition clause_filter (J: partial_asgn) (c: clause): clause :=
  filter (fun opx: bool * ident =>
            match opx with
            | (op, x) => match PV.look_up x J with
                         | None => true
                         | Some b => eqb b op
                         end
            end) c.

(** This function _[clause_not_ex_true]_ tests whether no literal in the
    clause is known to be true. *)
Definition clause_not_ex_true (J: partial_asgn) (c: clause): bool :=
  negb
  (existsb
      (fun opx: bool * ident =>
            match opx with
            | (op, x) => match PV.look_up x J with
                         | None => false
                         | Some b => eqb b op
                         end
            end) c).

(** After all, literals that are known to be false are eliminated;
    clauses with at least one literal known to be true are alsi
    eliminated. *)
Definition CNF_filter (P: CNF) (J: partial_asgn): CNF :=
  map (clause_filter J) (filter (clause_not_ex_true J) P).

(* ***************************************************************** *)
(*                                                                   *)
(*  DPLL                                                             *)
(*                                                                   *)
(* ***************************************************************** *)

(* Pick P is the first identifier of P. *)
Definition pick (P: CNF): ident :=
  match P with
  | ((_, x) :: _) :: _ => x
  | _ => "impossible"%string
  end.

Fixpoint DPLL_UP (P: CNF) (J: partial_asgn) (n: nat): bool :=
  match n with
  | O => true
  | S n' =>
    match unit_pro P J with  (* apply unit propagation to improve assignment *)
    | None => false
    | Some kJ =>
      match kJ with
        | nil => DPLL_filter P J n'  (* no unit, filter by assignment *)
        | _ => DPLL_UP P (kJ ++ J) n' (* improve assignment *)
      end
    end
  end
with DPLL_filter (P: CNF) (J: partial_asgn) (n: nat): bool :=
  match n with
    | O => true
    | S n' => DPLL_pick (CNF_filter P J) nil n' (* eliminate literals that are already known *)
  end
with DPLL_pick (P: CNF) (J: partial_asgn) (n: nat): bool :=
  match n with
    | O => true
    | S n' =>
      let x := pick P in
      DPLL_UP P ((x, true) :: J) n' || DPLL_UP P ((x, false) :: J) n'  (* DFS *)
  end.

(* ***************************************************************** *)
(*                                                                   *)
(*  Examples                                                         *)
(*                                                                   *)
(* ***************************************************************** *)

Local Open Scope string.

Definition cnf1 :=
  ((true, "x") :: (true, "y") :: nil) :: ((true, "x") :: (false, "y") :: nil) :: nil.

Eval compute in (DPLL_UP cnf1 nil 6).

Definition cnf2 :=
  ((true, "x") :: (true, "y") :: nil) :: ((true, "x") :: (false, "y") :: nil) :: ((false, "x") :: nil) :: nil.

Eval compute in (DPLL_UP cnf2 nil 6).

Definition cnf3 :=
  ((false, "x") :: (true, "y") :: nil) ::
  ((false, "y") :: (true, "z") :: nil) ::
  ((false, "z") :: (true, "w") :: nil) ::
  ((true, "x") :: nil) ::
  ((false, "w") :: nil) :: nil.

Eval compute in (DPLL_UP cnf3 nil 12).
Close Scope string.

(* ***************************************************************** *)
(*                                                                   *)
(*                                                                   *)
(*  Definition of Satisfiability                                     *)
(*                                                                   *)
(*                                                                   *)
(* ***************************************************************** *)

Lemma ident_eqdec: forall x y: ident, {x=y}+{x<>y}.
Proof. apply string_dec. Qed.

Check PV.eqb_eq.

Check PV.eqb_neq.

Check Bool.eqb_true_iff.

Check Bool.eqb_false_iff.

Definition asgn_match(J:partial_asgn)(B:asgn):=
  forall x b, PV.look_up x J = Some b -> B x = b.

Definition expand(J:partial_asgn): asgn:=
  fun x =>
    match PV.look_up x J with
    | Some b => b
    | None => true
    end.

Definition set_ident(B:asgn)(s:ident)(b:bool):asgn:=
  fun x => if ident_eqdec x s then b else B x.

(** CNF_sat: CNF -> asgn -> bool *)
Definition literal_sat(l: bool * ident)(B:asgn):bool:=
  match l with
  | (b,x) => eqb b (B x)
  end.

Print fold_right.

 (* Type of fold_right: (B -> A -> A) -> A -> list B -> A.
Below, A is bool and B is (bool * ident). *)
Definition clause_sat(C:clause)(B:asgn):bool:=
  fold_right (fun l => orb (literal_sat l B)) false C.

(* Below, A is bool and B is clause. *)
Definition CNF_sat (P:CNF)(B:asgn):bool:=
  fold_right (fun c => andb (clause_sat c B)) true P.

(* ***************************************************************** *)
(*                                                                   *)
(*                                                                   *)
(*  Your goal: prove CNF is not satisfiable if DPLL returns false    *)
(*                                                                   *)
(*                                                                   *)
(* ***************************************************************** *)

(**  Proving following lemmas may be helpful.

     But you can ignore them if you can prove the final theorem
     _[DPLL_sound]_ without these lemmas. *)

Lemma UP_cannot_to_Conflict: forall c J x op,
  find_unit_pro_in_clause c J (UP x op) = Conflict -> False.
Proof.
  intros.
  induction c.
  + simpl in H. discriminate H.
  + simpl in H.
      destruct a as (op0, x0).
      destruct (PV.look_up x0 J) eqn:?.
      - destruct (eqb op0 b) eqn:?.
        * discriminate H.
        * tauto.
      - discriminate H.
Qed.

Lemma find_unit_pro_in_clause_Conflict:
  forall c J B,
    find_unit_pro_in_clause c J Conflict = Conflict ->
    asgn_match J B ->
    clause_sat c B = false.
Proof.
  intros.
  induction c.
  + simpl. tauto.
  + simpl.
      unfold orb.
      destruct (literal_sat a B) eqn:?.
      - simpl in H.
        destruct a as (op,x).
        destruct (PV.look_up x J) eqn:?.
        * unfold asgn_match in H0.
           specialize (H0 x b).
           specialize (H0 Heqo).
           unfold literal_sat in Heqb.
           rewrite H0 in Heqb.
           rewrite Heqb in H.
           discriminate H.
        * specialize (UP_cannot_to_Conflict c J x op). tauto.
      - apply IHc.
        simpl in H.
        destruct a as (op,x).
        destruct (PV.look_up x J) eqn:?.
        * unfold asgn_match in H0.
           specialize (H0 x b).
           specialize (H0 Heqo).
           unfold literal_sat in Heqb.
           rewrite H0 in Heqb.
           rewrite Heqb in H.
           tauto.
        * specialize (UP_cannot_to_Conflict c J x op). tauto.
Qed.

Lemma UP_remain:
  forall c J x b x0 b0,
    find_unit_pro_in_clause c J (UP x0 b0) = UP x b ->
    (x = x0 /\ b = b0).
Proof.
  intros.
  induction c.
  + simpl in H. injection H. auto.
  + simpl in H. destruct a as (op,x1).
      destruct (PV.look_up x1 J) eqn:H1.
      - destruct (eqb op b1) eqn:Hop.
        * discriminate H.
        * auto.
      - discriminate H.
Qed.

Lemma UP_unchange_implies_unmatch:
  forall c J B x b,
    find_unit_pro_in_clause c J (UP x b) = UP x b ->
    clause_sat c B = true ->
    asgn_match J B ->
    False.
Proof.
  intros.
  induction c.
  + simpl in H0. discriminate H0.
  + destruct a as (b0, x0).
      simpl in H0.
      unfold orb in H0.
      destruct (eqb b0 (B x0)) eqn:Hb0.
      - simpl in H.
        destruct (PV.look_up x0 J) eqn:?.
        * destruct (eqb b0 b1) eqn:Hb1.
          ++ discriminate H.
          ++ unfold asgn_match in H1.
                specialize (H1 x0 b1 Heqo).
                rewrite eqb_true_iff in Hb0.
                rewrite <- Hb0 in H1.
                rewrite eqb_false_iff in Hb1. auto.
        * discriminate H.
      - apply IHc; try tauto. clear IHc.
        simpl in H.
        destruct (PV.look_up x0 J) eqn:?.
        * destruct (eqb b0 b1) eqn:Hb1.
           ++ discriminate H.
           ++ tauto.
        * discriminate H.
Qed.

Lemma find_unit_pro_in_clause_Conflict_UP:
  forall c J B x b,
    find_unit_pro_in_clause c J Conflict = UP x b ->
    asgn_match J B ->
    clause_sat c B = true ->
    asgn_match ((x, b) :: J) B.
Proof.
  intros.
  induction c; simpl.
  + unfold clause_sat in *; unfold fold_right in *; discriminate.
  + destruct a as [op id].
    unfold find_unit_pro_in_clause in *.
    destruct (PV.look_up id J) eqn:?.
    - destruct (eqb op b0) eqn:?.
      -- discriminate.
      -- pose proof IHc H.
        simpl in H1.
        pose proof H0 id b0.
        specialize (H3 Heqo).
        rewrite H3 in H1.
        rewrite Heqb1 in H1.
        simpl in H1.
        specialize (H2 H1).
        apply H2.
    - simpl in *.
      unfold asgn_match in *.
      simpl in *.
      intros.
      destruct (PV.eqb x x0) eqn:?.
      -- pose proof PV.eqb_eq x x0.
         rewrite H3 in Heqb1.
         injection H2. intros. subst x0 b0. simpl in *.
         assert (find_unit_pro_in_clause c J (UP id op) = UP x b) by auto. clear H.
         specialize (UP_remain c J x b id op). intros.
         specialize (H H4). destruct H. subst id op. clear H2 H3.
         unfold orb in H1.
         destruct (eqb b (B x)) eqn:HB.
         * rewrite eqb_true_iff in HB. auto.
         * specialize (UP_unchange_implies_unmatch c J B x b). intros.
            specialize (H H4 H1 H0). contradiction H.
      -- pose proof H0 x0 b0.
         specialize (H3 H2).
         apply H3.
Qed.

Lemma clause_filter_sat: forall c J B,
    asgn_match J B ->
    clause_sat c B = true ->
    clause_sat (clause_filter J c) B = true.
Proof.
  intros.
  unfold asgn_match in H.
  induction c.
  + unfold clause_sat in H0; unfold fold_right in H0. discriminate.
  + simpl.
    destruct a as [op x].
    destruct (PV.look_up x J) eqn:?; simpl.
    - destruct (eqb b op) eqn:?; simpl; apply H in Heqo.
      --rewrite Heqo.
        rewrite eqb_true_iff in Heqb0.
        assert (op = b). { auto. }
        rewrite <-eqb_true_iff in H1.
        rewrite H1. simpl; reflexivity.
      --unfold clause_sat in H0; unfold fold_right in H0; unfold literal_sat in H0.
        rewrite Heqo in H0.
        rewrite eqb_false_iff in Heqb0.
        assert (op <> b). { auto. }
        rewrite <-eqb_false_iff in H1.
        rewrite H1 in H0.
        simpl in H0.
        specialize (IHc H0); apply IHc.
    - unfold fold_right in H0; unfold literal_sat in H0.
      destruct (eqb op (B x)) eqn:?; simpl.
      --reflexivity.
      --simpl in H0.
        rewrite Heqb in H0.
        simpl in H0.
        specialize (IHc H0); apply IHc.
Qed.

Lemma CNF_filter_sat: forall P J B,
    asgn_match J B ->
    CNF_sat P B = true ->
    CNF_sat (CNF_filter P J ) B = true.
Proof.
  intros.
  induction P.
  + unfold CNF_sat; unfold fold_right; unfold CNF_filter.
    simpl; reflexivity.
  + unfold CNF_sat in *; unfold fold_right in *; unfold CNF_filter in *; simpl.
    destruct (clause_not_ex_true J a) eqn:?; simpl.
    - destruct (clause_sat a B) eqn:?; simpl.
      --pose proof clause_filter_sat a J B.
        pose proof H1 H Heqb0.
        simpl in H0.
        specialize (IHP H0).
        rewrite H2; simpl.
        apply IHP.
      --simpl in H0. discriminate.
    - destruct (clause_sat a B) eqn:?; simpl.
      --pose proof clause_filter_sat a J B.
        pose proof H1 H Heqb0.
        simpl in H0.
        specialize (IHP H0).
        apply IHP.
      --simpl in H0. discriminate.
Qed.

Lemma CNF_sat_pick_fail: forall x J B,
    asgn_match J B ->
    asgn_match ((x,true)::J) B \/ asgn_match ((x,false)::J) B.
Proof.
  intros.
(*   discuss B x = true or false *)
  destruct (B x) eqn:?.
  + left.
      unfold asgn_match.
      intros.
      destruct (ident_eqdec x x0).
      - subst x0.
        simpl in H0.
        destruct (PV.eqb x x) eqn:?.
        * injection H0.
           intros. subst b. tauto.
        * unfold PV.eqb in Heqb0.
           destruct (PV.eq_dec x x).
           ++ discriminate Heqb0.
           ++ contradiction n. tauto.
      - simpl in H0.
        destruct (PV.eqb x x0) eqn:?.
        * unfold PV.eqb in Heqb0.
          destruct (PV.eq_dec x x0).
          ++ subst x. contradiction.
          ++ discriminate Heqb0.
        * apply H. tauto.
  + right.
      unfold asgn_match.
      intros.
      destruct (ident_eqdec x x0).
      - subst x0.
        simpl in H0.
        destruct (PV.eqb x x) eqn:?.
        * injection H0.
           intros. subst b. tauto.
        * unfold PV.eqb in Heqb0.
           destruct (PV.eq_dec x x). discriminate Heqb0. contradiction n. tauto.
      - simpl in H0.
        destruct (PV.eqb x x0) eqn:?.
        * unfold PV.eqb in Heqb0.
          destruct (PV.eq_dec x x0).
          ++ subst x. contradiction.
          ++ discriminate Heqb0.
        * apply H. tauto.
Qed.

Lemma none_implies_none: forall rs,
  fold_left (fun (o: option partial_asgn) (r: UP_result) =>
           match r, o with
           | _, None => None
           | Nothing, _ => o
           | Conflict, _ => None
           | UP x b, Some J => Some ((x, b) :: J)
           end) rs None = None.
Proof.
  induction rs; simpl.
  + tauto.
  + destruct a; tauto.
Qed.

Lemma none_hold: forall rs J1 J2,
  fold_left (fun (o: option partial_asgn) (r: UP_result) =>
           match r, o with
           | _, None => None
           | Nothing, _ => o
           | Conflict, _ => None
           | UP x b, Some J => Some ((x, b) :: J)
           end) rs (Some J1) = None ->
  fold_left (fun (o: option partial_asgn) (r: UP_result) =>
           match r, o with
           | _, None => None
           | Nothing, _ => o
           | Conflict, _ => None
           | UP x b, Some J => Some ((x, b) :: J)
           end) rs (Some J2) = None.
Proof.
  induction rs.
  + simpl. intros. discriminate H.
  + intros. simpl in *.
      destruct a eqn:Ha.
      - specialize (none_implies_none rs). intros. tauto.
      - specialize (IHrs ((x, b) :: J1) ((x, b) :: J2)). tauto.
      - specialize (IHrs J1 J2). tauto.
Qed.

Lemma split_keep_none: forall rs x b,
  fold_UP_result (UP x b :: rs) = None ->
  fold_UP_result rs = None.
Proof.
  intros. unfold fold_UP_result in *. simpl in H.
  specialize (none_hold rs [(x, b)] []). intros. tauto.
Qed.

Lemma none_remain: forall rs x b,
  fold_UP_result rs = None ->
  fold_UP_result (UP x b :: rs) = None.
Proof.
  intros. unfold fold_UP_result in *. simpl.
  specialize (none_hold rs [] [(x,b)]). intros. tauto.
Qed.

Lemma unit_pro_keep_match: forall P J J1 B,
  unit_pro P J = Some J1 ->
  CNF_sat P B = true ->
  asgn_match J B ->
  asgn_match (J1 ++ J) B.
Proof.
  induction P.
  + intros.
      unfold unit_pro in H.
      simpl in H.
      unfold fold_UP_result in H.
      simpl in H.
      injection H. intros. rewrite <- H2. simpl. tauto.
  + intros.
      remember (unit_pro P J) as oJ2.
      assert (unit_pro P J = oJ2) by auto.
      destruct oJ2 eqn:?.
      - remember p as J2. clear HeqoJ2 Heqo oJ2 HeqJ2 p.
        simpl in H0. unfold andb in H0.
        destruct (clause_sat a B) eqn:?.
        * specialize (IHP J J2 B H2 H0 H1).
           destruct (find_unit_pro_in_clause a J Conflict) eqn:Ha.
           ++ (* H is impossible *)
                 unfold unit_pro in H. simpl in H.
                 rewrite Ha in H.
                 unfold fold_UP_result in H. simpl in H.
                 specialize (none_implies_none (unit_pro' P J)). intros.
                 rewrite H3 in H. discriminate H.
           ++ pose proof find_unit_pro_in_clause_Conflict_UP a J B x b.
                 specialize (H3 Ha H1 Heqb).
                 assert (B x = b). {
                     unfold asgn_match in H3.
                     specialize (H3 x b). simpl in H3.
                     assert (PV.eqb x x = true). {
                        rewrite PV.eqb_eq. tauto.
                     }
                     rewrite H4 in H3. auto.
                 }
                 unfold unit_pro in H. simpl in H.
                 rewrite Ha in H.
                 unfold unit_pro in H2.
                 admit.
                 (* unfold asgn_match. intros.
                 destruct (PV.look_up x0 (J2 ++ J)) eqn:HJ.
                 -- unfold asgn_match in IHP.
                     specialize (IHP x0 b0).
                     destruct (eqb b0 b1) eqn:Hb0.
                     ** rewrite eqb_true_iff in Hb0. subst b1. auto.
                     ** (* This is impossible because J1++J cannot contradicts with J2++J. *)
                         admit.
                 -- (* x0 must be x *)
                    admit. *)
           ++ assert (J1 = J2). {
                   unfold unit_pro in H. simpl in H.
                   rewrite Ha in H.
                   unfold fold_UP_result in H. simpl in H.
                   assert (fold_UP_result (unit_pro' P J) = Some J1) by auto.
                   assert (unit_pro P J = Some J1) by auto.
                   rewrite H4 in H2. injection H2. tauto.
                 }
                 rewrite H3. tauto.
        * discriminate H0.
      - unfold unit_pro in H, H2. simpl in H.
        destruct (find_unit_pro_in_clause a J Conflict) eqn:?.
        * unfold fold_UP_result in H. simpl in H.
           specialize (none_implies_none (unit_pro' P J)). intros.
           rewrite H3 in H. discriminate H.
        * specialize (none_remain (unit_pro' P J) x b).
           intros. specialize (H3 H2). rewrite H3 in H. discriminate H.
        * unfold fold_UP_result in H, H2. simpl in H.
           rewrite H in H2. discriminate H2.
Admitted.

(* ***************************************************************** *)
(*                                                                   *)
(*                                                                   *)
(*  Final Theorems: Soundness of DPLL                                *)
(*                                                                   *)
(*                                                                   *)
(* ***************************************************************** *)

Lemma DPLL_UP_false_Jsat: forall n P J B,
    DPLL_UP P J n = false ->
    CNF_sat P B = true ->
    asgn_match J B ->
    False
with
  DPLL_filter_false_Jsat: forall n P J B,
    DPLL_filter P J n = false ->
    CNF_sat P B = true ->
    asgn_match J B ->
    False
with
  DPLL_pick_false_Jsat: forall n P J B,
    DPLL_pick P J n = false ->
    CNF_sat P B = true ->
    asgn_match J B ->
    False.
Proof.
  + clear DPLL_UP_false_Jsat.
      intros n.
      induction n.
      - intros.
        unfold DPLL_UP in H. discriminate H.
      - intros.
        simpl in H.
        destruct (unit_pro P J) eqn:Hup.
        * destruct p eqn:Hp.
           ++ specialize (DPLL_filter_false_Jsat n P J B).
                 apply DPLL_filter_false_Jsat; tauto.
           ++ rewrite <- Hp in *.
                 specialize (IHn P (p ++ J) B).
                 apply IHn; try tauto.
                 specialize (unit_pro_keep_match P J p B).
                 intros. tauto.
        * (* conflict is derived *)
           (* One clause contradicts with J, so B cannot satisfy P. *)
          induction P.
          ++ unfold unit_pro in Hup.
                simpl in Hup.
                unfold fold_UP_result in Hup.
                simpl in Hup. discriminate Hup.
          ++ (* If _[a]_ contradicts with _[J]_, then _[B]_ cannot satisfy _[a]_.
                O.w., use _[IHP]_. *)
                destruct (find_unit_pro_in_clause a J Conflict) eqn:Ha.
                -- specialize (find_unit_pro_in_clause_Conflict a J B).
                    intros.
                    specialize (H2 Ha H1).
                    simpl in H0.
                    unfold andb in H0.
                    rewrite H2 in H0. discriminate H0.
                -- apply IHP.
                   ** unfold unit_pro in Hup.
                        simpl in Hup.
                        rewrite Ha in Hup.
                        specialize (split_keep_none (unit_pro' P J) x b).
                        tauto.
                   ** simpl in H0.
                        unfold andb in H0.
                        destruct (clause_sat a B).
                        +++ tauto.
                        +++ discriminate H0.
                -- apply IHP.
                   ** unfold unit_pro in Hup.
                        simpl in Hup.
                        rewrite Ha in Hup.
                        assert (fold_UP_result (unit_pro' P J) = None). {
                          unfold fold_UP_result in Hup.
                          simpl in Hup.
                          tauto.
                        }
                        tauto.
                   ** simpl in H0.
                        unfold andb in H0.
                        destruct (clause_sat a B).
                        +++ tauto.
                        +++ discriminate H0.
  + clear DPLL_filter_false_Jsat.
      intros n.
      induction n.
      - intros.
        unfold DPLL_filter in H. discriminate H.
      - intros.
        simpl in H.
        specialize (DPLL_pick_false_Jsat n (CNF_filter P J) [] B).
        apply DPLL_pick_false_Jsat; try tauto.
        * specialize (CNF_filter_sat P J B).
           tauto.
        * unfold asgn_match.
           intros.
           unfold PV.look_up in H2. discriminate H2.
  + clear DPLL_pick_false_Jsat.
      intros n.
      induction n.
      - intros.
        unfold DPLL_pick in H. discriminate H.
      - intros.
        simpl in H.
        remember (pick P) as x.
        unfold orb in H.
        destruct (DPLL_UP P ((x, true) :: J) n) eqn:?.
        * discriminate H.
        * specialize (CNF_sat_pick_fail x J B).
           intros.
           apply H2 in H1. clear H2.
           destruct H1.
           ++ specialize (DPLL_UP_false_Jsat n P ((x, true) :: J) B).
                 apply DPLL_UP_false_Jsat; try tauto.
           ++ specialize (DPLL_UP_false_Jsat n P ((x, false) :: J) B).
                 apply DPLL_UP_false_Jsat; try tauto.
Qed.

Theorem DPLL_sound: forall n P M,
  DPLL_UP P nil n = false ->
  CNF_sat P M = false.
Proof.
  intros.
  specialize (DPLL_UP_false_Jsat n P nil M).
  intros.
  destruct (CNF_sat P M) eqn:?.
  + apply H0 in H.
      - contradiction H.
      - tauto.
      - unfold asgn_match.
        intros.
        simpl in H1.
        discriminate H1.
  + tauto.
Qed.