From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.
From Categories Require Import Limits.Limit.
From Categories Require Import Archetypal.Discr.Discr.
From Categories Require Import Cat.Terminal.
From Categories.Basic_Cons Require Import Terminal Product Equalizer PullBack.

(** In this module we show that terminal objects, products, equalizers and
    pullbacks are limits. The corresponding duals are dually colimits. *)

Section Limits.
  Context {C : Category}.

  Section Terminal.

    Definition Terminal_Producing_Func_fun (x : Empty) : C
      :=
        match x with
        end.

    Context (L : Limit (Discr_Func Terminal_Producing_Func_fun)).

    Program Definition Terminal_as_Limit_Cone
            (c : C)
      :
        Cone (Discr_Func Terminal_Producing_Func_fun)
      :=
        {|
          cone_apex :=
            {|
              FO := fun _ => c;
              FA := fun _ _ _ => id
            |};
          cone_edge :=
            {|
              Trans :=
                fun x =>
                  match x with
                  end
            |}
        |}
    .

    Local Hint Extern 1 => match goal with [x : unit |- _] => destruct x end : core.
    Local Hint Extern 1 => rewrite From_Term_Cat : core.
    Local Hint Extern 1 => apply NatTrans_eq_simplify : core.
    Local Hint Extern 1 => progress cbn : core.

    Local Obligation Tactic := basic_simpl; auto 10.

    Program Definition Terminal_as_Limit_Cone_morph
            {c : C}
            (f : (c --> L)%morphism)
      :
        Cone_Morph _ (Terminal_as_Limit_Cone c) (LRKE L)
      :=
        {|
          cone_morph :=
            {|
              Trans :=
                fun c =>
                  match c as u return ( _ --> L _o u)%object%morphism with
                    tt => f
                  end
            |}
        |}.

    Program Definition Terminal_as_Limit : (𝟙_ C)%object :=
      {|
        terminal := L;
        t_morph :=
          fun c =>
            Trans (LRKE_morph_ex L (Terminal_as_Limit_Cone c)) tt
      |}
    .

    Local Obligation Tactic := idtac.

    Next Obligation.
    Proof.
      intros c f g.
      apply (
          f_equal
            (fun w : (Terminal_as_Limit_Cone c --> L)%nattrans => Trans w tt)
            (
              LRKE_morph_unique
                L
                _
                (Terminal_as_Limit_Cone_morph f)
                (Terminal_as_Limit_Cone_morph g)
            )
        ).
    Qed.

  End Terminal.

  Section Product.
    Context (a b : C).

    Definition Product_Producing_Func_fun (x : bool) : C :=
      match x with
      | true => a
      | false => b
      end.

    Context (L : Limit (Discr_Func Product_Producing_Func_fun)).

    Program Definition Product_as_Limit_Cone
            {p : C}
            (h : (p --> a)%morphism)
            (h' : (p --> b)%morphism)
      :
        Cone (Discr_Func Product_Producing_Func_fun)
      :=
        {|
          cone_apex :=
            {|
              FO := fun _ => p;
              FA := fun _ _ _ => id
            |};
          cone_edge :=
            {|
              Trans :=
                fun x =>
                  match x with
                  | true => h
                  | false => h'
                  end
            |}
        |}.

    Local Hint Extern 1 => match goal with [x : unit |- _] => destruct x end : core.
    Local Hint Extern 1 => match goal with [x : bool |- _] => destruct x end : core.
    Local Hint Extern 1 => rewrite From_Term_Cat : core.
    Local Hint Extern 1 => apply NatTrans_eq_simplify : core.
    Local Hint Extern 1 => progress cbn : core.

    Local Obligation Tactic := basic_simpl; auto 10.

    Program Definition Product_as_Limit_Cone_morph
            {p : C}
            (h : (p --> a)%morphism)
            (h' : (p --> b)%morphism)
            (f : (p --> L)%morphism)
            (H1 : (Trans L true ∘ f)%morphism = h)
            (H2 : (Trans L false ∘ f)%morphism = h')
      :
        Cone_Morph _ (Product_as_Limit_Cone h h') (LRKE L)
      :=
        {|
          cone_morph :=
            {|
              Trans :=
                fun c =>
                  match c as u return ( _ --> L _o u)%object%morphism with
                    tt => f
                  end
            |}
        |}.

    Program Definition Product_as_Limit : (a × b)%object :=
      {|
        product := L;
        Pi_1 := Trans (cone_edge L) true;
        Pi_2 := Trans (cone_edge L) false;
        Prod_morph_ex :=
          fun p h h' =>
            Trans (LRKE_morph_ex L (Product_as_Limit_Cone h h')) tt
      |}.

    Local Obligation Tactic := idtac.

    Next Obligation.
    Proof.
      intros p h h'.
      cbn.
      set (H :=
             f_equal
               (fun w
                    :
                      (Product_as_Limit_Cone h h'
                 ∘ Functor_To_1_Cat (Discr_Cat Datatypes.bool)
                 --> Discr_Func Product_Producing_Func_fun)%nattrans
                => Trans w true)
               (cone_morph_com (LRKE_morph_ex L (Product_as_Limit_Cone h h')))
          ).
      cbn in H.
      rewrite From_Term_Cat in H.
      auto.
    Qed.

    Next Obligation.
    Proof.
      intros p h h'.
      set (H :=
             f_equal
               (fun w
                    :
                      ((Product_as_Limit_Cone h h')
                         ∘ Functor_To_1_Cat (Discr_Cat Datatypes.bool)
                         --> Discr_Func Product_Producing_Func_fun)%nattrans
                => Trans w false)
               (cone_morph_com (LRKE_morph_ex L (Product_as_Limit_Cone h h')))
          ).
      cbn in H.
      rewrite From_Term_Cat in H.
      auto.
    Qed.

    Next Obligation.
    Proof.
      intros p h h' f g H1 H2 H3 H4.
      apply (
          f_equal
            (fun w : (Product_as_Limit_Cone h h' --> L)%nattrans => Trans w tt)
            (
              LRKE_morph_unique
                L
                _
                (Product_as_Limit_Cone_morph _ _ _ H1 H2)
                (Product_as_Limit_Cone_morph _ _ _ H3 H4)
            )
        ).
    Qed.

  End Product.

  Section Equalizer.
    Context {a b : C} (f g : (a --> b)%morphism).

    Local Hint Extern 1 => match goal with [x : unit |- _] => destruct x end : core.
    Local Hint Extern 1 => match goal with [x : Empty |- _] => destruct x end : core.
    Local Hint Extern 1 => match goal with [x : bool |- _] => destruct x end : core.
    Local Hint Extern 1 => rewrite From_Term_Cat : core.
    Local Hint Extern 1 => apply NatTrans_eq_simplify : core.
    Local Hint Extern 1 => progress cbn : core.

    Local Obligation Tactic := basic_simpl; auto 10.

    Program Definition Equalizer_Producing_Cat : Category
      :=
        {|
          Obj := bool;
          Hom :=
            fun x y =>
              match (x, y) with
              | (true, true) => unit
              | (true, false) => bool
              | (false, true) => Empty
              | (false, false) => unit
              end;
          compose :=
            fun x y z h h'=> _;
          id := fun x => _
        |}.

    Next Obligation.
    Proof.
      destruct x; destruct y; destruct z; auto.
    Defined.

    Next Obligation.
    Proof.
      destruct x; constructor.
    Defined.

    Program Definition Equalizer_Producing_Func :
      (Equalizer_Producing_Cat --> C)%functor
      :=
        {|
          FO :=
            fun x =>
              match x with
              | true => a
              | false => b
              end;
          FA := fun x y h => _
        |}.
    Next Obligation.
    Proof.
      destruct x; destruct y.
      exact id.
      destruct h.
      {
        exact f.
      }
      {
        exact g.
      }
      destruct h.
      exact id.
    Defined.

    Context (L : Limit Equalizer_Producing_Func).

    Program Definition Equalizer_as_Limit_Cone
            {p : C}
            {h : (p --> a)%morphism}
            (H : (f ∘ h)%morphism = (g ∘ h)%morphism)
      :
        Cone Equalizer_Producing_Func
      :=
        {|
          cone_apex :=
            {|
              FO := fun _ => p;
              FA := fun _ _ _ => id
            |};
          cone_edge :=
            {|
              Trans :=
                fun x =>
                  match x with
                  | true => h
                  | false => (f ∘ h)%morphism
                  end
            |}
        |}.

    Local Obligation Tactic := idtac.

    Program Definition Equalizer_as_Limit_Cone_morph
            {p : C}
            {h : (p --> a)%morphism}
            (H1 : (f ∘ h)%morphism = (g ∘ h)%morphism)
            (k : (p --> L)%morphism)
            (H2 : (Trans L true ∘ k)%morphism = h)
      :
        Cone_Morph _ (Equalizer_as_Limit_Cone H1) (LRKE L)
      :=
        {|
          cone_morph :=
            {|
              Trans :=
                fun c =>
                  match c as u return ( _ --> L _o u)%object%morphism with
                    tt => k
                  end
            |}
        |}.
    Next Obligation.
    Proof.
      basic_simpl; auto 10.
    Qed.
    Next Obligation.
    Proof.
      basic_simpl; auto 10.
    Qed.
    Next Obligation.
    Proof.
      intros p h H1 k H2.
      apply NatTrans_eq_simplify.
      extensionality x.
      cbn in *.
      destruct x; auto.
      rewrite assoc_sym.
      cbn_rewrite (@Trans_com _ _ _ _ L true false false).
      rewrite assoc.
      rewrite H1; rewrite <- H2.
      trivial.
    Qed.

    Program Definition Equalizer_as_Limit : Equalizer f g :=
      {|
        equalizer := L;
        equalizer_morph := Trans L true;
        equalizer_morph_ex :=
          fun e eqm H =>
            Trans (LRKE_morph_ex L (Equalizer_as_Limit_Cone H)) tt
      |}
    .

    Local Obligation Tactic := idtac.

    Next Obligation.
    Proof.
      set (H := @Trans_com _ _ _ _ L true false false).
      cbn in H.
      cbn_rewrite (@Trans_com _ _ _ _ L true false true) in H.
      trivial.
    Qed.

    Next Obligation.
    Proof.
      intros e eqm eqmc; cbn.
      cbn_rewrite (
          f_equal
            (fun w :
                   ((Equalizer_as_Limit_Cone eqmc)
                      ∘ Functor_To_1_Cat Equalizer_Producing_Cat
                      --> Equalizer_Producing_Func)%nattrans
             => Trans w true)
            (cone_morph_com (LRKE_morph_ex L (Equalizer_as_Limit_Cone eqmc)))
        ).
      auto.
    Qed.

    Next Obligation.
    Proof.
      intros e eqm H1 h h' H2 H3.
      apply (
          f_equal
            (fun w : (Equalizer_as_Limit_Cone H1 --> L)%nattrans => Trans w tt)
            (
              LRKE_morph_unique
                L
                _
                (Equalizer_as_Limit_Cone_morph _ _ H2)
                (Equalizer_as_Limit_Cone_morph _ _ H3)
            )
        ).
    Qed.

  End Equalizer.

  Section PullBack.
    Context
      {a b c : C}
      (f : (a --> c)%morphism)
      (g : (b --> c)%morphism).

    Inductive PBType :=
    | PB_A
    | PB_B
    | PB_C.

    Local Hint Extern 1 => match goal with [x : unit |- _] => destruct x end : core.
    Local Hint Extern 1 => match goal with [x : PBType |- _] => destruct x end : core.
    Local Hint Extern 1 => match goal with [x : Empty |- _] => destruct x end : core.
    Local Hint Extern 1 => match goal with [x : bool |- _] => destruct x end : core.
    Local Hint Extern 1 => match goal with [|- unit] => constructor end : core.
    Local Hint Extern 1 => rewrite From_Term_Cat : core.
    Local Hint Extern 1 => apply NatTrans_eq_simplify : core.
    Local Hint Extern 1 => progress cbn : core.

    Local Obligation Tactic := basic_simpl; auto 10.

    Program Definition PullBack_Producing_Cat : Category
      :=
        {|
          Obj := PBType;
          Hom :=
            fun x y =>
              match (x, y) with
              | (PB_A, PB_A) => unit
              | (PB_A, PB_B) => Empty
              | (PB_A, PB_C) => unit
              | (PB_B, PB_A) => Empty
              | (PB_B, PB_B) => unit
              | (PB_B, PB_C) => unit
              | (PB_C, PB_A) => Empty
              | (PB_C, PB_B) => Empty
              | (PB_C, PB_C) => unit
              end;
          compose :=
            fun x y z h h'=> _;
          id := fun x => _
        |}.

    Program Definition PullBack_Producing_Func :
      (PullBack_Producing_Cat --> C)%functor
      :=
        {|
          FO :=
            fun x =>
              match x with
              | PB_A => a
              | PB_B => b
              | PB_C => c
              end;
          FA := fun x y h => _
        |}.

    Next Obligation.
    Proof.
      destruct x; destruct y; auto; try exact id.
    Defined.

    Context (L : Limit PullBack_Producing_Func).

    Program Definition PullBack_as_Limit_Cone
            {p : C}
            {h : (p --> a)%morphism}
            {h' : (p --> b)%morphism}
            (H : (f ∘ h)%morphism = (g ∘ h')%morphism)
      :
        Cone PullBack_Producing_Func
      :=
        {|
          cone_apex :=
            {|
              FO := fun _ => p;
              FA := fun _ _ _ => id
            |};
          cone_edge :=
            {|
              Trans :=
                fun x =>
                  match x with
                  | PB_A => h
                  | PB_B => h'
                  | PB_C => (f ∘ h)%morphism
                  end
            |}
        |}
    .

    Local Obligation Tactic := idtac.

    Program Definition PullBack_as_Limit_Cone_morph
            {p : C}
            {h : (p --> a)%morphism}
            {h' : (p --> b)%morphism}
            (H1 : (f ∘ h)%morphism = (g ∘ h')%morphism)
            (k : (p --> L)%morphism)
            (H2 : (Trans L PB_A ∘ k)%morphism = h)
            (H3 : (Trans L PB_B ∘ k)%morphism = h')
      :
        Cone_Morph _ (PullBack_as_Limit_Cone H1) (LRKE L)
      :=
        {|
          cone_morph :=
            {|
              Trans :=
                fun c =>
                  match c as u return ( _ --> L _o u)%object%morphism with
                    tt => k
                  end
            |}
        |}.
    Next Obligation.
    Proof.
      basic_simpl; auto 10.
    Qed.
    Next Obligation.
    Proof.
      basic_simpl; auto 10.
    Qed.

    Next Obligation.
    Proof.
      intros p h h' H1 k H2 H3.
      apply NatTrans_eq_simplify.
      extensionality x.
      cbn in *.
      destruct x; auto.
      rewrite assoc_sym.
      cbn_rewrite (@Trans_com _ _ _ _ L PB_B PB_C tt).
      rewrite assoc.
      rewrite H1; rewrite <- H3.
      trivial.
    Qed.

    Local Obligation Tactic := idtac.

    Program Definition PullBack_as_Limit : PullBack f g :=
      {|
        pullback := L;
        pullback_morph_1 := Trans L PB_A;
        pullback_morph_2 := Trans L PB_B;
        pullback_morph_ex :=
          fun e pm1 pm2 pmc =>
            Trans (LRKE_morph_ex L (PullBack_as_Limit_Cone pmc)) tt
      |}.
    Next Obligation.
    Proof.
      set (H := @Trans_com _ _ _ _ L PB_B PB_C tt).
      cbn in H.
      cbn_rewrite (@Trans_com _ _ _ _ L PB_A PB_C tt) in H.
      trivial.
    Qed.
    Next Obligation.
    Proof.
      intros e pm1 pm2 pmc; cbn.
      cbn_rewrite (
          f_equal
            (fun w :
                   ((PullBack_as_Limit_Cone pmc)
                      ∘ Functor_To_1_Cat PullBack_Producing_Cat
                      --> PullBack_Producing_Func)%nattrans
             => Trans w PB_A)
            (cone_morph_com (LRKE_morph_ex L (PullBack_as_Limit_Cone pmc)))
        ).
      auto.
    Qed.

    Next Obligation.
    Proof.
      intros e pm1 pm2 pmc; cbn.
      cbn_rewrite (
          f_equal
            (fun w :
                   ((PullBack_as_Limit_Cone pmc)
                      ∘ Functor_To_1_Cat PullBack_Producing_Cat
                      --> PullBack_Producing_Func)%nattrans
             => Trans w PB_B)
            (cone_morph_com (LRKE_morph_ex L (PullBack_as_Limit_Cone pmc)))
        ).
      auto.
    Qed.
    Next Obligation.
    Proof.
      intros e pm1 pm2 H1 h h' H2 H3 H4 H5.
      apply (
          f_equal
            (fun w : (PullBack_as_Limit_Cone H1 --> L)%nattrans => Trans w tt)
            (
              LRKE_morph_unique
                L
                _
                (PullBack_as_Limit_Cone_morph _ _ H2 H3)
                (PullBack_as_Limit_Cone_morph _ _ H4 H5)
            )
        ).
    Qed.

  End PullBack.

End Limits.


Require Import LLC.Typing.
Require Import LLC.Syntax.
Require Import SmallStepSemantics.
Require Import Linear.Context.

Lemma step_app1_x : forall e1 e2,
  (exists e', step e1 e') ->
  exists e'', step (TApp e1 e2) e''.
Proof with eboom.
  intros e1 e2 Step1.
  decompose record Step1...
Qed.

Hint Resolve step_app1_x : linear.

Lemma fun_value_is_abs : forall E e t1 t2,
  is_empty E ->
  E |- e ~: TyFun t1 t2 ->
  value e ->
  (exists e', e = TAbs t1 e').
Proof.
  intros E e t1 t2 Empty WT Val.
  destruct e; try (solve by inversion).
  Case "e is a variable, impossible with an empty context".
    inversion WT; subst; exfalso; eauto 2 with linear.
  Case "e is a lambda abstraction, good!".
    inversion WT; subst.
    eauto.
Qed.

Hint Resolve fun_value_is_abs : linear.

Lemma value_app1_x : forall E1 e1 e2 t1 t2,
  is_empty E1 ->
  E1 |- e1 ~: TyFun t1 t2 ->
  value e1 ->
  (exists e2', step e2 e2') \/ value e2 ->
  (exists e'', step (TApp e1 e2) e'').
Proof with eboom.
  intros E1 e1 e2 t1 t2 Empty1 WT1 Val1 [Step2 | Val2].
  Case "e2 steps".
    decompose record Step2...
  Case "e2 is also a value".
    (* Beta reduction *)
    assert (exists e1', e1 = TAbs t1 e1') as [e1']...
    subst e1...
Qed.

Hint Resolve value_app1_x : linear.

(* Proof of progress! *)
Theorem progress : forall E e t,
  is_empty E ->
  E |- e ~: t ->
  (exists e', step e e') \/ value e.
Proof with eboom.
  intros E e t EmptyE WT.
  induction WT...
  Case "Application".
    assert (is_empty E1 /\ is_empty E2) as [? ?]...
    destruct IHWT1...
Qed.


(** * Many-One Reductions *)

Require Export Problems.Reduction DecidableEnumerable.

Lemma dec_red X (p : X -> Prop) Y (q : Y -> Prop) :
  p ⪯ q -> decidable q -> decidable p.
Proof.
  intros [f] [d]. exists (fun x => d (f x)). intros x. rewrite H. eapply H0.
Qed.

Lemma red_comp X (p : X -> Prop) Y (q : Y -> Prop) :
  p ⪯ q -> (fun x => ~ p x) ⪯ (fun y => ~ q y).
Proof.
  intros [f]. exists f. intros x. now rewrite H.
Qed.

Section enum_red.

  Variables (X Y : Type) (p : X -> Prop) (q : Y -> Prop).
  Variables (f : X -> Y) (Hf : forall x, p x <-> q (f x)).

  Variables (Lq : _) (qe : enum q Lq).

  Variables (x0 : X).

  Variables (d : eq_dec Y).

  Fixpoint L (LX : enumT X) n :=
    match n with
    | 0 => []
    | S n => L LX n ++ [ x | x ∈ L_T X n , f x el Lq n ]
    end.

  Lemma enum_red LX :
    enum p (L LX).
  Proof.
    split.
    - intros ?. cbn; eauto.
    - split.
      + intros H.
        eapply Hf in H. eapply qe in H as [m1]. destruct (el_T x) as [m2 ?].
        exists (1 + m1 + m2). cbn. in_app 2.
        in_collect x; eapply cum_ge'; eauto; try omega.
        eapply qe.
      + intros [m H]. induction m.
        * inv H.
        * cbn in H. inv_collect.
          eapply Hf. eapply qe. eauto.
  Qed.

End enum_red.

Lemma enumerable_red X Y (p : X -> Prop) (q : Y -> Prop) :
  p ⪯ q -> enumerable__T X -> discrete Y -> enumerable q -> enumerable p.
Proof.
  intros [f] [] % enum_enumT [] % discrete_iff [L] % enumerable_enum.
  eapply enum_count, enum_red with (Y := Y); eauto.
Qed.

Theorem not_decidable X Y (p : X -> Prop) (q : Y -> Prop) :
  p ⪯ q -> enumerable__T X -> ~ enumerable (compl p) ->
  ~ decidable q /\ ~ decidable (compl q).
Proof.
  intros. split; intros ?.
  - eapply H1. eapply dec_red in H2; eauto.
    eapply dec_compl in H2. eapply dec_count_enum; eauto.
  - eapply H1. eapply dec_red in H2; eauto.
    eapply dec_count_enum; eauto. now eapply red_comp.
Qed.

Theorem not_coenumerable X Y (p : X -> Prop) (q : Y -> Prop) :
  p ⪯ q -> enumerable__T X -> ~ enumerable (compl p) -> discrete Y ->
  ~ enumerable (compl q).
Proof.
  intros. intros ?. eapply H1. eapply enumerable_red in H3; eauto.
  now eapply red_comp.
Qed.


Set Implicit Arguments.
Unset Strict Implicit.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.

Import Num.Theory.

Require Import OUVerT.extrema games dynamics.

(** * Potential Games *)

Local Open Scope ring_scope.

Class PhiClass (pN : nat) (rty : realFieldType) (pT : finType)
      `(gameClass : game)
  : Type := Phi : state pN pT -> rty.

(* Class PhiAxiomClass (pN : nat) (rty : realFieldType) (pT : finType) *)
(*       `(costAxiomClass : CostAxiomClass pN rty pT) *)
(*       (gameClass : game costAxiomClass) *)
(*       (phiClass : PhiClass gameClass) : Type := *)
(*   PhiAxiom :  *)
(*     forall (i : 'I_pN) (t t' : state pN pT), *)
(*       Phi t' - Phi t = cost i t' - cost i t. *)
(* Notation "'phi_ax'" := (@PhiAxiom _ _ _ _ _ _ _) (at level 50). *)

Class PhiAxiomClass (pN : nat) (rty : realFieldType) (pT : finType)
      (costClass : CostClass pN rty pT)
      (costAxiomClass : CostAxiomClass costClass)
      (costMaxClass : CostMaxClass pN rty pT)
      (costMaxAxiomClass : CostMaxAxiomClass costClass costMaxClass)
      (gameClass : game _ _)
      (phiClass : PhiClass _ _ _ gameClass) : Type :=
  PhiAxiom :
    forall (i : 'I_pN) (t t' : state pN pT),
      Phi t' - Phi t = cost i t' - cost i t.
Notation "'phi_ax'" := (@PhiAxiom _ _ _ _ _ _ _) (at level 50).

(* Class Potential (N : nat) (rty : realFieldType) (T : finType) *)
(*       `(costAxiomClass : CostAxiomClass N rty T) *)
(*       (gameClass : game costAxiomClass) *)
(*       `(phiClass : PhiClass) *)
(*       (phiAxiomClass : PhiAxiomClass phiClass) *)
(*   : Type := {}. *)

Class Potential (* (N : nat) (rty : realFieldType) (T : finType) *)
      `(phiAxiomClass : PhiAxiomClass)
  : Type := {}.

Section PotentialLemmas.
  Context `{potentialClass : Potential}.
  Notation sT := (state pN pT).

  Definition minimal : pred sT :=
    [pred t : sT | [forall t' : sT, Phi t <= Phi t']].

  Lemma Phi_cost_le (t t' : sT) i :
    Phi t <= Phi t' -> cost i t <= cost i t'.
  Proof.
    rewrite -subr_ge0=> H0.
    generalize (phi_ax)=> H2.
    by rewrite -subr_ge0 -H2.
  Qed.

  Lemma cost_Phi_lt (t t' : sT) i :
    cost i t' < cost i t -> Phi t' < Phi t.
  Proof.
    generalize (phi_ax)=> H0.
    by rewrite -subr_lt0 -H0 subr_lt0.
  Qed.

  (** Any [t] minimal wrt. the potential function [Phi] is
      a Pure Nash Equilibrium. *)
  Lemma minimal_PNE (t : sT) : minimal t -> PNE t.
  Proof.
    rewrite /minimal=> /=; move/forallP=> H0 x.
    by move=> t'; move: H0; move/(_ t'); apply: Phi_cost_le.
  Qed.

  Definition Phi_minimizer (t0 : sT) : sT := arg_min predT Phi t0.

  Lemma minimal_Phi_minimizer (t0 : sT) : minimal (Phi_minimizer t0).
  Proof.
    have H0: predT t0 by [].
    by case: (andP (arg_minP Phi H0)).
  Qed.

  Lemma PNE_Phi_minimizer (t0 : sT) : PNE (Phi_minimizer t0).
  Proof.
    apply: minimal_PNE.
    apply: minimal_Phi_minimizer.
  Qed.

  (** Assuming [T] is inhabited, every potential game over [T] has at
      least one PNE. *)
  Lemma exists_PNE (t0 : sT) : exists t : sT, PNE t.
  Proof.
    exists (Phi_minimizer t0).
    apply: PNE_Phi_minimizer.
  Qed.
End PotentialLemmas.

Section BestResponseDynamics.
  Context `{potentialClass : Potential}.
  Notation sT := (state pN pT).

  Inductive step : sT -> sT -> Prop :=
  | step_progress t t' (i : 'I_pN) :
      cost i t' < cost i t -> step t t'.

  Definition halted (t : sT) := PNE t.

  Let hstate := (simpl_pred sT * simpl_pred sT * sT)%type.

  Definition P (sut : hstate) : Prop :=
    let: (s,u,t) := sut in
    forall t0, s t0 -> Phi t <= Phi t0.

  Lemma init_P t : P (init t).
  Proof. by move=> t0 /=; move/eqP=> <-. Qed.

  (* TODO: This proof should be cleaned up. *)

  Lemma step_P s u t t' :
    inv (s,u,t) -> P (s,u,t) -> step t t' ->
    [/\ u t' & P (predU1 t' s, predD1 u t', t')].
  Proof.
    case=> H0 H1 H2 H3; inversion 1; subst.
    have Hx: Phi t' < Phi t.
    { by apply: (cost_Phi_lt H4).
    }
    suff: ~~ s t'; last first.
    { apply/negP; move=> H6.
      move: (H3 _ H6)=> H7.
      move: (ltrW Hx)=> H8.
      have H9: Phi t' <> Phi t.
      { apply/eqP.
        by rewrite ltr_eqF.
      }
      move: H7 H8 H9; rewrite !ler_eqVlt; case/orP; first by move/eqP=> <-.
      move=> H7; case/orP; first by move/eqP=> <-.
      move=> H8 H9.
      have H10: Phi t' < Phi t'.
      { apply: ltr_trans.
        apply: H8.
        by [].
      }
      by rewrite ltrr in H10.
    }
    move=> H6.
    move: (H3 t')=> /=.
    move: (H0 t')=> /=.
    case: (s t') H6=> //= _.
    rewrite (mem_enum sT _).
    move=> -> _; split=> //.
    move=> t0; case/orP; first by move/eqP=> <-.
    move=> H6.
    apply: ltrW.
    apply: ltr_le_trans.
    apply: Hx.
    apply: (H3 t0 H6).
  Qed.

  Lemma halted_doesnt_step t t' :
    halted t -> step t t' -> False.
  Proof.
    rewrite /halted=> H0; inversion 1; subst.
    move: (H0 i)=> H4.
    generalize (ltr_le_asym (cost i t') (cost i t)).
    by rewrite H1 H4.
  Qed.

  Lemma best_response_safe t :
    safe step halted t.
  Proof.
    move=> t''; induction 1=> //.
    case: (PNEP t).
    { by move=> H0; right.
    }
    move=> H0; left.
    suff H2: ~~ (@PNEb _ _ _ costClass t); last first.
    { apply/negP=> H1; case: (PNE_PNEb t)=> H2 H3.
      by apply: H0; apply H3.
    }
    rewrite negb_forall in H2; case: (existsP H2)=> i; rewrite negb_forall.
    case/existsP=> t'; move/negP=> H4.
    exists t'; apply: (step_progress (i:=i))=> //.
    by rewrite ltrNge; apply/negP.
  Qed.

  Lemma best_response_everywhere_halts t :
    everywhere_halts step halted t.
  Proof.
    apply: (step_everywhere_halts_or_stuck P).
    apply: init_P.
    apply: step_P.
    apply: halted_doesnt_step.
    apply: best_response_safe.
  Qed.
End BestResponseDynamics.

Print Assumptions best_response_everywhere_halts.

Section PriceOfStabilityBound.
  (** The following section proves a bound on the Price of Stability
      of potential games. *)
  Context `{potentialClass : Potential}.
  Notation sT := (state pN pT).

  (** We assume the social cost function is positive. *)
  Hypothesis Cost_pos : forall t : sT, 0 < Cost t.

  (** The bound [A] must also be positive; otherwise, dividing by [A]
      in [AB_bound_Phi] is undefined. *)
  Variables A B : rty.
  Hypothesis (HAgt0 : 0 < A).

  (** The bound is proved assuming there exist real numbers [A] and [B]
      such that for any state [t], [Phi t] is bounded on the left by
      [Cost t / A] and bounded on the right by [B * Cost t]. *)
  Hypothesis AB_bound_Phi :
    forall t : sT, Cost t / A <= Phi t <= B * Cost t.

  (** Under the conditions stated above, the Price of Stability of
      any potential game is at most [A * B]. (For games in which the
      PNE is unique, this bound gives a bound on the Price of Anarchy
      as well.) *)
  Lemma POS_bounded (t0 : sT) (PNE_t0 : PNE t0) : POS t0 <= A * B.
  Proof.
    set (tN := Phi_minimizer t0).
    generalize (minimal_Phi_minimizer t0); move/forallP=> HtN.
    case: (andP (AB_bound_Phi tN))=> H3 H4; rewrite /POS.
    set (tStar := arg_min optimal Cost t0).
    move: (HtN tStar)=> H5.
    case: (andP (AB_bound_Phi tStar))=> H6 H7.
    rewrite ler_pdivr_mulr; last by apply: Cost_pos.
    apply: ler_trans.
    have H8: Cost (arg_min PNEb Cost t0) <= Cost tN.
    { have H9: PNE tN by apply: PNE_Phi_minimizer.
      have H10: PNEb t0 by move: PNE_t0; case: (PNEP t0).
      case: (andP (arg_minP Cost H10)).
      by move=> H11; move/forallP; move/(_ tN)/implyP; apply; rewrite -PNE_PNEb.
    }
    apply: H8.
    rewrite ler_pdivr_mulr in H3=> //.
    have H8: Phi tN * A <= Phi tStar * A.
    { rewrite GRing.mulrC [Phi tStar * _]GRing.mulrC.
      apply: ler_mull=> //; by rewrite -H.
    }
    apply: ler_trans; [apply: H3|].
    apply: ler_trans; [apply: H8|].
    rewrite GRing.mulrC -GRing.mulrA.
    by apply: ler_mull.
  Qed.
End PriceOfStabilityBound.


Require Export P04.

(** **** Exercise: 3 stars, recommended (loop_never_stops)  *)
Theorem loop_never_stops : forall st st',
  ~(loop / st \\ st').
Proof.
  intros st st' contra. unfold loop in contra.
  remember (WHILE BTrue DO SKIP END) as loopdef
           eqn:Heqloopdef.
  induction contra; inversion Heqloopdef.
  - (* WhileEnd *) rewrite H1 in H. inversion H.
  - (* WhileLoop *) subst. apply IHcontra2. assumption.
Qed.


From stdpp Require Import relations list.
From Coq Require Import ssreflect.
From LS2NF Require Import grammar util slice.

Section sub_derive.

  Context {Σ N : Type} `{!EqDecision Σ} `{!EqDecision N}.
  Context (G : grammar Σ N).

  Implicit Type A B S : N.
  Implicit Type w v u : sentence Σ.

  Open Scope grammar_scope.

  (* subtree *)

  Inductive child : relation (@tree Σ N) :=
  | child_unary A t :
    child t (unary_tree A t)
  | child_left A t t' :
    child t (binary_tree A t t')
  | child_right A t t' :
    child t (binary_tree A t' t)
  .

  Lemma child_valid t t' :
    child t' t →
    ✓{G} t →
    ✓{G} t'.
  Proof.
    induction 1; inversion 1; subst.
    all: naive_solver.
  Qed.

  Definition subtree := rtc child.

  (* By definition, subtree is transitive *)

  Lemma subtree_valid t t' :
    subtree t' t →
    ✓{G} t →
    ✓{G} t'.
  Proof.
    induction 1 => ? //.
    eapply child_valid; eauto.
  Qed.

  (* inversion lemmas *)

  Lemma subtree_ε_inv t A :
    subtree t (ε_tree A) → t = ε_tree A.
  Proof.
    intros H. apply rtc_inv_r in H.
    destruct H as [|[T [? Hc]]]; first done.
    by inversion Hc.
  Qed.

  Lemma subtree_token_inv t A tk :
    subtree t (token_tree A tk) → t = token_tree A tk.
  Proof.
    intros H. apply rtc_inv_r in H.
    destruct H as [|[T [? Hc]]]; first done.
    by inversion Hc.
  Qed.

  Lemma subtree_unary_inv t' A t :
    subtree t' (unary_tree A t) → t' = unary_tree A t ∨ subtree t' t.
  Proof.
    intros H. apply rtc_inv_r in H.
    destruct H as [|[T [? Hc]]]; [by left | right].
    invert Hc. done.
  Qed.

  Lemma subtree_binary_inv t' A tl tr :
    subtree t' (binary_tree A tl tr) →
    t' = binary_tree A tl tr ∨ subtree t' tl ∨ subtree t' tr.
  Proof.
    intros H. apply rtc_inv_r in H.
    destruct H as [|[T [? Hc]]]; [by left | right].
    invert Hc.
    all: naive_solver.
  Qed.

  (* sub derivation *)

  Definition sig : Type := N * sentence Σ.

  Definition sub_derive : relation sig :=
    λ σ1 σ2, match σ1, σ2 with (A, w), (B, v) =>
      ∀ t', t' ▷ B ={G}=> v →
        ∃ t, t ▷ A ={G}=> w ∧ subtree t' t
    end.

  Global Instance sub_derive_trans : Transitive sub_derive.
  Proof.
    intros [A w] [B v] [C u] HAB HBC t Ht.
    specialize (HBC _ Ht) as [t1 [Ht1 ?]].
    specialize (HAB _ Ht1) as [t2 [Ht2 ?]].
    exists t2. split; [done | etrans; eauto].
  Qed.

  (* encoding sub derivation via sig reachable *)

  Inductive step : relation sig :=
  | step_unary A B φ w :
    A ↦ unary B φ ∈ G →
    app₁ φ w = true →
    step (A, w) (B, w)
  | step_left A Bl Br φ wl wr :
    A ↦ binary Bl Br φ ∈ G →
    app₂ φ wl wr = true →
    G ⊨ Br => wr →
    step (A, wl ++ wr) (Bl, wl)
  | step_right A Bl Br φ wl wr :
    A ↦ binary Bl Br φ ∈ G →
    app₂ φ wl wr = true →
    G ⊨ Bl => wl →
    step (A, wl ++ wr) (Br, wr)
  .

  Infix "→₁" := step (at level 40).

  Definition reachable : relation sig := rtc step.

  Infix "→∗" := reachable (at level 40).

  Lemma step_spec A w B v :
    (A, w) →₁ (B, v) → sub_derive (A, w) (B, v).
  Proof.
    inversion 1; subst; intros t' [? [? ?]].
    all: repeat match goal with
    | H : _ ⊨ _ => _ |- _ => destruct H as [? [? [? ?]]]
    end.
    - exists (unary_tree A t'). split.
      * repeat split. { naive_solver. } econstructor; naive_solver.
      * apply rtc_once. constructor.
    - eexists (binary_tree A t' _). split.
      * repeat split. { naive_solver. } econstructor; naive_solver.
      * apply rtc_once. constructor.
    - eexists (binary_tree A _ t'). split.
      * repeat split. { naive_solver. } econstructor; naive_solver.
      * apply rtc_once. constructor.
  Qed.

  Lemma reachable_spec A w B v :
    G ⊨ B => v →
    (A, w) →∗ (B, v) ↔ sub_derive (A, w) (B, v).
  Proof.
    intros Hv. split.
    - (* -> *)
      induction 1 as [[]|[] [] [] H1 ? ?].
      + intros t ?. exists t. split; [done | constructor].
      + apply step_spec in H1. etrans; eauto.
    - (* <- *)
      intros H. destruct Hv as [t' Ht'].
      specialize (H _ Ht') as [t [? Hsub]].
      generalize dependent w.
      generalize dependent A.
      induction t as [?|??|?? IHt|?? IHt1 ? IHt2] => A w [? [? Ht]].
      all: apply rtc_inv_r in Hsub as [->|[c [? Hc]]].
      all: try by (have [-> ->] : A = B ∧ v = w by
          destruct Ht' as [? [? ?]]; naive_solver); constructor.
      all: invert Hc.
      all: invert Ht.
      + econstructor. eapply step_unary; eauto. by apply IHt.
      + econstructor. eapply step_left; eauto.
        { by eexists. } by apply IHt1.
      + econstructor. eapply step_right; eauto.
        { by eexists. } by apply IHt2.
  Qed.

  Lemma step_sub A w B v :
    (A, w) →₁ (B, v) →
    ∃ vl vr, w = vl ++ v ++ vr.
  Proof.
    inversion 1; subst.
    - exists [], []. by rewrite app_nil_l app_nil_r.
    - exists [], wr. by rewrite app_nil_l.
    - exists wl, []. by rewrite app_nil_r.
  Qed.

  Lemma reachable_sub_sig σ τ :
    σ →∗ τ →
    ∃ vl vr, σ.2 = vl ++ τ.2 ++ vr.
  Proof.
    induction 1 as [[A w]|[A w] [B u] [C v] Hst ? IHst].
    - exists [], []. by rewrite app_nil_l app_nil_r.
    - simpl in *.
      apply step_sub in Hst as [v1 [v4 ->]].
      destruct IHst as [v2 [v3 ->]].
      exists (v1 ++ v2), (v3 ++ v4).
      by normalize_app_assoc.
  Qed.

  Lemma reachable_sublist A w B v :
    (A, w) →∗ (B, v) → sublist v w.
  Proof.
    apply reachable_sub_sig.
  Qed.

  Inductive reachable_to σ : sig → Prop :=
  | reachable_to_refl :
    reachable_to σ σ
  | reachable_to_unary A B w φ :
    A ↦ unary B φ ∈ G →
    reachable_to σ (B, w) →
    app₁ φ w = true →
    reachable_to σ (A, w)
  | reachable_to_left A Bl w1 Br w2 φ :
    A ↦ binary Bl Br φ ∈ G →
    reachable_to σ (Bl, w1) →
    G ⊨ Br => w2 →
    app₂ φ w1 w2 = true →
    reachable_to σ (A, w1 ++ w2)
  | reachable_to_right A Bl w1 Br w2 φ :
    A ↦ binary Bl Br φ ∈ G →
    reachable_to σ (Br, w2) →
    G ⊨ Bl => w1 →
    app₂ φ w1 w2 = true →
    reachable_to σ (A, w1 ++ w2)
  .

  Lemma reachable_to_spec σ τ :
    reachable_to τ σ ↔ σ →∗ τ.
  Proof.
    split.
    - (* -> *)
      induction 1; subst. constructor.
      all: econstructor; last eauto.
      all: econstructor; eauto.
    - (* <- *)
      apply rtc_ind_l. constructor.
      intros [] [] Hst ? ?.
      invert Hst.
      + eapply reachable_to_unary; eauto.
      + eapply reachable_to_left; eauto.
      + eapply reachable_to_right; eauto.
  Qed.

  Inductive reachable_from σ : sig → Prop :=
  | reachable_from_refl :
    reachable_from σ σ
  | reachable_from_unary A B w φ :
    A ↦ unary B φ ∈ G →
    reachable_from σ (A, w) →
    app₁ φ w = true →
    reachable_from σ (B, w)
  | reachable_from_left A Bl w1 Br w2 φ :
    A ↦ binary Bl Br φ ∈ G →
    reachable_from σ (A, w1 ++ w2) →
    G ⊨ Br => w2 →
    app₂ φ w1 w2 = true →
    reachable_from σ (Bl, w1)
  | reachable_from_right A Bl w1 Br w2 φ :
    A ↦ binary Bl Br φ ∈ G →
    reachable_from σ (A, w1 ++ w2) →
    G ⊨ Bl => w1 →
    app₂ φ w1 w2 = true →
    reachable_from σ (Br, w2)
  .

  Lemma reachable_from_spec σ τ :
    reachable_from σ τ ↔ σ →∗ τ.
  Proof.
    split.
    - (* -> *)
      induction 1; subst. constructor.
      all: eapply rtc_r; first eauto.
      all: econstructor; eauto.
    - (* <- *)
      apply rtc_ind_r. constructor.
      intros [] [] ? Hst ?.
      invert Hst.
      + eapply reachable_from_unary; eauto.
      + eapply reachable_from_left; eauto.
      + eapply reachable_from_right; eauto.
  Qed.

  Definition check_reachable_from σ τ : Prop :=
    match σ, τ with
    | (X, u), (B, w) =>
      (B = X ∧ w = u) ∨
      (∃ A φ, A ↦ unary B φ ∈ G ∧ reachable_from σ (A, w) ∧ app₁ φ w = true) ∨
      (∃ A B' φ w', A ↦ binary B B' φ ∈ G ∧ reachable_from σ (A, w ++ w') ∧ G ⊨ B' => w' ∧
        app₂ φ w w' = true) ∨
      (∃ A B' φ w', A ↦ binary B' B φ ∈ G ∧ reachable_from σ (A, w' ++ w) ∧ G ⊨ B' => w' ∧
        app₂ φ w' w = true)
    end.

  Lemma check_reachable_from_spec σ τ :
    check_reachable_from σ τ ↔ reachable_from σ τ.
  Proof.
    destruct σ as [X u].
    destruct τ as [B w].
    split.
    - intros [H|[H|[H|H]]].
      + destruct H as [-> ->]. apply reachable_from_refl.
      + destruct H as [A [φ [? [? ?]]]]. eapply reachable_from_unary; eauto.
      + destruct H as [A [B' [φ [w' [? [? [? ?]]]]]]]. eapply reachable_from_left; eauto.
      + destruct H as [A [B' [φ [w' [? [? [? ?]]]]]]]. eapply reachable_from_right; eauto.
    - inversion 1; subst.
      + by left.
      + right; left. naive_solver.
      + right; right; left. naive_solver.
      + right; right; right. naive_solver.
  Qed.

End sub_derive.

Arguments subtree {_} {_}.
Arguments sub_derive {_} {_}.

Arguments step {_} {_}.
Arguments reachable {_} {_}.
Arguments reachable_to {_} {_}.
Arguments reachable_from {_} {_}.
Arguments check_reachable_from {_} {_}.


Require Import Extraction.
From Coq Require Import Init.Datatypes.

Module prods.

Definition p_tt_tt := (tt, tt).
Definition p_tt_I  := (tt,  I).
Definition p_I_tt  := (I,  tt).
Definition p_I_I   := (I,   I).

End prods.

(** OCaml extraction **)

Extraction Language OCaml.

Extraction prods.p_tt_tt.
Extraction prods.p_tt_I.
Extraction prods.p_I_tt.

(*

(** val p_tt_tt : (unit0, unit0) prod **)

let p_tt_tt =
  Pair (Tt, Tt)

(** val p_tt_I : (unit0, __) prod **)

let p_tt_I =
  Pair (Tt, __)

(** val p_I_tt : (__, unit0) prod **)

let p_I_tt =
  Pair (__, Tt)

 *)

Fail Extraction prods.p_I_I.
(* The informative inductive type prod has a Prop instance
 * in prods.p_I_I (or in its mutual block).
 * This happens when a sort-polymorphic singleton inductive type
 * has logical parameters, such as (I,I) : (True * True) : Prop.
 * The Ocaml extraction cannot handle this situation yet.
 * Instead, use a sort-monomorphic type such as (True /\ True)
 * or extract to Haskell.
 *)

(** Haskell extraction **)

Extraction Language Haskell.

Extraction prods.p_tt_tt.
Extraction prods.p_tt_I.
Extraction prods.p_I_tt.
Extraction prods.p_I_I.

(*

p_tt_tt :: Prod Unit Unit
p_tt_tt =
  Pair Tt Tt

p_tt_I :: Prod Unit ()
p_tt_I =
  Pair Tt __

p_I_tt :: Prod () Unit
p_I_tt =
  Pair __ Tt

p_I_I :: ()
p_I_I =
  __

*)


Set Implicit Arguments.

Require Import String.
Require Import ZArith.

Require Import domains.
Require Import kstyle.
Require Import coinduction.
Require Import evaluator.

Coercion EVar : string >-> Exp.
Coercion ECon : Z >-> Exp.

Function evals n kcfg :=
  match n with
    | 0 => kcfg
    | S n =>
      match eval kcfg with
      | Some kcfg' => evals n kcfg'
      | None => kcfg
     end
  end.

Lemma evals_sound :
  forall n c (P : kcfg -> Prop), P (evals n c) -> reaches c P.
Proof.
induction n; simpl; intros;
[|pose proof (eval_sound c); destruct (eval c)];
eauto using done,step.
Qed.

Lemma eval_happy' : forall env,
  steps (KCfg (kra (SAssign "x" (EPlus "x" "y")) nil)
            ("x" |-> 12%Z :* "y" |-> 13%Z :* env) mapEmpty mapEmpty)
        (KCfg nil ("x" |-> 25%Z :* "y" |-> 13%Z :* env) mapEmpty mapEmpty).
intros.
repeat (refine (step _ _);[match goal with [|- kstep ?l _] => eapply (eval_sound l) end|]);
instantiate;simpl Zplus;apply done;reflexivity.
Qed.

Definition gcdLabel := 1%Z.
Definition doneLabel := 2%Z.

Definition gcdProg : Map Z Stmt :=
  gcdLabel |->
        SIf (BLe "a" "b")
          (SIf (BLe "b" "a")
               (Jump doneLabel)
               (Seq (SAssign "b" (EMinus "b" "a"))
                    (Jump gcdLabel)))
          (Seq (SAssign "a" (EMinus "a" "b"))
               (Jump gcdLabel)).
Lemma label_eval : forall env,
  steps (KCfg (kra (Jump gcdLabel) kdot)
            ("a" |-> 12%Z :* "b" |-> 13%Z :* env) mapEmpty gcdProg)
        (KCfg (kra (Jump doneLabel) kdot)
             ("a" |-> 1%Z :* "b" |-> 1%Z :* env) mapEmpty gcdProg).
intros. apply evals_sound with 307. simpl; repeat split; reflexivity.
Qed.

(* Some performance tests *)
Definition test_prop :=
  steps (KCfg (kra (SWhile (BLe 0%Z "x")
    (SAssign "x" (EPlus "x" (-1)%Z)))
  nil) ("x" |-> 25%Z) mapEmpty mapEmpty)
  (KCfg nil ("x" |-> (-1)%Z) mapEmpty mapEmpty).
Ltac kequiv_tac := repeat (apply conj);[reflexivity|simpl;equate_maps ..].
Ltac finish := apply done;kequiv_tac.

(* Using tactics alone *)
Lemma loop_test: test_prop.
Proof.
intros;
repeat (refine (step _ _);[econstructor (reflexivity || find_map_entry)|];instantiate;simpl Zplus);
finish.
Qed.

(* go step by step, but compute successor with eval rather than by tactics *)
Lemma loop_test': test_prop.
Proof.
Ltac step_eval :=refine (step _ _);[match goal with [|- kstep ?l _] => eapply (eval_sound l) end|].
intros;repeat step_eval;simpl;finish.
Qed.

(* use multi-step evaluator, reduce with simpl *)
Lemma loop_test_evals_simpl : test_prop.
Proof.
intros;apply (evals_sound 1000);simpl;kequiv_tac.
Qed.

(* reduce with lazy *)
Lemma loop_test_evals_lazy: test_prop.
Proof.
intros;apply (evals_sound 1000);lazy;kequiv_tac.
Qed.

(* reduce with cbv *)
Lemma loop_test_evals_cbv: test_prop.
Proof.
intros;apply (evals_sound 1000);cbv;kequiv_tac.
Qed.

(* reduce with compute *)
Lemma loop_test_evals_compute : test_prop.
Proof.
intros;apply (evals_sound 1000);compute;kequiv_tac.
Qed.

(* reduce with vm_compute *)
Lemma loop_test_evals_vm_compute : test_prop.
Proof.
intros;apply (evals_sound 1000);vm_compute;kequiv_tac.
Qed.


Set warnings "-notation-overridden,-parsing".
Require Import Framework_common.
Require Import Framework_SOS.
From Coq Require Import BinNat.
From Coq Require Import omega.Omega.
From Coq Require Import Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Bool.Bool.

Inductive multi_k {X : Type} (R : relation X) : nat -> relation X :=
  | multikrefl : forall (x : X), multi_k R 0 x x
  | multikstep : forall (x y z : X) (k:nat),
                    R x y->
                    multi_k R k y z ->
                    multi_k R (S k) x z.
Notation " t ==>[ k ]  t' " := (multi_k sstep k t t' ) (at level 50).
Print multi_k.

Local Open Scope Z_scope.
Example e:
<<SKIP, (x!->2)>> ==>[1] <<x!->2>> .
Proof.
  eapply multikstep.
  apply SSSkip.
  eapply multikrefl.
Qed.

Local Close Scope Z_scope.
Close Scope while_scope.
Compute 2+3.

Definition isStuck (conf: Config) :=
0=0 -> ~ (exists (conf':Config), conf ==> conf').

Lemma final_is_stuck:
forall s,
 isStuck <<s>> .
Proof.
intros.
unfold isStuck.
intros.
intro.
destruct H0.
inversion H0.
Qed.

Lemma identity_zero:
forall c,
 c ==>[0] c.
Proof.
apply multikrefl.
Qed.

Lemma stuck_stops:
forall c c' k,
  isStuck c ->
  c ==>[k] c' ->
  k = 0 /\ c' = c.
Proof.
intros.
unfold isStuck in H.
induction k.
- inversion H0; subst.
 split. reflexivity. reflexivity.
- destruct H0. split. reflexivity. reflexivity.
  destruct H. reflexivity.
  exists y. assumption.
Qed.

Lemma state_k_zero:
forall k s conf,
  <<s>> ==>[k] conf
  ->
  k = 0 /\ conf = <<s>>.
Proof.
intros.
apply stuck_stops.
apply final_is_stuck.
assumption.
Qed.
(*
Lemma state_k_zero:
forall k s s' S,
  <<s>> ==>[k] <<S,s'>>
  ->
  k = 0 /\ <<S,s'>> = <<s>>.
Proof.
intros.
apply stuck_stops.
apply final_is_stuck.
assumption.
Qed.*)

Lemma zero_steps:
forall c c',
c ==>[0] c' -> c = c'.
Proof.
intros.  inversion H. reflexivity.
Qed.

Lemma zero_steps_rev:
forall c c',
c = c' ->
c ==>[0] c'.
Proof.
intros. induction H.
apply identity_zero.
Qed.

Lemma one_step:
forall c c',
  c ==> c' ->
  c ==>[1] c'.
Proof.
intros.
apply (multikstep sstep c c').
assumption. apply zero_steps_rev.
reflexivity.
Qed.

Lemma one_step_rev:
forall c c',
  c ==>[1] c' ->
  c ==> c'.
Proof.
intros.
inversion H. subst.
apply zero_steps in H2. subst.
assumption.
Qed.

Check nat_ind.
Theorem strong_induction:
forall P : nat -> Prop,
  P 0 ->
  (forall n : nat, (forall k : nat, ((k <= n)%nat -> P k)) -> P (S n))
  ->
  forall n : nat, P n.
Proof.
intros.
induction n.
- assumption.
- apply H0. intros.
  inversion H1.
    apply IHn. subst.
  induction H1. assumption.
  apply IHle.
  subst.
exfalso.

Admitted.

Lemma comp_complete:
forall k Ss1 Ss2 s s'',
  <<Ss1; Ss2, s>> ==>[k] <<s''>>
  ->
  exists s' k1 k2,
    <<Ss1,s>>==>[k1] <<s'>> /\ <<Ss2,s'>> ==>[k2] <<s''>> /\ k = (k1 + k2).
Proof.
(*induction on the length of the derivation seqence*)
induction k using strong_induction.
- (*0*)
  intros.
  inversion H.
- (*IS*)
  rename k into k0.
  intros.
  inversion H0. subst.
  inversion H2; subst.
  +(*compI*)

   assert (exists (s' : State) (k1 k2 : nat),
      << S1', st' >> ==>[ k1] << s' >> /\
      << Ss2, s' >> ==>[ k2] << s'' >> /\ k0 = k1 + k2).
     {apply H.
       * reflexivity. (*omega.*)
       * assumption.
     }
   destruct H1. rename x into s0. destruct H1. rename x into k1.
   destruct H1. rename x into k2. destruct H1. destruct H4.
   exists s0.
   exists (S k1).
   exists k2.
   split.
    -- apply (multikstep sstep<< Ss1, s >> << S1', st' >> ).
       assumption. assumption.
    -- split.
    --- assumption.
    --- omega.
  +(*compII*)
    exists st'.
    exists 1.
    exists k0.
    split.
    * apply one_step. assumption.
    * split.
      assumption.
      reflexivity.
Qed.

Definition property_half_comp(k:nat) :=
(forall S1 s s',
    <<S1,s>> ==>[k] <<s'>>
    ->
    forall S2,
      <<S1; S2, s>> ==>[k] <<S2, s'>>).

(*2.21*)
Theorem half_comp:
forall k,
  property_half_comp k.
  (*Why is it different????*)

  (*forall S1 s s',
    <<S1,s>> ==>[k] <<s'>>
    ->
    forall S2,
      <<S1; S2, s>> ==>[k] <<S2, s'>>.*)
Proof.
intros.
unfold property_half_comp.
induction k using strong_induction.
  - intros. inversion H.
  - rename k into k0.
    intros.
    inversion H0. subst.
    induction y. (* if it is commi or compii - if S1 is executed in many or 1 steps *)
    + rename s0 into s''.
      rename S into S1'.
      apply (multikstep sstep<< S1; S2, s >> << S1';S2, s'' >>).
      * apply SSCompI. assumption.
      * apply H. reflexivity. assumption.
    + rename s0 into s''.
      apply (multikstep sstep<< S1; S2, s >> <<S2, s'' >>).
      * apply SSCompII. assumption.
      * assert (k0 = 0 /\ <<s'>> = <<s''>>).
      { apply stuck_stops. apply final_is_stuck. assumption.
      }
      inversion H1. inversion H5. subst. apply zero_steps_rev. reflexivity.
Qed.

Definition prop_exec_comp (k1:nat) :=
forall k2 S1 s S2 s' s'',
<<S1, s>> ==>[k1] << s'>>
->
<< S2, s'>> ==>[k2] <<s''>>
->
exists k,
<<S1; S2, s>> ==>[k] <<s''>> /\ k = k1+k2.

Lemma exec_comp:
forall k1,
prop_exec_comp k1.
(*
forall k1 k2 S1 s S2 s' s'',
<<S1, s>> ==>[k1] << s'>>
->
<< S2, s'>> ==>[k2] <<s''>>
->
exists k,
<<S1; S2, s>> ==>[k] <<s''>> /\ k = k1+k2.
*)
Proof.
intros.
unfold prop_exec_comp.
induction k1 using  strong_induction; intros.
- exists (k2).
  split.
  assert (<< S1, s >> = << s' >>).
  {apply zero_steps. assumption. }
  inversion H1.
  omega.
- remember (k1 + k2) as k0.
  exists ( S k0).
  split.
  inversion H0.
  induction y.
  *subst.
   rename S into S1'.
    apply (multikstep sstep<< S1; S2, s >> << S1';S2, s0 >>).
      -- apply SSCompI. assumption.
      -- assert ( exists k0 : nat,
            << S1'; S2, s0 >> ==>[ k0] << s'' >> /\ k0 = k1+k2 ).
            { apply H with s'. reflexivity.
              assumption.
              assumption.
            }
         destruct H2. destruct H2. subst. assumption.
  * subst.
    apply (multikstep sstep<< S1; S2, s >> <<S2, s0 >>).
      -- apply SSCompII. assumption.
      -- assert (k1 = 0 /\ <<s'>> = <<s0>>).
         { apply state_k_zero. assumption. }
         destruct H2. inversion H5. subst.
         assumption.
  *  omega.
  Qed.


Require Export Category.Core Category.Morphisms.
Require Import Common.

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

Local Open Scope morphism_scope.

Notation IsCategory C := (forall s d : Object C, IsEquiv (@idtoiso C s d)).

Notation isotoid C s d := (@equiv_inv _ _ (@idtoiso C s d) _).

Instance trunc_category `{IsCategory C} : IsTrunc 1 C | 10000.
Proof.
  intros ? ?.
  eapply trunc_equiv';
  [ apply symmetry;
    esplit;
    apply_hyp
  | ].
  typeclasses eauto.
Qed.

Record Category :=
  {
    CategoryPreCategory :> PreCategory;
    CategoryPreCategory_IsCategory :> IsCategory CategoryPreCategory
  }.

Existing Instance CategoryPreCategory_IsCategory.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e511m187_16limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Export CatSem.PROP_untyped.prop_arities_initial.

Require Import Coq.Program.Equality.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Automatic Introduction.
Unset Transparent Obligations.

(* Check INITIAL_INEQ_REP. *)

Inductive Lambda_index := ABS | APP.

Definition Lambda : Signature := {|
  sig_index := Lambda_index ;
  sig := fun x => match x with
                  | ABS => [[ 1 ]]
                  | APP => [[ 0 ; 0]]
                  end
|}.

(*Definition Lambda_subst := subst_half_eq Lambda.
Check Lambda_subst.
*)

Section App_Abs_half_eq.

Section for_a_representation.

Variable R : REP Lambda.

Definition beta_carrier :
(forall c : TYPE, (S_Mod_classic_ob [[1; 0]] R) c ---> (S_Mod_classic_ob [[0]] R) c) .
simpl.
intros.
simpl in *.
inversion X.
simpl in *.
inversion X1.
simpl in X2.
constructor.
simpl.
destruct R as [Rr Repr].
simpl in *.
apply (Repr APP).
simpl.
simpl in *.
constructor.
simpl.
apply (Repr ABS).
simpl.
constructor.
simpl.
apply X0.
constructor.
constructor.
simpl.
apply X2.
constructor.
constructor.
Defined.

Program Instance beta_struct  : RModule_Hom_struct
  (M:=S_Mod_classic_ob [[1;0]] R) (N:=S_Mod_classic_ob [[0]] R) beta_carrier.
Next Obligation.
Proof.
  dependent destruction x.
  simpl.
  dependent destruction x.
  simpl in *.
  apply CONSTR_eq; auto.
  destruct R.
  simpl in *.
  rerew (rmhom_rmkl (repr APP)).
  apply f_equal.
  simpl in *.
  apply CONSTR_eq; auto.
  clear x.
  clear p0.
  rerew (rmhom_rmkl (repr ABS)).
Qed.

Definition beta_module_mor := Build_RModule_Hom beta_struct.

End for_a_representation.

Program Instance beta_half_s : half_equation_struct
      (U:=S_Mod_classic Lambda [[1 ; 0]])
      (V:=S_Mod_classic Lambda [[0]])
      beta_module_mor.
Next Obligation.
Proof.

  dependent destruction x.
  dependent destruction x.
  dependent destruction x.

  simpl.
  apply CONSTR_eq; auto.
  destruct T; simpl.
  destruct R; simpl.
  assert (H:=@repr_hom_s _ _ _ _ f).
  simpl in *.
  assert (Habs := H ABS).
  simpl in *.
  unfold commute in Habs; simpl in *.
  assert (Happ := H APP).
  simpl in *.
  unfold commute in Happ; simpl in *.
  rewrite <- Happ.
  apply f_equal.
  simpl in *.
  apply CONSTR_eq; auto.
  rewrite <- Habs.
  auto.
Qed.

Definition beta_half_eq := Build_half_equation beta_half_s.

End App_Abs_half_eq.

Definition beta_rule : ineq_classic Lambda := {|
   half_eq_l := beta_half_eq ;
   half_eq_r := subst_half_eq Lambda |}.

Definition Lambda_beta_Cat := INEQ_REP
    (S:=Lambda)(A:=unit)(fun x : unit => beta_rule).

Definition Lambda_beta_SynSem :=  (INITIAL_INEQ_REP (fun x : unit => beta_rule)).

Definition Lambda_beta := @Init _ _ _ (INITIAL_INEQ_REP (fun x : unit => beta_rule)).


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e266m3_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e206m5_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


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

Require Import Nat.

Inductive lst : Type :=
  | Nil : lst
  | Cons : nat -> lst -> lst.

Fixpoint len (l : lst) : nat :=
match l with
  | Nil => 0
  | Cons a l1 => 1 + (len l1)
end.

Fixpoint rev (l1 l2: lst): lst :=
  match l1 with
  | Nil => l2
  | Cons x l1' => rev l1' (Cons x l2)
  end.

Lemma list_rev2_len_lem: forall l1 l2,
len (rev l1 l2) = (len l1) + (len l2).
Proof.
  induction l1.
  - simpl. reflexivity.
  - simpl. intros. rewrite IHl1. simpl. rewrite <- plus_n_Sm.
    reflexivity.
Qed.

Theorem list_rev2_len: forall l: lst, len (rev l Nil) = len l.
Proof.
  induction l.
  - simpl. reflexivity.
- lfind. Admitted.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Functor.
Require Import Category.Construction.Opposite.
Require Import Category.Construction.Product.

Generalizable All Variables.

Section Dinatural.

Context {C : Category}.
Context `{@Terminal C}.
Context `{@Terminal (C^op)}.
Context {D : Category}.
Context {F : C^op ∏ C ⟶ D}.
Context {G : C^op ∏ C ⟶ D}.

Definition prod_split {x y z w} (f : x ~{C^op}~> z) (g : y ~{C}~> w) :
  (x, y) ~{ (C ^op) ∏ C }~> (z, w) := (f, g).
Arguments prod_split {_ _ _ _} _ _ /.

Infix "⋆⋆⋆" := prod_split (at level 100) : category_scope.

Class Dinatural := {
  ditransform {x} : F (x, x) ~> G (x, x);

  dinaturality {x y} (f : x ~{C}~> y) :
    fmap[G] (op f ⋆⋆⋆ id) ∘ ditransform ∘ fmap[F] (id ⋆⋆⋆ f)
        ≈ fmap[G] (id ⋆⋆⋆ f) ∘ ditransform ∘ fmap[F] (op f ⋆⋆⋆ id)
}.

#[export] Program Instance Dinatural_Setoid : Setoid Dinatural.

End Dinatural.

Notation "ditransform[ F ]" := (@ditransform _ _ _ _ F)
  (at level 9, format "ditransform[ F ]") : category_scope.

(* Dinatural transformations can be applied directly to functorial values to
   perform the functor mapping they imply. *)
Coercion ditransform : Dinatural >-> Funclass.


Set Implicit Arguments.

Require Import util.
Require list_utils.
Require Import List.
Require Import monads.

Record Monoid: Type :=
  { monoid_type:> Set
  ; monoid_zero: monoid_type
  ; monoid_mult: monoid_type -> monoid_type -> monoid_type
  ; monoid_lunit: forall x, monoid_mult monoid_zero x = x
  ; monoid_runit: forall x, monoid_mult x monoid_zero = x
  ; monoid_assoc: forall x y z, monoid_mult (monoid_mult x y) z = monoid_mult x (monoid_mult y z)
  }.

Record monoidHomo (m n: Monoid) (f: m -> n): Prop :=
  { monoidHomo_zero: f (monoid_zero m) = (monoid_zero n)
  ; monoidHomo_mult: forall x y, f (monoid_mult m x y) = monoid_mult n (f x) (f y)
  }.

Lemma monoidHomo_refl (m: Monoid): monoidHomo m m (fun x => x).
Proof. intros. apply Build_monoidHomo; auto. Qed.

Module MonoidMonadTrans.
Section MonoidMonadTrans.

  Variable monoid: Monoid.

  Section NewMonad.

    Variable monad: Monad.
    Hypothesis ext: extMonad monad.

    Let C_MMT (T: Set): Set := monad (prod monoid T).

    Let bind_MMT (A B: Set) (a: C_MMT A) (ab: A -> C_MMT B): C_MMT B :=
      x <- a ; y <- ab (snd x) ;
      ret (monoid_mult monoid (fst x) (fst y), snd y).

    Let ret_MMT (T: Set): T -> C_MMT T := ret ∘ pair (monoid_zero monoid).

    Definition M: Monad.
    Proof with simpl; auto.
      apply (Build_Monad C_MMT bind_MMT ret_MMT); intros.
          (* one unit *)
          unfold ret_MMT, bind_MMT, compose.
          simpl.
          rewrite mon_lunit.
          simpl.
          assert (ext_eq (fun y: prod monoid b => monads.ret (m:=monad) (monoid_mult monoid (monoid_zero monoid) (fst y), snd y)) ret).
            intro.
            rewrite monoid_lunit.
            destruct x0...
          rewrite (ext _ H (f x)).
          rewrite mon_runit...
        (* the other unit *)
        unfold ret_MMT, bind_MMT, compose.
        simpl.
        rewrite mon_lunit_under_bind...
        assert (ext_eq (fun x => monads.ret (m:=monad) (monoid_mult monoid (fst x) (monoid_zero monoid), snd x)) (@monads.ret monad (prod monoid a))).
          intro.
          rewrite monoid_runit.
          destruct x...
        rewrite (ext _ H f).
        rewrite mon_runit...
      (* assoc *)
      unfold bind_MMT.
      rewrite mon_assoc.
      apply (extFlipped ext n (prod monoid c)). intro.
      rewrite mon_assoc.
      rewrite mon_assoc.
      apply (extFlipped ext (f (snd x)) (prod monoid c)). intro.
      rewrite mon_assoc.
      rewrite mon_lunit...
      apply (extFlipped ext (g (snd x0)) (prod monoid c)). intro.
      rewrite mon_lunit.
      rewrite monoid_assoc...
    Defined.

    Lemma bind_toLower' (X V: Set) (f: M V) (g: V -> M X):
      f >>= g =
        x <- f: monad (prod monoid V);
        ((g (snd x): monad (prod monoid X)) >>=
          (ret ∘ (fun q => (monoid_mult monoid (fst x) (fst q), snd q)))).
    Proof. auto. Qed.

    Lemma bind_toLower (X V: Set) (f: M V) (g: V -> M X):
      f >>= g =
        x <- f: monad (prod monoid V);
        y <- g (snd x): monad (prod monoid X);
        ret (m:=monad) (monoid_mult monoid (fst x) (fst y), snd y).
    Proof. auto. Qed.

    Definition ret_toLower (X: Set) (x: X): @ret M X x = ret (m:=monad) (monoid_zero monoid, x).
    Proof. auto. Qed.

    Lemma mon_toLower: forall X, M X = monad (prod monoid X).
    Proof. auto. Qed.

    Lemma Mext: extMonad M.
    Proof with auto.
      unfold extMonad.
      intros.
      simpl.
      unfold bind_MMT.
      simpl in x.
      unfold C_MMT in x.
      set ext.
      unfold extMonad in e.
      apply (e (prod monoid A) (prod monoid B)).
      intro.
      unfold ext_eq in H.
      rewrite H...
    Qed.

    Definition lift (A: Set) (a: monad A): M A := a >>= (ret ∘ pair (monoid_zero monoid)).

  End NewMonad.

  Definition T: MonadTrans := Build_MonadTrans M lift.

End MonoidMonadTrans.
End MonoidMonadTrans.

Definition NatAddMonoid: Monoid.
Proof with auto with arith.
  apply (Build_Monoid 0 plus)...
Defined.

Definition SimplyProfiled: Monad := MonoidMonadTrans.M NatAddMonoid IdMonad.ext.

Definition cost {X: Set}: prod nat X -> nat := @fst _ _.
Definition result X: SimplyProfiled X -> X := @snd _ _.

Lemma bind_cost (T U: Set) (a: SimplyProfiled T) (b: T -> SimplyProfiled U):
  cost (bind a b) = cost a + cost (b (result a)).
Proof with auto.
  intros.
  destruct a.
  simpl.
  destruct (b t)...
Qed.

Lemma return_cost (T: Set) (x: T): cost (@ret SimplyProfiled T x) = 0.
Proof. auto. Qed.

Lemma SimplyProfiled_ext: extMonad SimplyProfiled.
  unfold SimplyProfiled.
  intro.
  simpl.
  unfold IdMonad.C.
  unfold IdMonad.bind.
  unfold IdMonad.ret.
  intros.
  rewrite (H (snd x)).
  reflexivity.
Qed.

Module ListMonoid.
Section ListMonoid.

  Variable T: Set.

  Definition M: Monoid :=
    Build_Monoid (@nil T) (@app T) (@refl_equal (list T)) (@list_utils.app_nil_r T) (@app_ass T).

End ListMonoid.
End ListMonoid.


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.

Local Coercion Nat.b2n : bool >-> nat.

Local Open Scope nat_scope.

(* Classical oracle function. *)
Variable f : nat -> bool.

(* in our limited case of k = 1, we can index the relevant subset of f-s by the x with which they return true *)
Definition f_unique (x:nat) : nat -> bool :=
  (fun y => x =? y).

Lemma f_unique_correct : forall x y, x <> y -> (f_unique x) x = true /\ (f_unique x) y = false.
Proof.
  intros.
  split.
  unfold f_unique.
  symmetry.
  apply beq_nat_refl.
  unfold f_unique.
  apply Nat.eqb_neq.
  apply H.
Qed.

(* type for the four functions for a database of 4 that only return true for one of them,
to delineate scope of current grover's implementation *)
Inductive Unique_Function: (nat -> bool) -> Set :=
    | f0 : Unique_Function (f_unique 0)
    | f1 : Unique_Function (f_unique 1)
    | f2 : Unique_Function (f_unique 2)
    | f3 : Unique_Function (f_unique 3).

(* To illustrate a more usual, but in this case not very nice way of restricting the scope via dependency *)
Inductive Longer_dep_ufunc (x:nat) (pf: x < 4) : (nat->bool) -> Set :=
    | long0 :  x = 0 -> Longer_dep_ufunc x pf (f_unique x)
    | long1 :  x = 1 -> Longer_dep_ufunc x pf (f_unique x)
    | long2 :  x = 2 -> Longer_dep_ufunc x pf (f_unique x)
    | long3 :  x = 3 -> Longer_dep_ufunc x pf (f_unique x).

(*Demonstratively, one-;line version*)
Inductive Short_Ufunc (x:nat) (pf: x < 4) : (nat -> bool) -> Set := one_line :  Short_Ufunc x pf (f_unique x).

(* Demonstratively, general version *)
Inductive U_Func_Ind : (nat -> bool) -> Set :=
    | finductive : U_Func_Ind (f_unique 0%nat)
    | SF :  forall (x:nat), U_Func_Ind (f_unique x) -> U_Func_Ind (f_unique (S x)).

(* Demonstratively, general without full induction *)
Inductive U_Func_Gen :  (nat -> bool ) -> Set := fx : forall (x:nat), U_Func_Gen (f_unique x).

(* Variable a in unique func *)
Variable a : nat.

(* limited classical  oracle function *)
Variable (g: Unique_Function (f_unique a)).

(* S gate is derived from the The "controlled phase gate" _R_ m with m = 2, so the rotation = Pi/2*)
Definition _S := _R_ (PI/2).

 (*Tactic for solving Complex Conjegate equivalences below*)
Ltac C1_conjunctive_solve :=
  C_field_simplify;
  try rewrite Copp_involutive;
  unfold C1;
  unfold Cconj;
  try unfold Copp;
  unfold fst, snd;
  try rewrite Ropp_involutive;
  try repeat rewrite Ropp_0;
  reflexivity.

Local Open Scope C_scope.

(* Proof that proving Mmult M M is sufficient for M=M to prove Minv M M *)
Lemma mmult_self_then_minv : forall {m} (M: Square m),
    Mmult M M = I m -> Minv M M.
Proof.
  intros.
  unfold Minv.
  split.
  apply H.
  apply H.
Qed.

(* Proof of involutoriness, sufficient given the above *)
Lemma all_oracles_denoted_matrix_involutory: forall i j k l, i =  C1 \/ i = (-C1) ->  j =  C1 \/ j = (-C1) ->  k =  C1 \/ k = (-C1) ->  l =  C1 \/ l = (-C1) -> Mmult (list2D_to_matrix ( [ [ i ; C0 ; C0 ; C0 ] ; [ C0 ; j; C0; C0 ] ; [ C0 ; C0 ;  k ;C0 ] ; [C0 ; C0; C0 ; l] ] )) (list2D_to_matrix  ( [ [ i ; C0 ; C0 ; C0 ] ; [ C0 ; j; C0; C0 ] ; [ C0 ; C0 ;  k ;C0 ] ; [C0 ; C0; C0 ; l] ] )) = I 4.
Proof.
  intros.
  solve_matrix.
  destruct H. 3: destruct H0. 5: destruct H1. 7: destruct H2.
  1,2: rewrite H. 3,4: rewrite H0. 5,6: rewrite H1. 7,8: rewrite H2.
  all: C_field.
Qed.

(*Proof that the underlying operators are unitary for all oracles here considered*)
Lemma all_oracles_denoted_matrix_hermitian: forall i j k l, i =  C1 \/ i = (-C1) ->  j =  C1 \/ j = (-C1) ->  k =  C1 \/ k = (-C1) ->  l =  C1 \/ l = (-C1) -> (list2D_to_matrix ( [ [ i ; C0 ; C0 ; C0 ] ; [ C0 ; j; C0; C0 ] ; [ C0 ; C0 ;  k ;C0 ] ; [C0 ; C0; C0 ; l] ] )) = (adjoint (list2D_to_matrix  ( [ [ i ; C0 ; C0 ; C0 ] ; [ C0 ; j; C0; C0 ] ; [ C0 ; C0 ;  k ;C0 ] ; [C0 ; C0; C0 ; l] ] ))).
Proof.
  intros.
  solve_matrix.
  destruct H. 3: destruct H0. 5: destruct H1. 7: destruct H2.
  1,2: rewrite H. 3,4: rewrite H0. 5,6: rewrite H1. 7,8: rewrite H2.
  all: C1_conjunctive_solve.
Qed.

(* Given that it is sufficient to prove the lemmas as set out below to prove unitarity when a matrix is its own inverse,
so that we can substitute in itself for its inverse in the proof *)
Lemma inverse_equiv_unit : forall {m} (M1 M2 : Square m),
    M1 = M2 -> Mmult M1 (adjoint M1) = Mmult M2 (adjoint M1).
Proof.
  intros.
  rewrite H.
  reflexivity.
Qed.

(* Proof of the unitarity of underlying opertors, directly*)
Lemma all_oracles_denoted_matrix_unitary: forall i j k l, i =  C1 \/ i = (-C1) ->  j =  C1 \/ j = (-C1) ->  k =  C1 \/ k = (-C1) ->  l =  C1 \/ l = (-C1) -> (Mmult (list2D_to_matrix ( [ [ i ; C0 ; C0 ; C0 ] ; [ C0 ; j; C0; C0 ] ; [ C0 ; C0 ;  k ;C0 ] ; [C0 ; C0; C0 ; l] ] )) (adjoint (list2D_to_matrix  ( [ [ i ; C0 ; C0 ; C0 ] ; [ C0 ; j; C0; C0 ] ; [ C0 ; C0 ;  k ;C0 ] ; [C0 ; C0; C0 ; l] ] )))) = I 4.
Proof.
  intros.
  solve_matrix.
  destruct H. 3: destruct H0. 5: destruct H1. 7: destruct H2.
  1,2: rewrite H. 3,4: rewrite H0. 5,6: rewrite H1. 7,8: rewrite H2.
  all: C1_conjunctive_solve.
 Qed.

(* equality is a congruence on A - by definition, of course*)
Lemma cong_eq : forall (A:Type) (a:A) (b:A) (f : A -> A), a = b -> f a = f b.
Proof.
  intros.
  rewrite H.
  reflexivity.
Qed.

(* equality is a congruence on A in f with f equal to partial application f a below*)
Lemma cong_eq_in_f_partial : forall (A:Type) (a:A) (b:A) (c:A) (f: A -> A), f a = c -> a = b -> f b = c.
Proof.
  intros.
  apply (cong_eq A a0 b f4)  in H0.
  symmetry in H0. rewrite H0.
  apply H.
Qed.

(* equality is a congruence on A in f *)
Lemma cong_eq_in_f : forall (A:Type) (a:A) (b:A) (c:A) (f: A -> A -> A), f a a = c -> a = b -> f a b = c.
Proof.
  intros.
  rewrite (cong_eq_in_f_partial A a0 b c (f4 a0)).
  symmetry in H.
  split.
  apply H.
  apply H0.
Qed.

(* Given the above, we can prove unitarity in a different way: *)
Lemma involutory_and_hermitian_then_unitary : forall (m:nat) (M: Square m),
    Mmult M M = I m -> M = adjoint M -> Mmult M (adjoint M) = I m.
Proof.
  intros.
  apply cong_eq_in_f.
  apply H.
  apply H0.
Qed.

(*multiplication is commutative on these*)
Lemma oracles_denoted_matrix_mult_comm : forall i j k l m n o p, (i =  C1 \/ i = (-C1)) ->  j =  C1 \/ j = (-C1) ->  k =  C1 \/ k = (-C1) ->  l =  C1 \/ l = (-C1) ->  m = C1 \/ m = (-C1) ->  n =  C1 \/ n = (-C1) ->  p =  C1 \/ p = (-C1) ->  o =  C1 \/ o = (-C1) -> Mmult (list2D_to_matrix ( [ [ i ; C0 ; C0 ; C0 ] ; [ C0 ; j; C0; C0 ] ; [ C0 ; C0 ;  k ;C0 ] ; [C0 ; C0; C0 ; l] ] )) (list2D_to_matrix  ( [ [ m ; C0 ; C0 ; C0 ] ; [ C0 ; n; C0; C0 ] ; [ C0 ; C0 ;  o ;C0 ] ; [C0 ; C0; C0 ; p] ] )) = Mmult  (list2D_to_matrix  ( [ [ m ; C0 ; C0 ; C0 ] ; [ C0 ; n; C0; C0 ] ; [ C0 ; C0 ;  o ;C0 ] ; [C0 ; C0; C0 ; p] ] )) (list2D_to_matrix  ( [ [ i ; C0 ; C0 ; C0 ] ; [ C0 ; j; C0; C0 ] ; [ C0 ; C0 ;  k ;C0 ] ; [C0 ; C0; C0 ; l] ] )).
Proof.
  intros.
  solve_matrix.
Qed.

Local Close Scope nat_scope.
Local Open Scope circ_scope.

(* Oracle for f(0) = true, else false *)
 Definition small_oracle_0 : Box ( Qubit ⊗ Qubit ) ( Qubit ⊗ Qubit ) :=
   box_ (x, y) ⇒
     let_ x ← _Z $ x;
     let_ y ← _Z $ y;
     let_ (x,y) ← ctrl _Z $ (x,y);
     (x,y).

(*well-typedness lemma for small_oracle_0; same for oracles below*)
Lemma small_oracle_0_WT : Typed_Box (small_oracle_0).
Proof. type_check. Qed.

(* Correctness lemma for small_oracle_0; same for oracles below *)
Lemma correct_small_oracle_0 : forall (s: Square 4), WF_Matrix s -> denote (small_oracle_0) s = super (list2D_to_matrix ( [ [ (-C1) ; C0 ; C0 ; C0 ] ; [ C0 ; C1; C0; C0 ] ; [ C0 ; C0 ; C1 ;C0 ] ; [C0 ; C0; C0 ; C1] ] )) s.
 Proof.
   matrix_denote.
   solve_matrix.
 Qed.

 (* Oracle for f(1) = true, else false *)
Definition small_oracle_1 :
Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
 box_ (x, y) ⇒
   let_ y ← _Z $ y;
   let_ (x,y) ← ctrl _Z $ (x,y);
   (x,y).

Lemma small_oracle_1_WT : Typed_Box (small_oracle_1).
Proof. type_check. Qed.

Lemma correct_small_oracle_1 : forall (s: Square 4), WF_Matrix s -> denote (small_oracle_1) s = super (list2D_to_matrix ( [ [ C1 ; C0 ; C0 ; C0 ] ; [ C0 ; (-C1); C0; C0 ] ; [ C0 ; C0 ; C1 ;C0 ] ; [C0 ; C0; C0 ; C1] ] )) s.
Proof.
   matrix_denote.
   solve_matrix.
Qed.

(* Oracle for f(2) = true, else false *)
 Definition small_oracle_2:
 Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
  box_ (x, y) ⇒
    let_ x ← _Z $ x;
    let_ (x,y) ← ctrl _Z $ (x,y);
    (x,y).

Lemma small_oracle_2_WT : Typed_Box (small_oracle_2).
Proof. type_check. Qed.

 Lemma correct_small_oracle_2 : forall (s: Square 4), WF_Matrix s -> denote (small_oracle_2) s = super (list2D_to_matrix ( [ [ C1 ; C0 ; C0 ; C0 ] ; [ C0 ; C1; C0; C0 ] ; [ C0 ; C0 ; (-C1) ;C0 ] ; [C0 ; C0; C0 ; C1] ] )) s.
 Proof.
   matrix_denote.
   solve_matrix.
 Qed.

(* Oracle for f(3) = true, else false *)
 Definition small_oracle_3 :
 Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
  box_ (x, y) ⇒
    let_ (x,y) ← ctrl _Z $ (x,y);
    (x,y).

Lemma small_oracle_3_WT : Typed_Box (small_oracle_3).
Proof. type_check. Qed.

Lemma correct_small_oracle_3 : forall (s: Square 4), WF_Matrix s -> denote (small_oracle_3) s = super (list2D_to_matrix ( [ [ C1 ; C0 ; C0 ; C0 ] ; [ C0 ; C1; C0; C0 ] ; [ C0 ; C0 ; C1 ;C0 ] ; [C0 ; C0; C0 ; (-C1)] ] )) s.
Proof.
   matrix_denote.
   solve_matrix.
Qed.

(* diffusion operator for 2 qubits *)
Definition small_diffusion : Box ( Qubit ⊗ Qubit ) ( Qubit ⊗ Qubit ) :=
  box_ (x, y) ⇒
    (*step 1*)
    let_ x ← _H $ x;
    let_ y ← _H $ y;
    (*step 2*)
    let_ x ← _X $ x;
    let_ y ← _X $ y;
    (*step 3*)
    let_ (x,y) ← ctrl _Z $ (x,y);
    (*step 4*)
    let_ x ← _X $ x;
    let_ y ← _X $ y;
    (*step 5*)
    let_ x ← _H $ x;
    let_ y ← _H $ y;
    (*end*)
    (x,y).

(* well-typedness lemma *)
Lemma small_diffusion_WT : Typed_Box (small_diffusion).
Proof. type_check. Qed.

(* First part of tactic proving that certain Real values are nonzero (this is a bit finnicky because reals are axiomatic in coq)
   Need for separation explained below *)
Ltac grover_nonzero_begin :=
  unfold C2;
  apply C0_fst_neq;
  unfold fst;
  replace 2%R with (sqrt 2 * sqrt 2)%R.

(* Second part of tactic for proving that certain Real values are nonzero *)
Ltac grover_nonzero_end :=
  apply Rmult_integral_contrapositive;
  split;
  apply sqrt2_neq_0;
  apply sqrt2_neq_0;
  apply sqrt_sqrt;
  intuition.

(* matrix form to help verify correctness; it is established, but commented out for now because it takes too long to run. Uncomment if desired*)
Definition diffusion_matrix : 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)) ] ] )).

(* The below runs perfectly fine, but way too slowly, so it is commented out *)
(*Lemma correct_small_diffusion : forall (s:Square 4), WF_Matrix s -> denote (small_diffusion) s = super diffusion_matrix s.
Proof.                                                                                unfold diffusion_matrix.
  matrix_denote.
  Msimpl.
  simpl.
  repeat rewrite <- Mmult_assoc.

  replace (I 2 ⊗ hadamard)%M with (list2D_to_matrix ( [ [ (1/ sqrt(2));  (1/ sqrt(2)) ; C0; C0 ] ; [  (1/ sqrt(2)) ; (- (1/ sqrt(2))) ; C0 ; C0]  ; [ C0 ; C0 ;  (1/ sqrt(2));  (1/ sqrt(2))] ; [ C0 ; C0 ;  (1/ sqrt(2));  (-(1/ sqrt(2)))] ] )).
  2: { solve_matrix. }
  replace (hadamard ⊗ I 2)%M with (list2D_to_matrix ( [ [ (1/ sqrt(2));  C0 ;  (1/ sqrt(2)); C0 ] ; [  C0 ;  (1/ sqrt(2)) ; C0 ;  (1/ sqrt(2))]  ; [  (1/ sqrt(2)) ; C0 ;  (-(1/ sqrt(2))); C0] ; [ C0 ; (1/ sqrt(2)) ;  C0;  (-(1/ sqrt(2)))] ] )).
  2: { solve_matrix. }
  replace (adjoint(hadamard) ⊗ I 2)%M with (list2D_to_matrix ( [ [ (1/ sqrt(2));  C0 ;  (1/ sqrt(2)); C0 ] ; [  C0 ;  (1/ sqrt(2)) ; C0 ;  (1/ sqrt(2))]  ; [  (1/ sqrt(2)) ; C0 ;  (-(1/ sqrt(2))); C0] ; [ C0 ; (1/ sqrt(2)) ;  C0;  (-(1/ sqrt(2)))] ] )).
  2: { solve_matrix. }
  solve_matrix.
  all: C_field_simplify. all: replace ((R1 + R1)%R, (R0 + R0)%R)%core with C2.
  all: C_field_simplify.
  all: solve_matrix.
  all: split.
  all: try apply Csqrt2_neq_0.
  all: grover_nonzero_begin.
  all: try apply sqrt_sqrt.
  2,4,6,8,10,12,14,16,18,20,22,24,26,28,30,32: intuition.
  all: try grover_nonzero_end.
Qed. *)

(*involutoriness of the diffusion operator *)
Lemma involutory_diffusion: Mmult diffusion_matrix diffusion_matrix = I 4.
Proof. solve_matrix. Qed.

(*and relying on this, its unitarity *)
 Lemma unitary_small_diffusion : diffusion_matrix = adjoint diffusion_matrix.
Proof. unfold diffusion_matrix. solve_matrix. Qed.

(* combining the above, we have the full function *)
Definition small_grover {a} (g : Unique_Function (f_unique a)) :  Box One (Qubit ⊗ Qubit) :=
  box_ () ⇒
    let_ x ← _H $ init0 $ ();
    let_ y ← _H $ init0 $ ();
match g with
  | f0 =>
        (let_ (x,y) ← small_oracle_0 $ (x,y);
        let_ (x,y) ← small_diffusion $ (x,y);
        (x,y))
  | f1 =>
        (let_ (x,y) ← small_oracle_1 $ (x,y);
        let_ (x,y) ← small_diffusion $ (x,y);
        (x,y))
  | f2 =>
        (let_ (x,y) ← small_oracle_2 $ (x,y);
        let_ (x,y) ← small_diffusion $ (x,y);
        (x,y))
  | f3 =>
        (let_ (x,y) ← small_oracle_3 $ (x,y);
        let_ (x,y) ← small_diffusion $ (x,y);
        (x,y))
end.

Lemma small_grover_WT : Typed_Box (small_grover g).
Proof. type_check. destruct g. all: type_check. Qed.

(*probability of measuring ξ on the first m qubits of ρ; we will onlz need actual measurements here but this is such a neat definition for something much more general that it is used instead of a specific case*)
Definition exp_val_meas_matrix {n} ( A: Density (2^n)) (ρ : Density (2^n)) : R :=
  fst (trace (Mmult ρ A)).

(* First part of solution tactic for result of gate composition *)
Ltac grover_2qubit_denote_to_nonzero :=
  matrix_denote;
  solve_matrix;
  repeat rewrite Cexp_PI2;
  solve_matrix;
  C_field_simplify;
  Msimpl;
  simpl;
  solve_matrix;
  split.

(* correctness of a songle iteration for each oracle: ---------------------------------------------*)

Lemma prob_matrix_0 : list2D_to_matrix ( [ [ C1 ; C0 ; C0 ; C0 ] ; [ C0 ; C0 ; C0 ; C0 ]  ; [ C0 ; C0 ; C0 ; C0 ] ; [ C0 ; C0 ; C0 ; C0 ] ] ) = denote (small_grover f0) (I 1).
Proof.
  unfold small_grover.
  unfold compose.
  grover_2qubit_denote_to_nonzero.
  all: C_field.
Qed.

Lemma prob_matrix_1 : list2D_to_matrix ( [ [ C0 ; C0 ; C0 ; C0 ] ; [ C0 ; C1 ; C0 ; C0 ]  ; [ C0 ; C0 ; C0 ; C0 ] ; [ C0 ; C0 ; C0 ; C0 ] ] ) = denote (small_grover f1) (I 1).
Proof.
  grover_2qubit_denote_to_nonzero.
  all: C_field.
Qed.

Lemma prob_matrix_2 : list2D_to_matrix ( [ [ C0 ; C0 ; C0 ; C0 ] ; [ C0 ; C0 ; C0 ; C0 ]  ; [ C0 ; C0 ; C1 ; C0 ] ; [ C0 ; C0 ; C0 ; C0 ] ] ) = denote (small_grover f2) (I 1).
Proof.
  grover_2qubit_denote_to_nonzero.
  all: C_field.
Qed.

Lemma prob_matrix_3 : list2D_to_matrix ( [ [ C0 ; C0 ; C0 ; C0 ] ; [ C0 ; C0 ; C0 ; C0 ]  ; [ C0 ; C0 ; C0 ; C0 ] ; [ C0 ; C0 ; C0 ; C1 ] ] ) = denote (small_grover f3) (I 1).
Proof.
  grover_2qubit_denote_to_nonzero.
  all: C_field.
Qed.

(* ------------------------------------------------------------------------------------------------*)

Local Close Scope nat_scope.

Definition get_true_value (g : Unique_Function (f_unique a)) : nat :=
  a.

(* correctness lemma for 2 qubits 1 rotatio *)
Lemma small_grover_correct_prob : forall g : Unique_Function (f_unique a),
  match g with
    | f0 => @exp_val_meas_matrix 2
    (outer_product (basis_vector (4) 0) (basis_vector (4) 0))
    (denote (small_grover f0) (I 1))
    | f1 => @exp_val_meas_matrix 2
    (outer_product (basis_vector (4) 1) (basis_vector (4) 1))
    (denote (small_grover f1) (I 1))
    | f2 => @exp_val_meas_matrix 2
    (outer_product (basis_vector (4) 2) (basis_vector (4) 2))
    (denote (small_grover f2) (I 1))
    | f3 => @exp_val_meas_matrix  2
    (outer_product (basis_vector (4) 3) (basis_vector (4) 3))
    (denote (small_grover f3) (I 1))
    end

               =
        (sin ((2 * 1 + 1) * asin (√ (1 / 4))) ^ 2)%R.                        (* k = 1 because there is only ever one solution*)

Proof.
  intros.
   (* rewrite would not recognize the goals (even with explicit inverted lemmas), so manual is the only way*)
  1: replace (denote (small_grover f0) (I 1)) with  (list2D_to_matrix ( [ [ C1 ; C0 ; C0 ; C0 ] ; [ C0 ; C0 ; C0 ; C0 ]  ; [ C0 ; C0 ; C0 ; C0 ] ; [ C0 ; C0 ; C0 ; C0 ] ] )).
  2: apply prob_matrix_0.
  1: replace (denote (small_grover f1) (I 1)) with  (list2D_to_matrix ( [ [ C0 ; C0 ; C0 ; C0 ] ; [ C0 ; C1 ; C0 ; C0 ]  ; [ C0 ; C0 ; C0 ; C0 ] ; [ C0 ; C0 ; C0 ; C0 ] ] )).
  2: apply prob_matrix_1.
  1: replace (denote (small_grover f2) (I 1)) with  (list2D_to_matrix ( [ [ C0 ; C0 ; C0 ; C0 ] ; [ C0 ; C0 ; C0 ; C0 ]  ; [ C0 ; C0 ; C1 ; C0 ] ; [ C0 ; C0 ; C0 ; C0 ] ] )).
  2: apply prob_matrix_2.
  1: replace (denote (small_grover f3) (I 1)) with  (list2D_to_matrix ( [ [ C0 ; C0 ; C0 ; C0 ] ; [ C0 ; C0 ; C0 ; C0 ]  ; [ C0 ; C0 ; C0 ; C0 ] ; [ C0 ; C0 ; C0 ; C1 ] ] )).
  2: apply prob_matrix_3.
  destruct g0.
  all: simpl.
  all: replace (2 * 1 + 1)%R with 3%R by ring;
  rewrite sqrt_div_alt;
  replace (asin (sqrt 1 / sqrt 4))%R with (PI/6)%R.
  all: try rewrite Rmult_1_r.
  all: try intuition.
  all: try symmetry; try apply asin14.
  all:unfold outer_product, basis_vector, exp_val_meas_matrix.
  all:unfold trace, fst.
  all: solve_matrix.
  all: repeat rewrite Rmult_0_l, Rmult_0_r, Rplus_0_l.
  all: repeat rewrite Rmult_1_r.
  all: R_field_simplify.
  all: replace (3 * (PI / 6))%R with (1 * (PI / 2))%R.
  all: try rewrite Rmult_1_l.
  all: try rewrite sin_PI2.
  all: try ring.
  all: unfold Rdiv.
  all: symmetry.
  all: rewrite Rmult_comm.
  all: rewrite Rmult_assoc.
  all: replace (/ 6 * 3)%R with (3 * / 6)%R by ring.
  all: replace (3 * / 6)%R with (/ 2)%R.
  all: R_field_simplify.
  all: reflexivity.
Qed.

(*-------------------------------------------------------------------------------------------*)
(*As an additional bit, we have this: *)
(* The definition and correctness of the bell_11 state *)
  Definition bell_11 : Box One (Qubit ⊗ Qubit) :=
    box_ () ⇒
         let_ x ← init0 $ ();
         let_ y ← init0 $ ();
         let_ x ← _H $ x;
         let_ (x,y) ← CNOT $ (x,y);
         let_ x ← _X $ _Z $ x;
         (x,y).

Definition exp_val_matrix {m n} (ξ : Density (2^m)) (ρ : Density (2^(n+m))) : R :=
  fst (trace (Mmult ξ ρ)).

Lemma bell_11_matrix : (denote bell_11 (I 1)) = (list2D_to_matrix ( [ [C0;C0;C0;C0]  ;[C0; (C1/C2)%C ;(-C1/C2)%C ;C0] ;[C0;(-C1/C2)%C ; (C1/C2)%C ;C0] ;[C0;C0;C0; C0] ])).
  matrix_denote.
  solve_matrix.
Qed.

Lemma bell_11_correct :  @exp_val_matrix  2 2  (list2D_to_matrix ( [ [C1;C0;C0;C0]  ;[C0; C0 ;C0;C0] ;[C0;C0; C0 ;C0] ;[C0;C0;C0; C1] ])) (denote bell_11 (I 1)) = 0%R.
Proof.
  replace (denote bell_11 (I 1))  with (list2D_to_matrix ( [ [C0;C0;C0;C0]  ;[C0; (C1/C2)%C ;(-C1/C2)%C ;C0] ;[C0;(-C1/C2)%C ; (C1/C2)%C ;C0] ;[C0;C0;C0; C0] ])).
  2: symmetry; apply bell_11_matrix.
  solve_matrix.
  unfold exp_val_matrix.
  solve_matrix.
  R_field.
Qed.

(* Other things that have been done, and may serve to be of value, but are not now relevant. Note that some require rescoping *)
(*============================================================================================================================*)
(* (H|0>)^⊗n proof of its invlutoriness remained incomplete so was scrapped

Definition P (p:nat) :  Square p := (fun i j => if i <? p then (if j <? p then C1/(RtoC (INR p)) else C0) else C0).

(*well-formed P*)
Lemma WF_P : forall p:nat,  WF_Matrix (P p).
  intros.
  unfold P.
  unfold WF_Matrix.
  intros.
  destruct H.
  replace (ge x p) with (le p x) in H. 2: intuition.
  1,2: bdestruct ( x <? p). 1,3: bdestruct (y <? p).
  all: intuition.
Qed.*)

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

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

Definition small_grover_rots_0 : Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
 box_ (x,y) ⇒
              let_ (x,y) ← small_oracle_0 $ (x,y);
              let_ (x,y) ← small_diffusion $ (x,y);
(x,y).

Definition small_grover_rots_1 : Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
   box_ (x,y) ⇒
          let_ (x,y) ← small_oracle_1 $ (x,y);
          let_ (x,y) ← small_diffusion $ (x,y);
          (x,y).

Definition small_grover_rots_2 : Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
  box_ (x,y) ⇒
              let_ (x,y) ← small_oracle_2 $ (x,y);
              let_ (x,y) ← small_diffusion $ (x,y);
              (x,y).

Definition small_grover_rots_3 : Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
  box_ (x,y) ⇒
              let_ (x,y) ← small_oracle_3 $ (x,y);
              let_ (x,y) ← small_diffusion $ (x,y);
(x,y).

Fixpoint grover_iteration_HH {n} (r:nat) (g : Unique_Function (f_unique a)) (ψ: Density n):  Density n  :=
  match r with
  | 0%nat  => ψ
  | S r' => match g with
           | f0 => grover_iteration_HH r' g (denote small_grover_rots_0 ψ)
           | f1 => grover_iteration_HH r' g (denote small_grover_rots_1 ψ)
           | f2 => grover_iteration_HH r' g (denote small_grover_rots_2 ψ)
           | f3 => grover_iteration_HH r' g (denote small_grover_rots_3 ψ)

           end
              end.

Fixpoint small_grover_r_rots_0 : Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
  match r with
  | 0%nat => id_circ
  | S r' => box_ (x,y) ⇒
             (let_ (x,y) ← small_grover_r_rots_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_r_rots_0_WT : forall r, Typed_Box (small_grover_r_rots_0 r).
Proof. intros.  induction r as [ | r]; type_check.  Qed.

Fixpoint small_grover_r_rots_1 (r:nat): Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
  match r with
  | 0%nat => id_circ
  | S r' => box_ (x,y) ⇒
             (let_ (x,y) ← small_grover_r_rots_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_r_rots_1_WT : forall r, Typed_Box (small_grover_r_rots_1 r).
Proof. intros.  induction r as [ | r]; type_check.  Qed.

Fixpoint small_grover_r_rots_2 (r:nat): Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
  match r with
  | 0%nat => id_circ
  | S r' => box_ (x,y) ⇒
             (let_ (x,y) ← small_grover_r_rots_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_r_rots_2_WT : forall r, Typed_Box (small_grover_r_rots_2 r).
Proof. intros.  induction r as [ | r]; type_check.  Qed.

Fixpoint small_grover_r_rots_3 (r:nat): Box (Qubit ⊗ Qubit) (Qubit ⊗ Qubit) :=
  match r with
  | 0%nat => id_circ
  | S r' => box_ (x,y) ⇒
             (let_ (x,y) ← small_grover_r_rots_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_r_rot_3_WT : forall r, Typed_Box (small_grover_r_rots_3 r).
Proof. intros.  induction r as [ | r]; type_check.  Qed.

Fixpoint small_grover_r_rots (r:nat) : Box One (Qubit ⊗ Qubit) :=
  box_ () ⇒
    let_ (x, y) ← equal_superposition $ ();
    match g with
    | f0 =>
        (let_ (x,y) ← small_grover_r_rots_0 r $ (x,y);
        (x,y))
    | f1 =>
        (let_ (x,y) ← small_grover_r_rots_1 r $ (x,y);
        (x,y))
    | f2 =>
        (let_ (x,y) ← small_grover_r_rots_2 r $ (x,y);
        (x,y))
    | f3 =>
        (let_ (x,y) ← small_grover_r_rots_3 r $ (x,y);
        (x,y))
end.
*)


(* -*- mode: coq; mode: visual-line -*- *)
Require Import Basics.Overture Basics.Tactics Basics.PathGroupoids.

Local Open Scope path_scope.

(** * Theorems about the 2-sphere [S^2]. *)

Generalizable Variables X A B f g n.

(* ** Definition of the 2-sphere. *)

Module Export TwoSphere.

Private Inductive TwoSphere : Type0 :=
| base : TwoSphere.

Axiom surf : idpath base = idpath base.

Definition TwoSphere_ind (P : TwoSphere -> Type)
  (b : P base) (s : idpath b = transport2 P surf b)
  : forall (x : TwoSphere), P x
  := fun x => match x with base => fun _ => b end s.

Axiom TwoSphere_ind_beta_surf : forall (P : TwoSphere -> Type)
  (b : P base) (s : idpath b = transport2 P surf b),
  apD02 (TwoSphere_ind P b s) surf = s @ (concat_p1 _)^.

End TwoSphere.

(* ** The non-dependent eliminator *)

Definition TwoSphere_rec (P : Type) (b : P) (s : idpath b = idpath b)
  : TwoSphere -> P
  := TwoSphere_ind (fun _ => P) b (s @ (transport2_const surf b) @ (concat_p1 _)).

Definition TwoSphere_rec_beta_surf (P : Type) (b : P) (s : idpath b = idpath b)
: ap02 (TwoSphere_rec P b s) surf = s.
Proof.
  apply (cancel2L (transport2_const surf b)).
  apply (cancelL (apD_const (TwoSphere_rec P b s) (idpath base))).
  apply (cancelR _ _ (concat_p_pp _ (transport_const _ b) _)^).
  apply (cancelR _ _ (whiskerL (transport2 _ surf b) (apD_const _ _)^)).
  refine ((apD02_const (TwoSphere_rec P b s) surf)^ @ _).
  refine ((TwoSphere_ind_beta_surf _ _ _) @ _).
  refine (_ @ (ap (fun w => _ @ w)
                  (triangulator
                     (transport2 (fun _ : TwoSphere => P) surf b) _))).
  cbn. refine (_ @ (ap (fun w => (w @ _) @ _) (concat_1p _)^)).

  refine (_ @ (concat_p_pp _ _ _)).
  refine (_ @ (ap (fun w => _ @ w) (concat_pp_p _ _ _))).
  refine (_ @ (ap (fun w => _ @ (w @ _)) (concat_Vp _)^)).
  refine (_ @ (ap (fun w => _ @ (w @ _))
                  (concat_pV (concat_p1
                                (transport2 (fun _ : TwoSphere => P) surf b @ 1))))).
  refine (_ @ (ap (fun w => _ @ w) (concat_p_pp _ _ _))).
  refine (_ @ (concat_pp_p _ _ _)). apply moveR_pV.
  refine (_ @ (concat_p_pp _ _ _)).
  refine (_ @ (ap (fun w => _ @ w) (whiskerR_p1 _)^)). f_ap.
  refine ((ap (fun w => w @ _) (whiskerL_1p_1 _)^) @ _).
  refine ((ap (fun w => _ @ w) (whiskerR_p1 _)^) @ _). cbn.
  refine ((concat_p_pp _ _ _) @ _). f_ap.
  refine ((ap (fun w => _ @ w) (concat_1p _)) @ _).
  refine ((concat_whisker 1 _ _ 1 (transport2_const surf b) s)^ @ _).

  symmetry.
  refine ((ap (fun w => w @@ _) (concat_p1 _)^) @ _).
  refine ((ap (fun w => _ @@ w) (concat_1p _)^) @ _).
  refine ((concat_concat2 _ _ _ _)^ @ _). f_ap.
Defined.