Require Import Grover2QubitTotal.
Require Import Grover2QubitBasic.
Require Import Nat.
Require Import DBCircuits.
Require Import TypeChecking.
Require Import Denotation.
Require Import Composition.
Require Import VectorDef.
Require Import List.
Require Import sin_asin_rules.
Require Import QuantumLib.VectorStates.
Require Import QuantumLib.Measurement.
Require Import QuantumLib.Matrix.
Require Import QuantumLib.FTA.
Require Import Rtrigo_facts.
Require Import FunctionalExtensionality.
Local Open Scope circ_scope.

Definition equal_superposition : Box One (Qubit ⊗ Qubit) :=
  box_ () ⇒
    let_ x ← _H $ init0 $ ();
    let_ y ← _H $ init0 $ ();
(x,y).

Lemma equal_sup_WT : Typed_Box (equal_superposition).
Proof. type_check. Qed.

Lemma equal_sup_correct : denote equal_superposition (I 1) = list2D_to_matrix ( [ [  (RtoC (1 / 4)) ; (RtoC (1/4)) ;(RtoC ((1/4))) ;  (RtoC (1 / 4)) ] ; [ (RtoC (1/4)) ; (RtoC (1 / 4)) ;  (RtoC (1 / 4)) ; (RtoC (1/4)) ]  ; [ (RtoC (1/4)) ; (RtoC (1 / 4)) ; (RtoC (1 / 4))  ; (RtoC (1/4)) ] ; [  (RtoC (1 / 4)) ; (RtoC (1/4)) ; (RtoC (1/4)) ;  (RtoC (1 / 4)) ] ] ).
Proof. matrix_denote. solve_matrix. Qed.

(*the below could be defined in one function with match, but it makes proofs ever so slightly more inconvenient *)
Fixpoint small_grover_iterate_0 (r:nat) : Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
  match r with
  | 0 => id_circ
  | S r' => box_ (x,y) ⇒
             (let_ (x,y) ← small_grover_iterate_0 r' $ (x,y);
             let_ (x,y) ← small_oracle_0 $ (x,y);
             let_ (x,y) ← small_diffusion $ (x,y);
             (x,y))
  end.
Lemma small_grover_iterate_0_WT : forall r, Typed_Box (small_grover_iterate_0 r).
Proof. type_check. induction r as [ | [ | r ] ]; type_check. Qed.

Fixpoint small_grover_iterate_1 (r:nat) : Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
  match r with
  | 0 => id_circ
  | S r' => box_ (x,y) ⇒
             (let_ (x,y) ← small_grover_iterate_1 r' $ (x,y);
              let_ (x,y) ← small_oracle_1 $ (x,y);
              let_ (x,y) ← small_diffusion $ (x,y);
             (x,y))
  end.

Lemma small_grover_iterate_1_WT : forall r, Typed_Box (small_grover_iterate_1 r).
Proof. type_check. induction r as [ | [ | r ] ]; type_check. Qed.

Fixpoint small_grover_iterate_2 (r:nat) : Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
  match r with
  | 0 => id_circ
  | S r' => box_ (x,y) ⇒
             (let_ (x,y) ← small_grover_iterate_2 r' $ (x,y);
              let_ (x,y) ← small_oracle_2 $ (x,y);
              let_ (x,y) ← small_diffusion $ (x,y);
              (x,y))
  end.

Lemma small_grover_iterate_2_WT : forall r, Typed_Box (small_grover_iterate_2 r).
Proof. type_check. induction r as [ | [ | r ] ]; type_check. Qed.

Fixpoint small_grover_iterate_3 (r:nat) : Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
  match r with
  | 0 => id_circ
  | S r' => box_ (x,y) ⇒
             (let_ (x,y) ← small_grover_iterate_3 r' $ (x,y);
              let_ (x,y) ← small_oracle_3 $ (x,y);
              let_ (x,y) ← small_diffusion $ (x,y);
              (x,y))
  end.

Lemma small_grover_iterate_3_WT : forall r, Typed_Box (small_grover_iterate_3 r).
Proof. type_check. induction r as [ | [ | r ] ]; type_check. Qed.

Fixpoint small_grover_iterate_0_1 (r:nat) : Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
  match r with
  | 0 => id_circ
  | S r' => box_ (x,y) ⇒
             (let_ (x,y) ← small_grover_iterate_0_1 r' $ (x,y);
              let_ (x,y) ← small_oracle_0_1 $ (x,y);
              let_ (x,y) ← small_diffusion $ (x,y);
              (x,y))
  end.

Lemma small_grover_iterate_0_1_WT : forall r, Typed_Box (small_grover_iterate_0_1 r).
Proof. type_check. induction r as [ | [ | r ] ]; type_check. Qed.

Fixpoint small_grover_iterate_0_2 (r:nat) : Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
  match r with
  | 0 => id_circ
  | S r' => box_ (x,y) ⇒
             (let_ (x,y) ← small_grover_iterate_0_2 r' $ (x,y);
              let_ (x,y) ← small_oracle_0_2 $ (x,y);
              let_ (x,y) ← small_diffusion $ (x,y);
              (x,y))
  end.

Lemma small_grover_iterate_0_2_WT : forall r, Typed_Box (small_grover_iterate_0_2 r).
Proof. type_check. induction r as [ | [ | r ] ]; type_check. Qed.

Fixpoint small_grover_iterate_0_3 (r:nat) : Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
  match r with
  | 0 => id_circ
  | S r' => box_ (x,y) ⇒
             (let_ (x,y) ← small_grover_iterate_0_3 r' $ (x,y);
              let_ (x,y) ← small_oracle_0_3 $ (x,y);
              let_ (x,y) ← small_diffusion $ (x,y);
             (x,y))
  end.

Lemma small_grover_iterate_0_3_WT : forall r, Typed_Box (small_grover_iterate_0_3 r).
Proof. type_check. induction r as [ | [ | r ] ]; type_check. Qed.

Fixpoint small_grover_iterate_1_2 (r:nat) : Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
  match r with
  | 0 => id_circ
  | S r' => box_ (x,y) ⇒
             (let_ (x,y) ← small_grover_iterate_1_2 r' $ (x,y);
              let_ (x,y) ← small_oracle_1_2 $ (x,y);
              let_ (x,y) ← small_diffusion $ (x,y);
              (x,y))
  end.

Lemma small_grover_iterate_1_2_WT : forall r, Typed_Box (small_grover_iterate_1_2 r).
Proof. type_check. induction r as [ | [ | r ] ]; type_check. Qed.

Fixpoint small_grover_iterate_1_3 (r:nat) : Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
  match r with
  | 0 => id_circ
  | S r' => box_ (x,y) ⇒
             (let_ (x,y) ← small_grover_iterate_1_3 r' $ (x,y);
              let_ (x,y) ← small_oracle_1_3 $ (x,y);
              let_ (x,y) ← small_diffusion $ (x,y);
              (x,y))
  end.

Lemma small_grover_iterate_1_3_WT : forall r, Typed_Box (small_grover_iterate_1_3 r).
Proof. type_check. induction r as [ | [ | r ] ]; type_check. Qed.

Fixpoint small_grover_iterate_2_3 (r:nat) : Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
  match r with
  | 0 => id_circ
  | S r' => box_ (x,y) ⇒
             (let_ (x,y) ← small_grover_iterate_2_3 r' $ (x,y);
              let_ (x,y) ← small_oracle_2_3 $ (x,y);
              let_ (x,y) ← small_diffusion $ (x,y);
              (x,y))

  end.

Lemma small_grover_iterate_2_3_WT : forall r, Typed_Box (small_grover_iterate_2_3 r).
Proof. type_check. induction r as [ | [ | r ] ]; type_check. Qed.

Fixpoint small_grover_iterate_0_1_2 (r:nat) : Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
  match r with
  | 0 => id_circ
  | S r' => box_ (x,y) ⇒
             (let_ (x,y) ← small_grover_iterate_0_1_2 r' $ (x,y);
              let_ (x,y) ← small_oracle_0_1_2 $ (x,y);
              let_ (x,y) ← small_diffusion $ (x,y);
              (x,y))
  end.

Lemma small_grover_iterate_0_1_2_WT : forall r, Typed_Box (small_grover_iterate_0_1_2 r).
Proof. type_check. induction r as [ | [ | r ] ]; type_check. Qed.

Fixpoint small_grover_iterate_0_1_3 (r:nat) : Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
  match r with
  | 0 => id_circ
  | S r' => box_ (x,y) ⇒
             (let_ (x,y) ← small_grover_iterate_0_1_3 r' $ (x,y);
              let_ (x,y) ← small_oracle_0_1_3 $ (x,y);
              let_ (x,y) ← small_diffusion $ (x,y);
              (x,y))
  end.

Lemma small_grover_iterate_0_1_3_WT : forall r, Typed_Box (small_grover_iterate_0_1_3 r).
Proof. type_check. induction r as [ | [ | r ] ]; type_check. Qed.

Fixpoint small_grover_iterate_0_2_3 (r:nat) : Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
  match r with
  | 0 => id_circ
  | S r' => box_ (x,y) ⇒
             (let_ (x,y) ← small_grover_iterate_0_2_3 r' $ (x,y);
              let_ (x,y) ← small_oracle_0_2_3 $ (x,y);
              let_ (x,y) ← small_diffusion $ (x,y);
              (x,y))
  end.

Lemma small_grover_iterate_0_2_3_WT : forall r, Typed_Box (small_grover_iterate_0_2_3 r).
Proof. type_check. induction r as [ | [ | r ] ]; type_check. Qed.

Fixpoint small_grover_iterate_1_2_3 (r:nat) : Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
  match r with
  | 0 => id_circ
  | S r' => box_ (x,y) ⇒
             (let_ (x,y) ← small_grover_iterate_1_2_3 r' $ (x,y);
              let_ (x,y) ← small_oracle_1_2_3 $ (x,y);
              let_ (x,y) ← small_diffusion $ (x,y);
              (x,y))
  end.

Lemma small_grover_iterate_1_2_3_WT : forall r, Typed_Box (small_grover_iterate_1_2_3 r).
Proof. type_check. induction r as [ | [ | r ] ]; type_check. Qed.

Local Close Scope nat_scope.

Definition small_grover_general_r_rots (f: nat -> bool) (r:nat) : Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
  box_ (x,y) ⇒
match f 0%nat, f 1%nat, f 2%nat, f 3%nat with
  |true, false, false, false =>
        (let_ (x,y) ← small_grover_iterate_0 r $ (x,y);
        (x,y))
  |false, true, false, false =>
        (let_ (x,y) ← small_grover_iterate_1 r $ (x,y);
        (x,y))
  |false, false, true, false =>
        (let_ (x,y) ← small_grover_iterate_2 r $ (x,y);
        (x,y))
  |false, false, false, true =>
        (let_ (x,y) ← small_grover_iterate_3 r $ (x,y);
        (x,y))
  |true, true, false, false =>
        (let_ (x,y) ← small_grover_iterate_0_1 r $ (x,y);
        (x,y))
  |true, false, true, false =>
        (let_ (x,y) ← small_grover_iterate_0_2 r $ (x,y);
        (x,y))
  |true, false, false, true =>
        (let_ (x,y) ← small_grover_iterate_0_3 r $ (x,y);
        (x,y))
  |false, true, true, false =>
        (let_ (x,y) ← small_grover_iterate_1_2 r $ (x,y);
        (x,y))
  |false, true, false, true =>
        (let_ (x,y) ← small_grover_iterate_1_3 r $ (x,y);
        (x,y))
  |false, false, true, true =>
        (let_ (x,y) ← small_grover_iterate_2_3 r $ (x,y);
        (x,y))
  |true, true, true, false =>
        (let_ (x,y) ← small_grover_iterate_0_1_2 r $ (x,y);
        (x,y))
  |true, true, false, true =>
        (let_ (x,y) ← small_grover_iterate_0_1_3 r $ (x,y);
        (x,y))
  |true, false, true, true =>
        (let_ (x,y) ← small_grover_iterate_0_2_3 r $ (x,y);
        (x,y))
  |false, true, true, true =>
        (let_ (x,y) ← small_grover_iterate_1_2_3 r $ (x,y);
        (x,y))
  | _, _, _, _ => (x,y)

end.
(*
Fixpoint small_grover_iterate (tars:nat) (r:nat) : Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
  match r with
  | 0 => id_circ
  | S r' => box_ (x,y) ⇒
      match tars with
        | 0 =>
            (let_ (x,y) ← small_oracle_0 $ (x,y);
             let_ (x,y) ← small_diffusion $ (x,y);
             let_ (x,y) ← small_grover_iterate 0 r' $ (x,y);
             (x,y))
        | 1 =>
            (let_ (x,y) ← small_oracle_1 $ (x,y);
             let_ (x,y) ← small_diffusion $ (x,y);
             let_ (x,y) ← small_grover_iterate 1 r' $ (x,y);
             (x,y))
        | 2 =>
            (let_ (x,y) ← small_oracle_2 $ (x,y);
             let_ (x,y) ← small_diffusion $ (x,y);
             let_ (x,y) ← small_grover_iterate 2 r' $ (x,y);
             (x,y))
        | 3 =>
            (let_ (x,y) ← small_oracle_3 $ (x,y);
             let_ (x,y) ← small_diffusion $ (x,y);
             let_ (x,y) ← small_grover_iterate 3 r' $ (x,y);
             (x,y))
        | 10 =>
            (let_ (x,y) ← small_oracle_0_1 $ (x,y);
             let_ (x,y) ← small_diffusion $ (x,y);
             let_ (x,y) ← small_grover_iterate 10 r' $ (x,y);
             (x,y))
        | 20 =>
            (let_ (x,y) ← small_oracle_0_2 $ (x,y);
             let_ (x,y) ← small_diffusion $ (x,y);
             let_ (x,y) ← small_grover_iterate 20 r' $ (x,y);
             (x,y))
        | 30 =>
            (let_ (x,y) ← small_oracle_0_3 $ (x,y);
             let_ (x,y) ← small_diffusion $ (x,y);
             let_ (x,y) ← small_grover_iterate 30 r' $ (x,y);
             (x,y))
        | 12 =>
            (let_ (x,y) ← small_oracle_1_2 $ (x,y);
             let_ (x,y) ← small_diffusion $ (x,y);
             let_ (x,y) ← small_grover_iterate 12 r' $ (x,y);
             (x,y))
        | 13 =>
            (let_ (x,y) ← small_oracle_1_3 $ (x,y);
             let_ (x,y) ← small_diffusion $ (x,y);
             let_ (x,y) ← small_grover_iterate 13 r' $ (x,y);
             (x,y))
        | 23 =>
            (let_ (x,y) ← small_oracle_2_3 $ (x,y);
             let_ (x,y) ← small_diffusion $ (x,y);
             let_ (x,y) ← small_grover_iterate 23 r' $ (x,y);
             (x,y))
        | 210 =>
            (let_ (x,y) ← small_oracle_0_1_2 $ (x,y);
             let_ (x,y) ← small_diffusion $ (x,y);
             let_ (x,y) ← small_grover_iterate 210 r' $ (x,y);
             (x,y))
        | 310 =>
            (let_ (x,y) ← small_oracle_0_1_3 $ (x,y);
             let_ (x,y) ← small_diffusion $ (x,y);
             let_ (x,y) ← small_grover_iterate 310 r' $ (x,y);
             (x,y))
        | 320 =>
            (let_ (x,y) ← small_oracle_0_2_3 $ (x,y);
             let_ (x,y) ← small_diffusion $ (x,y);
             let_ (x,y) ← small_grover_iterate 320 r' $ (x,y);
             (x,y))
        | 123 =>
            (let_ (x,y) ← small_oracle_1_2_3 $ (x,y);
             let_ (x,y) ← small_diffusion $ (x,y);
             let_ (x,y) ← small_grover_iterate 123 r' $ (x,y);
             (x,y))
        | _ =>  (x,y)
      end
   end.
Local Close Scope nat_scope.

Definition small_grover_general_r_rots (f: nat -> bool) (r:nat) : Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
  box_ () ⇒
    let_ x ← _H $ init0 $ ();
    let_ y ← _H $ init0 $ ();
match f 0%nat, f 1%nat, f 2%nat, f 3%nat with
  |true, false, false, false =>
        (let_ (x,y) ← small_grover_iterate 0 r $ (x,y);
        (x,y))
  |false, true, false, false =>
        (let_ (x,y) ← small_grover_iterate 1 r $ (x,y);
        (x,y))
  |false, false, true, false =>
        (let_ (x,y) ← small_grover_iterate 2 r $ (x,y);
        (x,y))
  |false, false, false, true =>
        (let_ (x,y) ← small_grover_iterate 3 r $ (x,y);
        (x,y))
  |true, true, false, false =>
        (let_ (x,y) ← small_grover_iterate 10 r $ (x,y);
        (x,y))
  |true, false, true, false =>
        (let_ (x,y) ← small_grover_iterate 20 r $ (x,y);
        (x,y))
  |true, false, false, true =>
        (let_ (x,y) ← small_grover_iterate 30 r $ (x,y);
        (x,y))
  |false, true, true, false =>
        (let_ (x,y) ← small_grover_iterate 12 r $ (x,y);
        (x,y))
  |false, true, false, true =>
        (let_ (x,y) ← small_grover_iterate 13 r $ (x,y);
        (x,y))
  |false, false, true, true =>
        (let_ (x,y) ← small_grover_iterate 23 r $ (x,y);
        (x,y))
  |true, true, true, false =>
        (let_ (x,y) ← small_grover_iterate 210 r $ (x,y);
        (x,y))
  |true, true, false, true =>
        (let_ (x,y) ← small_grover_iterate 310 r $ (x,y);
        (x,y))
  |true, false, true, true =>
        (let_ (x,y) ← small_grover_iterate 320 r $ (x,y);
        (x,y))
  |false, true, true, true =>
        (let_ (x,y) ← small_grover_iterate 123 r $ (x,y);
        (x,y))
  | _, _, _, _ => (x,y)

     end.
*)
(* Since the general form first mathes the function to a circuitry, then calls the relevant circuitry separately,
these lemmas have to be reestablished for this generalized version's first iteration (perhaps the equivalence can instead be proven)
Lemma small_grover_general_rot_equality : forall g, In g f_list ->
    (denote (small_grover_general_i_rots g 1) (I 1))
               =
                 (denote (small_grover_total g) (I 1)).
Proof.
  intros.
  induction H. symmetry in H. rewrite H.
  2:  destruct H. 2: symmetry in H. 2: rewrite H.
  3:  destruct H. 3: symmetry in H. 3: rewrite H.
  4:  destruct H. 4: symmetry in H. 4: rewrite H.
  5:  destruct H. 5: symmetry in H. 5: rewrite H.
  6:  destruct H. 6: symmetry in H. 6: rewrite H.
  7:  destruct H. 7: symmetry in H. 7: rewrite H.
  8:  destruct H. 8: symmetry in H. 8: rewrite H.
  9:  destruct H. 9: symmetry in H. 9: rewrite H.
  10:  destruct H. 10: symmetry in H. 10: rewrite H.
  11:  destruct H. 11: symmetry in H. 11: rewrite H.
  12:  destruct H. 12: symmetry in H. 12: rewrite H.
  13:  destruct H. 13: symmetry in H. 13: rewrite H.
  14:  destruct H. 14: symmetry in H. 14: rewrite H.
  15:  destruct H.
  all: matrix_denote.
  all:admit.
Admitted.

  all: solve_matrix.
 Qed.*)

Lemma small_grover_general_rot_equality : forall g, In g f_list ->
    (denote (small_grover_general_r_rots g 1) (denote (equal_superposition) (I 1)))
               =
                 (denote (small_grover_total g) (I 1)).
Proof.
  intros.
  induction H. symmetry in H. rewrite H.
  2:  destruct H. 2: symmetry in H. 2: rewrite H.
  3:  destruct H. 3: symmetry in H. 3: rewrite H.
  4:  destruct H. 4: symmetry in H. 4: rewrite H.
  5:  destruct H. 5: symmetry in H. 5: rewrite H.
  6:  destruct H. 6: symmetry in H. 6: rewrite H.
  7:  destruct H. 7: symmetry in H. 7: rewrite H.
  8:  destruct H. 8: symmetry in H. 8: rewrite H.
  9:  destruct H. 9: symmetry in H. 9: rewrite H.
  10:  destruct H. 10: symmetry in H. 10: rewrite H.
  11:  destruct H. 11: symmetry in H. 11: rewrite H.
  12:  destruct H. 12: symmetry in H. 12: rewrite H.
  13:  destruct H. 13: symmetry in H. 13: rewrite H.
  14:  destruct H. 14: symmetry in H. 14: rewrite H.
  15:  destruct H.
  all: matrix_denote.
  (*all: solve_matrix.   This works, but takes a rather long while, and we do not end up using this later, so it is instead admitted.
 Qed.*)
  all:admit.
Admitted.

Ltac trig_periodicity_start r :=
  rewrite asin14;
  replace    (S (S (S (S r))))  with (r +4)%nat by intuition;
  symmetry;
  rewrite mult_plus_distr_l;
  rewrite mult_minus_distr_l;
  rewrite mult_plus_distr_l;
  repeat rewrite plus_INR;
  repeat rewrite minus_INR;
  repeat rewrite mult_INR;
  repeat rewrite plus_INR;
  repeat rewrite mult_INR;
  replace (INR 1) with 1%R by easy;
  replace (INR 2) with 2%R by easy;
  replace (2%R *INR 4)%R with (2 * 4)%R;
  replace (2%R *INR 3)%R with (2 * 3)%R;
  unfold Rminus;
  repeat rewrite Rplus_assoc;
  replace   (8 + (- (6) + 1))%R with 3%R by ring;
  replace ( 8 + 1)%R with 9%R by ring;
  repeat rewrite Rmult_plus_distr_r.

Ltac trig_periodicity_start_from_0 r :=
  rewrite asin14;
  symmetry;
  rewrite mult_plus_distr_l;
  repeat rewrite plus_INR;
  repeat rewrite minus_INR;
  repeat rewrite mult_INR;
  repeat rewrite plus_INR;
  repeat rewrite mult_INR;
  replace (INR 1) with 1%R by easy;
  replace (INR 2) with 2%R by easy;
  replace (2%R *INR 2)%R with (2 * 2)%R;
  replace (2%R *INR 3)%R with (2 * 3)%R;
  unfold Rminus;
  repeat rewrite Rplus_assoc.

Lemma one_true_periodic_from_0 : forall r, (sin (INR (2 * r + 1) * asin (√ (1 / 4))) ^ 2)%R =  (sin ( INR (2 * (S (S (S r))) + 1) * asin (√ (1 / 4))) ^ 2)%R.

  intros.
  replace (S (S (S r)))%nat with (r+3)%nat by intuition.
  rewrite sqrt_div.
  trig_periodicity_start_from_0 r.
  5,6: intuition.
  2,3,4: unfold INR; R_field.
   replace (2 * 3 + 1)%R with 7%R by R_field.
   rewrite Rmult_plus_distr_r.
   symmetry.
   rewrite Rmult_plus_distr_r.
   rewrite sin_plus.
   symmetry.
   rewrite sin_plus.
   replace ((7 * (PI / 6)))%R with (PI + (PI / 6))%R by  R_field.
   rewrite cos_pi_plus, sin_pi_plus.
   R_field_simplify.
   repeat rewrite Rmult_1_l.
   replace (cos (PI / 6) * cos (2 * INR r * (PI / 6)))%R with (cos (2 * INR r * (PI / 6))*  cos (PI / 6))%R.
   2: rewrite Rmult_comm; reflexivity.
   R_field_simplify.
   reflexivity.
Qed.

Lemma three_true_periodic_from_0 : forall r, (sin (INR (2 * r + 1) * asin (√ (3 / 4))) ^ 2)%R =  (sin ( INR (2 * (S (S (S r))) + 1) * asin (√ (3/ 4))) ^ 2)%R.

  intros.
  replace (S (S (S r)))%nat with (r+3)%nat by intuition.
  rewrite sqrt_div.
  rewrite asin34;
  symmetry;
  rewrite mult_plus_distr_l;
  repeat rewrite plus_INR;
  repeat rewrite minus_INR;
  repeat rewrite mult_INR;
  repeat rewrite plus_INR;
  repeat rewrite mult_INR;
  replace (INR 1) with 1%R by easy;
  replace (INR 2) with 2%R by easy;
  replace (2%R *INR 2)%R with (2 * 2)%R;
  replace (2%R *INR 3)%R with (2 * 3)%R;
  unfold Rminus;
  repeat rewrite Rplus_assoc.
  5,6: intuition.
  2,3,4: unfold INR; R_field.
   replace (2 * 3 + 1)%R with 7%R by R_field.
   rewrite Rmult_plus_distr_r.
   symmetry.
   rewrite Rmult_plus_distr_r.
   rewrite sin_plus.
   symmetry.
   rewrite sin_plus.
   replace ((7 * (PI / 3)))%R with (PI +( PI + (PI / 3)))%R by  R_field.
   rewrite cos_pi_plus, sin_pi_plus.
   rewrite cos_pi_plus, sin_pi_plus.
   R_field_simplify.
   repeat rewrite Rmult_1_l.
   replace (cos (PI / 3) * cos (2 * INR r * (PI / 3)))%R with (cos (2 * INR r * (PI / 3))*  cos (PI / 3))%R.
   2: rewrite Rmult_comm; reflexivity.
   R_field_simplify.
   reflexivity.
Qed.

Lemma one_true_trig_1  :  (sin (INR (2 * 1 + 1) * asin (√ (1 / 4))) ^ 2)%R = 1.
  rewrite mult_1_r.
  replace (2+1)%nat with 3%nat by easy.
  unfold INR.
  replace (1 + 1 + 1)%R with 3%R by ring.
  rewrite sqrt_div. 2,3 : intuition.
  rewrite asin14.
  replace (3 * (PI / 6))%R with (1 * (PI / 2))%R.
  all: rewrite Rmult_1_l.
  rewrite sin_PI2.
  unfold pow.
  ring.
  R_field_simplify.
  reflexivity.
Qed.

Lemma one_true_trig_2  :  (sin (INR (2 * 2 + 1) * asin (√ (1 / 4))) ^ 2)%R = (1/4)%R.
  replace (2*2+1)%nat with 5%nat by easy.
  unfold INR.
  replace (1 + 1 + 1 + 1 + 1)%R with 5%R by ring.
  rewrite sqrt_div. 2,3 : intuition.
  rewrite asin14.
  replace (5 * (PI / 6))%R with (PI - (PI / 6))%R.
  2: { R_field_simplify. reflexivity. }
  rewrite sin_PI_x.
  rewrite sin_PI6.
  unfold pow.
  R_field_simplify.
  reflexivity.
Qed.

Lemma one_true_trig_3  :  (sin (INR (2 * 3 + 1) * asin (√ (1 / 4))) ^ 2)%R = (1/4)%R.
  replace (2*3+1)%nat with 7%nat by easy.
  unfold INR.
  replace (1 + 1 + 1 + 1 + 1 + 1 + 1)%R with 7%R by ring.
  rewrite sqrt_div. 2,3 : intuition.
  rewrite asin14.
  replace (7 * (PI / 6))%R with ((PI / 6) + PI)%R.
  2: { R_field_simplify. reflexivity. }
  rewrite neg_sin.
  rewrite sin_PI6.
  unfold pow.
  R_field_simplify.
  reflexivity.
Qed.

Lemma one_true_periodic : forall r, (r > 3)%nat -> (sin (INR (2 * r + 1) * asin (√ (1 / 4))) ^ 2)%R =  (sin ( INR (2 * (r-3) + 1) * asin (√ (1 / 4))) ^ 2)%R.
  intros.
  destruct r. inversion H.
  destruct r. inversion H. inversion H1.
  destruct r. inversion H. inversion H1. inversion H3.
  destruct r. inversion H. inversion H1. inversion H3. inversion H5.
  rewrite sqrt_div.
  trig_periodicity_start r.
  9,10 : intuition.
  5: intuition.
  2,3,4,5,6,7: unfold INR; R_field_simplify; reflexivity.
  R_field_simplify.
  replace  (2 * 4 * (PI / 6) + (- (2 * 3) * (PI / 6) + 1 * (PI / 6)))%R with (3 * (PI / 6))%R.
  2: { R_field_simplify. reflexivity. }
  replace (2 * 4 * (PI / 6) + 1 * (PI / 6))%R with (9 * (PI / 6))%R.
  2: { R_field_simplify. reflexivity. }
   replace (sin (2 * INR r * (PI / 6) + 3 * (PI / 6)) ^ 2)%R with   (sin (2 * INR r * (PI / 6) + (PI / 2)) ^ 2)%R.
  2: { unfold Rdiv.
       replace (3 * (PI * / 6))%R with ((PI / 2))%R.
       2: { R_field_simplify. reflexivity. }
       unfold Rdiv. reflexivity.
  }
  replace (9 * (PI / 6))%R  with (PI + PI * / 2)%R.
  2: { symmetry. rewrite <- Rmult_comm. unfold Rdiv. rewrite Rmult_assoc. replace (/ 6 * 9)%R with (1 + 1 / 2)%R.
       2: R_field_simplify; reflexivity.
       rewrite Rmult_plus_distr_l.
       unfold Rdiv.
       repeat rewrite Rmult_1_l.
       repeat rewrite Rmult_1_r.
       reflexivity. }
  symmetry.
  rewrite Rplus_comm.
  rewrite Rplus_assoc.
  rewrite sin_pi_plus.
  rewrite Rplus_comm.
  unfold pow.
  repeat rewrite Rmult_1_r.
  rewrite Rmult_opp_opp.
  unfold Rdiv.
  reflexivity.
Qed.

Lemma two_true_trig_1  :  (sin (INR (2 * 1 + 1) * asin (√ (2 / 4))) ^ 2)%R = (1/2)%R.
   rewrite mult_1_r.
  replace (2+1)%nat with 3%nat by easy.
  unfold INR.
  replace (1 + 1 + 1)%R with 3%R by ring.
  rewrite sqrt_div. 2,3 : intuition.
  rewrite asin24.
  rewrite sin_3PI4.
  unfold pow.
  R_field_simplify.
  reflexivity.
  apply sqrt2_neq_0.
 Qed.

Lemma two_true_trig_2  :  (sin (INR (2 * 2 + 1) * asin (√ (2 / 4))) ^ 2)%R = (1/2)%R.
  replace (2*2+1)%nat with 5%nat by easy.
  unfold INR.
  replace (1 + 1 + 1 +1 +1)%R with 5%R by ring.
  rewrite sqrt_div. 2,3 : intuition.
  rewrite asin24.
  replace (5 * (PI / 4))%R with (PI + (PI / 4))%R.
  2: R_field_simplify; reflexivity.
  rewrite sin_pi_plus.
  rewrite sin_PI4.
  unfold pow.
  R_field_simplify.
  reflexivity.
  apply sqrt2_neq_0.
Qed.

Lemma two_true_trig_3  :  (sin (INR (2 * 3 + 1) * asin (√ (2 / 4))) ^ 2)%R = (1/2)%R.
  replace (2*3+1)%nat with 7%nat by easy.
  unfold INR.
  replace (1 + 1 + 1 +1 +1 +1 +1)%R with 7%R by ring.
  rewrite sqrt_div. 2,3 : intuition.
  rewrite asin24.
  replace (7 * (PI / 4))%R with (PI + (3 * PI / 4))%R.
  2: R_field_simplify; reflexivity.
  rewrite sin_pi_plus.
  unfold pow.
  R_field_simplify.
  unfold Rdiv.
  rewrite Rmult_assoc.
  replace (PI * / 4)%R with (PI / 4)%R by easy.
  rewrite sin_3PI4.
  R_field_simplify.
  reflexivity.
  apply sqrt2_neq_0.
Qed.

Lemma sin_pi_period_zero : forall r:nat,  sin (PI * INR r) = 0.
Proof.
  intros. induction r.
  unfold INR. rewrite Rmult_0_r. apply sin_eq_O_2PI_1.
  intuition. apply Rmult_le_pos. intuition. unfold Rle.
  left. apply PI_RGT_0.
  left. reflexivity.
  replace (S r) with (r+1)%nat. 2:intuition.
  rewrite plus_INR. replace (INR 1) with 1%R by easy.
  rewrite Rmult_plus_distr_l. rewrite Rplus_comm.
  rewrite Rmult_1_r.
  rewrite sin_pi_plus.
  rewrite IHr.
  R_field_simplify.
  reflexivity.
Qed.

Lemma two_true_periodic : forall r, (r > 0)%nat -> (sin (INR (2 * r + 1) * asin (√ (2 / 4))) ^ 2)%R = (sin (INR (2 * (r+1) + 1) * asin (√ (2 / 4))) ^ 2)%R.
  intros. destruct r. inversion H.
  destruct r. rewrite two_true_trig_1.
  symmetry.
  replace (1 + 1)%nat with 2%nat by easy.
  rewrite two_true_trig_2.
  reflexivity.
  rewrite sqrt_div.
  rewrite asin24.
  2,3 : intuition.
  replace (S (S r)) with (r + 2)%nat by intuition.
  repeat rewrite mult_plus_distr_l.
  repeat rewrite plus_INR.
  repeat rewrite mult_INR.
  repeat replace (INR 1) with 1%R by easy.
  repeat replace (INR 2) with 2%R by easy.
  rewrite Rplus_assoc.
  replace (2 * 2 + 1)%R with 5%R. 2 : R_field_simplify; reflexivity.
  repeat rewrite Rplus_assoc.
  replace (2 * 2 + (2 * 1 + 1))%R with 7%R. 2: R_field_simplify; reflexivity.
  rewrite Rmult_comm. symmetry. rewrite Rmult_comm. symmetry.
  rewrite Rmult_plus_distr_l. symmetry. rewrite Rmult_plus_distr_l. symmetry.
  repeat rewrite sin_plus.
  replace (PI / 4 * 7)%R with (PI + (3 * (PI / 4)))%R.
  2: R_field_simplify; reflexivity.
  replace (PI / 4 * 5)%R with (PI + (PI / 4))%R.
  2: R_field_simplify; reflexivity.
  repeat rewrite sin_pi_plus.
  repeat rewrite cos_pi_plus.
  rewrite cos_PI4, sin_PI4, cos_3PI4, sin_3PI4.
  R_field_simplify.
  2: apply sqrt2_neq_0.
  replace (2 * sin (PI / 4 * (2 * INR r)) *
             cos (PI / 4 * (2 * INR r)))%R with (sin (2* PI / 4 * (2 * INR r)))%R.
  2: { unfold Rdiv. rewrite Rmult_assoc.  rewrite Rmult_assoc. symmetry.
       rewrite Rmult_assoc.  rewrite Rmult_assoc.
       rewrite  <- Rmult_assoc.
       symmetry.
       apply sin_2a. }
  replace (2 * PI / 4 * (2 * INR r))%R with (PI * INR r)%R. 2: R_field_simplify; reflexivity.
  replace (PI / 4 * (2 * INR r))%R with  (PI / 2 * INR r)%R. 2: R_field_simplify; reflexivity.
  replace (sin (PI * INR r))%R with 0%R.
  R_field_simplify.
  reflexivity.
  symmetry.
  apply sin_pi_period_zero.
Qed.

Lemma three_true_trig_1  :  (sin (INR (2 * 1 + 1) * asin (√ (3 / 4))) ^ 2)%R = 0.
Proof.
  rewrite mult_1_r.
  replace (2+1)%nat with 3%nat by easy.
  unfold INR.
  replace (1 + 1 + 1)%R with 3%R by ring.
  rewrite sqrt_div. 2,3 : intuition.
  rewrite asin34.
  unfold Rdiv.
  rewrite Rmult_comm.
  replace (PI * / 3 * 3)%R with PI%R. 2: { symmetry. rewrite Rmult_assoc. rewrite Rinv_l. 2: easy. apply Rmult_1_r. }
  rewrite sin_PI.
  unfold pow.
  ring.
Qed.

(*Lemma sin_pi_plus : forall x,
    sin (PI + x) = - sin x.
  *)
Lemma three_true_trig_2 :  (sin (INR (2 * 2 + 1) * asin (√ (3 / 4))) ^ 2)%R = (3/4)%R.
Proof.
  replace (2*2+1)%nat with 5%nat by easy.
  unfold INR.
  replace (1 + 1 + 1 + 1 + 1)%R with 5%R by ring.
  rewrite sqrt_div. 2,3 : intuition.
  rewrite asin34.
  unfold Rdiv.
  replace (5 * (PI * / 3))%R  with (PI + 2 * (PI / 3))%R.
  2: { symmetry. rewrite <- Rmult_comm. replace 5%R with (3 + 2)%R by ring.  rewrite Rmult_plus_distr_l.
       replace (PI * / 3 * 3)%R with PI%R.
       2: { symmetry. rewrite Rmult_assoc. rewrite Rinv_l. 2: easy. apply Rmult_1_r. }
                                         rewrite Rmult_comm. symmetry. unfold Rdiv. reflexivity. }
  rewrite sin_pi_plus.
  rewrite sin_2PI3.
  unfold pow.
  rewrite Rmult_1_r.
  rewrite Rmult_opp_opp.
  unfold Rdiv.
  rewrite <- Rmult_assoc.
  replace (√ 3 * / 2 * √ 3)%R with (√ 3 * √ 3 * / 2)%R. 2: { symmetry; rewrite Rmult_comm. rewrite Rmult_assoc. reflexivity. }
                                                      rewrite sqrt_sqrt. 2: intuition.
  rewrite Rmult_assoc.
  replace  (/ 2 * / 2)%R with  (/ ( 2 * 2))%R.
  2 : apply Rinv_mult_distr. 2,3: easy.
  replace ( 2* 2)%R with 4%R by ring.
  reflexivity.
Qed.

Lemma three_true_trig_3 :  (sin (INR (2 * 3 + 1) * asin (√ (3 / 4))) ^ 2)%R = (3/4)%R.
Proof.
  replace (2*3+1)%nat with 7%nat by easy.
  unfold INR.
  replace (1 + 1 + 1 + 1 + 1 +1 +1)%R with 7%R by ring.
  rewrite sqrt_div. 2,3 : intuition.
  rewrite asin34.
  unfold Rdiv.
  replace (7 * (PI * / 3))%R  with (PI + PI + (PI / 3))%R.
  2: { symmetry. rewrite <- Rmult_comm. replace 7%R with (3 + 4)%R by ring.  rewrite Rmult_plus_distr_l.
       replace (PI * / 3 * 3)%R with PI%R. 2: { symmetry. rewrite Rmult_assoc. rewrite Rinv_l. 2: easy. apply Rmult_1_r. }
                                         replace 4%R with (3 + 1)%R by ring.  rewrite Rmult_plus_distr_l.
       replace (PI * / 3 * 3)%R with PI%R. 2: { symmetry. rewrite Rmult_assoc. rewrite Rinv_l. 2: easy. apply Rmult_1_r. }
                                         rewrite Rmult_1_r.
                                         rewrite Rplus_assoc. symmetry. unfold Rdiv. reflexivity. }
  rewrite Rplus_assoc.
  rewrite sin_pi_plus.
  rewrite sin_pi_plus.
  rewrite sin_PI3.
  rewrite Ropp_involutive.
  unfold pow.
  rewrite Rmult_1_r.
  unfold Rdiv.
  rewrite <- Rmult_assoc.
  replace (√ 3 * / 2 * √ 3)%R with (√ 3 * √ 3 * / 2)%R. 2: { symmetry; rewrite Rmult_comm. rewrite Rmult_assoc. reflexivity. }
                                                      rewrite sqrt_sqrt. 2: intuition.
  rewrite Rmult_assoc.
  replace  (/ 2 * / 2)%R with  (/ ( 2 * 2))%R.
  2 : apply Rinv_mult_distr. 2,3: easy.
  replace ( 2* 2)%R with 4%R by ring.
  reflexivity.
Qed.

Lemma three_true_trig_4 :  (sin (INR (2 * 4 + 1) * asin (√ (3 / 4))) ^ 2)%R = 0%R.
Proof.
  replace (2*4+1)%nat with 9%nat by easy.
  unfold INR.
  replace (1 + 1 + 1 + 1 + 1 +1 +1 +1 +1)%R with 9%R by ring.
  rewrite sqrt_div. 2,3 : intuition.
  rewrite asin34.
  unfold Rdiv.
  replace (9 * (PI * / 3))%R  with (3 * PI)%R.
  2: { symmetry. rewrite <- Rmult_comm. rewrite Rmult_assoc. replace (/ 3 * 9)%R with (3)%R.
       2: { replace 9%R with ( 3 + 3 + 3 )%R by ring.
            repeat rewrite Rmult_plus_distr_l.
            rewrite Rmult_comm.
            rewrite Rinv_r.
            2: easy.
            ring.
       }
       rewrite Rmult_comm.
       reflexivity.
       }
       rewrite sin_eq_0_1.
  unfold pow.
  ring.
  apply ex_intro with (x:=3%Z).
  reflexivity.
Qed.

Lemma three_true_periodic : forall r, (r > 3)%nat -> (sin (INR (2 * r + 1) * asin (√ (3 / 4))) ^ 2)%R =  (sin ( INR (2 * (r-3) + 1) * asin (√ (3 / 4))) ^ 2)%R.
  intros.
  destruct r.
  inversion H.
  destruct r.
  inversion H.
  inversion H1.
  destruct r.
  inversion H.
  inversion H1.
  inversion H3.
  destruct r.
  inversion H.
  inversion H1.
  inversion H3.
  inversion H5.
  rewrite sqrt_div.
   2,3 : intuition.
   rewrite asin34.
   replace    (S (S (S (S r))))  with (r +4)%nat by intuition.
   symmetry.
   rewrite mult_plus_distr_l.
   rewrite mult_minus_distr_l.
   rewrite mult_plus_distr_l.
   repeat rewrite plus_INR.
   repeat rewrite minus_INR.
   repeat rewrite mult_INR.
   repeat rewrite plus_INR.
   repeat rewrite mult_INR.
   2: { replace (2 * 4)%nat with 8%nat by ring.
        replace (2 * 3)%nat with 6%nat by ring.
        intuition. }
   replace (INR 1) with 1%R by easy.
   replace (INR 2) with 2%R by easy.
   replace (2%R *INR 4)%R with (2 * 4)%R.
   2: { unfold INR. ring. }
   replace (2%R *INR 3)%R with (2 * 3)%R.
   2: { unfold INR. ring. }
   replace (2 * 4)%R with 8%R by ring.
   replace (2 * 3)%R with 6%R by ring.
   unfold Rminus.
   repeat rewrite Rplus_assoc.
   replace   (8 + (- (6) + 1))%R with 3%R by ring.
   replace ( 8 + 1)%R with 9%R by ring.
   repeat rewrite Rmult_plus_distr_r.
   replace (sin (2 * INR r * (PI / 3) + 3 * (PI / 3)) ^ 2)%R with   (sin (2 * INR r * (PI / 3)) ^ 2)%R.
   2: { unfold Rdiv. replace (3 * (PI * / 3))%R with PI%R.
        2:{ rewrite Rmult_comm. symmetry. rewrite Rmult_assoc. rewrite Rinv_l. 2: easy. apply Rmult_1_r. }
        rewrite Rplus_comm.
        rewrite sin_pi_plus.
        unfold pow.
        symmetry.
        repeat rewrite Rmult_1_r.
        rewrite Rmult_opp_opp.
        reflexivity.
}
   unfold Rdiv.
   replace (9 * (PI * / 3))%R  with (3 * PI)%R.
  2: { symmetry. rewrite <- Rmult_comm. rewrite Rmult_assoc. replace (/ 3 * 9)%R with (3)%R.
       2: { replace 9%R with ( 3 + 3 + 3 )%R by ring.
            repeat rewrite Rmult_plus_distr_l.
            rewrite Rmult_comm.
            rewrite Rinv_r.
            2: easy.
            ring.
       }
       rewrite Rmult_comm.
       reflexivity.
  }
   symmetry.
   rewrite Rplus_comm.
   replace (3 * PI)%R with (PI + PI + PI)%R.
   2: { ring. }
   rewrite Rplus_assoc.
   rewrite Rplus_assoc.
   rewrite sin_pi_plus.
   rewrite sin_pi_plus.
   rewrite Ropp_involutive.
   rewrite sin_pi_plus.
   unfold pow.
   repeat rewrite Rmult_1_r.
   rewrite Rmult_opp_opp.
   reflexivity.
Qed.

(* Example of proof using periodicity for f0, r rotations *)
(* -------------------------------------------------------------------------------------------------------------------*)

Definition id_4 := list2D_to_matrix ( [ [ C1 ; C0 ; C0 ; C0 ] ; [ C0 ; C1 ; C0 ; C0 ]  ; [ C0 ; C0 ; C1 ; C0 ] ; [ C0 ; C0 ; C0 ; C1 ] ] ).

Definition unitary_op_0 := (list2D_to_matrix ( [ [1/2; 1/2 ; 1/2 ; 1/2 ] ; [ -(1/2) ; -(1/2) ; 1/2 ; 1/2]  ; [ -(1/2) ; 1/2 ; -(1/2) ; 1/2 ] ; [ -(1/2) ; (1/2) ; (1/2) ; -(1/2) ] ] )).

(* just to be explicit; this is of course true *)
Lemma unitary_op_0_correct: unitary_op_0  = Mmult (list2D_to_matrix ( [ [-1/2; 1/2 ; 1/2 ; 1/2 ] ; [ (1/2) ; -(1/2) ; 1/2 ; 1/2]  ; [ (1/2) ; 1/2 ; -(1/2) ; 1/2 ] ; [ (1/2) ; (1/2) ; (1/2) ; -(1/2) ] ] )) (list2D_to_matrix  ( [ [ -C1 ; C0 ; C0 ; C0 ] ; [ C0 ; C1 ; C0 ; C0 ]  ; [ C0 ; C0 ; C1 ; C0 ] ; [ C0 ; C0 ; C0 ; C1 ] ] )). Proof. intros. unfold unitary_op_0. solve_matrix. Qed.
Definition unitary_op_0_adj :=  (list2D_to_matrix ( [ [ ((1/2)); (-(1/2)) ; (-(1/2)) ; (-(1/2)) ] ; [ (1/2) ; (-(1/2)) ;(1/2); (1/2)]  ; [ (1/2) ; (1/2) ; (-(1/2)) ; (1/2) ] ; [ (1/2) ; (1/2) ; (1/2) ; (-(1/2)) ] ] )).

Lemma unitary_op_0_adj_eq: adjoint unitary_op_0 = (list2D_to_matrix ( [ [ ((1/2)); (-(1/2)) ; (-(1/2)) ; (-(1/2)) ] ; [ (1/2) ; (-(1/2)) ;(1/2); (1/2)]  ; [ (1/2) ; (1/2) ; (-(1/2)) ; (1/2) ] ; [ (1/2) ; (1/2) ; (1/2) ; (-(1/2)) ] ] )).
Proof. unfold unitary_op_0. solve_matrix. Qed.

Lemma unitary_adj_3_eq : forall (a: Square 4), WF_Matrix a -> a × ( adjoint unitary_op_0)  × (adjoint unitary_op_0)  × (adjoint unitary_op_0)  = -1 .* a.
Proof. intros. rewrite unitary_op_0_adj_eq. solve_matrix. Qed.

Definition unitary_op_0_double := (list2D_to_matrix ( [ [ -((1/2)); ((1/2)) ; ((1/2)) ; ((1/2)) ] ; [ -(1/2) ; ((1/2)) ;-(1/2); -(1/2)]  ; [ -(1/2) ; -(1/2) ; ((1/2)) ; -(1/2) ] ; [ -(1/2) ;- (1/2) ; -(1/2) ; ((1/2)) ] ] )).

Fixpoint grover_matrix_op_0 (ρ: Density 4) (r:nat): Density 4 :=
  match r with
    | 0%nat => ρ
    | S r' => super unitary_op_0 (grover_matrix_op_0 ρ r')
  end.

Definition eq_sup_2_q :=  list2D_to_matrix ( [ [(1/4) ; (1/4) ; (1/4) ;  (1/4) ] ; [(1/4) ; (1/4) ; (1/4) ;  (1/4) ] ;[(1/4) ; (1/4) ; (1/4) ;  (1/4) ] ;[(1/4) ; (1/4) ; (1/4) ;  (1/4) ] ] ).

Definition observable_0 := list2D_to_matrix ( [ [ C1 ; C0 ; C0 ; C0 ] ; [ C0 ; C0 ; C0 ; C0 ]  ; [ C0 ; C0 ; C0 ; C0 ] ; [ C0 ; C0 ; C0 ; C0 ] ] ).

Lemma inductive_expr: forall ρ r,  (grover_matrix_op_0 ρ (S r)) = super unitary_op_0 (grover_matrix_op_0 ρ r).
Proof. unfold grover_matrix_op_0. reflexivity. Qed.

Ltac only_left :=
match goal with
|- _ = ?rhs =>remember rhs
end.

Lemma grover_0_iter_2 : (grover_matrix_op_0 eq_sup_2_q 2) = (list2D_to_matrix [ [C1 / 4; -C1 / 4; -C1 / 4; -C1 / 4]; [-C1 / 4; C1 / 4; C1 / 4; C1 / 4]; [-C1 / 4; C1 / 4; C1 / 4; C1 / 4]; [-C1 / 4; C1 / 4; C1 / 4; C1 / 4] ]).
Proof.
  unfold grover_matrix_op_0, eq_sup_2_q, super.
  rewrite unitary_op_0_adj_eq.
  repeat rewrite <- Mmult_assoc.
  replace ( unitary_op_0 × unitary_op_0) with unitary_op_0_double. 2: unfold unitary_op_0, unitary_op_0_double; solve_matrix.
  unfold unitary_op_0_double.
  solve_matrix.
Qed.

Lemma grover_0_iter_3: (grover_matrix_op_0 eq_sup_2_q 3) = (grover_matrix_op_0 eq_sup_2_q 0).
Proof.
  rewrite inductive_expr.
  rewrite grover_0_iter_2.
  unfold grover_matrix_op_0, eq_sup_2_q.
  unfold super.
  rewrite unitary_op_0_adj_eq.
  unfold unitary_op_0.
  solve_matrix.
Qed.

Lemma grover_0_iter_period_of_3: forall r, (grover_matrix_op_0 eq_sup_2_q (S (S (S r)))) = (grover_matrix_op_0 eq_sup_2_q (r)).
  induction r.
  apply grover_0_iter_3.
  rewrite inductive_expr.
  symmetry.
  rewrite inductive_expr.
  apply (cong_eq (Square 4)  (grover_matrix_op_0 eq_sup_2_q r) (grover_matrix_op_0 eq_sup_2_q (S (S (S r)))) ( super unitary_op_0)).
  symmetry.
  apply IHr.
Qed.

Lemma matrix_form_induction_arg : forall r:nat,
    (@exp_val_meas_matrix 2 observable_0 (grover_matrix_op_0 (eq_sup_2_q) r) =  ((sin (INR (2 * r + 1) * asin (√ (1 / 4)))) ^ 2)%R -> @exp_val_meas_matrix 2 observable_0 (grover_matrix_op_0 (eq_sup_2_q) (S (S (S r)))) =  ((sin (INR (2 * (S (S (S r))) + 1) * asin (√ (1 / 4)))) ^ 2)%R).
Proof.
  intros.
  rewrite grover_0_iter_period_of_3.
  symmetry.
  rewrite <- one_true_periodic_from_0.
  symmetry.
  apply H.
Qed.

(* For the version form only one onwards for expresivity *)
Lemma matrix_form_induction_arg_Sr : forall r:nat,
    (@exp_val_meas_matrix 2 observable_0 (grover_matrix_op_0 (eq_sup_2_q) (S r)) =  ((sin (INR (2 * (S r) + 1) * asin (√ (1 / 4)))) ^ 2)%R -> @exp_val_meas_matrix 2 observable_0 (grover_matrix_op_0 (eq_sup_2_q) (S (S (S (S r))))) =  ((sin (INR (2 * (S (S (S (S r)))) + 1) * asin (√ (1 / 4)))) ^ 2)%R).
Proof.
  intros;
  rewrite grover_0_iter_period_of_3;
  symmetry;
  rewrite <- one_true_periodic_from_0;
  symmetry.
  apply H.
Qed.

Local Close Scope circ_scope.
Local Close Scope matrix_scope.
Local Open Scope nat_scope.

Lemma nat_ind_3: forall (Pr: nat -> Prop), (Pr 0%nat) -> (Pr 1%nat) -> (Pr 2%nat) -> (forall (n:nat), Pr n -> Pr (S (S (S n)))) ->
    forall (n:nat), Pr n.
Proof.
  intros Pr Pr0 Pr1 Pr2 H.
  assert (G: forall n, Pr n /\ Pr (S n) /\ Pr (S (S n))).
    induction n as [ | n [ Pn PSn ] ]; auto.
    split.
    destruct PSn.
    apply H0.
    destruct PSn.
    split.
    apply H1.
    apply H.
    apply Pn.
  apply G.
Qed.

Local Close Scope nat_scope.
Local Open Scope circ_scope.

Lemma matrix_form_grover_0_prop0:  @exp_val_meas_matrix 2 observable_0 (grover_matrix_op_0 (eq_sup_2_q)  0) =  ((sin (INR (2 * 0 + 1) * asin (√ (1 / 4)))) ^ 2)%R.
Proof.
  rewrite sqrt_div. rewrite asin14. rewrite mult_0_r. rewrite plus_0_l. unfold INR. rewrite Rmult_1_l.
  2,3: intuition.
  rewrite sin_PI6.
  unfold exp_val_meas_matrix, observable_0.
  solve_matrix.
  R_field.
Qed.

Lemma matrix_form_grover_0_prop1:  @exp_val_meas_matrix 2 observable_0 (grover_matrix_op_0 (eq_sup_2_q)  1) =  ((sin (INR (2 * 1 + 1) * asin (√ (1 / 4)))) ^ 2)%R.
Proof.
  rewrite one_true_trig_1.
  unfold exp_val_meas_matrix.
  replace (grover_matrix_op_0 eq_sup_2_q 1) with observable_0.
  solve_matrix.
  R_field.
  unfold eq_sup_2_q, grover_matrix_op_0, observable_0.
  solve_matrix.
Qed.

Lemma matrix_form_grover_0_prop2:  @exp_val_meas_matrix 2 observable_0 (grover_matrix_op_0 (eq_sup_2_q)  2) =  ((sin (INR (2 * 2 + 1) * asin (√ (1 / 4)))) ^ 2)%R.
Proof.
  rewrite one_true_trig_2.
  rewrite grover_0_iter_2.
   unfold exp_val_meas_matrix, observable_0.
  solve_matrix.
  R_field.
Qed.

(* additional, for the S r case *)
Lemma matrix_form_grover_0_prop3:  @exp_val_meas_matrix 2 observable_0 (grover_matrix_op_0 (eq_sup_2_q)  3) =  ((sin (INR (2 * 3 + 1) * asin (√ (1 / 4)))) ^ 2)%R.
Proof.
  rewrite one_true_trig_3.
  rewrite grover_0_iter_3.
   unfold exp_val_meas_matrix, observable_0.
  solve_matrix.
  R_field.
Qed.

Lemma matrix_form_induction_grover_0_correct : forall r:nat, @exp_val_meas_matrix 2 observable_0 (grover_matrix_op_0 (eq_sup_2_q)  r) =  ((sin (INR (2 * r + 1) * asin (√ (1 / 4)))) ^ 2)%R.
Proof.
  intros.
  apply (nat_ind_3 (fun r0 => @exp_val_meas_matrix 2 observable_0 (grover_matrix_op_0 (eq_sup_2_q)  r0) =  ((sin (INR (2 *  r0 + 1) * asin (√ (1 / 4)))) ^ 2)%R) matrix_form_grover_0_prop0 matrix_form_grover_0_prop1 matrix_form_grover_0_prop2 matrix_form_induction_arg).
Qed.

Lemma matrix_form_induction_grover_0_correct_Sr : forall r:nat, (r > 2)%nat -> @exp_val_meas_matrix 2 observable_0 (grover_matrix_op_0 (eq_sup_2_q)  (S r)) =  ((sin (INR (2 * (S r) + 1) * asin (√ (1 / 4)))) ^ 2)%R.
Proof.
  intros.
  induction r.
  inversion H.
  induction r.
  inversion H. inversion H1.
  induction r.
  inversion H. inversion H1. inversion H3.
  apply (nat_ind_3 (fun r0 => @exp_val_meas_matrix 2 observable_0 (grover_matrix_op_0 (eq_sup_2_q)  (S r0)) =  ((sin (INR (2 * (S r0) + 1) * asin (√ (1 / 4)))) ^ 2)%R) matrix_form_grover_0_prop1 matrix_form_grover_0_prop2 matrix_form_grover_0_prop3 matrix_form_induction_arg_Sr).
Qed.

(* Proof of denotational equivalence using the assumption of denotational composition *)
(*-------------------------------------------------------------------------------------*)

Lemma grover_0_comp: forall (r:nat),
      denote_box true (small_grover_iterate_0 (S r)) = denote_box true (small_grover_iterate_0 (r);;(small_grover_iterate_0 (1))).
Proof.
  intros.
  unfold inSeq.
  unfold small_grover_iterate_0.
  unfold unbox.
  autounfold with den_db.
  simpl. reflexivity.
Qed.

(*Proof of the inductive construction of circuits *)
Lemma denote_inductive: forall{W} (f: nat -> Box W W) (r:nat), denote_box true (f (S r)) = denote_box true ((f r);;(f 1%nat)) ->
      (forall k:nat, f (S k) = f k ;; f 1%nat) -> denote_box true (f (S (S r))) = denote_box true ((f (S r));;(f 1%nat)).
Proof. intros. rewrite H0. reflexivity. Qed.

Lemma equiv_transf: forall (A:Type) (f: A -> A) (g: A ->A) (a:A) (b:A), a = b -> (f = g -> f a = g b).
  Proof. intros. rewrite H0. apply cong_eq. apply H. Qed.

 Lemma matrix_equiv_1 : forall (ρ:Density 4), WF_Matrix ρ -> denote_box true (small_grover_iterate_0 1) ρ = super unitary_op_0 ρ.
 Proof.
  matrix_denote.
  (* again, solve matrix takes too long, but can solve this goal; simplifications make it so solve_matrix does not run, or else coq does not recognize them;
  many ways have beenb tried. Regardless, this is solved *)
  (* solve_matrix. R_field.*)
  admit.
  Admitted.

Lemma denotation_matrix_equivalencce_grover_0: forall (r:nat) (ρ:Density 4),  WF_Matrix ρ ->
       denote_box true (small_grover_iterate_0  r) ρ = (grover_matrix_op_0 ρ  r).
Proof.
  intros.
  induction r.
  unfold grover_matrix_op_0.
  matrix_denote. solve_matrix.
  rewrite grover_0_comp.
  rewrite inSeq_correct. 2,3: apply small_grover_iterate_0_WT.
  rewrite inductive_expr.
  unfold compose_super.
  symmetry in IHr.
  rewrite IHr.
  apply matrix_equiv_1.
  apply (WF_denote_box true (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) (small_grover_iterate_0 r) ρ).
  apply small_grover_iterate_0_WT.
  apply H.
Qed.

Lemma circ_induction_grover_0_correct : forall (r:nat), @exp_val_meas_matrix 2 observable_0
  (denote_box true (small_grover_iterate_0  r) (denote equal_superposition (I 1))) =
  ((sin (INR (2 * r + 1) * asin (√ (1 / 4)))) ^ 2)%R.
Proof.
  intros.
  replace  (denote equal_superposition (I 1)) with eq_sup_2_q.
  2: matrix_denote; Msimpl; unfold eq_sup_2_q. 2: solve_matrix.
  rewrite denotation_matrix_equivalencce_grover_0.
  2: { unfold eq_sup_2_q. unfold WF_Matrix. intros. rewrite WF_list2D_to_matrix.
       reflexivity. intuition. intros. destruct H0. symmetry in H0. rewrite H0.
       intuition. inversion H0. symmetry in H1. rewrite H1. reflexivity. inversion H1.
       symmetry in H2. 1: rewrite H2. symmetry in H2. reflexivity. inversion H2.
       symmetry in H3. 1: rewrite H3. symmetry in H3. reflexivity. inversion H3.
       intuition. }
  apply matrix_form_induction_grover_0_correct.
Qed.

  (* -------------------------------------------------------------------------------------------------------------------*)
(* this works, but was only an exetrcise in provability. It was a pain; we are not mean to oeprate witch such large expressions
Lemma period_of_6: forall r, (grover_matrix_op_0 eq_sup_2_q (S (S (S (S (S (S r))))))) = (grover_matrix_op_0 eq_sup_2_q (r)).
  induction r.

  unfold grover_matrix_op_0, super.
  repeat rewrite <- Mmult_assoc.
  replace ( unitary_op_0 × unitary_op_0 × unitary_op_0 × unitary_op_0 × unitary_op_0 × unitary_op_0) with id_4.
  2: { replace (unitary_op_0 × unitary_op_0  × unitary_op_0) with (-1 .* id_4). 2: { unfold id_4. solve_matrix.}
                                                                              unfold unitary_op_0, id_4. solve_matrix.}
  symmetry. only_left. replace ((eq_sup_2_q)) with  (id_4 × eq_sup_2_q). 2: { unfold eq_sup_2_q, id_4. solve_matrix. }
                                                                       replace (id_4 × eq_sup_2_q)  with (-1 .* id_4 × eq_sup_2_q × (unitary_op_0) † × (unitary_op_0) † × (unitary_op_0) †).
  2: rewrite unitary_adj_3_eq. 2: unfold eq_sup_2_q; solve_matrix.
  replace (-1 .* id_4 × eq_sup_2_q × (unitary_op_0) † × (unitary_op_0) † × (unitary_op_0) †)  with ( id_4 × eq_sup_2_q × (unitary_op_0) † × (unitary_op_0) † × (unitary_op_0) † × (unitary_op_0) † × (unitary_op_0) † × (unitary_op_0) †).
  2: rewrite unitary_adj_3_eq. 2: rewrite unitary_adj_3_eq. 2: rewrite unitary_adj_3_eq. 2: unfold id_4, eq_sup_2_q; solve_matrix.
  4: rewrite unitary_adj_3_eq; solve_matrix.
  rewrite Heqm.
  reflexivity.
  2,3,4: replace id_4 with (I 4); try unfold id_4. 3,5,7: solve_matrix.
  1,2,3,4,5: unfold eq_sup_2_q, unitary_op_0, id_4.
  all: try rewrite Mmult_1_l.
  (* unfortunately there is no way to rewrite using matrix solution only replace *)
  (* also, rplace statements once again did not work with some matrices unless unfolded *)
  1, 8:replace (-1 .* list2D_to_matrix [ [C1; C0; C0; C0]; [C0; C1;C0; C0]; [C0; C0; C1; C0]; [C0; C0; C0; C1] ]
     × list2D_to_matrix
         [ [C1 / 4; C1 / 4; C1 / 4; C1 / 4]; [C1 / 4; C1 / 4; C1 / 4; C1 / 4]; [C1 / 4; C1 / 4; C1 / 4; C1 / 4];
         [C1 / 4; C1 / 4; C1 / 4; C1 / 4] ]) with (list2D_to_matrix
         [ [-C1 / 4; -C1 / 4; -C1 / 4; -C1 / 4]; [-C1 / 4; -C1 / 4; -C1 / 4; -C1 / 4]; [-C1 / 4; -C1 / 4; -C1 / 4; -C1 / 4];
           [-C1 / 4; -C1 / 4; -C1 / 4; -C1 / 4] ]).
  2,4: solve_matrix.
  1:{ unfold WF_Matrix. intros. rewrite WF_list2D_to_matrix. reflexivity. intuition. intros. destruct H0. symmetry in H0. rewrite H0. intuition. inversion H0. symmetry in H1. rewrite H1.  reflexivity. inversion H1. symmetry in H2. 1: rewrite H2. symmetry in H2. reflexivity. inversion H2. symmetry in H3. 1: rewrite H3. symmetry in H3. reflexivity. inversion H3. intuition. } solve_matrix.
  (* repeated; not a lot of ways arounnd it I am afraid, unless every statement is very carefully indexed *)
  3:{ unfold WF_Matrix. intros. unfold scale.
      rewrite WF_list2D_to_matrix. C_field. intuition. intros. destruct H0. symmetry in H0. rewrite H0. intuition. inversion H0. symmetry in H1. rewrite H1.  reflexivity. inversion H1. symmetry in H2. 1: rewrite H2. symmetry in H2. reflexivity. inversion H2. symmetry in H3. 1: rewrite H3. symmetry in H3. reflexivity. inversion H3. intuition. } solve_matrix.

  unfold WF_Matrix. intros. rewrite WF_list2D_to_matrix. reflexivity. intuition. intros. destruct H0. symmetry in H0. rewrite H0. intuition. inversion H0. symmetry in H1. rewrite H1.  reflexivity. inversion H1. symmetry in H2. 1: rewrite H2. symmetry in H2. reflexivity. inversion H2. symmetry in H3. 1: rewrite H3. symmetry in H3. reflexivity. inversion H3. intuition. solve_matrix.
  unfold WF_Matrix. intros. rewrite WF_list2D_to_matrix. reflexivity. intuition. intros. destruct H0. symmetry in H0. rewrite H0. intuition. inversion H0. symmetry in H1. rewrite H1.  reflexivity. inversion H1. symmetry in H2. 1: rewrite H2. symmetry in H2. reflexivity. inversion H2. symmetry in H3. 1: rewrite H3. symmetry in H3. reflexivity. inversion H3. intuition. solve_matrix.
  unfold WF_Matrix. intros. unfold scale. rewrite WF_list2D_to_matrix. C_field. intuition. intros. destruct H0. symmetry in H0. rewrite H0. intuition. inversion H0. symmetry in H1. rewrite H1.  reflexivity. inversion H1. symmetry in H2. 1: rewrite H2. symmetry in H2. reflexivity. inversion H2. symmetry in H3. 1: rewrite H3. symmetry in H3. reflexivity. inversion H3. intuition. solve_matrix.
  unfold WF_Matrix. intros. rewrite WF_list2D_to_matrix. reflexivity. intuition. intros. destruct H0. symmetry in H0. rewrite H0. intuition. inversion H0. symmetry in H1. rewrite H1.  reflexivity. inversion H1. symmetry in H2. 1: rewrite H2. symmetry in H2. reflexivity. inversion H2. symmetry in H3. 1: rewrite H3. symmetry in H3. reflexivity. inversion H3. intuition. solve_matrix.
  unfold WF_Matrix. intros. rewrite WF_list2D_to_matrix. reflexivity. intuition. intros. destruct H0. symmetry in H0. rewrite H0. intuition. inversion H0. symmetry in H1. rewrite H1.  reflexivity. inversion H1. symmetry in H2. 1: rewrite H2. symmetry in H2. reflexivity. inversion H2. symmetry in H3. 1: rewrite H3. symmetry in H3. reflexivity. inversion H3. intuition. solve_matrix.
  unfold WF_Matrix. intros. rewrite WF_list2D_to_matrix. reflexivity. intuition. intros. destruct H0. symmetry in H0. rewrite H0. intuition. inversion H0. symmetry in H1. rewrite H1.  reflexivity. inversion H1. symmetry in H2. 1: rewrite H2. symmetry in H2. reflexivity. inversion H2. symmetry in H3. 1: rewrite H3. symmetry in H3. reflexivity. inversion H3. intuition.
   rewrite inductive_expr.
   symmetry.
   rewrite inductive_expr.
   apply cong_eq.
   symmetry.
   apply IHr.
Qed.

(------------------------------------------------------------------------------------)
(------------------------------------------------------------------------------------)
Failed or unnecessary lemmas to be taken up later, possibly:

Lemma small_grover_general_correct_prob_1_3  : forall (r:nat) g, In g f_list -> (r > 0)%nat -> (r < 4)%nat ->
    Rsum 4 (fun z => if g z
              then (@prob_partial_meas_matrix 2 0
    (basis_matrix_4 z)
    (denote (small_grover_general_i_rots g r) (denote equal_superposition (I 1)))) else 0)
               =
                 ((sin ( INR (2 * r + 1) * asin (√ (INR (count g 0 (4)) / 4)))) ^ 2)%R.
Proof.
  intros.
  induction r.
  inversion H0.
  induction r.
  replace ((⟦ small_grover_general_i_rots g 1 ⟧) ((⟦ equal_superposition ⟧) (I 1))) with ((⟦ small_grover_total g⟧) (I 1)).
  2:  symmetry; apply small_grover_general_rot_equality; apply H.
  apply Grover2QubitGeneral.small_grover_general_correct_prob_simpl; apply H.
  destruct r.
  induction H. symmetry in H. rewrite H.
  2:  destruct H. 2: symmetry in H. 2: rewrite H.
  3:  destruct H. 3: symmetry in H. 3: rewrite H.
  4:  destruct H. 4: symmetry in H. 4: rewrite H.
  5:  destruct H. 5: symmetry in H. 5: rewrite H.
  6:  destruct H. 6: symmetry in H. 6: rewrite H.
  7:  destruct H. 7: symmetry in H. 7: rewrite H.
  8:  destruct H. 8: symmetry in H. 8: rewrite H.
  9:  destruct H. 9: symmetry in H. 9: rewrite H.
  10:  destruct H. 10: symmetry in H. 10: rewrite H.
  11:  destruct H. 11: symmetry in H. 11: rewrite H.
  12:  destruct H. 12: symmetry in H. 12: rewrite H.
  13:  destruct H. 13: symmetry in H. 13: rewrite H.
  14:  destruct H. 14: symmetry in H. 14: rewrite H.
  15:  destruct H.
  unfold Rsum, sum_f_R0, count. simpl; unfold prob_partial_meas_matrix. replace ((sin ((1 + 1 + 1 + 1 + 1) * asin (√ (1 / 4))) * (sin ((1 + 1 + 1 + 1 + 1) * asin (√ (1 / 4))) * 1))%R) with (sin ( INR (2 * 2 + 1) * asin (√ (1 / 4))) ^ 2)%R.
  2: { simpl. replace (2 * 2 + 1)%R with (1 + 1 + 1 + 1 + 1)%R by R_field. reflexivity. }
  rewrite one_true_trig_2.
  R_field_simplify.
  replace (denote_box true (small_grover_general_i_rots (fs [0%nat]) 2) (denote_box true equal_superposition (I 1))) with (list2D_to_matrix ( [ [  (RtoC (1 / 4)) ;  (RtoC ((1/4))) ;  (RtoC (-(1 / 4))) ;   (RtoC (-(1/4))) ] ; [   (RtoC ((1/4)));  (RtoC (1 / 4))  ;  (RtoC (-(1/4))) ; (RtoC (-(1 / 4)))  ]  ; [ (RtoC (-(1 / 4)))  ;  (RtoC (-(1/4))) ; (RtoC ((1 / 4)))  ;  (RtoC ((1/4))) ] ; [   (RtoC (-(1/4))) ; (RtoC (-(1 / 4))) ;  (RtoC ((1/4)));  (RtoC (1 / 4)) ] ] ))%M. 2: symmetry; apply small_grover_2_rots_0.
  solve_matrix. R_field. Admitted.

Definition operator_single_rot_0 : Square 4 :=
        (list2D_to_matrix ( [ [ ((1/2)); (-(1/2)) ; (-(1/2)) ; (1/2) ] ; [ (1/2) ; (-(1/2)) ;(1/2); (1/2)]  ; [ (1/2) ; (1/2) ; (-(1/2)) ; (1/2) ] ; [ (1/2) ; (1/2) ; (1/2) ; (-(1/2)) ] ] )).

Lemma small_grover_r_single_op: forall (r:nat) (s:Square 4), WF_Matrix s -> (r > 0)%nat ->

    super (unitary_op_0) (denote (small_grover_iterate_0 r) s)
               =
                 (denote (small_grover_iterate_0 (S r))) s.
Proof.
  intros.
  destruct r.
  inversion H0.
  destruct r.
  unfold operator_single_rot_0.

  matrix_denote.
  Msimpl.
  admit.
  solve_matrix.
  destruct (fs [0%nat] 0), (fs [0%nat] 1), (fs [0%nat] 2),  (fs [0%nat] 3).
  1: rewrite small_grover_general_rot_equality.
  replace ((⟦ small_grover_total (fs [0%nat]) ⟧) (I 1)) with (list2D_to_matrix ( [ [ C1 ; C0 ; C0 ; C0 ] ; [ C0 ; C0 ; C0 ; C0 ]  ; [ C0 ; C0 ; C0 ; C0 ] ; [ C0 ; C0 ; C0 ; C0 ] ] )).
  2: symmetry. 2: apply Grover2QubitGeneral.prob_matrix_0.
  unfold super.
  matrix_denote.
  solve_matrix.
  all: try C_field_simplify. all: try replace ((/ C2) ^* ) with (/ C2). all: try C_field_simplify. all: try reflexivity.

  Lemma small_grover_rotations_single_op: forall (r:nat) g, In g f_list -> (r > 0)%nat ->

    super (match_operator_single_rot g) (denote (small_grover_general_i_rots g r) (I 1))
               =
                 (denote (small_grover_general_i_rots g (S r))) (I 1).
Lemma small_grover_general_periodic : forall (r:nat) g, In g f_list -> (r > 0)%nat ->

    (denote (small_grover_general_i_rots g r) (I 1))
               =
                 (denote (small_grover_general_i_rots g (S (S (S (S (S (S r)))))) ) (I 1)).
Proof.
  intros.
  destruct r.
  inversion H0.
  destruct r.
  rewrite small_grover_general_rot_equality.
  2: apply H.
  induction H. symmetry in H. rewrite H.
  2:  destruct H. 2: symmetry in H. 2: rewrite H.
  3:  destruct H. 3: symmetry in H. 3: rewrite H.
  4:  destruct H. 4: symmetry in H. 4: rewrite H.
  5:  destruct H. 5: symmetry in H. 5: rewrite H.
  6:  destruct H. 6: symmetry in H. 6: rewrite H.
  7:  destruct H. 7: symmetry in H. 7: rewrite H.
  8:  destruct H. 8: symmetry in H. 8: rewrite H.
  9:  destruct H. 9: symmetry in H. 9: rewrite H.
  10:  destruct H. 10: symmetry in H. 10: rewrite H.
  11:  destruct H. 11: symmetry in H. 11: rewrite H.
  12:  destruct H. 12: symmetry in H. 12: rewrite H.
  13:  destruct H. 13: symmetry in H. 13: rewrite H.
  14:  destruct H. 14: symmetry in H. 14: rewrite H.
  15:  destruct H.
   again, rewrite does not recognize the appropriate terms, unfortunately.
  1: { replace((⟦ small_grover_total (fs [0%nat]) ⟧) (I 1))  with(list2D_to_matrix ( [ [ C1 ; C0 ; C0 ; C0 ] ; [ C0 ; C0 ; C0 ; C0 ]  ; [ C0 ; C0 ; C0 ; C0 ] ; [ C0 ; C0 ; C0 ; C0 ] ] )).
  2: symmetry. 2: apply Grover2QubitGeneral.prob_matrix_0. matrix_denote. symmetry. Msimpl. solve_matrix.

Lemma small_grover_general_correct_prob  : forall (r:nat) g, In g f_list -> (r > 0)%nat ->
    Rsum 4 (fun z => if g z
              then (@prob_partial_meas_matrix 2 0
    (basis_matrix_4 z)
    (denote (small_grover_general_r_rots g r) (I 1))) else 0)
               =
                 ((sin ( INR (2 * r + 1) * asin (√ (INR (count g 0 (4)) / 4)))) ^ 2)%R.
Proof.
  intros.
  induction r.
  inversion H0.
  induction r.
  replace ((⟦ small_grover_general_i_rots g 1 ⟧) (I 1)) with ((⟦ small_grover_total g⟧) (I 1)).
  2:  symmetry; apply small_grover_general_correct_prob_simpl; apply H.
  apply Grover2QubitGeneral.small_grover_general_correct_prob_simpl; apply H.

  replace

Lemma small_grover_general_periodic : forall (r:nat) g, In g f_list -> (r > 0)%nat ->

    (denote (small_grover_general_i_rots g r) (I 1))
               =
                 (denote (small_grover_general_i_rots g (S (S r)) ) (I 1)).
Proof.
  intros.
  destruct r.
  inversion H0.
  induction H. symmetry in H. rewrite H.
  2:  destruct H. 2: symmetry in H. 2: rewrite H.
  3:  destruct H. 3: symmetry in H. 3: rewrite H.
  4:  destruct H. 4: symmetry in H. 4: rewrite H.
  5:  destruct H. 5: symmetry in H. 5: rewrite H.
  6:  destruct H. 6: symmetry in H. 6: rewrite H.
  7:  destruct H. 7: symmetry in H. 7: rewrite H.
  8:  destruct H. 8: symmetry in H. 8: rewrite H.
  9:  destruct H. 9: symmetry in H. 9: rewrite H.
  10:  destruct H. 10: symmetry in H. 10: rewrite H.
  11:  destruct H. 11: symmetry in H. 11: rewrite H.
  12:  destruct H. 12: symmetry in H. 12: rewrite H.
  13:  destruct H. 13: symmetry in H. 13: rewrite H.
  14:  destruct H. 14: symmetry in H. 14: rewrite H.
  15:  destruct H.
  1: { matrix_denote. solve_matrix.

Lemma small_grover_2_rots_0 :
  denote (small_grover_general_i_rots (fs [0%nat]) 2) (denote equal_superposition (I 1)) =  list2D_to_matrix ( [ [  (RtoC (1 / 4)) ;  (RtoC ((1/4))) ;  (RtoC (-(1 / 4))) ;   (RtoC (-(1/4))) ] ; [   (RtoC ((1/4)));  (RtoC (1 / 4))  ;  (RtoC (-(1/4))) ; (RtoC (-(1 / 4)))  ]  ; [ (RtoC (-(1 / 4)))  ;  (RtoC (-(1/4))) ; (RtoC ((1 / 4)))  ;  (RtoC ((1/4))) ] ; [   (RtoC (-(1/4))) ; (RtoC (-(1 / 4))) ;  (RtoC ((1/4)));  (RtoC (1 / 4)) ] ] ).
Proof.
  matrix_denote.
  Msimpl.
Admitted.

Lemma super_over_denotation_0: forall s r,
                                 super (list2D_to_matrix [ [  (RtoC (1 / 4)) ;  (RtoC ((1/4))) ;  (RtoC (-(1 / 4))) ;   (RtoC (-(1/4))) ] ; [   (RtoC (-(1/4)));  (RtoC (1 / 4))  ;  (RtoC (-(1/4))) ; (RtoC (-(1 / 4)))  ]  ; [ (RtoC ((1 / 4)))  ;  (RtoC ((1/4))) ; (RtoC (-(1 / 4)))  ;  (RtoC ((1/4))) ] ; [   (RtoC ((1/4))) ; (RtoC ((1 / 4))) ;  (RtoC ((1/4)));  (RtoC (-(1 / 4)))] ] ) (denote (small_grover_general_i_rots (fs [0%nat]) (r)) s) =
                                   (denote (small_grover_general_i_rots (fs [0%nat]) (S r)) s).
Proof.
   destruct r. matrix_denote. solve_matrix.
*)


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  zNil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma append_assoc: forall l1 l2 l3,
  append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
induction l1.
  - simpl. intros. rewrite IHl1. reflexivity.
  - reflexivity.
Qed.

Lemma lem: forall l n, Cons n (rev l) = rev (append l (Cons n Nil)).
Proof.
intros. induction l.
  - simpl. rewrite <- IHl. reflexivity.
  - reflexivity.
Qed.

Lemma lem2: forall l, rev (rev l) = l.
Proof.
induction l.
  - simpl. rewrite <- lem. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Lemma lem3: forall l, append l Nil = l.
Proof.
induction l.
  - simpl. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (append (rev x) (rev y))) (append y x).
Proof.
 induction x.
 - intros. simpl. rewrite <- append_assoc. simpl.
   rewrite lem. rewrite IHx. rewrite <- append_assoc. reflexivity.
 - intros. simpl. rewrite lem2. lfind. Admitted.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.time prosa.classic.model.arrival.basic.task prosa.classic.model.arrival.basic.job prosa.classic.model.arrival.basic.arrival_sequence.
Require Import prosa.classic.model.schedule.uni.schedule.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

Module ScheduleOfTask.

  Export SporadicTaskset UniprocessorSchedule.

  (* In this section, we define properties about schedules of tasks. *)
  Section ScheduleProperties.

    Context {Task: eqType}.
    Context {Job: eqType}.
    Variable job_cost: Job -> time.
    Variable job_task: Job -> Task.

    (* Consider any uniprocessor schedule. *)
    Variable sched: schedule Job.

    Section TaskProperties.

      (* Let tsk be any task. *)
      Variable tsk: Task.

      (* Next we define whether a task is scheduled at time t, ... *)
      Definition task_scheduled_at (t: time) :=
        if sched t is Some j then
          job_task j == tsk
        else false.

      (* ...which also corresponds to the instantaneous service it receives. *)
      Definition task_service_at (t: time) : time := task_scheduled_at t.

      (* Based on the notion of instantaneous service, we define the
         cumulative service received by tsk during any interval [t1, t2)... *)
      Definition task_service_during (t1 t2: time) :=
        \sum_(t1 <= t < t2) task_service_at t.

      (* ...and the cumulative service received by tsk up to time t2,
         i.e., in the interval [0, t2). *)
      Definition task_service (t2: time) := task_service_during 0 t2.

    End TaskProperties.

  End ScheduleProperties.

End ScheduleOfTask.


Require Import List EqdepClass.
Require Export EquivDec.
Require Import Decidables.

Set Implicit Arguments.
Set Strict Implicit.

Section fin.
  Variable A : Type.

  Inductive fin : list A -> Type :=
  | FO : forall x ls, fin (x :: ls)
  | FS : forall x ls, fin ls -> fin (x :: ls).

  Fixpoint lift (ls : list A) e : fin ls -> fin (e ++ ls) :=
    match e as e return fin ls -> fin (e ++ ls) with
      | nil => fun x => x
      | a :: b => fun x => FS a (@lift ls b x)
    end.

  Definition finOut ls (f : fin ls) : match ls return fin ls -> Type with
                                        | nil => fun _ => Empty_set
                                        | _ => fun f => {f' : _ & f = FS _ f'} + {f = FO _ _}
                                      end f :=
  match f with
    | FO _ _ => inright _ (refl_equal _)
    | FS _ _ f' => inleft _ (existT _ f' (refl_equal _))
  end.

  Definition finIfz t (ls : list A) (d : fin (t :: ls))
    : forall (R : fin (t :: ls) -> Type) (h : R (@FO _ _)) (n : forall c, R (@FS _ _ c)),
    R d :=
    match d as d' in fin ls' return match ls' return fin ls' -> Type with
                                | nil => fun _ => Empty_set
                                | a :: b => fun d =>
                                  forall (R : fin (a :: b) -> Type) (h : R (@FO _ _)) (n : forall c, R (@FS _ _ c)), R d
                              end d'
      with
      | FO _ _ => fun _ h _ => h
      | FS _ _ x => fun _ _ f => f x
    end.

  Definition finArg ls (f : fin ls) : option (fin (tl ls)) :=
    match f with
      | FO _ _ => None
      | FS _ _ f' => Some f'
    end.

  Lemma fin_inj : forall z ls (x y : fin ls),
    x <> y
    -> FS z x <> FS z y.
    red; intros.
    assert (finArg (FS z x) = finArg (FS z y)) by congruence.
    simpl in *; congruence.
  Qed.

  Hint Immediate fin_inj.

  Definition finEq : forall ls (x y : fin ls), {x = y} + {x <> y}.
    refine (fix finEq ls : forall x y : fin ls, {x = y} + {x <> y} :=
      match ls return forall x y : fin ls, {x = y} + {x <> y} with
        | nil => fun x _ => match finOut x with end
        | _ :: _ => fun x y => match finOut x, finOut y with
                                 | inleft (existT x' _), inleft (existT y' _) => if finEq _ x' y' then left _ _ else right _ _
                                 | inright _, inright _ => left _ _
                                 | _, _ => right _ _
                               end
      end); clear finEq; (subst; auto; try congruence;
        match goal with
          | [ H : sigT _ |- _ ] => destruct H
        end; subst; discriminate).
  Defined.

  Global Instance EquivDec_fin ls : EqDec (fin ls) (@eq _) :=
  { equiv_dec := @finEq ls }.

  Definition dcomp_option T (a b : T) (d : dcomp a b) : option (a = b) :=
    match d with
      | Eq pf => Some pf
      | _ => None
    end.

  Global Instance Comparable_fin ls : Comparable (fin ls).
  constructor.
  refine ((fix finCmp ls (x : fin ls) : forall y : fin ls, dcomp x y :=
    match x in fin ls return forall y : fin ls, dcomp x y with
      | FO a b => fun y : fin (a :: b) =>
        @finIfz _ _ y (dcomp (FO a b)) (Eq (refl_equal _)) (fun _ => Lt _ _)
      | FS a ls r => fun y : fin (a :: ls) =>
        @finIfz _ _ y (dcomp (FS a r)) (Gt _ _)
          (fun r' => match finCmp _ r r' with
                       | Eq pf => Eq (match pf in _ = t return FS a r = FS a t with
                                        | refl_equal => refl_equal _
                                      end)

                       | Gt => Gt _ _
                       | Lt => Lt _ _
                     end)
    end) ls).
  Defined.

  Fixpoint get (ls : list A) : fin ls -> A :=
    match ls return fin ls -> A with
      | nil => fun f => match f in fin N return match N with
                                                  | nil => A
                                                  | _ => unit
                                                end with
                          | FO _ _ => tt
                          | FS _ _ _ => tt
                        end
      | x :: ls' => fun f => match f in fin N return match N with
                                                       | nil => Empty_set
                                                       | _ :: ls' => (fin ls' -> A) -> A
                                                     end with
                               | FO _ _ => fun _ => x
                               | FS _ _ f' => fun get_ls' => get_ls' f'
                             end (@get ls')
    end.

  Fixpoint liftD (ls : list A) e : forall i : fin ls, { x : fin (e ++ ls) & get x = get i } :=
    match e as e return forall i : fin ls, { x : fin (e ++ ls) & get x = get i } with
      | nil => fun x => existT _ x (refl_equal _)
      | a :: b => fun x =>
        match @liftD ls b x with
          | existT x pf =>
            existT _ (FS a x) (match pf in _ = t
                                 return get (FS a x) = t with
                                 | refl_equal => refl_equal _
                               end)
        end
    end.

  Fixpoint pf_list_simpl A b c (a : list A) : (a ++ b :: nil) ++ c = a ++ b :: c :=
    match a as a return (a ++ b :: nil) ++ c = a ++ b :: c with
      | nil => refl_equal (nil ++ b :: nil ++ c)
      | a' :: b' => match eq_sym (@pf_list_simpl A b c b') in _ = t return a' :: t = a' :: b' ++ b :: c
                      with
                      | refl_equal => refl_equal _
                    end
    end.

  Fixpoint fin_remove (U : Type) ls t ls' : forall (f : fin (ls ++ t :: ls')),
    (t = get f -> U) -> (forall f' : fin (ls ++ ls'), get f' = get f -> U) -> U :=
    match ls as ls
      return forall f : fin (ls ++ t :: ls'), (t = get f -> U) -> (forall f' : fin (ls ++ ls'), get f' = get f -> U) -> U
      with
      | nil => fun (f : fin (t :: ls')) =>
        match f in fin z
          return match z with
                   | nil => unit
                   | a :: b => (a = get f -> U) -> (forall f' : fin b, get f' = get f -> U) -> U
                 end
          with
          | FO _ _ => fun D _ => D refl_equal
          | FS _ _ f => fun _ F => F _ refl_equal
        end
      | a :: b => fun (f : fin (a :: b ++ t :: ls')) D F =>
        match finOut f with
          | inleft s =>
            @fin_remove _ _ _ _ (projT1 s)
              (match eq_sym (projT2 s) in _ = t' return (t = get t' -> U) -> (t = get (projT1 s)) -> U with
                 | refl_equal => fun x => x
               end D)
              (fun x' pf => F (FS _ x')
                match eq_sym (projT2 s) in _ = t return get (FS a x') = get t with
                  | refl_equal => pf
                end)
          | inright l => F (FO _ _) match eq_sym l in _ = t return get (FO _ _) = get t with
                                      | refl_equal => refl_equal
                                    end
        end
    end.

  Fixpoint fin_remove_range' (U : Type) ls'' ls' : forall (f : fin (ls'' ++ ls')),
    (forall x' : fin ls'', get x' = get f -> U) -> (forall f' : fin (ls'), get f' = get f -> U) -> U :=
    match ls'' as ls''
      return forall f : fin (ls'' ++ ls'), (forall x' : fin ls'', get x' = get f -> U) -> (forall f' : fin ls', get f' = get f -> U) -> U
      with
      | nil => fun (f : fin ls') => fun _ z => z f refl_equal
      | a :: b => fun (f : fin (a :: b ++  ls')) D F =>
        match finOut f with
          | inleft s =>
            @fin_remove_range' _ b ls' (projT1 s)
              (fun x' pf => D (FS _ x') match eq_sym (projT2 s) in _ = t return get (FS a x') = get t with
                                          | refl_equal => pf
                                        end)
              (fun x' pf => F x' match eq_sym (projT2 s) in _ = t return get x' = get t with
                                   | refl_equal => pf
                                 end)
          | inright l => D (FO _ _) match eq_sym l in _ = t return get (FO a b) = get t with
                                      | refl_equal => refl_equal
                                    end
        end
    end.

  Fixpoint fin_remove_range (U : Type) ls ls'' ls' : forall (f : fin (ls ++ ls'' ++ ls')),
    (forall x' : fin ls'', get x' = get f -> U) -> (forall f' : fin (ls ++ ls'), get f' = get f -> U) -> U :=
    match ls as ls
      return forall f : fin (ls ++ ls'' ++ ls'), (forall x' : fin ls'', get x' = get f -> U) -> (forall f' : fin (ls ++ ls'), get f' = get f -> U) -> U
      with
      | nil => fun (f : fin (ls'' ++ ls')) => @fin_remove_range' U ls'' ls' f
      | a :: b => fun (f : fin (a :: b ++ ls'' ++  ls')) D F =>
        match finOut f with
          | inleft s =>
            @fin_remove_range _ _ _ _ (projT1 s)
              (fun x' pf => D x' match eq_sym (projT2 s) in _ = t return get x' = get t with
                                   | refl_equal => pf
                                 end)
              (fun x' pf => F (FS _ x') match eq_sym (projT2 s) in _ = t return get (FS _ x') = get t with
                                          | refl_equal => pf
                                        end)
          | inright l => F (FO _ _)
              match eq_sym l in _ = t return get (FO _ _) = get t with
                | refl_equal => refl_equal
              end
        end
    end.

  Fixpoint liftDmid (ls ls' : list A) e : forall (i : fin (ls' ++ ls)),
    { x : fin (ls' ++ e ++ ls) & get x = get i }.
  refine (
    match ls' as ls' return forall (i : fin (ls' ++ ls)),
      { x : fin (ls' ++ e ++ ls) & get x = get i } with
      | nil => fun i => liftD e i
      | a :: b => fun i : fin (a :: b ++ ls) =>
        match finOut i with
          | inleft (existT r pf) =>
            match liftDmid ls b e r with
              | existT rr pf' =>
                @existT _ _ (FS a rr) _
            end
          | inright pf => @existT _ _ (FO _ _) _
        end
    end).
  rewrite pf; simpl; assumption.
  rewrite pf; reflexivity.
  Defined.

  Fixpoint liftDend (ls : list A) e (i : fin ls) :
    { x : fin (ls ++ e) & get x = get i } :=
    match i as i in fin ls return { x : fin (ls ++ e) & get x = get i } with
      | FO _ _ => existT _ (FO _ _) refl_equal
      | FS _ _ f =>
        match liftDend e f with
         | existT _ e => existT _ (FS _ _) e
        end
    end.

  Section liftD_Proofs.
    Variable EQ : EqDec A (@eq A).

    Lemma liftD_liftD_app : forall (a z y : list A) x0,
      projT1 (liftD y (projT1 (liftD a x0))) =
      match app_assoc_reverse y a z in (_ = t) return (fin t) with
        | eq_refl => projT1 (liftD (y ++ a) x0)
      end.
    Proof.
      induction y; simpl in *; uip_all.
        simpl in *. uip_all. reflexivity.
        simpl in *. case_eq (liftD y (projT1 (liftD a x0))).
        simpl. intros. assert (projT1 (liftD y (projT1 (liftD a x0))) = x).
        rewrite H; auto.
        rewrite IHy in H0. subst.
        destruct (liftD (y ++ a) x0). simpl. uip_all.
        generalize e e2. rewrite <- e2. uip_all. reflexivity.
    Qed.

    Lemma liftDmid_lift_nil : forall (a b : list A) x0,
      projT1 (liftDmid a b nil x0) = x0.
    Proof.
      induction b; simpl; intros; auto.
      destruct (finOut x0). destruct s. subst.
      specialize (IHb x). destruct (liftDmid a b nil x). simpl in *. subst; auto.

      subst. simpl. reflexivity.
    Qed.

    Lemma liftDmid_liftDmid_app : forall x y z a x0,
      projT1 (liftDmid (a ++ z) x y (projT1 (liftDmid z x a x0)))
      = match app_ass _ _ _ in _ = t return fin (_ ++ t) with
          | refl_equal => projT1 (liftDmid z x (y ++ a) x0)
        end.
    Proof.
      induction x.
        simpl; intros; apply liftD_liftD_app.
        intros. simpl in x0. destruct (finOut x0).

        destruct s. specialize (IHx y z a0 x1). subst. simpl in *.
        destruct (liftDmid z x a0 x1); simpl in *. destruct (liftDmid (a0 ++ z) x y x0); simpl in *.
        subst. destruct (liftDmid z x (y ++ a0) x1). simpl. uip_all. generalize e2 x2. rewrite e2.
        intros. rewrite (UIP_refl e3). reflexivity.

        subst; simpl. uip_all. generalize e. rewrite e. uip_all. reflexivity.
    Qed.
  End liftD_Proofs.

  Variable B : A -> Type.

  Inductive hlist : list A -> Type :=
  | HNil : hlist nil
  | HCons : forall x ls, B x -> hlist ls -> hlist (x :: ls).

  Definition hlist_hd (T : A) (ls : list A) (v : hlist (T :: ls)) : B T :=
    match v in hlist ls return match ls with
                                 | nil => unit
                                 | a :: _ => B a
                               end with
      | HNil => tt
      | HCons _ _ x _ => x
    end.

  Definition hlist_tl (T : A) (ls : list A) (v : hlist (T :: ls)) : hlist ls :=
    match v in hlist ls return match ls with
                                 | nil => unit
                                 | _ :: ls => hlist ls
                               end with
      | HNil => tt
      | HCons _ _ _ x => x
    end.

  Fixpoint hlist_app ll lr : hlist ll -> hlist lr -> hlist (ll ++ lr) :=
    match ll with
      | nil => fun _ x => x
      | _ :: _ => fun l r => HCons (hlist_hd l) (hlist_app (hlist_tl l) r)
    end.

  Fixpoint hlist_All ls (P : forall t, B t -> Prop) (h : hlist ls) {struct h} : Prop :=
    match h with
      | HNil => True
      | HCons _ _ a b => P _ a /\ hlist_All P b
    end.

  Variable dec : forall x (y z : B x), option (y = z).

  Definition hlistEq : forall x (y z : hlist x), option (y = z).
    refine (fix hlistEq x (y : hlist x) : forall z : hlist x, option (y = z) :=
      match y in hlist x return forall z : hlist x, option (y = z) with
        | HNil => fun z => match z in hlist x return match x return hlist x -> Type with
                                                       | nil => fun z => option (HNil = z)
                                                       | _ => fun _ => unit
                                                     end z with
                             | HNil => Some _
                             | _ => tt
                           end
        | HCons _ _ v1 y' => fun z => match z in hlist x return match x return hlist x -> Type with
                                                                  | nil => fun _ => unit
                                                                  | t :: x' => fun z => forall (v1 : B t) (y' : hlist x'),
                                                                    (forall v2, option (v1 = v2))
                                                                    -> (forall z', option (y' = z'))
                                                                    -> option (HCons v1 y' = z)
                                                                end z with
                                        | HNil => tt
                                        | HCons _ _ v2 z' => fun v1 _ dec' self => if dec' v2 then if self z' then Some _ else None else None
                                      end v1 y' (dec v1) (hlistEq _ y')
      end); clear hlistEq; abstract congruence.
  Defined.

  Variable cmp : forall x (y z : B x), dcomp y z.
  Definition hlistCmp : forall x (y z : hlist x), dcomp y z.
    refine (fix hlistCmp x (y : hlist x) : forall z : hlist x, dcomp y z :=
      match y in hlist x return forall z : hlist x, dcomp y z with
        | HNil => fun z => match z in hlist x return match x return hlist x -> Type with
                                                       | nil => fun z => dcomp HNil z
                                                       | _ => fun _ => unit
                                                     end z with
                             | HNil => Eq _
                             | _ => tt
                           end
        | HCons _ _ v1 y' => fun z => match z in hlist x return match x return hlist x -> Type with
                                                                  | nil => fun _ => unit
                                                                  | t :: x' => fun z => forall (v1 : B t) (y' : hlist x'),
                                                                    (forall v2, dcomp v1 v2)
                                                                    -> (forall z', dcomp y' z')
                                                                    -> dcomp (HCons v1 y') z
                                                                end z with
                                        | HNil => tt
                                        | HCons _ _ v2 z' => fun v1 _ cmp' self =>
                                          match cmp' v2 with
                                            | Eq _ =>
                                              match self z' with
                                                | Gt => Gt _ _
                                                | Lt => Lt _ _
                                                | Eq _ => Eq _
                                              end
                                            | Gt => Gt _ _
                                            | Lt => Lt _ _
                                          end
                                      end v1 y' (cmp v1) (hlistCmp _ y')
      end); clear hlistCmp; abstract congruence.
  Defined.

  Variable ocmp : forall x (y z : B x), option (dcomp y z).
  Fixpoint hlistOCmp x (y : hlist x) : forall (z : hlist x), option (dcomp y z).
    refine (
      match y as y in hlist x return forall z : hlist x, option (dcomp y z) with
        | HNil => fun z =>
          match z in hlist x return match x return hlist x -> Type with
                                      | nil => fun z => option (dcomp HNil z)
                                      | _ => fun _ => unit
                                    end z with
            | HNil => Some (Eq _)
            | _ => tt
          end
        | HCons _ _ v1 y' => fun z =>
          match z in hlist x return match x return hlist x -> Type with
                                      | nil => fun _ => unit
                                      | t :: x' => fun z => forall (v1 : B t) (y' : hlist x'),
                                        (forall v2, option (dcomp v1 v2))
                                        -> (forall z', option (dcomp y' z'))
                                        -> option (dcomp (HCons v1 y') z)
                                    end z with
            | HNil => tt
            | HCons _ _ v2 z' => fun v1 _ cmp' self =>
              match cmp' v2 with
                | None =>
                  match self z' with
                    | None => None
                    | Some Gt => Some (Gt _ _)
                    | Some Lt => Some (Lt _ _)
                    | Some (Eq _) => None
                  end
                | Some (Eq _) =>
                  match self z' with
                    | None => None
                    | Some Gt => Some (Gt _ _)
                    | Some Lt => Some (Lt _ _)
                    | Some (Eq _) => Some (Eq _)
                  end
                | Some Gt => Some (Gt _ _)
                | Some Lt => Some (Lt _ _)
              end
          end v1 y' (ocmp v1) (hlistOCmp _ y')
      end); clear hlistOCmp; abstract congruence.
  Defined.

  Fixpoint hlist_get (ls : list A) (i : fin ls) : hlist ls -> B (get i) :=
    match i in fin ls return hlist ls -> B (get i) with
      | FO _ _ => fun hl => hlist_hd hl
      | FS _ _ f' => fun hl => hlist_get f' (hlist_tl hl)
    end.

  Section hlist_Proofs.
    Variable EQ : EqDec A (@eq A).
    Lemma hlist_nil_only : forall (h : hlist nil),
      h = HNil.
    Proof.
      intros.
      change h with (match refl_equal in _ = t return hlist t with
                       | refl_equal => h
                     end).
      generalize (refl_equal (@nil A)). generalize h.
      assert (forall k (h : hlist k) (e : k = nil),
        match e in (_ = t) return (hlist t) with
          | eq_refl => h
        end = HNil).
      destruct h0.
      uip_all. reflexivity.
      congruence.
      eauto.
    Qed.

    Lemma hlist_eta : forall a b (h : hlist (a :: b)),
      h = HCons (hlist_hd h) (hlist_tl h).
    Proof.
      intros.
      assert (forall k (h : hlist k) (e : k = a :: b),
        match e in (_ = t) return (hlist t) with
          | eq_refl => h
        end = HCons (hlist_hd match e in _ = t return hlist t with
                                | eq_refl => h
                              end)
        (hlist_tl match e in _ = t return  hlist t with
                    | eq_refl => h
                  end)).
      destruct h0. congruence.
      intros. inversion e. subst.
      generalize e. uip_all. reflexivity.

      specialize (H _ h (refl_equal _)). assumption.
    Qed.

    Theorem hlist_get_lift : forall ls ls' ls'' (f : fin (ls ++ ls'')) G G' G'',
      hlist_get f (hlist_app G G'') =
      match liftDmid ls'' ls ls' f with
        | existT f' pf =>
          match pf in _ = t return B t with
            | refl_equal =>
              hlist_get f' (hlist_app G (hlist_app G' G''))
          end
      end.
    Proof.
      induction ls. simpl. intros. unfold liftDmid; simpl.
        Focus.
        generalize dependent ls'. induction ls'; simpl; auto.
          intros. specialize (IHls' (hlist_tl G')). rewrite IHls'. destruct (liftD ls' f).
          simpl. generalize (hlist_get x (hlist_app (hlist_tl G') G'')). generalize e. rewrite e.
          intros. rewrite (UIP_refl e0). reflexivity.

        intros. simpl in f. destruct (finOut f). destruct s; subst. simpl.
        specialize (@IHls ls' _ x (hlist_tl G) G' G''). rewrite IHls. clear IHls.
        destruct (liftDmid ls'' ls ls' x). reflexivity.
        subst. reflexivity.
    Qed.

    Theorem hlist_get_lift_end : forall ls' G' ls (f : fin ls) G,
      hlist_get f G =
      match liftDend ls' f with
        | existT f' pf =>
          match pf in _ = t return B t with
            | refl_equal =>
              hlist_get f' (hlist_app G G')
          end
      end.
    Proof.
      clear dec cmp ocmp.
      induction f; simpl; auto.
      destruct f; simpl in *. auto.
      intros. rewrite IHf. clear IHf. destruct (liftDend ls' f).
      generalize e. rewrite <- e. uip_all. auto.
    Qed.

    Lemma hlist_get_remove_range' : forall U a b (A : hlist a) (B' : hlist b) x P
      (D : forall x' : fin a, get x' = get x -> U) F,
      (forall x' (pf : get x' = get x),
        hlist_get x (hlist_app A B') =
          match pf in _ = z return B z with
            | refl_equal => hlist_get x' A
          end ->
        P (D x' pf)) ->
      (forall x' pf,
        hlist_get x (hlist_app A B') =
          match pf in _ = t return B t with
            | refl_equal => hlist_get x' B'
          end ->
        P (F x' pf)) ->
      P (@fin_remove_range' U a b x D F).
    Proof.
      clear dec cmp ocmp.
      induction a; simpl; intros; eauto.
      destruct (finOut x) as [ [ ? ? ] | ? ]; subst; simpl; eauto.
      eapply IHa; eauto.
    Qed.

    Theorem hlist_get_remove_range : forall U a b c (A : hlist a) (B' : hlist b) (C : hlist c) x P (D : forall x' : fin b, get x' = get x -> U) F,
      (forall x' (pf : get x' = get x),
        hlist_get x (hlist_app A (hlist_app B' C)) =
          match pf in _ = z return B z with
            | refl_equal => hlist_get x' B'
          end ->
        P (D x' pf)) ->
      (forall x' pf,
        hlist_get x (hlist_app A (hlist_app B' C)) =
          match pf in _ = t return B t with
            | refl_equal => hlist_get x' (hlist_app A C)
          end ->
        P (F x' pf)) ->
      P (@fin_remove_range U a b c x D F).
    Proof.
      clear dec cmp ocmp.
      induction a; simpl; intros.
      eapply hlist_get_remove_range'; eauto.
      destruct (finOut x); subst; simpl.
        destruct s; subst; simpl. eapply IHa; eauto.
        eapply X0. auto.
    Qed.

  End hlist_Proofs.

  Fixpoint absAll (ls : list A) :
    (hlist ls -> Type) -> Type :=
    match ls return (hlist ls -> Type) -> Type with
      | nil => fun R => R (HNil)
      | a :: b => fun R =>
        forall x : B a, absAll (fun y => R (HCons x y))
    end.

  Fixpoint hlistDestruct (ls : list A) (args : hlist ls) {struct args}
    : forall K : hlist ls -> Type, absAll K -> K args :=
      match
        args as args0 in hlist ls0
          return (forall K : hlist ls0 -> Type, absAll K -> K args0)
        with
        | HNil =>
          fun (K : hlist nil -> Type) (cc : absAll K) => cc
        | HCons x0 ls0 x args =>
          fun (K : hlist (x0 :: ls0) -> Type) (cc : absAll K) =>
            hlistDestruct args
            (fun y : hlist ls0 => K (HCons x y))
            (cc x)
      end.

  Variable a : A.
  Variable b : B a.
  Fixpoint hlistIn (ls : list A) : hlist ls -> Prop :=
    match ls as ls return hlist ls -> Prop with
      | nil => fun _ => False
      | hd :: tl => fun hl =>
        (exists pf : a = hd, hlist_hd hl = match pf in _ = t return B t with
                                             | refl_equal => b
                                           end)
        \/ hlistIn (hlist_tl hl)
    end.

End fin.

Implicit Arguments FO [A x ls].
Implicit Arguments FS [A x ls].
Implicit Arguments finIfz [A t ls].

Implicit Arguments get [A].
Implicit Arguments HNil [A B].
Implicit Arguments HCons [A B x ls].

Section hlist_map.
  Variable A : Type.
  Variable F : A -> Type.
  Variable G : A -> Type.
  Variable ff : forall x, F x -> G x.

  Fixpoint hlist_map (ls : list A) (hl : hlist F ls) {struct hl} : hlist G ls :=
    match hl in @hlist _ _ ls return hlist G ls with
      | HNil => HNil
      | HCons _ _ hd tl =>
        HCons (ff hd) (hlist_map tl)
    end.
End hlist_map.

Section hlist_fold2.
  Variables T U V : Type.
  Variables F G : T -> Type.
  Variable f : U -> forall t : T, F t -> G t -> U.

  Fixpoint hlist_fold2 ls (l : hlist F ls) {struct l} : hlist G ls -> U -> U :=
    match l in hlist _ ls
      return hlist G ls -> U -> U
      with
      | HNil => fun _ acc => acc
      | HCons _ _ fr hr => fun r acc =>
        hlist_fold2 hr (hlist_tl r) (f acc fr (hlist_hd r))
    end.
End hlist_fold2.

Export Decidables.


Require Export List.

Require Import term.
Require Import rpo.

Require Export utils.
Require Export coccinelle_utils.

(** Translation of the specification *)
Module Specif.

  Inductive symb : Set :=
  | id_0
  | id_S
  | id_Nil
  | id_Cons
  | id_true
  | id_false
  | id_sorted
  | id_leq
  | id_length
  | id_insert
  | id_isort
  | id_eq_nat
  .

  Definition arity (f:symb) :=
    match f with
    | id_0 => term_spec.Free 0
    | id_S => term_spec.Free 1
    | id_Nil => term_spec.Free 0
    | id_Cons => term_spec.Free 2
    | id_true => term_spec.Free 0
    | id_false => term_spec.Free 0
    | id_sorted => term_spec.Free 1
    | id_leq => term_spec.Free 2
    | id_length => term_spec.Free 1
    | id_insert => term_spec.Free 2
    | id_isort => term_spec.Free 1
    | id_eq_nat => term_spec.Free 2
    end.

Definition status (f:symb) :=
     match f with
    | id_0 => rpo.Mul
    | id_S => rpo.Mul
    | id_Nil => rpo.Mul
    | id_Cons => rpo.Mul
    | id_true => rpo.Mul
    | id_false => rpo.Mul
    | id_sorted => rpo.Mul
    | id_leq => rpo.Mul
    | id_length => rpo.Mul
    | id_insert => rpo.Mul
    | id_isort => rpo.Mul
    | id_eq_nat => rpo.Mul

    end.
  Definition index (f:symb) :=
     match f with
    | id_0 => 2
    | id_S => 3
    | id_Nil => 4
    | id_Cons => 5
    | id_true => 6
    | id_false => 7
    | id_sorted => 16
    | id_leq => 11
    | id_length => 12
    | id_insert => 17
    | id_isort => 18
    | id_eq_nat => 13
    end.

  Definition max_size := 100.

End Specif.

(* Nat and comparisons *)
Module Nat <: decidable_set.S.

  Definition A:=nat.
  Definition eq_bool := utils.beq_nat.
  Definition eq_bool_ok := utils.beq_nat_ok.

End Nat. (*: decidable_set.S*)

(** Initialisation of Coccinelle *)
Module Symbols <: term_spec.Signature.

  Module Symb <: decidable_set.S.

    Definition A:=Specif.symb.

    Theorem symb_eq_dec: forall x y:A, {x=y}+{x<>y}.
    Proof.
    decide equality.
    Defined.

    Definition eq_bool := utils.eq_bool A symb_eq_dec.
    Definition eq_bool_ok := utils.eq_bool_ok A symb_eq_dec.

  End Symb. (* Symb : decidable_set.S *)

  Definition arity := Specif.arity.

End Symbols. (* Symbols : term_spec.Signature *)

Module Terms <: term_spec.Term := term.Make' Symbols Nat.
Module Rpo := coccinelle_utils.Make Terms.

Export Specif.
Export Rpo.

Theorem prec_eq_status : forall f g, utils.prec_eq symb index f g -> status f = status g.
Proof.
intros f g; case f; case g; reflexivity.
Qed.

Definition P := rpo.Build_Precedence status
    (utils.prec_bool symb index) (utils.prec_bool_ok symb index)  (utils.prec_antisym symb index) (utils.prec_transitive symb index) (utils.prec_eq_bool symb index) (utils.prec_eq_transitive symb index) (utils.prec_eq_refl symb index) (utils.prec_eq_bool_ok symb index) (utils.prec_eq_prec1 symb index) (utils.prec_eq_prec2 symb index) (utils.prec_eq_sym symb index) (utils.prec_not_prec_eq symb index) (prec_eq_status).

Notation less := (rpo_mul P (bb (empty_rpo_infos P max_size))).

(* Coq version of the specification. *) (* TODO: should be in Spec module but model_* *)

Fixpoint model_nat (v: nat): term :=
match v with
| O => (Term id_0 nil)
| (S x) => let x' := model_nat x in   (Term id_S (x'::nil))
 end.

Fixpoint model_bool (v: bool): term :=
match v with
|true => (Term id_true nil)
|false => (Term id_false nil)
end.

Inductive list : Set :=
|Nil : list
|Cons : nat -> list -> list.

Fixpoint model_list (v:list) : term :=
match v with
| Nil => (Term id_Nil nil)
| (Cons x l) => let x' := model_nat x in let l' := model_list l in
(Term id_Cons (x' :: l' :: nil))
end.

Fixpoint eq_nat (n1:nat) (n2:nat): bool :=
match n1, n2 with
| O, O => true
| O, _ => false
| _, O => false
| (S x), (S y) => eq_nat x y
end.

Fixpoint leq (n1:nat) (n2: nat) : bool :=
match n1, n2 with
|O, _ => true
| _, 0 => false
| (S x), (S y) => leq x y
end.

Fixpoint length (l:list): nat :=
match l with
| Nil => O
| Cons _ y => S (length y)
end.

Fixpoint insert (x:nat) (l:list): list :=
match l with
|Nil => Cons x Nil
|Cons h tl => match leq x h with |true => Cons x l |false => Cons h (insert x tl) end
end.

Fixpoint isort (l:list): list:=
match l with
|Nil => Nil
|Cons h tl =>insert h (isort tl)
end.

Definition head_sorted (l : list) : bool := match l with
Cons a (Cons b _) => leq a b | _ => true end.

Fixpoint sorted (l : list) : bool := match l with
Cons a tl => if head_sorted (Cons a tl) then sorted tl else false | Nil => true end.

(** Initialisation of proof process *)
Lemma model_nat_0: model_nat 0 = (Term id_0 nil).
Proof.
auto.
Qed.

Lemma model_nat_S: forall (u1: nat), model_nat (S u1) = (Term id_S ((model_nat u1)::nil)).
Proof.
auto.
Qed.

Lemma model_list_Nil: model_list Nil = (Term id_Nil nil).
Proof.
auto.
Qed.

Lemma model_list_Cons: forall (u1: nat), forall (u2: list), model_list (Cons u1 u2) = (Term id_Cons ((model_nat u1):: (model_list u2)::nil)).
Proof.
auto.
Qed.

Lemma model_bool_true: model_bool true = (Term id_true nil).
Proof.
auto.
Qed.

Lemma model_bool_false: model_bool false = (Term id_false nil).
Proof.
auto.
Qed.

Hint Rewrite model_list_Nil model_list_Cons : model_list.
Hint Rewrite model_nat_0 model_nat_S : model_nat.
Hint Rewrite model_bool_true model_bool_false : model_bool.

Ltac rewrite_model := autorewrite with model_list model_nat model_bool.


Load LFindLoad.
From lfind Require Import LFind.
Require Import Arith.

                    From adtind Require Import goal82.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_2  := ( Cons (Succ (Succ Zero))         (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil))).
Definition lfind_example_3  := ( Cons (Succ Zero) (Cons Zero (Cons Zero (Cons (Succ Zero) Nil)))).
Definition lfind_example_4  := ( Cons (Succ (Succ (Succ Zero))) (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_5  := ( Cons (Succ Zero) Nil).
Definition lfind_example_6  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_7  := ( Cons Zero         (Cons (Succ Zero)            (Cons Zero               (Cons (Succ (Succ (Succ (Succ Zero))))                  (Cons (Succ (Succ Zero)) Nil))))).
Definition lfind_example_8  := ( Cons Zero         (Cons Zero (Cons (Succ (Succ (Succ (Succ (Succ Zero))))) Nil))).
Definition lfind_example_9  := ( Cons Zero (Cons Zero (Cons (Succ Zero) Nil))).
Definition lfind_example_10  := ( Cons Zero (Cons (Succ (Succ Zero)) (Cons (Succ (Succ Zero)) Nil))).
Definition lfind_example_11  := ( Cons Zero Nil).
Definition lfind_example_12  := ( Cons Zero Nil).
Definition lfind_example_13  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_14  := ( Cons Zero         (Cons (Succ (Succ (Succ (Succ Zero))))            (Cons (Succ Zero) (Cons (Succ Zero) (Cons (Succ Zero) Nil))))).
Definition lfind_example_15  := ( Cons Zero Nil).
Definition lfind_example_16  := ( Cons (Succ Zero) Nil).
Definition lfind_example_17  := ( Cons (Succ Zero) Nil).
Definition lfind_example_18  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_19  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_20  := ( Cons (Succ (Succ Zero))         (Cons (Succ (Succ (Succ Zero))) (Cons Zero (Cons Zero Nil)))).
Definition lfind_example_21  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_22  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_23  := ( Cons (Succ (Succ (Succ Zero))) Nil).
Definition lfind_example_24  := ( Cons (Succ (Succ Zero)) (Cons Zero (Cons (Succ Zero) Nil))).
Definition lfind_example_25  := ( Cons (Succ Zero) Nil).
Definition lfind_example_26  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_27  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_28  := ( Cons Zero (Cons Zero (Cons (Succ (Succ Zero)) Nil))).
Definition lfind_example_29  := ( Cons Zero Nil).
Definition lfind_example_30  := ( Cons (Succ (Succ Zero))         (Cons (Succ (Succ (Succ Zero))) (Cons Zero Nil))).
Definition lfind_example_31  := ( Cons (Succ (Succ (Succ Zero))) Nil).
Definition lfind_example_32  := ( Cons Zero Nil).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal82_rev_append_50_append_assoc/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 lfind_example_15 lfind_example_16 lfind_example_17 lfind_example_18 lfind_example_19 lfind_example_20 lfind_example_21 lfind_example_22 lfind_example_23 lfind_example_24 lfind_example_25 lfind_example_26 lfind_example_27 lfind_example_28 lfind_example_29 lfind_example_30 lfind_example_31 lfind_example_32 .