Require Export FunctorCategory Category.Product.
Require Import Common.

Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Local Open Scope functor_scope.

Section Law4.
  Context `{Funext}.
  Variable C1 : PreCategory.
  Variable C2 : PreCategory.
  Variable D : PreCategory.

  Local Open Scope morphism_scope.

  Local Ltac do_exponential4_helper rew_comp :=
    intros; simpl;
    repeat (simpl;
            match goal with
              | _ => reflexivity
              | _ => progress rew_comp
              | _ => rewrite !FIdentityOf
              | _ => rewrite !LeftIdentity
              | _ => rewrite !RightIdentity
              | _ => try_associativity_quick ltac:(f_ap)
              | _ => rewrite !Commutes
              | _ => try_associativity_quick ltac:(rewrite !Commutes)
            end).

  Section functor.
    Local Ltac do_exponential4
      := do_exponential4_helper ltac:(rewrite !FCompositionOf).

    Definition ExponentialLaw4Functor_ObjectOf
    : [C1, [C2, D]]%category -> [C1 * C2, D]%category.
    Proof.
      intro F; hnf in F |- *.
      refine (Build_Functor
                (C1 * C2) D
                (fun c1c2 => F (fst c1c2) (snd c1c2))
                (fun s d m => F (fst d) ₁ (snd m) ∘ (F ₁ (fst m)) (snd s))
                _
                _);
        abstract do_exponential4.
    Defined.

    Definition ExponentialLaw4Functor_MorphismOf
               s d (m : Morphism [C1, [C2, D]] s d)
    : Morphism [C1 * C2, D]
               (ExponentialLaw4Functor_ObjectOf s)
               (ExponentialLaw4Functor_ObjectOf d).
    Proof.
      simpl.
      refine (Build_NaturalTransformation
                (ExponentialLaw4Functor_ObjectOf s)
                (ExponentialLaw4Functor_ObjectOf d)
                (fun c => m (fst c) (snd c))
                _);
        abstract (
            repeat match goal with
                     | [ |- appcontext[ComponentsOf ?T ?x ∘ ComponentsOf ?U ?x] ] =>
                       change (T x ∘ U x) with ((Compose (C := [_, _]) T U) x)
                     | _ => f_ap
                     | _ => rewrite !Commutes
                     | _ => do_exponential4
                   end
          ).
    Defined.

    Definition ExponentialLaw4Functor
    : Functor [C1, [C2, D]] [C1 * C2, D].
    Proof.
      refine (Build_Functor
                [C1, [C2, D]] [C1 * C2, D]
                ExponentialLaw4Functor_ObjectOf
                ExponentialLaw4Functor_MorphismOf
                _
                _);
      abstract by nt_eq.
    Defined.
  End functor.

  Section inverse.
    Local Ltac do_exponential4_inverse
      := do_exponential4_helper ltac:(rewrite <- !FCompositionOf).

    Section ObjectOf.
      Variable F : Functor (C1 * C2) D.

      Definition ExponentialLaw4Functor_Inverse_ObjectOf_ObjectOf
      : C1 -> [C2, D]%category.
      Proof.
        intro c1.
        refine (Build_Functor
                  C2 D
                  (fun c2 => F (c1, c2))
                  (fun s2 d2 m2 => F.(MorphismOf) (s := (c1, s2)) (d := (c1, d2)) (Identity c1, m2))
                  _
                  _);
          abstract do_exponential4_inverse.
      Defined.

      Definition ExponentialLaw4Functor_Inverse_ObjectOf_MorphismOf
                 s d (m : Morphism C1 s d)
      : Morphism [C2, D]
                 (ExponentialLaw4Functor_Inverse_ObjectOf_ObjectOf s)
                 (ExponentialLaw4Functor_Inverse_ObjectOf_ObjectOf d).
      Proof.
        refine (Build_NaturalTransformation
                  (ExponentialLaw4Functor_Inverse_ObjectOf_ObjectOf s)
                  (ExponentialLaw4Functor_Inverse_ObjectOf_ObjectOf d)
                  (fun c => F.(MorphismOf) (s := (s, c)) (d := (d, c)) (m, Identity c))
                  _);
        abstract do_exponential4_inverse.
      Defined.

      Definition ExponentialLaw4Functor_Inverse_ObjectOf
      : [C1, [C2, D]]%category.
      Proof.
        refine (Build_Functor
                  C1 [C2, D]
                  ExponentialLaw4Functor_Inverse_ObjectOf_ObjectOf
                  ExponentialLaw4Functor_Inverse_ObjectOf_MorphismOf
                  _
                  _);
        abstract (nt_eq; do_exponential4_inverse).
      Defined.
    End ObjectOf.

    Section MorphismOf.
      Definition ExponentialLaw4Functor_Inverse_MorphismOf_ComponentsOf
                 s d (m : Morphism [C1 * C2, D] s d)
      : forall c, Morphism [C2, D]
                           ((ExponentialLaw4Functor_Inverse_ObjectOf s) c)
                           ((ExponentialLaw4Functor_Inverse_ObjectOf d) c).
      Proof.
        intro c.
        refine (Build_NaturalTransformation
                  ((ExponentialLaw4Functor_Inverse_ObjectOf s) c)
                  ((ExponentialLaw4Functor_Inverse_ObjectOf d) c)
                  (fun c' => m (c, c'))
                  _).
        abstract do_exponential4_inverse.
      Defined.

      Definition ExponentialLaw4Functor_Inverse_MorphismOf
                 s d (m : Morphism [C1 * C2, D] s d)
      : Morphism [C1, [C2, D]]
                 (ExponentialLaw4Functor_Inverse_ObjectOf s)
                 (ExponentialLaw4Functor_Inverse_ObjectOf d).
      Proof.
        refine (Build_NaturalTransformation
                  (ExponentialLaw4Functor_Inverse_ObjectOf s)
                  (ExponentialLaw4Functor_Inverse_ObjectOf d)
                  (ExponentialLaw4Functor_Inverse_MorphismOf_ComponentsOf m)
                  _).
        abstract (nt_eq; do_exponential4_inverse).
      Defined.
    End MorphismOf.

    Arguments ExponentialLaw4Functor_Inverse_MorphismOf_ComponentsOf / _ _ _ _ .

    Definition ExponentialLaw4Functor_Inverse
    : Functor [C1 * C2, D] [C1, [C2, D]].
    Proof.
      refine (Build_Functor
                [C1 * C2, D] [C1, [C2, D]]
                ExponentialLaw4Functor_Inverse_ObjectOf
                ExponentialLaw4Functor_Inverse_MorphismOf
                _
                _);
      abstract by nt_eq.
    Defined.
  End inverse.
End Law4.


Require Import Coq.omega.Omega.
Require Import MathClasses.interfaces.abstract_algebra MathClasses.theory.ua_packed.
Require MathClasses.interfaces.universal_algebra MathClasses.varieties.monoids.

Notation msig := varieties.monoids.sig.
Notation Op := (universal_algebra.Op msig False).
Notation App := (universal_algebra.App msig False _ _).

Import universal_algebra.

Section contents.
  (* Ideally, we would like to operate exclusively on the universal term representation(s).
   If Coq had decent support for dependent pattern matching, this would be no problem.
   Unfortunately, Coq does not, and so we resort to defining an ad-hoc data type for
   monoidal expressions, with nasty conversions to and from the universal term
   representation(s): *)

  Context (V: Type).

  Notation uaTerm := (universal_algebra.Term0 msig V tt).
  Notation Applied := (@ua_packed.Applied msig V tt).

  Inductive Term := Var (v: V) | Unit | Comp (x y: Term).

  Fixpoint to_ua (e: Term): Applied :=
    match e with
    | Var v => ua_packed.AppliedVar msig v tt
    | Unit => ua_packed.AppliedOp msig monoids.one (ua_packed.NoMoreArguments msig tt)
    | Comp x y => ua_packed.AppliedOp msig monoids.mult
       (MoreArguments msig tt _ (to_ua x) (MoreArguments msig tt _ (to_ua y) (NoMoreArguments msig tt)))
    end.

  Definition from_ua (t: Applied): { r: Term | to_ua r ≡ t }.
  Proof with reflexivity.
    refine (better_Applied_rect msig (λ s,
       match s return (ua_packed.Applied msig s → Type) with
       | tt => λ t, {r : Term | to_ua r ≡ t}
       end) _ _ t).
    simpl.
    intros []; simpl.
     intros.
     exists (Comp (` (fst (forallSplit msig _ _ X)))
       (` ((fst (forallSplit msig _ _ (snd (forallSplit msig _ _ X))))))).
     do 3 dependent destruction x.
     simpl in *.
     destruct X. destruct p, s. destruct s0.
     simpl. subst...
    exists Unit.
    dependent destruction x...
   intros v [].
   exists (Var v)...
  Defined.

  Fixpoint measure (e: Term): nat :=
    match e with
    | Var v => 0%nat
    | Unit => 1%nat
    | Comp x y => S (2 * measure x + measure y)
    end.

  Context `{Monoid M}.

  Notation eval vs := (universal_algebra.eval msig (λ _, (vs: V → M))).

  Program Fixpoint internal_simplify (t: Term) {measure (measure t)}:
      { r: Term | ∀ v, eval v (curry (to_ua r)) = eval v (curry (to_ua t)) } :=
    match t with
    | Var _ => t
    | Unit => t
    | Comp Unit y => internal_simplify y
    | Comp x Unit => internal_simplify x
    | Comp ((Var _) as x) y => Comp x (internal_simplify y)
    | Comp (Comp x y) z => internal_simplify (Comp x (Comp y z))
    end.

  Solve Obligations with (program_simpl; simpl; try apply reflexivity; omega).

  Next Obligation.
   destruct internal_simplify.
   simpl.
   rewrite e.
   transitivity (mon_unit & universal_algebra.eval msig (λ _, v) (curry (to_ua y))).
    symmetry.
    apply left_identity.
   reflexivity.
  Qed.

  Next Obligation.
   destruct internal_simplify.
   simpl.
   rewrite e.
   transitivity (universal_algebra.eval msig (λ _, v) (curry (to_ua x)) & mon_unit).
    symmetry.
    apply right_identity.
   reflexivity.
  Qed.

  Next Obligation. destruct internal_simplify. simpl. rewrite e. reflexivity. Qed.
  Next Obligation. destruct internal_simplify. simpl. rewrite e. simpl. apply associativity. Qed.

  Program Definition simplify (t: uaTerm): { r: uaTerm | ∀ v, eval v r = eval v t } :=
    curry (to_ua (internal_simplify (from_ua (decode0 t)))).

  Next Obligation.
   destruct @internal_simplify. simpl.
   destruct @from_ua in e. simpl in *.
   rewrite e.
   rewrite e0.
   rewrite @curry_decode0.
   reflexivity.
  Qed.

  (* This would be a nice theorem to prove:

  Require varieties.open_terms.

  Instance: Equiv V := eq.

  Goal ∀ (x y: uaTerm), open_terms.ee msig msig monoids.Laws (ne_list.one tt) x y →
   ` (simplify x) ≡ ` (simplify y).
  Proof.

  *)

End contents.


Require Import Morphisms Base.

Definition cup x y := union (pair x y).

Instance Proper_cup : Proper (V_eq ==> V_eq ==> V_eq) cup.
Proof.
unfold cup; repeat intro; repeat f_equiv; assumption.
Qed.

Lemma cup_spec : forall x y z, z ∈ cup x y <-> z ∈ x \/ z ∈ y.
Proof.
intros x y z; split; intro H.
+ apply union_spec in H; destruct H as [u [Hu Hm]].
  apply pair_spec in Hm; destruct Hm as [Hm|Hm];
  rewrite <- Hm; intuition.
+ apply union_spec; destruct H as [Hm|Hm].
  - exists x; split; [assumption|apply pair_spec; left; reflexivity].
  - exists y; split; [assumption|apply pair_spec; right; reflexivity].
Qed.

Lemma cup_idem : forall x, cup x x ≅ x.
Proof.
intros x; apply extensionality; apply included_spec; intros z Hz.
+ apply cup_spec in Hz; intuition.
+ apply cup_spec; intuition.
Qed.

Definition cap x y := comprehension x (fun z => z ∈ y).

Instance Proper_cap : Proper (V_eq ==> V_eq ==> V_eq) cap.
Proof.
intros x1 x2 Hx y1 y2 Hy; unfold cap; f_equiv; [assumption|].
intros z1 z2 Hz; rewrite Hy, Hz; reflexivity.
Qed.

Lemma cap_spec : forall x y z, z ∈ cap x y <-> (z ∈ x /\ z ∈ y).
Proof.
intros x y z; split; intros H.
+ apply comprehension_spec in H; [|intros x1 x2 Hx; rewrite Hx; reflexivity].
  assumption.
+ apply comprehension_spec; [|assumption].
  intros x1 x2 Hx; rewrite Hx; reflexivity.
Qed.


Require Import Eqdep_dec.
Require Import EquivDec.

Section Classes.
  Context {A : Type}.
  Context {dec : EqDec A (@eq A)}.

  Theorem UIP_refl : forall {x : A} (p1 : x = x), p1 = refl_equal _.
    intros.
    eapply UIP_dec. apply equiv_dec.
  Qed.

  Theorem UIP_equal : forall {x y : A} (p1 p2 : x = y), p1 = p2.
    eapply UIP_dec. apply equiv_dec.
  Qed.

  Lemma inj_pair2 :
    forall (P:A -> Type) (p:A) (x y:P p),
      existT P p x = existT P p y -> x = y.
  Proof.
    intros. eapply inj_pair2_eq_dec; auto.
  Qed.

End Classes.

Global Instance option_eqdec T (_ : EqDec T (@eq T)) : EqDec (option T) (@eq (option T)).
  red; refine (
  fun a b =>
    match a, b with
      | None, None => left (refl_equal _)
      | Some a, Some b => match equiv_dec a b with
                            | left pf => left match (pf : a = b) in _ = t return Some a = Some t with
                                                | refl_equal => refl_equal
                                              end
                            | right pf => right (fun pf' => pf _)
                          end
      | None , Some _ => right _
      | Some _ , None => right _
    end).
  inversion pf'; reflexivity.
  abstract (intro; congruence).
  abstract (intro; congruence).
Defined.

(*
Global Instance list_eqdec T (_ : EqDec T (@eq T)) : EqDec (list T) (@eq (list T)).
  red; refine (
  fun a b =>
    match a, b with
      | None, None => left (refl_equal _)
      | Some a, Some b => match equiv_dec a b with
                            | left pf => left _
                            | right pf => right _
                          end
      | _ , _ => right _
    end).
  abstract (rewrite pf; reflexivity).
  abstract (intro H; apply pf; inversion H; reflexivity).
  abstract (intro; congruence).
  abstract (intro; congruence).
Defined.
*)

Ltac notVar X :=
  match X with
    | _ _ => idtac
    | _ _ _ => idtac
    | _ _ _ _ => idtac
    | _ _ _ _ _ => idtac
    | _ _ _ _ _ _ => idtac
    | _ _ _ _ _ _ _ => idtac
    | _ _ _ _ _ _ _ _ => idtac
    | _ _ _ _ _ _ _ _ _ => idtac
    | _ _ _ _ _ _ _ _ _ _ => idtac
    | _ _ _ _ _ _ _ _ _ _ _ => idtac
    | _ _ _ _ _ _ _ _ _ _ _ _ => idtac
    | _ _ _ _ _ _ _ _ _ _ _ _ _ => idtac
    | _ _ _ _ _ _ _ _ _ _ _ _ _ _ => idtac
  end.

Ltac uip_all :=
  repeat match goal with
           | [ H : _ = _ |- _ ] => rewrite H
           | [ |- context [ match ?X in _ = t return _ with
                              | refl_equal => _
                            end ] ] => notVar X; generalize X
           | [ |- context [ eq_rect_r _ _ ?X ] ] => notVar X; generalize X
         end;
  intros;
    repeat match goal with
             | [ H : ?X = ?X |- _ ] => rewrite (UIP_refl H) in *
           end.

Require Export EquivDec.


Require Utf8.

Require Import S00_setoid_basics.

Inductive Identity {A: Set}(x: A) : A -> Set
  := Identity_refl : Identity x x.

Notation "x == y" := (Identity x y)
                       (at level 70, no associativity, only parsing).

Notation "x =={ A } y" := (@Identity A x y)
                            (at level 70, no associativity, only parsing).

Definition rfl {A : Set}{x : A} : x == x
  := Identity_refl x.

Theorem Identity_congr {A B: Set}(f:A -> B)(x y:A):
Identity x y -> Identity (f x) (f y).
Proof.
  intro P. destruct P. apply rfl.
Defined.

Definition Identity_trans  {A: Set}{a b c:A}:
Identity a b -> Identity b c -> Identity a c.
  intros p q. destruct p. apply q.
Defined.

Definition Identity_sym  {A: Set}{a b:A}:
Identity a b -> Identity b a.
  intros p. destruct p. apply rfl.
Defined.

Notation "p ⁻¹" := (Identity_sym p)
                     (at level 3, no associativity).

Notation "p ⊙ᵐ q" := (Identity_trans p q)
                      (at level 34, right associativity).

Notation "f ↱ᵐ p" := (Identity_congr f _ _ p)
                      (at level 100).

Definition ap {A B : Set}{f : A → B}{x x' : A}
  : x == x' → f x == f x'
  := Identity_congr f x x'.

Definition setcmp {A B C : Set}
  : (A → B) → (B → C) → A → C
  := fun f g x => g (f x).

Notation "g · f" := (setcmp f g) (at level 34, right associativity).

Definition transp {A : Set}(B : A → Set){x x' : A} :
  x == x' → B x → B x'.

  intro p. destruct p. apply (λ y, y).
Defined.

Notation "B •ᵐ p" := (transp B p)
                      (at level 9, right associativity).

Definition Identity_congr_dep {A : Set}(B : A → Set)
           (f : ∀ x, B x){x x' : A} :
  ∀ u : x == x', (B•ᵐu (f x)) == (f x').

  intro u. destruct u. apply Identity_refl.
Defined.

Notation "f ↱ᵈᵐ p" := (Identity_congr_dep _ f p)
                        (at level 100).

Definition HIdΠ {A : Set}{B : A → Set}(f f' : ∀ x : A, B x) : Set :=
  ∀ x, f x == f' x.

Definition Id2HΠ {A : Set}{B : A → Set}{f f' : ∀ x : A, B x} :
  f == f' → HIdΠ f f'.

intro p. destruct p. unfold HIdΠ. apply (λ x, Identity_refl (f x)).
Defined.

Definition transpCongr {A : Set}{B : A → Set}{x x' : A}(p : x == x'){y y' : B x}
  : y == y' → B•ᵐp y == B•ᵐp y'.

  intros q. destruct p. apply q.
Defined.

Definition transpIsFunct {A : Set}{B : A → Set}{x x' x'' : A}
           (p : x == x')(q : x' == x'') :
  B•ᵐ(p⊙ᵐq) == B•ᵐq · B•ᵐp.

  destruct p. apply Identity_refl.
Defined.

Definition transpfunct {A : Set}{B : A → Set}{x x' x'' : A}
           (p : x == x')(q : x' == x'')
  : ∀ y y', (B•ᵐq · B•ᵐp) y == y' → B•ᵐ(p⊙ᵐq) y == y'.

  intros y y' r. apply (Identity_trans (b := (B•ᵐq · B•ᵐp) y)).
  apply (Id2HΠ (transpIsFunct p q) y). apply r.
  (*destruct p. apply r.*)
Defined.

Definition transpfunct_rev {A : Set}{B : A → Set}{x x' x'' : A}
           (p : x == x')(q : x' == x''){y : B x}{y' : B x''}
  : B•ᵐ(p⊙ᵐq) y == y' → (B•ᵐq · B•ᵐp) y == y'.

  intros r. apply (Identity_trans (b := B•ᵐ(p⊙ᵐq) y)).
  apply Identity_sym. apply (Id2HΠ (transpIsFunct p q) y).
  apply r.
Defined.

Definition transpEq {A : Set}(B : A → Set){x x' : A}
           (p p' : x == x')(h : p == p') :
  B•ᵐp == B•ᵐp'.

  apply ((λ u, B•ᵐu)↱ᵐh).
Defined.

Definition transpIsEqv1 {A : Set}(B : A → Set){x x' : A}
           (p : x == x') :
  ∀ y, B•ᵐp (B•ᵐp⁻¹ y) == y.

  destruct p. apply Identity_refl.
Defined.

Definition transpIsEqv2 {A : Set}(B : A → Set){x x' : A}
           (p : Identity x x') :
  ∀ y, B•ᵐp⁻¹ (B•ᵐp y) == y.

  destruct p. apply Identity_refl.
Defined.

Definition transpflip {A : Set}(B : A → Set){x x' : A}
           (p : Identity x x')
  : ∀ y y', B•ᵐp y == y' → y == B•ᵐp⁻¹ y'.

  intros y y' q. destruct p. apply q.
Defined.

Definition transpflip_inv {A : Set}(B : A → Set){x x' : A}
           (p : Identity x x')
  : ∀ y y', y == B•ᵐp⁻¹ y' → B•ᵐp y == y'.

  intros y y' q. destruct p. apply q.
Defined.

Definition transpcmp {A : Set}(B : A → Set){x x' x'' : A}
           (p : x == x')(q : x' == x''){y : B x}{y' : B x'}{y'' : B x''}
  : B•ᵐp y == y' → B•ᵐq y' == y'' → B•ᵐ(p⊙ᵐq) y == y''.

  intros r s. apply transpfunct.
  refine (_⊙ᵐs).
  apply transpCongr. apply r.
Defined.

Definition HIdΣ {A : Set}{B : A → Set}(z z' : sigT B) : Set :=
  ∃ p : projT1 z == projT1 z', B•ᵐp (projT2 z) == projT2 z'.

Definition extΣ {A : Set}{B : A → Set}(z z' : sigT B) :
              HIdΣ z z' → z == z'.

  destruct z as [a b]. destruct z' as [a' b'].
  intro r. destruct r as [p q]. simpl in *|-.
  destruct p. destruct q.
  apply rfl.
Defined.

Definition EqOver {A : Set}(B : A → Set){x x' : A}(p : x == x')
  : B x → B x' → Set
  := λ y y', B•ᵐp y == y'.

Notation "y ==[ p ] y'" := (EqOver _ p y y')
  (at level 70, no associativity, only parsing).

Definition TotEq {A : Set}(B : A → Set){x x' : A}
  : x == x' → Set
  := λ p, (sigT (λ z, EqOver B p (fst z) (snd z))).

Definition isTotEq {A : Set}(B : A → Set){x x' : A}(p : x == x')
  : ∀ y : B x, ∀ y' : B x', y ==[p] y' → TotEq B p
  :=  λ y y' q, existT _ (y , y') q.

Definition fstTotEq {A : Set}(B : A → Set){x x' : A}{p : x == x'}
  : TotEq B p → B x
  := λ v, fst (projT1 v).

Definition sndTotEq {A : Set}(B : A → Set){x x' : A}{p : x == x'}
  : TotEq B p → B x'
  := λ v, snd (projT1 v).

Definition eqTotEq {A : Set}(B : A → Set){x x' : A}{p : x == x'}(v : TotEq B p)
  : fstTotEq B v ==[p] sndTotEq B v
  := projT2 v.

Lemma domtransp  {A Y : Set}{B : A → Set}{x x' : A}(p : x == x')
  : ∀ f f', f == f' · B•ᵐp → (λ x, B x → Y)•ᵐp f == f'.
Proof.
  intros f f' q. destruct p. apply q.
Qed.


From FA Require Import String DFA NFA NFA2DFA eNFA eNFA2NFA eNFA2DFA Closure.
From mathcomp Require Import all_ssreflect.
Require Import Relations Classes.Equivalence.

Definition Lang := pred String.

Class MNR (L: Lang): Type :=
  mkMNR
  {
    mnr  : relation String;
    rcong: forall (x y: String) (a: Sigma), mnr x y -> mnr (glue x a) (glue y a);
    refin: forall (x y: String), mnr x y -> x \in L <-> y \in L;
    part : finType;
    pmap : String -> part;
    pmapp: forall (x y: String), mnr x y <-> pmap x = pmap y;
    trans: part -> Sigma -> part
  }.

Lemma EquivMNR: forall (L: Lang) (m: MNR L), Equivalence (@mnr L m).
Proof. intros.
       destruct m.
       unshelve econstructor.
       - unfold Reflexive.
         intro x.
         simpl in *.
         apply <- pmapp0.
         reflexivity.
       - unfold Symmetric.
         intros.
         apply <- pmapp0.
         symmetry.
         apply pmapp0.
         simpl in H.
         exact H.
       - unfold Transitive.
         intros.
         apply <- pmapp0.
         pose proof pmapp0 as pmapp.
         simpl in *.
         specialize (pmapp0 x y).
         specialize (pmapp y z).
         edestruct pmapp0.
         rewrite H1.
         edestruct pmapp.
         rewrite H3.
         reflexivity.
         exact H0.
         exact H.
        (*  Unshelve.
         exact a.
         unshelve econstructor. *)
Qed.

Lemma eta {A B C} (f : A -> B -> C) : (fun x y => f x y) = f.
Proof.
cbv. (* I would like to see f = f now *)
reflexivity. (* this proof works in any case, but sometimes syntax matters (rewriting, match...) *)
Defined.

Definition dfa2mnr (d: dfa): MNR (dfa_language d).
Proof. destruct d as (Q, s, delta, F).
       unshelve econstructor.
       - exact (fun x y => dfa_multistep (mkdfa Q s delta F) s x = dfa_multistep (mkdfa Q s delta F) s y).
       - exact Q.
       - intros x.
         exact (dfa_multistep (mkdfa Q s delta F) s x).
       - simpl. intros.
         rewrite H.
         reflexivity.
       - simpl. intros.
         rewrite !inE.
         split.
         unfold dfa_acceptance.
         simpl. intro Ha.
         move=>/existsP in Ha.
         destruct Ha as (z, Ha).
         apply /existsP.
         exists z.
         rewrite <- H.
         exact Ha.

         simpl. intro Ha.
         move=>/existsP in Ha.
         destruct Ha as (z, Ha).
         apply /existsP.
         exists z.
         rewrite H.
         exact Ha.
       - simpl. intros.
         reflexivity.
       - exact delta.
Defined.

Definition mnr2dfa (L: Lang) (R: MNR L): dfa.
Proof. destruct R as (mnr, rcong, refin, part, pmap, pmapp, trans).
       unshelve econstructor.
       - exact part.
       - exact (pmap eps).
       - intros p c.
         exact (trans p c).
       -
Admitted.


From mathcomp Require Import all_ssreflect ssralg ssrint ssrnum finmap matrix.
From mathcomp Require Import rat interval zmodp vector fieldext falgebra.
From mathcomp Require Import boolp classical_sets functions.
From mathcomp Require Import cardinality set_interval mathcomp_extra.
From mathcomp Require Import ereal reals signed topology prodnormedzmodule.
From mathcomp Require Import normedtype sequences mxalgebra.

Import Order.Theory GRing.Theory Num.Def Num.Theory.
Import numFieldTopology.Exports.
Import numFieldNormedType.Exports.
Import normedtype.NbhsNorm.

Import topology.numFieldTopology.Exports.
Import CompleteNormedModule.Exports.

Local Open Scope ring_scope.

Section Examples.

Variables (R: realType) (m n : nat).
(* test examples of sharing using norm properties from ssrnum*)

Example matrix_triangle  (M N : 'M[R]_(m.+1, n.+1)) :
  `|M + N| <= `|M| + `|N|.
Proof.  apply ler_norm_add. Qed.

Example matrix_norm_positive (A : 'M[R]_(m.+1, n.+1)) :
        0 <= `|A|.
Proof. apply normr_ge0. Qed.

End Examples.

Section Inverse.

Variables (R: realType) (m n : nat).

Lemma eqmx_mulr (b a1 a2: 'M[R]_m.+1) :
        a1 = a2 -> a1 * b = a2 * b.
Proof.
by move => H; rewrite H.
Qed.

Lemma mulr_eqmx : forall  (b a1 a2: 'M[R]_m.+1) ,
        b \is a GRing.unit -> a1 *m b = a2 *m b -> a1 = a2.
Proof.
move => b a1 a2  H1 H2.
have : a1 * b * b^-1 = a2 * b * b^-1 by apply eqmx_mulr; apply H2.
rewrite -!mulrA mulrV // !mulr1 //.
Qed.

Lemma invmx_mul (A B: 'M[R]_m.+1) :
        A \in unitmx -> B \in unitmx ->
        invmx (A *m B) = invmx B *m invmx A.
Proof.
move => H1 H2.
have H3: A *m B \in unitmx by (rewrite unitmx_mul; apply/andP => //=).
have H4: invmx (A *m B) * (A *m B) = invmx B *m invmx A * (A *m B).
 rewrite -mulmxE (mulVmx H3) mulmxE mulrA -mulmxE.
 rewrite -!mulmxA [invmx A *m (A *m B)]mulmxA (mulVmx H1) mul1mx (mulVmx H2) //.
apply (mulr_eqmx _ _ _ H3 H4).
Qed.

Lemma invmx_pert (A E: 'M[R]_m.+1) :
        A \in unitmx -> 1 + invmx A * E \in unitmx ->
        invmx (A + E) = invmx (1 + invmx A * E) * invmx A.
Proof.
move => H1 H2.
have H3: invmx (A + E) = invmx (A * (1 + invmx A * E)).
rewrite mulrDr mulrA mulr1 -mulmxE (mulmxV H1) mul1mx //.
rewrite H3 (invmx_mul _ _ H1) //.
Qed.

End Inverse.

Section MatrixFacts.

Variables (m n : nat) (R: realType).

Variable g : {linear 'rV[R]_m.+1 -> 'rV[R]_n.+1}.

Lemma trmxeq (m' n' : nat) (A B : 'M[R]_(m',n')) : A = B -> A^T = B^T.
Proof. by move => H; rewrite H. Qed.

Lemma trmx_mul_rV_lin1 u : (u *m lin1_mx g)^T = (g u)^T.
Proof. by apply trmxeq; apply mul_rV_lin1. Qed.

Lemma trmxZ a (A : 'M[R]_n) : (a *: A)^T = a *: (A^T).
Proof.  by apply/matrixP =>  k i /[!mxE]. Qed.

End MatrixFacts.

Section Maps.

(** Notes:
 contractive maps are defined in sequences *)
Variables (m n : nat) (R: realType).
Variables (Sv : set 'cV[R]_(m.+1)).

Definition f_app (f : 'rV[R]_m -> 'rV[R]_m)
        (u: 'rV[R]_m)  := fun n => iter n f u.

Goal forall (f : 'rV[R]_m -> 'rV[R]_m) (u: 'rV[R]_m) ,
       f_app f u 1 = f u.
rewrite/f_app/iter //. Qed.

Goal forall (f : 'rV[R]_m -> 'rV[R]_m) (u: 'rV[R]_m) ,
       f_app f u 0 =  u.
rewrite/f_app/iter //. Qed.

Canonical mat_R_CompleteNormedModule (m' n' : nat) :=
  [completeNormedModType R of (matrix R m'.+1 n'.+1)].

Lemma Banach_test : forall (f' : {fun Sv >-> Sv}) ,
  is_contraction f' -> closed Sv -> (Sv !=set0)%classic ->
        exists2 x:'cV_m.+1, Sv x & x = f' x .
Proof.
move => f' A B C; apply banach_fixed_point => //.
Qed.

Definition lin2_mx {m' n' : nat} (f: 'cV[R]_n'.+1 -> 'cV[R]_m'.+1) :
  'M[R]_(m'.+1, n'.+1) := \matrix[lin1_mx_key]_(j, i) f (delta_mx i 0) j 0.

Variable f : {linear 'cV[R]_n.+1 -> 'cV[R]_m.+1}.
Variable g : {linear 'rV[R]_m.+1 -> 'rV[R]_n.+1}.

Lemma mul_cV_lin2 (u : 'cV_n.+1):
   lin2_mx f *m u = f u.
Proof.
by rewrite {2}[u]matrix_sum_delta linear_sum; apply/colP=> i;
rewrite mxE summxE; apply eq_bigr => j _; rewrite big_ord1 linearZ !mxE mulrC.
Qed.

Variable fs : {fun Sv >-> Sv}.
Axiom linear_fs : linear fs.

Canonical fs' := Linear linear_fs.

Lemma Banach_tests :
  is_contraction fs' -> closed Sv -> (Sv !=set0)%classic ->
        exists2 x:'cV_m.+1, Sv x & x = fs' x .
Proof.
move => A B C; apply banach_fixed_point => //.
Qed.

Lemma mul_cV_lin2'  (u : 'cV_m.+1):
   lin2_mx fs *m u = fs' u.
Proof.
by rewrite {2}[u]matrix_sum_delta linear_sum; apply/colP=> i;
rewrite mxE summxE; apply eq_bigr => j _; rewrite big_ord1 linearZ !mxE mulrC.
Qed.

(* Search normr matrix_normedZmodType *)

Lemma linear_exists (m' n' : nat) (A: 'M[R]_(m'.+1,n'.+1)) :
  exists f, forall u : 'cV_(n'.+1) , f u = A *m u /\ linear f.
Proof.
Admitted.

Lemma subMultNorm (A: 'M[R]_m.+1) (u : 'cV_m.+1) :
  `| A *m u | <= `|A| * `|u|.
Proof.
rewrite /normr /= !mx_normE.
Search normr.
Search BigOp.bigop normr.
Admitted.

Lemma mx_norm_is_klipschitz :
  forall (k : R) (HBND: `|lin2_mx fs| <= k),   k.-lipschitz_Sv fs.
Proof.
move => k HBND.
rewrite/dominated_by/globally /= => x Hx.
rewrite -linearB // .
rewrite -mul_cV_lin2'.
eapply le_trans => [ | ].
apply subMultNorm =>  //.
Admitted.

Lemma norm_lt_contraction:
  `|lin2_mx fs| < 1 -> is_contraction fs.
Proof.
move => H.
exists `|lin2_mx fs|%:nng => // (* see signed.v; x%:nng explicitly casts x to {nonneg R} *).
unfold contraction; simpl.
split => [//|].
apply mx_norm_is_klipschitz => //.
Qed.

(* definition of the matrix condition number *)
Definition kappa (A : 'M[R]_m.+1) := `|(invmx A)| * `|A|.

Lemma Neumann_bound' (A : 'M[R]_m.+1):
        (1 - A) * \sum_(0 <= i < n.+1) A^i.
Proof.

Lemma Neumann_bound (F : 'M[R]_m.+1):
        `|invmx(1 - F)| <=  \sum_(0 <= i < n.+1) `|F|^i.
Proof.
unfold norm.


Definition plus (n m : cnat) : cnat :=
  fun (X : Type) (f : X -> X) (x: X) => n X f (m X f x).

Example plus_1 : plus zero one = one.
Proof.
  intros. simpl.
  reflexivity.
Qed.

Example plus_2 : plus two three = plus three two.
Proof.
  intros. simpl.
  reflexivity.
Qed.

Example plus_3 :
  plus (plus two two) three = plus one (plus three three).
Proof.
  intros. simpl.
  reflexivity.
Qed.


Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Classical_Pred_Type.
Add LoadPath "src/".
Require Import Model.

(*
  The axiom of regularity does not hold in this set theory.
  The weaker form of regularity holds, and its necessary to
  prove extensionality: a positive set does cannot belong to itself.
*)
Theorem weak_regularity: forall {x}, low x -> iin x x -> False.
Proof.
  induction x; simpl low; auto; intros.
  destruct H1. apply (H x).
  - destruct (s x); simpl; auto.
  - assert (H1' := H1). destruct (s x) in H1; destruct H1.
    destruct (H2 x).
    apply (in_sound_left (eeq_sym H1')).
    apply (in_sound_right (eeq_sym H1')).
    exists x. assumption.
Qed.

(*
  The lemma [pos_neg_ext_neq] below is fundamental to
  prove extensionality. It proves that a positive set cannot
  be extensionally equal to a negative set.

  In order to prove [pos_neg_ext_neq], we first prove the
  auxiliary [pos_univ]. It says that if a positive set is
  extensionally equal to a negative set, then one can
  express the universal set (defined as negative) as a
  positive set.
  This, together with weak regularity, yields the required
  contradiction.
*)

Definition f_sum {X Y} f g (z: X + Y): set := match z with
  | inl x => f x
  | inr y => g y
end.

Lemma pos_univ: forall X f Y g, (forall z, iin z (@Pos X f) <-> iin z (@Neg Y g)) -> (forall z, iin z (@Pos (X + Y) (f_sum f g))).
Proof.
  intros. simpl iin in *.
  pose proof (H z).
  destruct (classic (exists x : X, eeq (f x) z)).
  - destruct H1. exists (inl x). simpl f_sum. assumption.
  - cut (exists y : Y, eeq (g y) z). intro. destruct H2.
    exists (inr x). auto.
  destruct H0. pose proof (fun T => H1 (H2 T)).
  apply NNPP. intro. apply H3. intros. apply H4. exists x. auto.
Qed.

Lemma pos_neg_ext_neq: forall X f Y g, (forall z, iin z (@Pos X f) <-> iin z (@Neg Y g)) -> False.
Proof.
  intros.
  pose proof (pos_univ _ _ _ _ H).
  apply (@weak_regularity (@Pos (X + Y) (f_sum f g)) I). apply H0.
Qed.

Lemma ext_pos: forall X f Y g, (forall z, iin z (@Pos X f) <-> iin z (@Pos Y g)) -> eeq (@Pos X f) (@Pos Y g).
Proof.
  intros. simpl; split; intro.
  - destruct (H (f x)). simpl iin in H0.
    cut (exists x0 : X, eeq (f x0) (f x)). intro. destruct (H0 H2). exists x0. apply eeq_sym. assumption. exists x. apply eeq_refl.
  - destruct (H (g y)). simpl iin in H1.
  cut (exists x : Y, eeq (g x) (g y)). intro. destruct (H1 H2). exists x. assumption. exists y. apply eeq_refl.
Qed.

Lemma ext_neg: forall X f Y g, (forall z, iin z (@Neg X f) <-> iin z (@Neg Y g)) -> eeq (@Pos X f) (@Pos Y g).
Proof.
  intros. simpl; split; intro.
  - destruct (H (f x)). simpl iin in H1.
    apply NNPP. intro.
    cut (forall x0 : Y, eeq (g x0) (f x) -> False). intro.
    pose proof (H1 H3). apply (H4 x). apply eeq_refl. intros.
    pose proof (eeq_sym H3). revert H4. clear H3. revert x0.
    apply not_ex_all_not. assumption.
  - destruct (H (g y)). simpl iin in H0.
  apply NNPP. intro.
  cut (forall x : X, eeq (f x) (g y) -> False). intro.
  pose proof (H0 H3). apply (H4 y). apply eeq_refl.
  apply not_ex_all_not. assumption.
Qed.

Theorem extensionality: forall x y, x ≡ y <-> forall z, z ∈ x <-> z ∈ y.
Proof.
  intros. split. intros. split; apply in_sound_right; auto. apply eeq_sym. assumption.
  destruct x; destruct y.
  - apply ext_pos.
  - intros. destruct (pos_neg_ext_neq _ _ _ _ H).
  - intros. cut (forall z : set, iin z (@Pos X0 s0) <-> iin z (@Neg X s)).
    intro. destruct (pos_neg_ext_neq _ _ _ _ H0).
    intro z. apply iff_sym. apply (H z).
  - apply ext_neg.
Qed.


Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.universal_algebra MathClasses.theory.ua_homomorphisms
  MathClasses.interfaces.canonical_names MathClasses.theory.categories MathClasses.theory.ua_mapped_operations.

Require MathClasses.categories.varieties.

Section contents.

  Context (et: EquationalTheory) `{InVariety et A} `{InVariety et B}
    `{!HomoMorphism et A B ab} `{!HomoMorphism et B A ba}
    (i: iso_arrows (varieties.arrow et ab) (varieties.arrow et ba)).

  Arguments ab {a} _.
  Arguments ba {a} _.

  Let ab_proper a: Proper ((=) ==> (=)) (@ab a).
  Proof. apply _. Qed.

  Let ba_proper a: Proper ((=) ==> (=)) (@ba a).
  Proof. apply _. Qed.

  Let epA: ∀ V n, Proper ((=) ==> eq ==> (=)) (@eval _ A _ V n) := _.
  Let epB: ∀ V n, Proper ((=) ==> eq ==> (=)) (@eval _ B _ V n) := _.
    (* hints. shouldn't be necessary *)

  Let ab_ba: ∀ b (a: B b), ab (ba a) = a := proj1 i.
  Let ba_ab: ∀ b (a: A b), ba (ab a) = a := proj2 i.

  Program Lemma transfer_eval n (t: Term et nat n) (v: Vars et B nat):
    eval et (A:=A) (λ _ i, ba (v _ i)) t = map_op _ (@ba) (@ab) (eval et v t).
  Proof with auto; try reflexivity.
   induction t; simpl in *; intros...
    set (eval et (λ (a: sorts et) (i : nat), ba (v a i)) t2).
    eapply transitivity.
     apply (@epA nat (ne_list.cons y t1) (λ a i, ba (v a i))
         (λ a i, ba (v a i)) (reflexivity _) t2 t2 (reflexivity _)
         : Proper ((=) ==> op_type_equiv (sorts et) A t1)%signature o).
     now apply IHt2.
    subst o.
    rewrite (IHt1 (ba (eval et v t3)) (ba (eval et v t3)))...
    apply (@map_op_proper (sorts et) B A _ _ _ _ _ _).
    unfold compose in *.
    rapply (epB _ _ v v (reflexivity _) t2 t2 (reflexivity _)).
    apply ab_ba.
   generalize
     (@algebra_propers _ A _ _ _ o)
     (@algebra_propers _ B _ _ _ o).
   generalize (@preserves et A B _ _ _ _ (@ab) _ o).
   fold (@algebra_op et A _ o) (@algebra_op et B _ o).
   generalize (@algebra_op et A _ o), (@algebra_op et B _ o).
   induction (et o); simpl; repeat intro.
    rewrite <- ba_ab, H1...
   apply IHo0.
     eapply Preservation_proper''; eauto; intros; try apply _.
     symmetry. apply H3, ab_proper, H4.
    apply H2...
   apply H3...
  Qed. (* todo: make [reflexivity] work as a hint. further cleanup. *)

  Program Lemma transfer_eval' n (t: Term et nat n) (v: Vars et B nat):
    map_op _ (@ab) (@ba) (eval et (A:=A) (λ _ i, ba (v _ i)) t) = eval et v t.
  Proof with auto.
   intros.
   pose proof (@map_op_proper (sorts et) A B _ _ _ _ _ _).
   rewrite transfer_eval.
   apply (@map_iso _ A B _ _ (@ab) (@ba) ab_ba).
   apply _.
  Qed.

  Program Lemma transfer_statement_and_vars (s: Statement et) (v: Vars et B nat):
    eval_stmt et v s ↔ eval_stmt et (A:=A) (λ _ i, ba (v _ i)) s.
  Proof with auto; reflexivity.
   intros.
   induction s; simpl; intuition.
    rewrite transfer_eval. symmetry.
    rewrite transfer_eval. symmetry.
    apply (map_op_proper _ _ _)...
   rewrite <- transfer_eval'. symmetry.
   rewrite <- transfer_eval'. symmetry.
   apply (map_op_proper _ _ _)...
  Qed.

  Theorem transfer_statement (s: Statement et): (∀ v, eval_stmt et (A:=A) v s) → (∀ v, eval_stmt et (A:=B) v s).
  Proof with intuition auto.
   intros ? v.
   assert (v = (λ _ i, ab (ba (v _ i)))) as P.
    destruct i. intros a a0. symmetry...
   rewrite P, transfer_statement_and_vars...
  Qed.

End contents.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Morphisms.
Require Export Category.Theory.Isomorphism.
Require Export Category.Functor.Bifunctor.
Require Export Category.Structure.Monoidal.
Require Export Category.Structure.Monoidal.Naturality.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section SymmetricMonoidal.

Context `{@Monoidal C}.

Class SymmetricMonoidal := {
  twist {x y} : x ⨂ y ≅ y ⨂ x;
  twist_natural : natural (@twist);

  twist_invol {x y} : twist ∘ twist ≈ id[x ⨂ y];

  hexagon_identity {x y z} :
    tensor_assoc ∘ twist ∘ tensor_assoc
      << (x ⨂ y) ⨂ z ~~> y ⨂ (z ⨂ x) >>
    id ⨂ twist ∘ tensor_assoc ∘ twist ⨂ id
}.

Corollary bimap_twist `{SymmetricMonoidal} {x y z w} (f : x ~> z) (g : y ~> w) :
  twist ∘ g ⨂ f ∘ twist ≈ f ⨂ g.
Proof.
  spose (fst twist_natural _ _ f _ _ g) as X.
  normal.
  rewrite <- comp_assoc.
  rewrites.
  rewrite comp_assoc.
  rewrite twist_invol; cat.
Qed.

End SymmetricMonoidal.


From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Printing Implicit Defensive.

Require Import ClassicalExtras.
Require Import MyNotation.
Require Import Setoid.
Require Import FunctionalExtensionality.
Require Import Setoid.

Require Import Galois.
Require Import LanguageModel.
Require Import TraceModel.
Require Import Properties.
Require Import ChainModel.
Require Import RobustSSCHPreservation.

Require Import PropExtensionality.
Definition prop_extensionality := propositional_extensionality.

Section RobustSSCHCriterion.

  Variable Source Target: Language.
  Variable compilation_chain : CompilationChain Source Target.

  (*CA: we don't need a particular structure of traces to define preservation
        e.g. traces = values or our defn of traces both make sense
   *)
  Variable trace__S trace__T : Type.

  Local Definition prop__S := prop trace__S.
  Local Definition prop__T := prop trace__T.
  Local Definition hprop__S := hprop trace__S.
  Local Definition hprop__T := hprop trace__T.

  Variable Source_Semantics : Semantics Source trace__S.
  Variable Target_Semantics : Semantics Target trace__T.

  Local Definition sem__S := sem Source_Semantics.
  Local Definition sem__T := sem Target_Semantics.
  Local Definition beh__S := beh Source_Semantics.
  Local Definition beh__T := beh Target_Semantics.
  Local Definition par__S := par Source.
  Local Definition par__T := par Target.
  Local Definition ctx__S := ctx Source.
  Local Definition ctx__T := ctx Target.
  Local Definition rhsat__S := rhsat Source_Semantics.
  Local Definition rhsat__T := rhsat Target_Semantics.

  Local Definition cmp := compile_par Source Target compilation_chain.

  Local Notation "P ↓" := (cmp P) (at level 50).

  Local Definition plug__S:= plug Source.
  Local Definition plug__T := plug Target.

  Variable rel : trace__S -> trace__T -> Prop.

  Local Definition adjunction :=  induced_connection rel.

  Local Definition τ' : prop__S -> prop__T := α adjunction.
  Local Definition σ' : prop__T -> prop__S := γ adjunction.

  Local Definition rel_adjunction_law : Adjunction_law τ' σ' := adjunction_law adjunction.

  Definition rel_RSCHC := forall P C__T, exists C__S,
       ( forall t, sem__T (plug__T (P ↓) C__T) t -> exists s, rel s t /\ sem__S (plug__S P C__S) s).

  Local Definition sCl_σ : hprop__T -> hprop__S := sCl_σ σ'.
  Local Definition sCl_τ : hprop__S -> hprop__T := sCl_τ τ'.

  Local Definition sCl_τRhP := sCl_τRhP compilation_chain
                                        Source_Semantics Target_Semantics
                                        τ'.

  Local Definition sCl_σRhP := sCl_σRhP compilation_chain
                                        Source_Semantics Target_Semantics
                                        σ'.

  Lemma sCl_σRhP_sCl_τRhP : (forall (P : par__S) (H__T : hprop__T), SSC H__T ->  sCl_σRhP P H__T) <->
                            (forall (P : par__S) (H__S : hprop__S), SSC H__S -> sCl_τRhP P H__S).
  Proof.
    split.
    + move => Hσ P H__S ssc_H rsat_source.
      have rsat_sigma_tau : rhsat__S P (sCl_σ (sCl_τ H__S)).
      { apply: rhsat_upper_closed. exact rsat_source.
        apply: Galois_snd_lift. exact rel_adjunction_law. exact ssc_H. }
      have τ_ssc : SSC (sCl_τ H__S) by apply: sCl_SCH.
      exact (Hσ P (sCl_τ H__S) τ_ssc rsat_sigma_tau).
    + move => Hτ P H__T ssc_H rsat_source.
      have h_ssc: SSC (sCl_σ H__T) by apply: sCl_SCH.
      move: (Hτ P (sCl_σ H__T) h_ssc rsat_source).
      move => HHH. eapply rhsat_upper_closed. exact HHH.
      apply: Galois_fst_lift; eauto. exact rel_adjunction_law.
  Qed.

  Theorem rel_RSCHC_sClτRSCHP : rel_RSCHC <-> (forall (P : par__S) (H__S : hprop__S), SSC H__S -> sCl_τRhP P H__S).
  Proof.
    split.
    - move => Htilde P H H_ssc. setoid_rewrite contra_τRhP.
      move => [C__T Hsem].
      move: (Htilde P C__T) => [C__S HH]. exists C__S => Hfalse.
      apply: Hsem.
      exists (τ' (beh__S (plug__S P C__S))). split.
      + by exists (beh__S (plug__S P C__S)).
      + move => t Ht. destruct (HH t Ht) as [s [Hs1 Hs2]]. now exists s.
    - move => Hτ P Ct.
      have Hssc : SSC (fun b: prop__S =>  ~ beh__T (plug__T (P↓) Ct) ⊆ τ' b).
      { move => b1 Hb1 b2 b1_b2 Hb2. apply: Hb1. firstorder. }
      specialize (Hτ P (fun b: prop__S =>  ~ beh__T (plug__T (P↓) Ct) ⊆ τ' b) Hssc).
      apply contra in Hτ. move: Hτ. rewrite !neg_rhsat.
      move => [Cs Hbeh]. move/NNPP: Hbeh.
      exists Cs => t Hsem_t. move: (Hbeh t Hsem_t). firstorder.
      move => Hf. specialize (Hf Ct).
      destruct Hf as [b' [Hb' Hbb]]. destruct Hb' as [bs [Hbs1 Hbs2]]. now subst.
  Qed.

  Theorem rel_RTC_σRTP : rel_RSCHC <-> (forall (P : par__S) (H__T : hprop__T), SSC H__T ->  sCl_σRhP P H__T).
  Proof. by rewrite sCl_σRhP_sCl_τRhP rel_RSCHC_sClτRSCHP. Qed.

End RobustSSCHCriterion.


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.
*)