Require Import Coq.Array.PArray.
Require Import Coq.Numbers.Cyclic.Int63.Int63.
Require ZArith.
From LinAlg Require Export Vector.

Definition Matrix (A: Type) (n m : nat) := Vector (Vector A m) n.

Theorem matrix_on_init : forall {A B C : Type} {n m : nat}
                           (f : A -> B -> C)
                           (m1 : Matrix A n m)
                           (m2 : Matrix B n m), Matrix C n m.
Proof.
  intros.
  destruct m1 eqn:E.
  apply vect with (make
                     (vect_length_int m1)
                     (zip_with_vect_init
                        (vect_default m1)
                        (vect_default m2)
                        f)).
  rewrite length_make.
  rewrite vect_leb_length.
  rewrite E.
  simpl.
  apply prf.
Qed.

Lemma transpose_on_lemma2 : forall {A : Type} {n m : nat}
                             (mat : Matrix A n m), Vector A m.
Proof.
  intros.
  apply (vect_default mat).
Qed.

Lemma transpose_on_lemma : forall {A : Type} {n m :nat}
                              (mat : Matrix A n m), Vector A n.
Proof.
  intros.
  destruct mat eqn:E.
  apply vect with (make
                     (vect_length_int mat)
                     (vect_default (vect_default mat))).
  rewrite length_make.
  rewrite vect_leb_length.
  rewrite E.
  apply prf.
Qed.

Theorem transpose_on_init : forall {A : Type} {n m : nat}
                              (mat : Matrix A n m), Matrix A m n.
Proof.
  intros.
  destruct mat eqn:E.
  remember (default arr) as vdef.
  unfold Matrix.
  apply vect with (make
                     (vect_length_int vdef)
                     (transpose_on_lemma mat)).
  rewrite length_make.
  rewrite vect_leb_length.
  destruct vdef.
  simpl.
  apply prf0.
Qed.

Definition matrix_get {A : Type} {n m : nat} (mat : Matrix A n m) (i j : int) : A :=
  mat.[i].[j].

Definition matrix_set {A : Type} {n m : nat} (mat: Matrix A n m)  (i j : int) (a : A) : (Matrix A n m)
  := mat.[i <- (mat.[i].[j <- a])].

Notation "t .[ i , j ]" := (matrix_get t i j)
  (at level 2, left associativity, format "t .[ i , j ]").
Notation "t .[ i , j <- a ]" := (matrix_set t i j a)
  (at level 2, left associativity, format "t .[ i , j <- a ]").

Local Open Scope int63_scope.

Lemma matrix_get_set_same : forall (A : Type) (n m : nat) (mat : Matrix A n m) (i1 j1 i2 j2 : int) (a : A), (i1 <? vect_length_int mat = true) -> (i2 <? vect_length_int mat = true) -> (j1 <? vect_length_int mat.[i1] = true) -> (j2 <? vect_length_int mat.[i2] = true) -> i1 = i2 /\ j1 = j2 -> mat.[i1,j1 <- a].[i2,j2] = a.
Proof.
  intros.
  unfold matrix_set.
  unfold matrix_get.
  inversion H3.
  subst.
  rewrite vect_get_set_same.
  apply vect_get_set_same.
  assumption.
  assumption.
Qed.

Lemma matrix_get_set_id : forall A n m (mat : Matrix A n m) (i1 i2 j1 j2 : int), (i1 <? vect_length_int mat = true) -> (j1 <? vect_length_int mat.[i1] = true) -> mat.[i1,j1 <- mat.[i1,j1]].[i2,j2] = mat.[i2, j2].
Proof.
  intros.
  unfold matrix_get, matrix_set.
  destruct (eqb i1 i2) eqn:Eqi; destruct (eqb j1 j2) eqn:Eqj.
  + apply eqb_spec in Eqi.
    apply eqb_spec in Eqj.
    subst.
    rewrite vect_get_set_same.
    rewrite vect_get_set_same.
    reflexivity.
    easy.
    easy.
  + apply eqb_spec in Eqi.
    apply eqb_false_spec in Eqj.
    subst.
    rewrite vect_get_set_same.
    rewrite vect_get_set_other.
    reflexivity.
    easy.
    easy.
  + apply eqb_false_spec in Eqi.
    apply eqb_spec in Eqj.
    subst.
    rewrite vect_get_set_other.
    reflexivity.
    easy.
  + apply eqb_false_spec in Eqi.
    apply eqb_false_spec in Eqj.
    subst.
    rewrite vect_get_set_other.
    reflexivity.
    easy.
Qed.

Local Close Scope int63_scope.

Definition matrix_get_row {A : Type} {n m : nat} (i : int) (mat : Matrix A n m) : Vector A m :=
  mat.[i].

Notation "t .[ i , '_' ]" := (matrix_get_row t i)
                             (at level 2, left associativity, format "t .[ i , '_' ]").
Local Open Scope int63_scope.
Theorem matrix_ext : forall A n m (m1 m2 : Matrix A n m), (forall i j, i <? vect_length_int m1 = true /\
                                                             j <? vect_length_int m1.[i] = true ->
                                                             m1.[i,j] = m2.[i,j]) -> m1 = m2.
Proof.
  intros.
  apply vect_ext.
  intros i Hi.
  apply vect_ext.
  intros j Hj.
  apply H.
  split; assumption.
Qed.

Definition matrix_transpose_el_on {A : Type} {n m : nat} (i j : int) (mat: Matrix A n m) (tgt: Matrix A m n) : Matrix A m n :=
  tgt.[j,i <- mat.[i,j]].

Fixpoint matrix_transpose_col_on {A : Type} {n m : nat} (ni : nat) (i j : int) (mat : Matrix A n m) (tgt : Matrix A m n) : Matrix A m n :=
  match ni with
  | 0 => matrix_transpose_el_on i j mat tgt
  | S ni' => matrix_transpose_col_on ni' (i - 1%int63) j mat (matrix_transpose_el_on i j mat tgt)
  end.

Fixpoint matrix_transpose_on_helper {A : Type} {n m: nat} (nj : nat) (i j : int) (mat : Matrix A n m) (tgt : Matrix A m n) : Matrix A m n :=
  match nj with
  | 0 => matrix_transpose_col_on (n - 1) i j mat tgt
  | S nj' => matrix_transpose_on_helper nj' i (j - 1%int63) mat (matrix_transpose_col_on (n - 1) i j mat tgt)
  end.

Definition matrix_transpose_on {A : Type} {n m : nat} (mat : Matrix A n m) (tgt : Matrix A m n) :=
  matrix_transpose_on_helper (m - 1) ((vect_length_int mat) - 1%int63) ((vect_length_int (mat.[0%int63] (* Maybe replace with default *))) - 1%int63) mat tgt.

Definition matrix_transpose {A : Type} {n m : nat} (mat : Matrix A n m) :=
  matrix_transpose_on mat (transpose_on_init mat).

Definition matrix_get_col {A : Type} {n m : nat} (i : int) (mat : Matrix A n m) : Vector A n :=
  matrix_get_row i (matrix_transpose mat).
Notation "t .[ '_' , i ]" := (matrix_get_col t i)
                             (at level 2, left associativity, format "t .[ '_' , i ]").

Fixpoint matrix_mult_single_rc_helper {A : Type} `{F : Field A} {n m l : nat} (ni : nat) (i c1 c2: int) (acc : A) (mat1 : Matrix A n m) (mat2 : Matrix A m l) : A :=
  match ni with
  | 0 => plus acc (mult mat1.[c1, i] mat2.[i, c2])
  | S ni' => matrix_mult_single_rc_helper ni' (i-1%int63) c1 c2 (plus acc (mult mat1.[c1,i] mat2.[i,c2])) mat1 mat2
  end.

Definition matrix_mult_single_rc {A : Type} `{F : Field A} {n m l : nat} (c1 c2 : int) (mat1 : Matrix A n m) (mat2 : Matrix A m l) : A :=
  matrix_mult_single_rc_helper (m-1) ((vect_length_int mat2) - 1%int63) c1 c2 zero mat1 mat2.

Fixpoint matrix_mult_col_on { A : Type} `{F : Field A} {n m l : nat} (ni : nat) (i j :  int) (mat1 : Matrix A n m) (mat2 : Matrix A m l) (tgt : Matrix A n l) : Matrix A n l :=
  match ni with
  | 0 => tgt.[i,j <- (matrix_mult_single_rc i j mat1 mat2)]
  | S ni' => matrix_mult_col_on (ni') (i - 1%int63) j mat1 mat2 (tgt.[i,j <- (matrix_mult_single_rc i j mat1 mat2)])
  end.

Fixpoint matrix_mult_on_helper {A : Type} `{F : Field A} {n m l: nat} (nj : nat) (i j : int) (mat1 : Matrix A n m) (mat2 : Matrix A m l) (tgt : Matrix A n l) : Matrix A n l :=
  match nj with
  | 0 => matrix_mult_col_on (n-1) i j mat1 mat2 tgt
  | S nj' => matrix_mult_on_helper nj' (i-1%int63) j mat1 mat2 (matrix_mult_col_on (n-1) i j mat1 mat2 tgt)
  end.

Definition matrix_mult_on {A : Type} `{F : Field  A} {n m l : nat} (mat1 : Matrix A n m) (mat2 : Matrix A m l) (tgt : Matrix A n l) : Matrix A n l :=
  matrix_mult_on_helper (l - 1) (vect_length_int mat1 - 1%int63) (vect_length_int (mat2.[0%int63]) - 1%int63) mat1 mat2 tgt.

Fixpoint matrix_add_on_helper {A : Type} `{F : Field A} {n m : nat} (ni : nat) (i : int)
         (mat1 : Matrix A n m) (mat2 : Matrix A n m) (tgt : Matrix A n m) : Matrix A n m :=
  match ni with
  | 0 => tgt.[i <- (mat1.[i] +@ mat2.[i])]
  | S ni' => matrix_add_on_helper ni' (i - 1%int63) mat1 mat2 (tgt.[i <- mat1.[i] +@ mat2.[i]])
  end.

Definition matrix_add_on {A : Type} `{F : Field A} {n m : nat} (mat1 : Matrix A n m) (mat2: Matrix A n m) (tgt: Matrix A n m) : Matrix A n m :=
  matrix_add_on_helper (vect_length mat1 - 1) ((vect_length_int mat1) - 1%int63) mat1 mat2 tgt.

Definition matrix_add {A : Type} `{F : Field A} {n m : nat} (mat1 : Matrix A n m) (mat2: Matrix A n m): Matrix A n m :=
  matrix_add_on mat1 mat2 (matrix_on_init (fun x y => zero) mat1 mat2).

Fixpoint matrix_add_inv_on_helper {A : Type} `{F : Field A} {n m : nat} (ni : nat) (i : int) (mat : Matrix A n m) (tgt : Matrix A n m) : Matrix A n m :=
  match ni with
  | 0 => tgt.[i <- (-@ mat.[i])]
  | S ni' => matrix_add_inv_on_helper ni' (i - 1%int63) mat (tgt.[i <- -@ mat.[i]])
  end.

Definition matrix_add_inv_on {A : Type} `{F : Field A} {n m : nat} (mat : Matrix A n m) (tgt: Matrix A n m) : Matrix A n m :=
  matrix_add_inv_on_helper (vect_length mat - 1) ((vect_length_int mat) - 1%int63) mat tgt.

Definition matrix_sub_on {A : Type} `{F : Field A} {n m : nat} (mat1 : Matrix A n m) (mat2: Matrix A n m) (tgt: Matrix A n m) : Matrix A n m :=
  matrix_add_on mat1 (matrix_add_inv_on mat2 tgt) tgt.

Definition matrix_sub {A : Type} `{F : Field A} {n m : nat} (mat1 : Matrix A n m) (mat2: Matrix A n m) : Matrix A n m :=
  matrix_sub_on mat1 mat2 (matrix_on_init (fun x y => zero) mat1 mat2).

Fixpoint shave_vector_on_helper {A : Type} {n : nat} (v : Vector A (n+1)) (tgt : Vector A n) (ni : nat) (i : int) : Vector A n :=
  let new_tgt := tgt.[i <- v.[i + 1%int63]] in
  match ni with
  | 0 => new_tgt
  | S ni' => shave_vector_on_helper v new_tgt ni' (i-1%int63)
  end.

Definition shave_vector_on {A : Type} {n : nat} (v : Vector A (n+1)) (tgt : Vector A n) : Vector A n := shave_vector_on_helper v tgt (n-1) (vect_length_int v - 1%int63).

Fixpoint grow_vector_on_helper  {A : Type} {n : nat}
                                         (v : Vector A n)
                                         (tgt : Vector A (n + 1))
                                         (ni : nat) (i : int) : Vector A (n+1) :=
  match ni with
  | 0   => tgt.[1%int63 <- v.[0%int63]]
  | S k => grow_vector_on_helper v (tgt.[i+1%int63 <- v.[i]]) (k) (i-1%int63)
  end.

Fixpoint nat_int (n : nat) : int :=
  match n with
  | 0 => 0%int63
  | S k => 1%int63 + (nat_int k)
  end.

Search int.

(* Max array length is 4194303 by max_length *)

Theorem vect_exist : forall {A : Type} (n : nat), Vector A n.
Proof.
  Admitted.
(*
  Due to limits placed on the size of arrays in Coq, this is not actually provable. For simplicities sake, we are admitting it as the max array length is 4,194,303 objects, which borders computational infeasability, so this admittance does not affect the well-foundedness of our statements as arbitrary size arrays exist mathematically speaking, and we can not create large enough arrays in Coq to break any functions created using this existentiality.
 *)

Theorem matrix_exist : forall {A : Type} (n m : nat), Matrix A n m.
Proof.
  intros.
  apply vect_exist.
Qed.

Definition grow_vector_on {A : Type} {n : nat} (v : Vector A n) (a : A) (tgt : Vector A (n + 1)) :=
  grow_vector_on_helper v (tgt.[0%int63 <- a]) n (vect_length_int v - 1%int63).

Definition grow_vector {A : Type} {n : nat} (v : Vector A n) (a : A) :=
  grow_vector_on v a (vect_exist (n + 1)).

Fixpoint grow_matrix_on_helper {A : Type} {n m : nat} (ni : nat) (i : int) (top_vec : Vector A (n+1)) (mat : Matrix A (n+1) m) (tgt : Matrix A (n+1) (m+1)) :=
  let new_tgt := tgt.[i <- grow_vector_on (mat.[i]) (top_vec.[i]) (vect_copy (tgt.[0%int63]))] in
    match ni with
    | 0 => new_tgt
    | S ni' => grow_matrix_on_helper ni' (i - 1%int63) top_vec mat new_tgt
    end.

Lemma grow_matrix_on_helper_lemma : forall {A : Type} {n m : nat}
                                      (v : Vector A m)
                                      (mat : Matrix A (n + 1) (m + 1)), (Matrix A (n + 1) m).
Proof.
  intros.
  apply vect with (make
                     (vect_length_int mat)
                     (v)).
  rewrite length_make.
  rewrite vect_leb_length.
  destruct mat.
  assumption.
Qed.

Definition grow_matrix_on {A : Type} {n m : nat} (mat : Matrix A n m)
           (top_vec : Vector A n) (left_vec : Vector A m) (corner_el : A)
           (tgt : Matrix A (n+1) (m+1)) : Matrix A (n + 1) (m + 1) :=
  grow_matrix_on_helper ((n + 1) - 1) ((vect_length_int tgt) - 1%int63)  (grow_vector_on top_vec corner_el (transpose_on_lemma tgt)) (grow_vector_on mat left_vec (grow_matrix_on_helper_lemma left_vec tgt)) tgt.

Definition grow_matrix {A : Type} {n m : nat} (mat : Matrix A n m)
           (top_vec : Vector A n) (left_vec : Vector A m) (corner_el : A) : Matrix A (n + 1) (m + 1) :=
  grow_matrix_on mat top_vec left_vec corner_el (matrix_exist (n + 1) (m + 1)).

Definition Square A n := Matrix A n n.

Fixpoint L_SetRow {A : Type} `{F : Field A} {n : nat}
         (itr : nat)
         (tgtCol : int) (currentRow : int)
         (mat : Square A n) : Square A n :=
  match itr with
  | 0 => match eqb tgtCol currentRow with
        | true  => mat.[ currentRow, tgtCol <- one  ]
        | false => mat.[ currentRow, tgtCol <- zero ]
        end
  | S k => match eqb tgtCol currentRow with
          | true  => L_SetRow (k) (tgtCol - 1%int63) currentRow (mat.[ currentRow, tgtCol <- one  ])
          | false => L_SetRow (k) (tgtCol - 1%int63) currentRow (mat.[ currentRow, tgtCol <- zero ])
          end
  end.

Fixpoint L_Setter {A : Type} `{F : Field A} {n : nat} (itr : nat) (tgtRow :int) (mat : Square A n) :=
  match itr with
  | 0   => L_SetRow (n - 1) (vect_length_int mat - 1%int63) (tgtRow) mat
  | S k => L_Setter k (tgtRow - 1%int63) (L_SetRow (n - 1) (vect_length_int mat - 1%int63) (tgtRow) mat)
  end.

Definition L {A : Type} `{F : Field A} {n : nat} (mat : Square A n) : Square A n :=
  L_Setter (n - 1) ((vect_length_int mat) - 1%int63) mat.

Fixpoint U_SetRow {A : Type} `{F : Field A} {n : nat}
         (itr : nat)
         (tgtCol : int) (currentRow : int)
         (mat : Square A n) : Square A n :=
  match itr with
  | 0 => match eqb tgtCol currentRow with
        | true  => mat
        | false => mat.[ currentRow, tgtCol <- zero ]
        end
  | S k => match eqb tgtCol currentRow with
          | true  => U_SetRow (k) (tgtCol - 1%int63) currentRow mat
          | false => U_SetRow (k) (tgtCol - 1%int63) currentRow (mat.[ currentRow, tgtCol <- zero ])
          end
  end.

Fixpoint U_Setter {A : Type} `{F : Field A} {n : nat} (itr : nat) (tgtRow :int) (mat : Square A n) :=
  match itr with
  | 0   => U_SetRow (n - 1) (vect_length_int mat - 1%int63) (tgtRow) mat
  | S k => U_Setter k (tgtRow - 1%int63) (U_SetRow (n - 1) (vect_length_int mat - 1%int63) (tgtRow) mat)
  end.

Definition U {A : Type} `{F : Field A} {n : nat} (mat : Square A n) : Square A n :=
  U_Setter (n - 1) ((vect_length_int mat) - 1%int63) mat.

Fixpoint U_Diag_Update_Setter {A : Type} `{F : Field A} {n : nat}
         (U : Square A n) (M : Square A n)
         (itr : nat) (tgt : int) : Square A n :=
  match itr with
  | 0   => U.[tgt, tgt <- M.[tgt, tgt]]
  | S k => U_Diag_Update_Setter (U.[tgt,tgt <- M.[tgt,tgt]]) M (k) (tgt - 1)
  end.

Definition U_Diag_Update {A : Type} `{F : Field A} {n : nat} (U : Square A n) (M : Square A n) : Square A n :=
  U_Diag_Update_Setter U M (n - 1) (vect_length_int U - 1%int63).

Fixpoint L_Col_Update_Setter {A : Type} `{F : Field A} {n : nat}
                                          (M : Square A n) (L : Square A n)
                                          (itr : nat)
                                          (tgtRow : int) (currentCol : int) : Square A n :=
  match itr with
  | 0   => L.[ tgtRow, currentCol <- mult (M.[ tgtRow, currentCol ]) (mult_inv M.[ currentCol, currentCol ])]
  | S k => L_Col_Update_Setter M
                              (L.[ tgtRow, currentCol <-
                                           mult (M.[ tgtRow, currentCol ])
                                                (mult_inv M.[ currentCol, currentCol ]) ])
                              k (tgtRow - 1%int63) currentCol
  end.

Definition L_Col_Update  {A : Type} `{F : Field A} {n : nat} (offset : nat) (currentCol : int)
                                     (M : Square A n) (L : Square A n) : Square A n :=
  L_Col_Update_Setter M L (n - offset - 1) (vect_length_int M - 1%int63) (currentCol).

Fixpoint U_Row_Update_Setter {A : Type} `{F : Field A} {n : nat}
                                          (M : Square A n) (U : Square A n)
                                          (itr : nat)
                                          (currentRow : int) (tgtCol : int) : Square A n :=
  match itr with
  | 0   => U.[ currentRow, tgtCol <- M.[currentRow, tgtCol] ]
  | S k => U_Row_Update_Setter M
                              (U.[ currentRow, tgtCol <- M.[ currentRow, tgtCol] ])
                              k currentRow (tgtCol - 1%int63)
  end.

Definition U_Row_Update {A : Type} `{F : Field A} {n : nat} (offset : nat) (currentRow : int)
                                     (M : Square A n) (L : Square A n) : Square A n:=
  U_Row_Update_Setter M L (n - offset - 1) (vect_length_int M - 1%int63) (currentRow).

Fixpoint M_Block_Update_Inner_Setter {A : Type} `{F : Field A} {n : nat} (nj : nat) (j : int) (i : int) (k : int) (M L U : Square A n) : Square A n :=
  let new_M := M.[i, j <- (plus (M.[i,j]) (add_inv (mult L.[i,k] U.[k,j])))] in
  match nj with
  | 0 => new_M
  | S nj' => M_Block_Update_Inner_Setter nj' (j - 1%int63) i k new_M L U
  end.

Definition M_Block_Update_Inner {A : Type} `{F : Field A} {n : nat} (i : int) (nk : nat) (k : int) (M L U : Square A n) : Square A n :=
  M_Block_Update_Inner_Setter (n - nk -1) (vect_length_int M - 1%int63) i k M L U.

Fixpoint M_Block_Update_Outer_Run {A : Type} `{F : Field A} {n : nat} (i : int) (ni nk : nat) (k : int) (M L U : Square A n) : Square A n :=
  let new_M := M_Block_Update_Inner i nk k M L U in
  match ni with
  | 0 => new_M
  | S ni' => M_Block_Update_Outer_Run (i - 1%int63) ni' nk k new_M L U
  end.

Definition M_Block_Update_Outer {A : Type} `{F : Field A} {n : nat} (nk : nat) (k : int) (M L U : Square A n): Square A n :=
  M_Block_Update_Outer_Run (vect_length_int M - 1%int63) (n-nk-1) nk k M L U.

Fixpoint LU_decomp_step {A : Type} `{F : Field A} {n : nat} (nk : nat) (k : int) (M L U : Square A n) :=
  let U' := U.[k,k <- M.[k,k]] in
  let L' := L_Col_Update nk k M L in
  let U'' := U_Row_Update nk k M L in
  let M' := M_Block_Update_Outer nk k M L' U'' in
  match nk with
  | 0 => (L' , U')
  | S nk' => LU_decomp_step nk' (k - 1%int63) M' L' U''
  end.

Definition LU_decomp_with {A : Type} `{F : Field A} {n : nat} (M L U : Square A n) :=
  LU_decomp_step (n-1) (vect_length_int M - 1%int63) M L U.

Fixpoint matrix_copy_helper {A : Type} {n m : nat} (ni : nat) (i : int) (mat : Matrix A n m) : Matrix A n m :=
  let cpy := mat.[i <- vect_copy mat.[i]] in
  match ni with
  | 0 => cpy
  | S ni' => matrix_copy_helper ni' (i-1%int63) cpy
  end.

Definition matrix_copy {A : Type} {n m : nat} (mat : Matrix A n m) : Matrix A n m :=
  matrix_copy_helper (n-1) (vect_length_int mat - 1%int63) (vect_copy mat).

Theorem matrix_copy_eq : forall A n m (M : Matrix A n m), matrix_copy M = M.
Proof.
  intros.
  unfold matrix_copy.
  rewrite vect_copy_eq.
  unfold matrix_copy_helper.
  induction n.
  - simpl.
    rewrite vect_copy_eq.
    Check vect_set_get_id.
    apply vect_ext.
    + intros.
      rewrite vect_set_get_id.
      reflexivity.
      admit.
  -
  Admitted.

Definition LU_decomp {A : Type} `{F : Field A} {n : nat} (M : Square A n) :=
  LU_decomp_with M (L (matrix_copy M)) (U (matrix_copy M)).

Local Open Scope int63_scope.

Theorem LU_decomp_correct: forall n {A : Type} `{F: Field A} (M : Square A (S n)), let (L, U) := LU_decomp M in matrix_mult_on L U (matrix_copy M) = M.
Proof.
  induction n; intros.
  - remember (LU_decomp M) as LU.
    destruct LU.
    unfold matrix_mult_on.
    unfold matrix_mult_on_helper.
    simpl.
    assert (Hs : vect_length_int s = 1%int63).
    + assert (H : 1 = vect_length_int (vect_make (make 1 1))).
      * rewrite vect_length_make.
        compute.
        reflexivity.
      * rewrite H.
        apply vect_length_type_vect_length_int.
        rewrite length_make.
        compute.
        reflexivity.
    + rewrite Hs.
      assert (Hm0 : vect_length_int m.[0] = 1).
      * assert (H : 1 = vect_length_int (vect_make (make 1 1))).
        -- rewrite vect_length_make.
           compute.
           reflexivity.
        -- rewrite H.
           apply vect_length_type_vect_length_int.
           rewrite length_make.
           compute.
           reflexivity.
      * rewrite Hm0.
        unfold matrix_mult_single_rc.
        unfold matrix_mult_single_rc_helper.
        simpl.
        Print Field.
        rewrite add_0.
        assert ( Hm : vect_length_int m = 1).
        assert (H : 1 = vect_length_int (vect_make (make 1 1))).
        rewrite vect_length_make;compute;reflexivity.
        rewrite H.
        apply vect_length_type_vect_length_int.
        rewrite length_make.
        compute.
        reflexivity.
        rewrite Hm.
        assert (EZ : 1 - 1 = 0).
        easy.
        rewrite EZ.
        unfold LU_decomp in HeqLU.
        unfold LU_decomp_with in HeqLU.
        simpl in HeqLU.
        unfold L_Col_Update in HeqLU.
        unfold L_Col_Update_Setter in HeqLU.
        simpl in HeqLU.
        rewrite mult_mult_inv in HeqLU.
        assert (HM : (vect_length_int M) = 1).
        --  assert (H : 1 = vect_length_int (vect_make (make 1 1))).
           ** rewrite vect_length_make.
              compute.
              reflexivity.
           ** rewrite H.
              apply vect_length_type_vect_length_int.
              rewrite length_make.
              compute.
              reflexivity.
        -- rewrite HM in HeqLU.
           rewrite EZ in HeqLU.
           inversion HeqLU.
           rewrite matrix_get_set_same.
           ** rewrite matrix_get_set_same.
              --- rewrite mult_1.
                  rewrite matrix_copy_eq.
                  apply matrix_ext.
                  intros.
                  apply matrix_get_set_id.
                  +++ rewrite HM.
                      easy.
                  +++ assert (HM0 : 1 = vect_length_int M.[0]).
                      *** assert (HM0h : 1 = vect_length_int (vect_make (make 1 1))).
                          ---- rewrite vect_length_make.
                               compute.
                               reflexivity.
                          ---- rewrite HM0h.
                               apply vect_length_type_vect_length_int.
                               rewrite length_make.
                               compute.
                               reflexivity.
                      *** rewrite <- HM0.
                          easy.
              --- Check vect_length_type_vect_length_int.
                  rewrite vect_length_type_vect_length_int with (Vector A 1%nat) (Vector A 1%nat) 1%nat 1%nat (U (matrix_copy M)) M.
                  rewrite HM; easy.
                  easy.
              --- rewrite vect_length_type_vect_length_int with (Vector A 1%nat) (Vector A 1%nat) 1%nat 1%nat (U (matrix_copy M)) M.
                  rewrite HM; easy.
                  easy.
              --- rewrite vect_length_type_vect_length_int with _ _ 1%nat 1%nat (U (matrix_copy M)).[0] M.[0].
                  +++ assert (HM0 : 1 = vect_length_int M.[0]).
                      *** assert (HM0h : 1 = vect_length_int (vect_make (make 1 1))).
                          ---- rewrite vect_length_make.
                               compute.
                               reflexivity.
                          ---- rewrite HM0h.
                               apply vect_length_type_vect_length_int.
                               rewrite length_make.
                               compute.
                               reflexivity.
                      *** rewrite <- HM0.
                          easy.
                  +++ easy.
              --- rewrite vect_length_type_vect_length_int with _ _ 1%nat 1%nat (U (matrix_copy M)).[0] M.[0].
                  +++ assert (HM0 : 1 = vect_length_int M.[0]).
                      *** assert (HM0h : 1 = vect_length_int (vect_make (make 1 1))).
                          ---- rewrite vect_length_make.
                               compute.
                               reflexivity.
                          ---- rewrite HM0h.
                               apply vect_length_type_vect_length_int.
                               rewrite length_make.
                               compute.
                               reflexivity.
                      *** rewrite <- HM0.
                          easy.
                  +++ easy.
              --- split; easy.
           ** rewrite vect_length_type_vect_length_int with _ _ 1%nat 1%nat (L (matrix_copy M)) M.
                  rewrite HM; easy.
                  easy.
           ** rewrite vect_length_type_vect_length_int with _ _ 1%nat 1%nat (L (matrix_copy M)) M.
                  rewrite HM; easy.
                  easy.
           ** rewrite vect_length_type_vect_length_int with _ _ 1%nat 1%nat (L (matrix_copy M)).[0] M.[0].
                  +++ assert (HM0 : 1 = vect_length_int M.[0]).
                      *** assert (HM0h : 1 = vect_length_int (vect_make (make 1 1))).
                          ---- rewrite vect_length_make.
                               compute.
                               reflexivity.
                          ---- rewrite HM0h.
                               apply vect_length_type_vect_length_int.
                               rewrite length_make.
                               compute.
                               reflexivity.
                      *** rewrite <- HM0.
                          easy.
                  +++ easy.
           ** rewrite vect_length_type_vect_length_int with _ _ 1%nat 1%nat (L (matrix_copy M)).[0] M.[0].
                  +++ assert (HM0 : 1 = vect_length_int M.[0]).
                      *** assert (HM0h : 1 = vect_length_int (vect_make (make 1 1))).
                          ---- rewrite vect_length_make.
                               compute.
                               reflexivity.
                          ---- rewrite HM0h.
                               apply vect_length_type_vect_length_int.
                               rewrite length_make.
                               compute.
                               reflexivity.
                      *** rewrite <- HM0.
                          easy.
                  +++ easy.
           ** split; easy.
  - unfold LU_decomp.
    unfold LU_decomp_with.
    Admitted.


Require Import Coq.Lists.List.

Fixpoint InAtMostOnce{A:Type}(a:A)(l:list A)(H : forall x y : A, {x = y} + {x <> y}) {struct l}: Prop :=
match l with
|nil => True
|cons a' l' => match H a a' with
                  |left _ => (In a l') -> False
                  |right _ => (InAtMostOnce a l' H)
                  end
end.

Record Dictionary (K V:Type) :=
{
  dict_entries : list (K * V);
  dict_decide_key_eq : forall x y:K, {x = y} + {x <> y};
  dict_unique : forall k:K, InAtMostOnce k (map fst dict_entries) dict_decide_key_eq
}.

Definition EmptyDictionary(K V:Type)(H : forall x y : K, {x = y} + {x <> y}) : Dictionary K V :=
{|
  dict_entries := nil;
  dict_decide_key_eq := H;
  dict_unique := fun (_ : K) => I
|}.

Definition keys{K V:Type}(D:Dictionary K V) : list K := map fst (dict_entries _ _ D).
Definition values{K V:Type}(D:Dictionary K V) : list V := map snd (dict_entries _ _ D).

Fixpoint getValue_list {K V:Type}(l:list (K * V))(H : forall x y : K, {x = y} + {x <> y})(k:K) {struct l}: option V :=
match l with
|nil => None
|(k', v) :: l' => match H k k' with
                  |left _ => Some v
                  |right _ => getValue_list l' H k
                  end
end.

Definition getValue{K V:Type}(D:Dictionary K V)(k:K) : option V :=
  getValue_list (dict_entries _ _ D) (dict_decide_key_eq _ _ D)(k:K).

Fixpoint setValue_list {K V:Type}(l:list (K * V))(H : forall x y : K, {x = y} + {x <> y})(k:K)(v:V) {struct l}: list (K * V) :=
match l with
|nil => (k, v) :: nil
|(k', v') :: l' => match H k k' with
                  |left _ => (k, v) :: l'
                  |right _ => (k', v') :: setValue_list l' H k v
                  end
end.

Ltac generalize_clear H := generalize H; clear H.

Lemma notinLemma{A:Type}(a:A)(l:list A)(H : forall x y : A, {x = y} + {x <> y}) : (In a l -> False) -> InAtMostOnce a l H.
induction l.
all: simpl.
all: intros.
apply I.
destruct (H a a0).
symmetry in e.
destruct (H0 (or_introl e)).
apply IHl.
intro.
destruct (H0 (or_intror H1)).
Optimize Proof.
Defined.

Lemma sVInLemma{K V:Type}(dict_entries0 : list (K * V))
 : forall (k' k:K)(v:V)(n:k<>k')(dict_decide_key_eq0 : forall x y : K, {x = y} + {x <> y}),
   In k' (map fst (setValue_list dict_entries0 dict_decide_key_eq0 k v)) -> In k' (map fst dict_entries0).
induction dict_entries0.
all: intros.
2: destruct a as [x y].
all: simpl in *.
destruct H.
apply (n H).
apply H.
destruct (dict_decide_key_eq0 k x).
simpl in H.
destruct H.
constructor 1.
destruct H.
destruct e.
trivial.
constructor 2.
apply H.
simpl in H.
destruct H.
constructor 1.
apply H.
constructor 2.
apply (IHdict_entries0 _ _ _ n dict_decide_key_eq0 H).
Optimize Proof.
Defined.

Definition setValue {K V:Type}(D:Dictionary K V)(k:K)(v:V) : Dictionary K V.
apply (Build_Dictionary _ _
   (setValue_list (dict_entries K V D) (dict_decide_key_eq K V D) k v)
   (dict_decide_key_eq K V D)).
destruct D.
simpl in *.
induction dict_entries0.
all: intro k'.
simpl in *.
destruct (dict_decide_key_eq0 k' k).
intro F; apply F.
apply I.
destruct a as [x y].
simpl in *.
destruct (dict_decide_key_eq0 k x).
destruct e.
simpl in *.
apply dict_unique0.
unfold map.
fold (map fst (setValue_list dict_entries0 dict_decide_key_eq0 k v)).
unfold fst at 1.
unfold InAtMostOnce.
fold (InAtMostOnce k').
assert (forall k : K, InAtMostOnce k (map fst dict_entries0) dict_decide_key_eq0).
intros.
assert (H := dict_unique0 k0).
destruct (dict_decide_key_eq0 k0 x).
apply notinLemma.
apply H.
apply H.
assert (H' := IHdict_entries0 H k').
destruct (dict_decide_key_eq0 k' x).
destruct e.
2: apply H'.
assert (H'' := dict_unique0 k').
destruct (dict_decide_key_eq0 k' k').
2: destruct (n0 eq_refl).
intros.
apply H''.
generalize H0.
apply sVInLemma.
apply n.
Optimize Proof.
Defined.

Definition setValues {K V:Type}(D:Dictionary K V)(l:list (K*V)) : Dictionary K V :=
fold_right (fun x:(K * V) => fun y:Dictionary K V =>  setValue y (fst x) (snd x)) D l.

Definition merge {K V:Type}(D D':Dictionary K V) : Dictionary K V := setValues D (dict_entries _ _ D').


Require Coq.Logic.Eqdep_dec.
Require Import Coq.Numbers.Natural.Peano.NPeano Coq.omega.Omega.
Require Import Coq.micromega.Lia.
Import Nat.

Scheme Equality for nat.

Create HintDb natsimplify discriminated.

Hint Resolve mod_bound_pos plus_le_compat : arith.
Hint Resolve (fun x y p q => proj1 (@Nat.mod_bound_pos x y p q)) (fun x y p q => proj2 (@Nat.mod_bound_pos x y p q)) : arith.

Hint Rewrite @mod_small @mod_mod @mod_1_l @mod_1_r succ_pred using omega : natsimplify.

Hint Rewrite sub_diag add_0_l add_0_r sub_0_r sub_succ : natsimplify.

Local Open Scope nat_scope.

Lemma min_def {x y} : min x y = x - (x - y).
Proof. apply Min.min_case_strong; omega. Qed.
Lemma max_def {x y} : max x y = x + (y - x).
Proof. apply Max.max_case_strong; omega. Qed.
Ltac coq_omega := omega.
Ltac handle_min_max_for_omega_gen min max :=
  repeat match goal with
         | [ H : context[min _ _] |- _ ] => rewrite !min_def in H || setoid_rewrite min_def in H
         | [ H : context[max _ _] |- _ ] => rewrite !max_def in H || setoid_rewrite max_def in H
         | [ |- context[min _ _] ] => rewrite !min_def || setoid_rewrite min_def
         | [ |- context[max _ _] ] => rewrite !max_def || setoid_rewrite max_def
         end.
Ltac handle_min_max_for_omega_case_gen min max :=
  repeat match goal with
         | [ H : context[min _ _] |- _ ] => revert H
         | [ H : context[max _ _] |- _ ] => revert H
         | [ |- context[min _ _] ] => apply Min.min_case_strong
         | [ |- context[max _ _] ] => apply Max.max_case_strong
         end;
  intros.
Ltac handle_min_max_for_omega := handle_min_max_for_omega_gen min max.
Ltac handle_min_max_for_omega_case := handle_min_max_for_omega_case_gen min max.
(* In 8.4, Nat.min is a definition, so we need to unfold it *)
Ltac handle_min_max_for_omega_compat_84 :=
  let min := (eval cbv [min] in min) in
  let max := (eval cbv [max] in max) in
  handle_min_max_for_omega_gen min max.
Ltac handle_min_max_for_omega_case_compat_84 :=
  let min := (eval cbv [min] in min) in
  let max := (eval cbv [max] in max) in
  handle_min_max_for_omega_case_gen min max.
Ltac omega_with_min_max :=
  handle_min_max_for_omega;
  try handle_min_max_for_omega_compat_84;
  omega.
Ltac omega_with_min_max_case :=
  handle_min_max_for_omega_case;
  try handle_min_max_for_omega_case_compat_84;
  omega.
Tactic Notation "omega" := coq_omega.
Tactic Notation "omega" "*" := omega_with_min_max_case.
Tactic Notation "omega" "**" := omega_with_min_max.

Lemma nat_eq_dec_S x y
  : match nat_eq_dec (S x) (S y), nat_eq_dec x y with
    | left pfS, left pf => pfS = f_equal S pf
    | right _, right _ => True
    | _, _ => False
    end.
Proof.
  unfold nat_eq_dec; simpl.
  match goal with
  | [ |- match match ?e with _ => _ end with _ => _ end ]
    => destruct e
  end; simpl; try exact I.
  reflexivity.
Defined.

Lemma UIP_nat_transparent x y (p1 p2 : x = y :> nat) : p1 = p2.
Proof.
  transitivity (match nat_eq_dec x y, nat_eq_dec y y with
                | left pf1, left pf2 => eq_trans pf1 (eq_sym pf2)
                | _, _ => p1
                end);
    [ revert p2 | revert p1 ];
    subst y; intro p;
      destruct (nat_eq_dec x x) as [q|q]; case q; reflexivity.
Defined.

Lemma nat_beq_false_iff x y : nat_beq x y = false <-> x <> y.
Proof.
  split; intro H; repeat intro; subst.
  { erewrite internal_nat_dec_lb in H by reflexivity; congruence. }
  { destruct (nat_beq x y) eqn:H'; [ | reflexivity ].
    apply internal_nat_dec_bl in H'; subst; congruence. }
Qed.

Ltac nat_beq_to_eq :=
  repeat match goal with
         | [ H : nat_beq _ _ = true |- _ ] => apply internal_nat_dec_bl in H
         | [ H : is_true (nat_beq _ _) = true |- _ ] => apply internal_nat_dec_bl in H
         | [ |- nat_beq _ _ = true ] => apply internal_nat_dec_lb
         | [ |- is_true (nat_beq _ _) ] => apply internal_nat_dec_lb
         | [ H : nat_beq _ _ = false |- _ ] => apply nat_beq_false_iff in H
         | [ |- nat_beq _ _ = false ] => apply nat_beq_false_iff
         end.

Lemma div_minus : forall a b, b <> 0 -> (a + b) / b = a / b + 1.
Proof.
  intros a b H.
  assert (H0 : b = 1 * b) by omega.
  rewrite H0 at 1.
  rewrite <- Nat.div_add by auto.
  reflexivity.
Qed.

Lemma pred_mod : forall m, (0 < m)%nat -> ((pred m) mod m)%nat = pred m.
Proof.
  intros m H; apply Nat.mod_small.
  destruct m; try omega; rewrite Nat.pred_succ; auto.
Qed.

Lemma div_add_l' : forall a b c, a <> 0 -> (a * b + c) / a = b + c / a.
Proof.
  intros; rewrite Nat.mul_comm; auto using div_add_l.
Qed.

Lemma mod_add_l : forall a b c, b <> 0 -> (a * b + c) mod b = c mod b.
Proof.
  intros; rewrite Nat.add_comm; auto using mod_add.
Qed.

Lemma mod_add_l' : forall a b c, b <> 0 -> (b * a + c) mod b = c mod b.
Proof.
  intros; rewrite Nat.mul_comm; auto using mod_add_l.
Qed.

Lemma mod_div_eq0 : forall a b, b <> 0 -> a mod b / b = 0.
Proof.
  intros; apply Nat.div_small, mod_bound_pos; omega.
Qed.

Lemma divide2_1mod4_nat : forall c x, c = x / 4 -> x mod 4 = 1 -> exists y, 2 * y = (x / 2).
Proof.
  assert (4 <> 0) as ne40 by omega.
  induction c; intros x H H0; pose proof (div_mod x 4 ne40) as H1; rewrite <- H in H1. {
    rewrite H0 in H1.
    simpl in H1.
    rewrite H1.
    exists 0; auto.
  } {
    rewrite mult_succ_r in H1.
    assert (4 <= x) as le4x by (apply Nat.div_str_pos_iff; omega).
    rewrite <- Nat.add_1_r in H.
    replace x with ((x - 4) + 4) in H by omega.
    rewrite div_minus in H by auto.
    apply Nat.add_cancel_r in H.
    replace x with ((x - 4) + (1 * 4)) in H0 by omega.
    rewrite Nat.mod_add in H0 by auto.
    pose proof (IHc _ H H0) as H2.
    destruct H2 as [x0 H2].
    exists (x0 + 1).
    rewrite <- (Nat.sub_add 4 x) in H1 at 1 by auto.
    replace (4 * c + 4 + x mod 4) with (4 * c + x mod 4 + 4) in H1 by omega.
    apply Nat.add_cancel_r in H1.
    replace (2 * (x0 + 1)) with (2 * x0 + 2)
      by (rewrite Nat.mul_add_distr_l; auto).
    rewrite H2.
    rewrite <- Nat.div_add by omega.
    f_equal.
    simpl.
    apply Nat.sub_add; auto.
  }
Qed.

Lemma Nat2N_inj_lt : forall n m, (N.of_nat n < N.of_nat m)%N <-> n < m.
Proof.
  split; intros. {
    rewrite nat_compare_lt.
    rewrite Nnat.Nat2N.inj_compare.
    rewrite N.compare_lt_iff; auto.
  } {
    rewrite <- N.compare_lt_iff.
    rewrite <- Nnat.Nat2N.inj_compare.
    rewrite <- nat_compare_lt; auto.
  }
Qed.

Lemma lt_min_l : forall x a b, (x < min a b)%nat -> (x < a)%nat.
Proof.
  intros ? ? ? lt_min.
  apply Nat.min_glb_lt_iff in lt_min.
  destruct lt_min; assumption.
Qed.

(* useful for hints *)
Lemma eq_le_incl_rev : forall a b, a = b -> b <= a.
Proof.
  intros; omega.
Qed.

Lemma beq_nat_eq_nat_dec {R} (x y : nat) (a b : R)
  : (if EqNat.beq_nat x y then a else b) = (if eq_nat_dec x y then a else b).
Proof.
  destruct (eq_nat_dec x y) as [H|H];
    [ rewrite (proj2 (@beq_nat_true_iff _ _) H); reflexivity
    | rewrite (proj2 (@beq_nat_false_iff _ _) H); reflexivity ].
Qed.

Lemma pow_nonzero a k : a <> 0 -> a ^ k <> 0.
Proof.
  intro; induction k; simpl; nia.
Qed.

Hint Resolve pow_nonzero : arith.

Lemma S_pred_nonzero : forall a, (a > 0 -> S (pred a) = a)%nat.
Proof.
  destruct a; simpl; omega.
Qed.

Hint Rewrite S_pred_nonzero using omega : natsimplify.

Lemma mod_same_eq a b : a <> 0 -> a = b -> b mod a = 0.
Proof. intros; subst; apply mod_same; assumption. Qed.

Hint Rewrite @mod_same_eq using omega : natsimplify.
Hint Resolve mod_same_eq : arith.

Lemma mod_mod_eq a b c : a <> 0 -> b = c mod a -> b mod a = b.
Proof. intros; subst; autorewrite with natsimplify; reflexivity. Qed.

Hint Rewrite @mod_mod_eq using (reflexivity || omega) : natsimplify.

Local Arguments minus !_ !_.

Lemma S_mod_full a b : a <> 0 -> (S b) mod a = if eq_nat_dec (S (b mod a)) a
                                               then 0
                                               else S (b mod a).
Proof.
  change (S b) with (1+b); intros.
  pose proof (mod_bound_pos b a).
  rewrite add_mod by assumption.
  destruct (eq_nat_dec (S (b mod a)) a) as [H'|H'];
    destruct a as [|[|a]]; autorewrite with natsimplify in *;
      try congruence; try reflexivity.
Qed.

Hint Rewrite S_mod_full using omega : natsimplify.

Lemma S_mod a b : a <> 0 -> S (b mod a) <> a -> (S b) mod a = S (b mod a).
Proof.
  intros; rewrite S_mod_full by assumption.
  edestruct eq_nat_dec; omega.
Qed.

Hint Rewrite S_mod using (omega || autorewrite with natsimplify; omega) : natsimplify.

Lemma eq_nat_dec_refl x : eq_nat_dec x x = left (Logic.eq_refl x).
Proof.
  edestruct eq_nat_dec; try congruence.
  apply f_equal, Eqdep_dec.UIP_dec, eq_nat_dec.
Qed.

Hint Rewrite eq_nat_dec_refl : natsimplify.

(** Helper to get around the lack of function extensionality *)
Definition eq_nat_dec_right_val n m (pf0 : n <> m) : { pf | eq_nat_dec n m = right pf }.
Proof.
  revert dependent n; induction m as [|m IHm]; destruct n as [|n]; simpl;
    intro pf0;
    [ (exists pf0; exfalso; abstract congruence)
    | eexists; reflexivity
    | eexists; reflexivity
    | ].
  { specialize (IHm n).
    destruct IHm as [? IHm]; [ omega | ].
    eexists; rewrite IHm; reflexivity. }
Qed.

Lemma eq_nat_dec_S_n n : eq_nat_dec (S n) n = right (proj1_sig (@eq_nat_dec_right_val _ _ (@neq_succ_diag_l n))).
Proof.
  edestruct eq_nat_dec_right_val; assumption.
Qed.

Hint Rewrite eq_nat_dec_S_n : natsimplify.

Lemma eq_nat_dec_n_S n : eq_nat_dec n (S n) = right (proj1_sig (@eq_nat_dec_right_val _ _ (n_Sn n))).
Proof.
  edestruct eq_nat_dec_right_val; assumption.
Qed.

Hint Rewrite eq_nat_dec_n_S : natsimplify.

Hint Rewrite Max.max_0_l Max.max_0_r Max.max_idempotent Min.min_0_l Min.min_0_r Min.min_idempotent : natsimplify.

(** Helper to get around the lack of function extensionality *)
Definition le_dec_right_val n m (pf0 : ~n <= m) : { pf | le_dec n m = right pf }.
Proof.
  destruct (le_dec n m) eqn:Heq; [ | eexists; reflexivity ].
  exfalso; clear Heq; apply pf0; assumption.
Qed.

(** Helper to get around the lack of function extensionality *)
Definition lt_dec_right_val n m (pf0 : ~n < m) : { pf | lt_dec n m = right pf }
  := @le_dec_right_val _ _ pf0.

Lemma lt_dec_irrefl n : lt_dec n n = right (proj1_sig (@lt_dec_right_val _ _ (lt_irrefl n))).
Proof. edestruct lt_dec_right_val; assumption. Qed.
Hint Rewrite lt_dec_irrefl : natsimplify.

Lemma not_lt_n_pred_n n : ~n < pred n.
Proof. destruct n; simpl; omega. Qed.

Lemma lt_dec_n_pred_n n : lt_dec n (pred n) = right (proj1_sig (@lt_dec_right_val _ _ (not_lt_n_pred_n n))).
Proof. edestruct lt_dec_right_val; assumption. Qed.
Hint Rewrite lt_dec_n_pred_n : natsimplify.

Lemma le_dec_refl n : le_dec n n = left (le_refl n).
Proof.
  edestruct le_dec; try omega.
  apply f_equal, le_unique.
Qed.
Hint Rewrite le_dec_refl : natsimplify.

Lemma le_dec_pred_l n : le_dec (pred n) n = left (le_pred_l n).
Proof.
  edestruct le_dec; [ | destruct n; simpl in *; omega ].
  apply f_equal, le_unique.
Qed.
Hint Rewrite le_dec_pred_l : natsimplify.

Lemma le_pred_plus_same n : n <= pred (n + n).
Proof. destruct n; simpl; omega. Qed.

Lemma le_dec_pred_plus_same n : le_dec n (pred (n + n)) = left (le_pred_plus_same n).
Proof.
  edestruct le_dec; [ | destruct n; simpl in *; omega ].
  apply f_equal, le_unique.
Qed.
Hint Rewrite le_dec_pred_plus_same : natsimplify.

Lemma minus_S_diag x : (S x - x = 1)%nat.
Proof. omega. Qed.
Hint Rewrite minus_S_diag : natsimplify.

Lemma min_idempotent_S_l x : min (S x) x = x.
Proof. omega *. Qed.
Hint Rewrite min_idempotent_S_l : natsimplify.

Lemma min_idempotent_S_r x : min x (S x) = x.
Proof. omega *. Qed.
Hint Rewrite min_idempotent_S_r : natsimplify.

Lemma mod_pow_same b e : b <> 0 -> e <> 0 -> b^e mod b = 0.
Proof.
  intros; destruct e as [|e]; [ omega | simpl ].
  rewrite mul_comm, mod_mul by omega; omega.
Qed.

Lemma setbit_high : forall x i, (x < 2^i -> setbit x i = x + 2^i)%nat.
Proof.
  intros x i H; apply bits_inj; intro n.
  rewrite setbit_eqb.
  destruct (beq_nat i n) eqn:H'; simpl.
  { apply beq_nat_true in H'; subst.
    symmetry; apply testbit_true.
    rewrite div_minus, div_small by omega.
    reflexivity. }
  { assert (H'' : (((x + 2 ^ i) / 2 ^ n) mod 2) = ((x / 2 ^ n) mod 2)).
    { assert (2^(i-n) <> 0) by auto with arith.
      assert (2^(i-n) <> 0) by omega.
      destruct (lt_eq_lt_dec i n) as [ [?|?] | ? ]; [ | subst; rewrite <- beq_nat_refl in H'; congruence | ].
      { assert (i <= n - 1) by omega.
        assert (2^i <= 2^n) by auto using pow_le_mono_r with arith.
        assert (2^i <= 2^(n - 1)) by auto using pow_le_mono_r with arith.
        assert (2^(n-1) <> 0) by auto with arith.
        assert (2^(n-1) + 2^(n-1) = 2^n)
          by (transitivity (2^(S (n - 1))); [ simpl; omega | apply f_equal; omega ]).
        assert ((2^(n - 1) - 1) + (2^(n - 1)) < 2^n) by omega.
        rewrite !div_small; try omega. }
      { replace (2^i) with (2^(i - n) * 2^n)
          by (rewrite <- pow_add_r, ?le_plus_minus_r, ?sub_add by omega; omega).
        rewrite div_add by auto with arith.
        rewrite <- add_mod_idemp_r, mod_pow_same, add_0_r by omega.
        reflexivity. } }
    { match goal with
      | [ |- ?x = ?y ]
        => destruct x eqn:H0; destruct y eqn:H1; try reflexivity;
             try apply testbit_true in H0;
             try apply testbit_true in H1;
             first [ rewrite <- H0; clear H0 | rewrite <- H1; clear H1 ];
             first [ symmetry; apply testbit_true | apply testbit_true ]
      end;
        rewrite H'' in *; assumption. } }
Qed.


Require Export Fibrations Contractible Equivalences.
Require Export UsefulEquivalences FiberEquivalences.

(** For compatibility with Coq 8.2. *)
Unset Automatic Introduction.

Definition ext_dep_eq {X} {P : X -> Type} (f g : forall x, P x) := forall x : X, f x == g x.

Notation "f === g" := (ext_dep_eq f g) (at level 50).

(** The simplest notion we call "naive functional extensionality".
   This is what a type theorist would probably write down when
   thinking of types as sets and identity types as equalities: it says
   that if two functions are equal pointwise, then they are equal.  It
   comes in both ordinary and dependent versions. *)

Definition funext_statement : Type :=
  forall (X Y : Type) (f g: X -> Y), f === g -> f == g.

Definition funext_dep_statement : Type :=
  forall (X : Type) (P : X -> Type) (f g : section P), f === g -> (f == g).

(** However, there are clearly going to be problems with this in the
   homotopy world, since "being equal" is not merely a property, but
   being equipped with a path is structure.  We should expect some
   sort of coherence or canonicity of the path from f to g relating it
   to the pointwise homotopy we started with.

   A natural way to state a "homotopically good" notion of function
   extensionality is to observe that there is a canonical map in the
   other direction, taking paths between functions to pointwise
   homotopies.  We can thus just ask for that map to be an
   equivalence.  We call this "strong functional extensionality."  Of
   course, it also comes in ordinary and dependent versions.  *)

Definition strong_funext_statement : Type :=
  forall (X Y : Type) (f g : X -> Y), is_equiv (@happly X Y f g).

Definition strong_funext_dep_statement : Type :=
  forall (X : Type) (P : X -> Type) (f g : section P),
    is_equiv (@happly_dep X P f g).

(** Of course, strong functional extensionality implies naive
   functional extensionality, along with a computation rule. *)

Theorem strong_to_naive_funext :
  strong_funext_statement -> funext_statement.
Proof.
  intros H X Y f g.
  exact ((@happly X Y f g  ;  H X Y f g) ^-1).
Defined.

Theorem strong_funext_compute
  (strong_funext : strong_funext_statement)
  (X Y:Type) (f g : X -> Y) (p : f === g) (x : X) :
  happly (strong_to_naive_funext strong_funext X Y f g p) x == p x.
Proof.
  intros.
  unfold strong_to_naive_funext.
  unfold inverse.
  simpl.
  exact (happly_dep (pr2 (pr1 (strong_funext X Y f g p))) x).
Defined.

Theorem strong_to_naive_funext_dep :
  strong_funext_dep_statement -> funext_dep_statement.
Proof.
  intros H X Y f g.
  exact ((@happly_dep X Y f g ; H X Y f g) ^-1).
Defined.

Theorem strong_funext_dep_compute
  (strong_funext_dep : strong_funext_dep_statement)
  (X : Type) (P : X -> Type) (f g : section P) (p : f === g) (x : X) :
  happly_dep (strong_to_naive_funext_dep strong_funext_dep X P f g p) x == p x.
Proof.
  intros.
  unfold strong_to_naive_funext_dep.
  unfold inverse.
  simpl.
  exact (happly_dep (pr2 (pr1 (strong_funext_dep X P f g p))) x).
Defined.

(** We also observe that for both strong and naive functional
   extensionality, the dependent version implies the non-dependent
   version.  *)

Theorem strong_funext_dep_to_nondep :
  strong_funext_dep_statement -> strong_funext_statement.
Proof.
  intros H X Y f g.
  exact (H X (fun x => Y) f g).
Defined.

Theorem funext_dep_to_nondep :
  funext_dep_statement -> funext_statement.
Proof.
  intros H X Y f g.
  exact (H X (fun x => Y) f g).
Defined.

(** Can we go backwards, getting to strong functional extensionality
   from naive functional extensionality?  At first the prospects don't
   look good; naive functional extensionality gives us a map going
   backwards, but it doesn't assert anything *about* that map, so it
   seems unlikely that it would be an inverse to [happly].

   However, it turns out that we can go backwards; the key is to first
   forget down to an even weaker axiom, called "weak functional
   extensionality".  This has only one version, which states that the
   dependent product of a family of (continuously) contractible types
   is contractible.  *)

Definition weak_funext_statement := forall (X : Type) (P : X -> Type),
  (forall x : X, is_contr (P x)) -> is_contr (forall x : X, P x).

(** It is easy to see that naive dependent functional extensionality
   implies weak functional extensionality. *)

Theorem funext_dep_to_weak :
  funext_dep_statement -> weak_funext_statement.
Proof.
  intros H X P H1.
  exists (fun x => projT1 (H1 x)).
  intro f.
  assert (p : forall (x:X) (y:P x), y == ((fun x => projT1 (H1 x)) x)).
  intros. apply contr_path, H1.
  apply H. intro x. apply p.
Defined.

(** Another (very) weak type of functional extensionality is the
   (propositional) eta rule, which is implied by naive functional
   extensionality. *)

Definition eta {A B} (f : A -> B) :=
  fun x => f x.

Definition eta_statement :=
  forall (A B:Type) (f : A -> B), eta f == f.

Theorem naive_funext_implies_eta : funext_statement -> eta_statement.
Proof.
  intros funext A B f.
  apply funext.
  intro x.
  auto.
Defined.

(** Here is the dependent version. *)

Definition eta_dep {A} {P : A -> Type} (f : forall x, P x) :=
  fun x => f x.

Definition eta_dep_statement :=
  forall (A:Type) (P : A -> Type) (f : forall x, P x), eta_dep f == f.

Theorem naive_funext_dep_implies_eta : funext_dep_statement -> eta_dep_statement.
Proof.
  intros funext_dep A P f.
  apply funext_dep.
  intro x.
  auto.
Defined.

(** A "mini" form of the desired implication (naive => strong) is that
   the eta rule does implies directly that the eta map is an
   equivalence. *)

Lemma eta_is_equiv : eta_statement -> forall (A B : Type),
  is_equiv (@eta A B).
Proof.
  intros H A B.
  apply equiv_pointwise_idmap.
  intro f.
  apply H.
Defined.

Definition eta_equiv (Heta : eta_statement) (A B : Type) :
  (A -> B) <~> (A -> B) :=
  existT is_equiv (@eta A B) (eta_is_equiv Heta A B).

(** And the dependent version. *)

Lemma eta_dep_is_equiv : eta_dep_statement -> forall (A:Type) (P : A -> Type),
   is_equiv (@eta_dep A P).
Proof.
  intros H A P.
  apply equiv_pointwise_idmap.
  intro f.
  apply H.
Defined.

Definition eta_dep_equiv (Heta : eta_dep_statement) (A : Type) (P : A -> Type) :
  (forall x, P x) <~> (forall x, P x) :=
  existT is_equiv (@eta_dep A P) (eta_dep_is_equiv Heta A P).

(** Less trivial is the fact that weak functional extensionality
   implies *strong* (dependent) functional extensionality, at least in
   the presence of the dependent eta rule. *)

Theorem weak_to_strong_funext_dep :
  eta_dep_statement -> weak_funext_statement -> strong_funext_dep_statement.
Proof.
  intros Heta H X P f g.
  (* The idea is that [happly_dep] is one fiber map in a map of
     fibrations, whose total spaces are contractible and hence
     equivalent.  *)
  set (A := forall x, P x).
  set (Q := (fun h => f == h) : A -> Type).
  set (R := (fun h => forall x, f x == h x) : A -> Type).
  set (fibhap := (@happly_dep X P f) : forall h, Q h -> R h).
  apply (fiber_is_equiv _ _ fibhap).
  apply contr_contr_equiv.
  (* Contractibility of this space is easy. *)
  apply pathspace_contr'.
  (* This one is trickier; we show it is contractible by showing it
     equivalent to the total space of a different fibration. *)
  set (altAR := forall x, { y : P x & f x == y }).
  (* which is easily shown to be contractible. *)
  assert (contr_alt: is_contr altAR).
  apply H.
  intro x.
  apply pathspace_contr'.
  apply contr_equiv_contr with (A := altAR).
  (* The map between these spaces is obvious. *)
  set (k := (fun d => existT R (fun x => pr1 (d x)) (fun x => pr2 (d x)))
    : altAR -> sigT R).
  exists k.
  eapply hequiv_is_equiv.
  (* as is its inverse. *)
  instantiate (1 := fun e => (fun x => (pr1 e x ; pr2 e x))).
  unfold k. intro y.
  simpl.
  (* Now we have to be a bit clever.  The LHS here is the image of [z]
     under the following endofunction. *)
  set (W := fun z:sigT R => existT R (fun x:X => pr1 z x) (fun x:X => pr2 z x)).
  path_via (W y).
  (* So if we can show that [W] is homotopic to the identity, we'll be
     done.  We do this by showing that it is (1) idempotent and (2) an
     equivalence. *)
  assert (W_idempotent : forall z, W (W z) == W z); auto.
  assert (W_equiv : is_equiv W).
  (* We show that [W] is an equivalence by showing it is homotopic to
     the following slightly different map. *)
  set (W' := fun z:sigT R => let (h,q) := z in existT R (fun x => h x) q).
  apply @equiv_homotopic with (g := W').
  intro z. destruct z.
  unfold W, W'.
  apply @total_path with (p := idpath (fun x0 => x x0)).
  simpl.
  apply Heta.
  (* But [W'] is an equivalence because it is the pullback of the
     equivalence [eta_dep] along a fibration. *)
  change (is_equiv (pullback_total_equiv R (eta_dep_equiv Heta X P))).
  apply pullback_total_is_equiv.
  (* Now any idempotent equivalence is homotopic to the identity. *)
  set (We := (W ; W_equiv) : (sigT R <~> sigT R)).
  path_via (We^-1 (W (W y))).
  apply opposite, inverse_is_retraction.
  path_via' (We^-1 (W y)).
  apply map. apply W_idempotent.
  apply inverse_is_retraction.
  (* This looks like it would be difficult, except that it is a path
     in a contractible space! *)
  intro x.
  apply contr_path.
  assumption. assumption.
Defined.

(** Of course, naive dependent functional extensionality implies the
   eta rule. *)

Theorem funext_dep_to_eta_dep : funext_dep_statement -> eta_dep_statement.
Proof.
  intros H A P f.
  apply H.
  intro x.
  unfold eta_dep.
  auto.
Defined.

(** Therefore, strong dependent functional extensionality is
   equivalent to (weak functional extensionality + dependent eta). *)


(** * Specification of what it means for a simple_parse_of to be correct *)
Require Import Coq.Lists.List.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.

(** We currently have two versions, one defined by [Fixpoint], and another as an inductive.  I suspect the fixpoint will be easier to reason with, but I leave both in for now in case this is not the case. *)

Section correctness.
  Context {Char} {HSLM} {HSL : @StringLike Char HSLM}.
  Context (G : grammar Char).

  (** First we write the inductive; it's simpler; we just copy [parse_of] *)
  Inductive simple_parse_of_correct_inductive (str : String) : productions Char -> simple_parse_of  Char -> Type :=
  | SimpleParseHeadCorrect : forall pat pats t, simple_parse_of_production_correct_inductive str pat t
                                              -> simple_parse_of_correct_inductive str (pat::pats) (SimpleParseHead t)
  | SimpleParseTailCorrect : forall pat pats t, simple_parse_of_correct_inductive str pats t
                                              -> simple_parse_of_correct_inductive str (pat::pats) (SimpleParseTail t)
  with simple_parse_of_production_correct_inductive (str : String) : production Char -> simple_parse_of_production Char -> Type :=
       | SimpleParseProductionNilCorrect : length str = 0 -> simple_parse_of_production_correct_inductive str nil SimpleParseProductionNil
       | SimpleParseProductionConsCorrect : forall n pat pats t t',
           simple_parse_of_item_correct_inductive (take n str) pat t
           -> simple_parse_of_production_correct_inductive (drop n str) pats t'
           -> simple_parse_of_production_correct_inductive str (pat::pats) (SimpleParseProductionCons t t')
  with simple_parse_of_item_correct_inductive (str : String) : item Char -> simple_parse_of_item Char -> Type :=
       | SimpleParseTerminalCorrect : forall ch P, is_true (P ch) -> is_true (str ~= [ ch ])%string_like -> simple_parse_of_item_correct_inductive str (Terminal P) (SimpleParseTerminal ch)
       | SimpleParseNonTerminalCorrect : forall nt t,
           List.In nt (Valid_nonterminals G)
           -> simple_parse_of_correct_inductive str (Lookup G nt) t
           -> simple_parse_of_item_correct_inductive str (NonTerminal nt) (SimpleParseNonTerminal nt t).

  Section bodies.
    Context (simple_parse_of_correct
             : forall (str : String) (pats : productions Char) (t : @simple_parse_of Char),
                Prop)
            (simple_parse_of_production_correct
             : forall (str : String) (pat : production Char) (t : @simple_parse_of_production Char),
                Prop)
            (simple_parse_of_item_correct
             : forall (str : String) (it : item Char) (t : @simple_parse_of_item Char),
                Prop).
    Definition simple_parse_of_correct_step
               (str : String) (pats : productions Char)
               (t : simple_parse_of) : Prop :=
      match t with
      | SimpleParseHead t'
        => match pats with
           | nil => False
           | pat'::pats' => simple_parse_of_production_correct str pat' t'
           end
      | SimpleParseTail t'
        => match pats with
           | nil => False
           | pat'::pats' => simple_parse_of_correct str pats' t'
           end
      end.
    Definition simple_parse_of_production_correct_step
               (str : String) (pat : production Char)
               (t : simple_parse_of_production) : Prop :=
      match t with
      | SimpleParseProductionNil
        => length str = 0 /\ pat = nil
      | SimpleParseProductionCons t' ts'
        => match pat with
           | nil => False
           | it::its
             => exists n, simple_parse_of_item_correct (take n str) it t'
                          /\ simple_parse_of_production_correct (drop n str) its ts'
           end
      end.
    Definition simple_parse_of_item_correct_step
               (str : String) (it : item Char)
               (t : simple_parse_of_item) : Prop :=
      match t with
      | SimpleParseTerminal ch
        => match it with
           | Terminal P => is_true (P ch && (str ~= [ ch ])%string_like)%bool
           | NonTerminal _ => False
           end
      | SimpleParseNonTerminal nt x
        => match it with
           | Terminal _ => False
           | NonTerminal nt' => nt = nt'
                                /\ List.In nt (Valid_nonterminals G)
                                /\ simple_parse_of_correct str (Lookup G nt) x
           end
      end.
  End bodies.

  Fixpoint simple_parse_of_correct str pats t
    := @simple_parse_of_correct_step
         simple_parse_of_correct simple_parse_of_production_correct
         str pats t
  with simple_parse_of_production_correct str pat t
       := @simple_parse_of_production_correct_step
            simple_parse_of_production_correct simple_parse_of_item_correct
            str pat t
  with simple_parse_of_item_correct str it t
       := @simple_parse_of_item_correct_step
            simple_parse_of_correct
            str it t.
End correctness.

Arguments simple_parse_of_correct_step _ _ _ _ _ _ !_ / .
Arguments simple_parse_of_production_correct_step _ _ _ _ _ _ _ !_ / .
Arguments simple_parse_of_item_correct_step _ _ _ _ _ _ _ !_ / .

Ltac unfold_simple_parse_of_correct_constr term
  := lazymatch term with
    | @simple_parse_of_correct ?Char ?HSLM ?HSL ?G ?str ?x ?y
      => constr:(@simple_parse_of_correct_step
                   Char HSLM
                   (@simple_parse_of_correct Char HSLM HSL G)
                   (@simple_parse_of_production_correct Char HSLM HSL G)
                   str x y)
    | @simple_parse_of_production_correct ?Char ?HSLM ?HSL ?G ?str ?x ?y
      => constr:(@simple_parse_of_production_correct_step
                   Char HSLM HSL
                   (@simple_parse_of_production_correct Char HSLM HSL G)
                   (@simple_parse_of_item_correct Char HSLM HSL G)
                   str x y)
    | @simple_parse_of_item_correct ?Char ?HSLM ?HSL ?G ?str ?x ?y
      => constr:(@simple_parse_of_item_correct_step
                   Char HSLM HSL G
                   (@simple_parse_of_correct Char HSLM HSL G)
                   str x y)
    end.
Ltac simpl_simple_parse_of_correct :=
  repeat match goal with
         | [ |- context[@simple_parse_of_correct ?Char ?HSLM ?HSL ?G ?str ?x ?y] ]
           => let term := constr:(@simple_parse_of_correct Char HSLM HSL G str x y) in
              let term' := unfold_simple_parse_of_correct_constr term in
              change term with term'; simpl @simple_parse_of_correct_step
         | [ |- context[@simple_parse_of_production_correct ?Char ?HSLM ?HSL ?G ?str ?x ?y] ]
           => let term := constr:(@simple_parse_of_production_correct Char HSLM HSL G str x y) in
              let term' := unfold_simple_parse_of_correct_constr term in
              change term with term'; simpl @simple_parse_of_production_correct_step
         | [ |- context[@simple_parse_of_item_correct ?Char ?HSLM ?HSL ?G ?str ?x ?y] ]
           => let term := constr:(@simple_parse_of_item_correct Char HSLM HSL G str x y) in
              let term' := unfold_simple_parse_of_correct_constr term in
              change term with term'; simpl @simple_parse_of_item_correct_step
         | [ H : context[@simple_parse_of_correct ?Char ?HSLM ?HSL ?G ?str ?x ?y] |- _ ]
           => let term := constr:(@simple_parse_of_correct Char HSLM HSL G str x y) in
              let term' := unfold_simple_parse_of_correct_constr term in
              change term with term' in H; simpl @simple_parse_of_correct_step in H
         | [ H : context[@simple_parse_of_production_correct ?Char ?HSLM ?HSL ?G ?str ?x ?y] |- _ ]
           => let term := constr:(@simple_parse_of_production_correct Char HSLM HSL G str x y) in
              let term' := unfold_simple_parse_of_correct_constr term in
              change term with term' in H; simpl @simple_parse_of_production_correct_step in H
         | [ H : context[@simple_parse_of_item_correct ?Char ?HSLM ?HSL ?G ?str ?x ?y] |- _ ]
           => let term := constr:(@simple_parse_of_item_correct Char HSLM HSL G str x y) in
              let term' := unfold_simple_parse_of_correct_constr term in
              change term with term' in H; simpl @simple_parse_of_item_correct_step in H
         end.


Require Export Reals.
Require Import EnsemblesImplicit.
Require Import ImageImplicit.

Definition sup := completeness.

Open Scope R_scope.

Definition is_lower_bound (E:R->Prop) (m:R) :=
  forall x:R, E x -> x >= m.
Definition lower_bound (E:R->Prop) :=
  exists m:R, is_lower_bound E m.
Definition is_glb (E:R->Prop) (m:R) :=
  is_lower_bound E m /\ (forall b:R, is_lower_bound E b -> b <= m).

Definition inf: forall E:R->Prop, lower_bound E -> (exists x:R, E x) ->
  { m:R | is_glb E m }.
refine (fun E Hlb Hinh =>
  let H:=_ in let H0:=_ in
  exist _ (- (proj1_sig (sup (Im E Ropp) H H0))) _).
destruct Hlb as [m].
exists (-m).
red; intros.
destruct H0.
rewrite H1.
auto with real.

destruct Hinh as [x].
exists (-x).
exists x; trivial.

destruct sup as [m].
simpl.
split.
red; intros.
cut (-x <= m).
intros.
replace x with (--x) by ring.
auto with real.
apply i.
exists x; trivial.

intros.
cut (m <= -b).
intros.
replace b with (--b) by ring.
auto with real.
apply i.
red; intros.
cut (-x >= b).
intros.
replace x with (--x) by ring.
auto with real.
apply H1.
destruct H2.
rewrite H3.
replace (--x) with x by ring; trivial.
Qed.

Lemma lub_approx: forall (S:Ensemble R) (m:R) (eps:R),
  is_lub S m -> eps > 0 -> exists x:R, In S x /\
    m - eps < x <= m.
Proof.
intros.
assert (exists x:R, In S x /\ m - eps < x).
apply NNPP; intro.
pose proof (not_ex_all_not _ _ H1); clear H1.
simpl in H2.
assert (is_upper_bound S (m-eps)).
red; intros.
assert (~ x > m - eps).
red; intro.
contradiction (H2 x).
split; trivial.
destruct (total_order_T x (m-eps)) as [[?|?]|?]; auto with *.
contradiction H3; trivial.
destruct H.
pose proof (H3 _ H1).
apply Rle_minus in H4.
ring_simplify in H4.
assert (0 < 0).
apply Rlt_le_trans with eps; trivial.
revert H5; apply Rlt_irrefl.

destruct H1 as [x [? ?]].
exists x; repeat split; trivial.
destruct H.
apply H; trivial.
Qed.

Lemma glb_approx: forall (S:Ensemble R) (m:R) (eps:R),
  is_glb S m -> eps > 0 -> exists x:R, In S x /\ m <= x < m + eps.
Proof.
intros.
assert (exists x:R, In S x /\ x < m + eps).
apply NNPP; intro.
pose proof (not_ex_all_not _ _ H1); clear H1.
simpl in H2.
assert (is_lower_bound S (m+eps)).
red; intros.
assert (~ x < m + eps).
red; intro.
contradiction (H2 x).
split; trivial.
destruct (total_order_T x (m+eps)) as [[?|?]|?]; auto with *.
contradiction H3; trivial.
destruct H.
pose proof (H3 _ H1).
apply Rle_minus in H4.
ring_simplify in H4.
assert (0 < 0).
apply Rlt_le_trans with eps; trivial.
revert H5; apply Rlt_irrefl.

destruct H1 as [x [? ?]].
exists x; repeat split; trivial.
destruct H.
assert (x >= m).
apply H; trivial.
auto with *.
Qed.

Lemma lt_plus_epsilon_le: forall x y:R,
  (forall eps:R, eps > 0 -> x < y + eps) -> x <= y.
Proof.
intros.
destruct (total_order_T x y) as [[?|?]|?]; auto with *.
assert (x < y + (x - y)).
apply H.
apply Rgt_minus; trivial.
ring_simplify in H0.
contradict H0.
apply Rlt_irrefl.
Qed.

Lemma gt_minus_epsilon_ge: forall x y:R,
  (forall eps:R, eps > 0 -> x > y - eps) -> x >= y.
Proof.
intros.
destruct (total_order_T x y) as [[?|?]|?]; auto with *.
assert (x > y - (y - x)).
apply H.
apply Rgt_minus; trivial.
ring_simplify in H0.
contradict H0.
apply Rlt_irrefl.
Qed.


Require Import JRWTactics.

Require Import Relations.
Require Import Operators_Properties.

Require Import EQ ANY MAP.
Require Import EqMapFacts.
Require Import Alist.

Declare Module Name : EQ.
Declare Module TypeName : EQ.

Definition name := Name.t.
Definition name_eq_dec := Name.t_eq_dec.

Definition type_name := TypeName.t.
Definition type_name_eq_dec := TypeName.t_eq_dec.

Inductive type : Type :=
| TyVar : type_name -> type
| TyBool : type
| TyArrow : type -> type -> type
| TyForall : type_name -> type -> type.
(*  | TyExists : name -> type -> type. *)

Inductive term : Type :=
| TConst : bool -> term
| TVar : name -> term
| TIf : term -> term -> term -> term
| TAbs : name -> type -> term -> term
| TApp : term -> term -> term
| TTyAbs : type_name -> term -> term
| TTyApp : term -> type -> term.

Module UnitAny.
  Definition t := unit.
End UnitAny.

Module KindingContext := alist TypeName UnitAny.

Definition kinding_context := KindingContext.t.

Module TypeAny.
  Definition t := type.
End TypeAny.

Module TypingContext := alist Name TypeAny.

Definition typing_context := TypingContext.t.

Inductive well_kinded : kinding_context -> type -> Prop :=
| WK_var : forall Delta alpha u,
    KindingContext.get alpha Delta = Some u ->
    well_kinded Delta (TyVar alpha)
| WK_bool : forall Delta, well_kinded Delta TyBool
| WK_arrow : forall Delta tau1 tau2,
    well_kinded Delta tau1 ->
    well_kinded Delta tau2 ->
    well_kinded Delta (TyArrow tau1 tau2)
| WK_forall : forall Delta alpha tau,
    well_kinded (KindingContext.shadow alpha tt Delta) tau ->
    well_kinded Delta (TyForall alpha tau).

Inductive has_type : kinding_context -> typing_context -> term -> type -> Prop :=
| HTConst : forall Delta Gamma b, has_type Delta Gamma (TConst b) TyBool
| HTVar : forall Delta Gamma x tau,
    TypingContext.get x Gamma = Some tau ->
    has_type Delta Gamma (TVar x) tau
| HTIf : forall Delta Gamma e1 e2 e3 tau,
    has_type Delta Gamma e1 TyBool ->
    has_type Delta Gamma e2 tau ->
    has_type Delta Gamma e3 tau ->
    has_type Delta Gamma (TIf e1 e2 e3) tau
| HTAbs : forall Delta Gamma x tyx e tau,
    well_kinded Delta tyx ->
    has_type Delta (TypingContext.shadow x tyx Gamma) e tau ->
    has_type Delta Gamma (TAbs x tyx e) (TyArrow tyx tau)
| HTApp : forall Delta Gamma e1 e2 ty2 tau,
    has_type Delta Gamma e1 (TyArrow ty2 tau) ->
    has_type Delta Gamma e2 ty2 ->
    has_type Delta Gamma (TApp e1 e2) tau
| HTTTyAbs : forall Delta Gamma alpha e tau,
    has_type (KindingContext.shadow alpha tt Delta) Gamma e tau ->
    has_type Delta Gamma e (TyForall alpha tau)
 .
(*
| HTTyApp : forall Delta Gamma e1 tau1 tau2,
    has_type Delta Gamma e1 (TyForall alpha tau1) ->
    well_kinded Delta tau2 ->
    has_type Delta Gamma (TTyApp e1 tau2) (ty_subs alpha tau2

Fixpoint subs (from : name) (to : term) (e : term) : term :=
  match e with
  | TConst _ => e
  | TVar y => if name_eq_dec from y then to else e
  | TIf e1 e2 e3 => TIf (subs from to e1)
                       (subs from to e2)
                       (subs from to e3)
  | TAbs y tau e' => if name_eq_dec from y then e else TAbs y tau (subs from to e')
  | TApp e1 e2 => TApp (subs from to e1) (subs from to e2)
  end.

Definition is_value (e : term) : Prop :=
  match e with
  | TConst _ => True
  | TAbs _ _ _ => True
  | _ => False
  end.

Inductive step : term -> term -> Prop :=
| step_if_true :
    forall e2 e3,
      step (TIf (TConst true) e2 e3) e2
| step_if_false :
    forall e2 e3,
      step (TIf (TConst false) e2 e3) e3
| step_if_step :
    forall e1 e1' e2 e3,
      step e1 e1' ->
      step (TIf e1 e2 e3) (TIf e1' e2 e3)
| step_beta :
    forall x tau e1 e2,
      is_value e2 ->
      step (TApp (TAbs x tau e1) e2) (subs x e2 e1)
| step_app1 :
    forall e1 e1' e2,
      step e1 e1' ->
      step (TApp e1 e2) (TApp e1' e2)
| step_app2 :
    forall e1 e2 e2',
      is_value e1 ->
      step e2 e2' ->
      step (TApp e1 e2) (TApp e1 e2').

Definition step_star := clos_refl_trans_n1 term step.
Definition irreducible (e : term) : Prop := forall e', step e e' -> False.
Definition terminates (e : term) : Prop := exists v, irreducible v /\ step_star e v.

*)


Require Import Arith.

Definition t := nat.
Definition eq_dec := eq_nat_dec.


Require Import rt.util.all.
Require Import rt.model.arrival.basic.task rt.model.arrival.basic.job rt.model.arrival.basic.task_arrival rt.model.priority.
Require Import rt.model.schedule.global.workload rt.model.schedule.global.schedulability
               rt.model.schedule.global.response_time.
Require Import rt.model.schedule.global.basic.schedule rt.model.schedule.global.basic.interference
               rt.model.schedule.global.basic.platform.
Require Import rt.analysis.global.parallel.workload_bound
               rt.analysis.global.parallel.interference_bound_edf.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop div path.

Module ResponseTimeAnalysisEDF.

  Export Job SporadicTaskset Schedule ScheduleOfSporadicTask Workload Schedulability ResponseTime
         Priority TaskArrival WorkloadBound InterferenceBoundEDF
         Interference Platform.

  (* In this section, we prove that any fixed point in Bertogna and
     Cirinei's RTA for EDF scheduling modified to consider (potentially)
     parallel jobs yields a safe response-time bound. This is an extension
     of the analysis found in Chapter 17.1.2 of Baruah et al.'s book
     Multiprocessor Scheduling for Real-time Systems. *)
  Section ResponseTimeBound.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_deadline: Job -> time.
    Variable job_task: Job -> sporadic_task.

    (* Assume any job arrival sequence... *)
    Variable arr_seq: arrival_sequence Job.

    (* ... in which jobs arrive sporadically and have valid parameters. *)
    Hypothesis H_sporadic_tasks:
      sporadic_task_model task_period job_arrival job_task arr_seq.
    Hypothesis H_valid_job_parameters:
      forall j,
        arrives_in arr_seq j ->
        valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.

    (* Assume that we have a task set where all tasks have valid
       parameters and constrained deadlines, ... *)
    Variable ts: taskset_of sporadic_task.
    Hypothesis H_valid_task_parameters:
      valid_sporadic_taskset task_cost task_period task_deadline ts.
    Hypothesis H_constrained_deadlines:
      forall tsk, tsk \in ts -> task_deadline tsk <= task_period tsk.

    (* ... and that all jobs in the arrival sequence come from the task set. *)
    Hypothesis H_all_jobs_from_taskset:
      forall j, arrives_in arr_seq j -> job_task j \in ts.

    (* Next, consider any schedule such that...*)
    Variable num_cpus: nat.
    Variable sched: schedule Job num_cpus.
    Hypothesis H_jobs_come_from_arrival_sequence:
      jobs_come_from_arrival_sequence sched arr_seq.

    (* ...jobs do not execute before their arrival times nor longer
       than their execution costs. *)
    Hypothesis H_jobs_must_arrive_to_execute:
      jobs_must_arrive_to_execute job_arrival sched.
    Hypothesis H_completed_jobs_dont_execute:
      completed_jobs_dont_execute job_cost sched.

    (* Assume that there exists at least one processor. *)
    Hypothesis H_at_least_one_cpu: num_cpus > 0.

    (* Assume that the schedule is a work-conserving EDF schedule. *)
    Hypothesis H_work_conserving: work_conserving job_arrival job_cost arr_seq sched.
    Hypothesis H_edf_policy: respects_JLFP_policy job_arrival job_cost arr_seq sched
                                                  (EDF job_arrival job_deadline).

    (* Let's define some local names to avoid passing many parameters. *)
    Let no_deadline_is_missed_by_tsk (tsk: sporadic_task) :=
      task_misses_no_deadline job_arrival job_cost job_deadline job_task arr_seq sched tsk.
    Let response_time_bounded_by (tsk: sporadic_task) :=
      is_response_time_bound_of_task job_arrival job_cost job_task arr_seq sched tsk.

    (* Next we consider the response-time recurrence.
       Assume that a response-time bound R is known...  *)
    Let task_with_response_time := (sporadic_task * time)%type.
    Variable rt_bounds: seq task_with_response_time.

    (* ...for any task in the task set, ... *)
    Hypothesis H_rt_bounds_contains_all_tasks: unzip1 rt_bounds = ts.

    (* ...where R is a fixed-point of the response-time recurrence, ... *)
    Let I (tsk: sporadic_task) (delta: time) :=
      total_interference_bound_edf task_cost task_period task_deadline tsk rt_bounds delta.
    Hypothesis H_response_time_is_fixed_point :
      forall tsk R,
        (tsk, R) \in rt_bounds ->
        R = task_cost tsk + div_floor (I tsk R) num_cpus.

    (* ..., and R is no larger than the deadline. *)
    Hypothesis H_tasks_miss_no_deadlines:
      forall tsk_other R,
        (tsk_other, R) \in rt_bounds -> R <= task_deadline tsk_other.

    (* In order to prove that R is a response-time bound, we first provide some lemmas. *)
    Section Lemmas.

      (* Let (tsk, R) be any task to be analyzed, with its response-time bound R. *)
      Variable tsk: sporadic_task.
      Variable R: time.
      Hypothesis H_tsk_R_in_rt_bounds: (tsk, R) \in rt_bounds.

      (* Consider any job j of tsk. *)
      Variable j: Job.
      Hypothesis H_j_arrives: arrives_in arr_seq j.
      Hypothesis H_job_of_tsk: job_task j = tsk.

      (* Assume that job j did not complete on time, ... *)
      Hypothesis H_j_not_completed: ~~ completed job_cost sched j (job_arrival j + R).

      (* ...and that it is the first job not to satisfy its response-time bound. *)
      Hypothesis H_all_previous_jobs_completed_on_time :
        forall j_other tsk_other R_other,
          arrives_in arr_seq j_other ->
          job_task j_other = tsk_other ->
          (tsk_other, R_other) \in rt_bounds ->
          job_arrival j_other + R_other < job_arrival j + R ->
          completed job_cost sched j_other (job_arrival j_other + R_other).

      (* Let's call x the interference incurred by job j due to tsk_other, ...*)
      Let x (tsk_other: sporadic_task) :=
        task_interference job_arrival job_cost job_task sched j
                          tsk_other (job_arrival j) (job_arrival j + R).

      (* ...and X the total interference incurred by job j due to any task. *)
      Let X := total_interference job_arrival job_cost sched j (job_arrival j) (job_arrival j + R).

      (* Recall Bertogna and Cirinei's workload bound ... *)
      Let workload_bound (tsk_other: sporadic_task) (R_other: time) :=
        W task_cost task_period tsk_other R_other R.

      (*... and the EDF-specific bound, ... *)
      Let edf_specific_bound (tsk_other: sporadic_task) (R_other: time) :=
        edf_specific_interference_bound task_cost task_period task_deadline tsk tsk_other R_other.

      (* ... which combined form the interference bound. *)
      Let interference_bound (tsk_other: sporadic_task) (R_other: time) :=
        interference_bound_edf task_cost task_period task_deadline tsk R (tsk_other, R_other).

      (* Based on the definition of a different task, ... *)
      Let other_task := different_task tsk.

      (* ...let other_tasks denote the set of tasks that are different from tsk. *)
      Let other_tasks :=
        [seq tsk_other <- ts | other_task tsk_other].

      (* Now we establish results the interfering tasks. *)
      Section LemmasAboutInterferingTasks.

        (* Let (tsk_other, R_other) be any pair of higher-priority task and
           response-time bound computed in previous iterations. *)
        Variable tsk_other: sporadic_task.
        Variable R_other: time.
        Hypothesis H_response_time_of_tsk_other: (tsk_other, R_other) \in rt_bounds.

        (* Note that tsk_other is in task set ts ...*)
        Lemma bertogna_edf_tsk_other_in_ts: tsk_other \in ts.
        Proof.
          by rewrite set_mem -H_rt_bounds_contains_all_tasks; apply/mapP; exists (tsk_other, R_other).
        Qed.

        (* Also, R_other is larger than the cost of tsk_other. *)
        Lemma bertogna_edf_R_other_ge_cost :
          R_other >= task_cost tsk_other.
        Proof.
          by rewrite [R_other](H_response_time_is_fixed_point tsk_other);
            first by apply leq_addr.
        Qed.

        (* Since tsk_other cannot interfere more than it executes, we show that
           the interference caused by tsk_other is no larger than workload bound W. *)
        Lemma bertogna_edf_workload_bounds_interference :
          x tsk_other <= workload_bound tsk_other R_other.
        Proof.
          unfold valid_sporadic_job in *.
          rename H_all_previous_jobs_completed_on_time into BEFOREok,
                 H_valid_job_parameters into PARAMS,
                 H_valid_task_parameters into TASK_PARAMS,
                 H_constrained_deadlines into RESTR,
                 H_tasks_miss_no_deadlines into NOMISS.
          unfold x, task_interference.
          have INts := bertogna_edf_tsk_other_in_ts.
          apply leq_trans with (n := workload job_task sched tsk_other
                                         (job_arrival j) (job_arrival j + R));
            first apply task_interference_le_workload.
          have BOUND := workload_bounded_by_W task_cost task_period task_deadline
            job_arrival job_cost job_task job_deadline arr_seq _ sched.
          apply BOUND; try (by done); last 2 first.
            - by ins; apply TASK_PARAMS.
            - by ins; apply BEFOREok with (tsk_other := tsk_other).
        Qed.

        (* Recall that the edf-specific interference bound also holds. *)
        Lemma bertogna_edf_specific_bound_holds :
          x tsk_other <= edf_specific_bound tsk_other R_other.
        Proof.
          rename H_job_of_tsk into JOBtsk, H_all_jobs_from_taskset into FROMTS.
          apply interference_bound_edf_bounds_interference with (job_deadline0 := job_deadline)
                                               (arr_seq0 := arr_seq) (ts0 := ts); try (by done);
          [ by rewrite -JOBtsk FROMTS
          | by apply bertogna_edf_tsk_other_in_ts
          | by apply H_tasks_miss_no_deadlines
          | by ins; apply H_all_previous_jobs_completed_on_time with (tsk_other := tsk_other)].
        Qed.

      End LemmasAboutInterferingTasks.

      (* Next we prove some lemmas that help to derive a contradiction.*)
      Section DerivingContradiction.

      (* 0) Since job j did not complete by its response time bound, it follows that
            the total interference X >= R - e_k + 1. *)
      Lemma bertogna_edf_too_much_interference : X >= R - task_cost tsk + 1.
      Proof.
        rename H_completed_jobs_dont_execute into COMP,
               H_valid_job_parameters into PARAMS,
               H_response_time_is_fixed_point into REC,
               H_job_of_tsk into JOBtsk,
               H_j_not_completed into NOTCOMP.
        unfold completed, valid_sporadic_job in *.
        unfold X, total_interference; rewrite addn1.
        rewrite -(ltn_add2r (task_cost tsk)).
        rewrite subh1; last by rewrite [R](REC tsk) // leq_addr.
        rewrite -addnBA // subnn addn0.
        move: (NOTCOMP) => /negP NOTCOMP'.
        rewrite neq_ltn in NOTCOMP.
        move: NOTCOMP => /orP [LT | BUG]; last first.
        {
          exfalso; rewrite ltnNge in BUG; move: BUG => /negP BUG; apply BUG.
          by apply cumulative_service_le_job_cost.
        }
        apply leq_ltn_trans with (n := (\sum_(job_arrival j <= t < job_arrival j + R)
                                     backlogged job_arrival job_cost sched j t) +
                                   service sched j (job_arrival j + R)); last first.
        {
          rewrite -addn1 -addnA leq_add2l addn1.
          apply leq_trans with (n := job_cost j); first by done.
          by specialize (PARAMS j H_j_arrives); des; rewrite -JOBtsk.
        }
        unfold service; rewrite service_before_arrival_eq_service_during //.
        rewrite -big_split /=.
        apply leq_trans with (n := \sum_(job_arrival j <= i < job_arrival j + R) 1);
          first by rewrite big_const_nat iter_addn mul1n addn0 addKn.
        rewrite big_nat_cond [\sum_(_ <= _ < _ | true) _]big_nat_cond.
        apply leq_sum; move => i /andP [/andP [GEi LTi] _].
        destruct (backlogged job_arrival job_cost sched j i) eqn:BACK;
          first by rewrite -addn1 addnC; apply leq_add.
        apply negbT in BACK.
        rewrite add0n lt0n -not_scheduled_no_service negbK.
        rewrite /backlogged negb_and negbK in BACK.
        move: BACK => /orP [/negP NOTPENDING | SCHED]; last by done.
        exfalso; apply NOTPENDING; unfold pending; apply/andP; split; first by done.
        apply/negP; red; intro BUG; apply NOTCOMP'.
        by apply completion_monotonic with (t := i); try (by done); apply ltnW.
      Qed.

      (* 1) Next, we prove that the sum of the interference of each task is equal
            to the total interference multiplied by the number of processors. This
            holds because interference only occurs when all processors are busy.
            With this lemma we can relate per-task interference with the total
            interference incurred by j (backlogged time). *)
      Lemma bertogna_edf_interference_on_all_cpus :
        \sum_(tsk_k <- other_tasks) x tsk_k = X * num_cpus.
      Proof.
        rename H_all_jobs_from_taskset into FROMTS,
               H_valid_task_parameters into PARAMS,
               H_job_of_tsk into JOBtsk, H_jobs_come_from_arrival_sequence into FROMSEQ,
               H_sporadic_tasks into SPO, H_work_conserving into WORK,
               H_tsk_R_in_rt_bounds into INbounds,
               H_all_previous_jobs_completed_on_time into BEFOREok,
               H_tasks_miss_no_deadlines into NOMISS,
               H_rt_bounds_contains_all_tasks into UNZIP,
               H_constrained_deadlines into RESTR.
        unfold sporadic_task_model in *.
        unfold x, X, total_interference, task_interference.
        rewrite -big_mkcond -exchange_big big_distrl /=.
        rewrite [\sum_(_ <= _ < _ | backlogged _ _ _ _ _) _]big_mkcond.
        apply eq_big_nat; move => t /andP [GEt LTt].
        destruct (backlogged job_arrival job_cost sched j t) eqn:BACK; last first.
        {
          rewrite (eq_bigr (fun i => 0));
            first by rewrite big_const_seq iter_addn mul0n addn0.
          by intros i _; rewrite (eq_bigr (fun i => 0));
            first by rewrite big_const_seq iter_addn mul0n addn0.
        }
        rewrite big_mkcond mul1n /=.
        rewrite exchange_big /=.
        apply eq_trans with (y := \sum_(cpu < num_cpus) 1);
          last by rewrite big_const_ord iter_addn mul1n addn0.
        apply eq_bigr; intros cpu _.
        specialize (WORK j t H_j_arrives BACK cpu); des.
        move: WORK => /eqP SCHED.
        have ARRother: arrives_in arr_seq j_other.
          by apply (FROMSEQ j_other t); apply/existsP; exists cpu; apply/eqP.
        rewrite (bigD1_seq (job_task j_other)) /=; last by rewrite filter_uniq; destruct ts.
        {
          rewrite (eq_bigr (fun i => 0));
            last by intros i DIFF; rewrite /task_scheduled_on SCHED;apply/eqP;rewrite eqb0 eq_sym.
          rewrite big_const_seq iter_addn mul0n 2!addn0; apply/eqP; rewrite eqb1.
          by unfold task_scheduled_on; rewrite SCHED.
        }
        rewrite mem_filter; apply/andP; split; last by apply FROMTS.
        unfold different_task.
        apply/eqP; red; intro SAMEtsk.
        assert (SCHED': scheduled sched j_other t).
        {
          unfold scheduled, scheduled_on.
          by apply/existsP; exists cpu; rewrite SCHED.
        }
        clear SCHED; rename SCHED' into SCHED.
        move: (SCHED) => PENDING.
        apply scheduled_implies_pending with (job_cost0 := job_cost) (job_arrival0 := job_arrival)
          in PENDING; try (by done).
        destruct (ltnP (job_arrival j_other) (job_arrival j)) as [BEFOREother | BEFOREj].
         {
          move: (BEFOREother) => LT; rewrite -(ltn_add2r R) in LT.
          specialize (BEFOREok j_other tsk R ARRother SAMEtsk INbounds LT).
          move: PENDING => /andP [_ /negP NOTCOMP]; apply NOTCOMP.
          apply completion_monotonic with (t0 := job_arrival j_other + R); try (by done).
          apply leq_trans with (n := job_arrival j); last by done.
          apply leq_trans with (n := job_arrival j_other + task_deadline tsk);
            first by rewrite leq_add2l; apply NOMISS.
          apply leq_trans with (n := job_arrival j_other + task_period tsk);
            first by rewrite leq_add2l; apply RESTR; rewrite -JOBtsk FROMTS.
          rewrite -SAMEtsk; apply SPO; try (by done); [ | by rewrite JOBtsk | by apply ltnW].
          by red; intro EQ; subst; rewrite ltnn in BEFOREother.
        }
        {
          move: PENDING => /andP [ARRIVED _].
          exploit (SPO j j_other); try (by done); [ | by rewrite SAMEtsk | ]; last first.
          {
            apply/negP; rewrite -ltnNge.
            apply leq_ltn_trans with (n := t); first by done.
            apply leq_trans with (n := job_arrival j + R); first by done.
            by rewrite leq_add2l; apply leq_trans with (n := task_deadline tsk);
              [by apply NOMISS | by rewrite JOBtsk RESTR // -JOBtsk FROMTS].
          }
          by red; intros EQtsk; subst; rewrite /backlogged SCHED andbF in BACK.
        }
      Qed.

      (* 2) Next, using lemmas (0) and (1) we prove that the reduction-based
            interference bound is not enough to cover the sum of the minima over all tasks
            (artifact of the proof by contradiction). *)
      Lemma bertogna_edf_sum_exceeds_total_interference:
        \sum_((tsk_other, R_other) <- rt_bounds | other_task tsk_other)
          x tsk_other > I tsk R.
      Proof.
        have GE_COST := bertogna_edf_R_other_ge_cost.
        have ALLBUSY := bertogna_edf_interference_on_all_cpus.
        have TOOMUCH := bertogna_edf_too_much_interference.
        rename H_rt_bounds_contains_all_tasks into UNZIP,
               H_response_time_is_fixed_point into REC.
        apply leq_trans with (n := \sum_(tsk_other <- other_tasks) x tsk_other);
          last first.
        {
          rewrite (eq_bigr (fun i => x (fst i))); last by ins; destruct i.
          assert (FILTER: filter (different_task tsk) (unzip1 rt_bounds) =
                          filter (different_task tsk) ts).
            by f_equal.
          unfold other_tasks; rewrite -FILTER; clear FILTER.
          rewrite -[\sum_(_ <- rt_bounds | _)_]big_filter.
          assert (SUBST: [seq i <- rt_bounds
                           | let '(tsk_other, _) := i in other_task tsk_other] =
                         [seq i <- rt_bounds| other_task (fst i)]).
          {
            by apply eq_filter; red; intro i; destruct i.
          } rewrite SUBST; clear SUBST.
          have MAP := big_map (fun x => fst x) (fun i => true) (fun i => x i).
          by rewrite -MAP; apply eq_leq; f_equal; rewrite filter_map.
        }

        apply ltn_div_trunc with (d := num_cpus); first by apply H_at_least_one_cpu.
        rewrite -(ltn_add2l (task_cost tsk)) -REC; last by done.
        rewrite -addn1 -leq_subLR.
        rewrite -[R + 1 - _]subh1; last by apply GE_COST.
        rewrite leq_divRL; last by apply H_at_least_one_cpu.
        rewrite ALLBUSY.
        by rewrite leq_mul2r; apply/orP; right; apply TOOMUCH.
      Qed.

      (* 3) After concluding that the sum of the minima exceeds (R - e_i + 1),
            we prove that there exists a tuple (tsk_k, R_k) that satisfies
            min (x_k, R - e_i + 1) > min (W_k, I_edf, R - e_i + 1).
            This implies that either x_k > W_k or x_k > I_edf, which is a contradiction,
            since both W_k and I_edf are valid task interference bounds. *)
      Lemma bertogna_edf_exists_task_that_exceeds_bound :
        exists tsk_other R_other,
          (tsk_other, R_other) \in rt_bounds /\
          x tsk_other > interference_bound tsk_other R_other.
      Proof.
        have SUM := bertogna_edf_sum_exceeds_total_interference.
        have BOUND := bertogna_edf_workload_bounds_interference.
        have EDFBOUND := bertogna_edf_specific_bound_holds.
        rename H_rt_bounds_contains_all_tasks into UNZIP.
        assert (HAS: has (fun tup : task_with_response_time =>
                       let (tsk_other, R_other) := tup in
                         (tsk_other \in ts) && other_task tsk_other &&
                        (x tsk_other  > interference_bound tsk_other R_other))
                         rt_bounds).
        {
          apply/negP; unfold not; intro NOTHAS.
          move: NOTHAS => /negP /hasPn ALL.
          rewrite -[_ < _]negbK in SUM.
          move: SUM => /negP SUM; apply SUM; rewrite -leqNgt.
          unfold I, total_interference_bound_edf.
          rewrite big_seq_cond [\sum_(_ <- _ | let _ := _ in _)_]big_seq_cond.
          apply leq_sum; move => tsk_k /andP [INBOUNDSk INTERFk]; destruct tsk_k as [tsk_k R_k].
          specialize (ALL (tsk_k, R_k) INBOUNDSk).
          unfold interference_bound_edf; simpl in *.
          by rewrite leq_min; apply/andP; split;
            [by apply BOUND | by apply EDFBOUND].
        }
        move: HAS => /hasP HAS; destruct HAS as [[tsk_k R_k] HPk MIN].
        move: MIN => /andP [/andP [INts INTERFk] MINk].
        by exists tsk_k, R_k; repeat split.
      Qed.

      End DerivingContradiction.

    End Lemmas.

    Section MainProof.

      (* Let (tsk, R) be any task to be analyzed, with its response-time bound R. *)
      Variable tsk: sporadic_task.
      Variable R: time.
      Hypothesis H_tsk_R_in_rt_bounds: (tsk, R) \in rt_bounds.

      (* Using the lemmas above, we prove that R bounds the response time of task tsk. *)
      Theorem bertogna_cirinei_response_time_bound_edf :
        response_time_bounded_by tsk R.
      Proof.
        intros j ARRj JOBtsk.

        (* First, rewrite the claim in terms of the *absolute* response-time bound (arrival + R) *)
        remember (job_arrival j + R) as ctime.

        revert H_tsk_R_in_rt_bounds.
        generalize dependent R; generalize dependent tsk; generalize dependent j.

        (* Now, we apply strong induction on the absolute response-time bound. *)
        induction ctime as [ctime IH] using strong_ind.

        intros j ARRj tsk' JOBtsk R' EQc INbounds; subst ctime.

        (* First, let's simplify the induction hypothesis. *)
        assert (BEFOREok: forall j0 tsk R0,
                               arrives_in arr_seq j0 ->
                               job_task j0 = tsk ->
                               (tsk, R0) \in rt_bounds ->
                               job_arrival j0 + R0 < job_arrival j + R' ->
                               service sched j0 (job_arrival j0 + R0) == job_cost j0).
        {
            by ins; apply IH with (tsk := tsk0) (R := R0).
        }
        clear IH.

        (* The proof follows by contradiction. Assume that job j does not complete by its
           response-time bound. By the induction hypothesis, all jobs with absolute
           response-time bound t < (job_arrival j + R) have correct response-time bounds. *)
        destruct (completed job_cost sched j (job_arrival j + R')) eqn:NOTCOMP;
          first by done.
        apply negbT in NOTCOMP; exfalso.

        (* Next, we derive a contradiction using the previous lemmas. *)
        exploit (bertogna_edf_exists_task_that_exceeds_bound tsk' R' INbounds j ARRj JOBtsk NOTCOMP).
        {
          by ins; apply IH with (tsk := tsk_other) (R := R_other).
        }
        intro EX; destruct EX as [tsk_other [R_other [HP LTmin]]].
        unfold interference_bound_edf, interference_bound_generic in LTmin.
        have BASICBOUND := bertogna_edf_workload_bounds_interference R' j BEFOREok tsk_other R_other HP.
        have EDFBOUND := bertogna_edf_specific_bound_holds tsk' R' j ARRj JOBtsk
                                                           BEFOREok tsk_other R_other HP.
        unfold minn in LTmin; clear -LTmin HP BASICBOUND EDFBOUND tsk; desf.
        {
          by apply (leq_ltn_trans BASICBOUND) in LTmin; rewrite ltnn in LTmin.
        }
        {
          by apply (leq_ltn_trans EDFBOUND) in LTmin; rewrite ltnn in LTmin.
        }
      Qed.

    End MainProof.

  End ResponseTimeBound.

End ResponseTimeAnalysisEDF.