(** * Relation up to tau *)

(** [rutt] ("relation up to tau") is a generalization of [eutt] that may relate trees
  indexed by different event type families [E]. *)

(** It corresponds roughly to the interpretation of "types as relations" from the relational
  parametricity model by Reynolds (Types, Abstraction and Parametric Polymorphism).
  Any polymorphic function [f : forall E R, itree E R -> ...] should respect this relation,
  in the sense that for any relations [rE], [rR], the implication
  [rutt rE rR t t' -> (f t ~~ f t')] should hold, where [~~] is some canonical relation on the
  codomain of [f].

  If we could actually quotient itrees "up to taus", and Coq could generate
  parametricity ("free") theorems on demand, the above might be a free theorem. *)

(** [rutt] is used to define the [trace_refine] relation in [ITree.ITrace.ITraceDefinition]. *)

From Coq Require Import
     Morphisms
.

From ExtLib Require Import
     Structures.Monad.

From ITree Require Import
     Basics.Tacs
     Axioms
     ITree
     Eq
     Basics
.

From Paco Require Import paco.

Import Monads.
Import MonadNotation.
Local Open Scope monad_scope.

Section RuttF.

  Context {E1 E2 : Type -> Type}.
  Context {R1 R2 : Type}.
  (* From the point of view of relational parametricity, it would be more fitting
  to replace [(REv, RAns)] with one [REv : forall A1 A2, (A1 -> A2 -> Prop) -> (E1 A1 -> E2 A2 -> Prop)].
  Contributions to that effect are welcome. *)
  Context (REv : forall (A B : Type), E1 A -> E2 B -> Prop ).
  Context (RAns : forall (A B : Type), E1 A -> A -> E2 B -> B -> Prop ).
  Context (RR : R1 -> R2 -> Prop).
  Arguments REv {A} {B}.
  Arguments RAns {A} {B}.

  Inductive ruttF (sim : itree E1 R1 -> itree E2 R2 -> Prop) : itree' E1 R1 -> itree' E2 R2 -> Prop :=
  | EqRet : forall (r1 : R1) (r2 : R2),
      RR r1 r2 ->
      ruttF sim (RetF r1) (RetF r2)
  | EqTau : forall (m1 : itree E1 R1) (m2 : itree E2 R2),
      sim m1 m2 ->
      ruttF sim (TauF m1) (TauF m2)
  | EqVis : forall (A B : Type) (e1 : E1 A) (e2 : E2 B ) (k1 : A -> itree E1 R1) (k2 : B -> itree E2 R2),
      REv e1 e2 ->
      (forall (a : A) (b : B), RAns e1 a e2 b -> sim (k1 a) (k2 b)) ->
      ruttF sim (VisF e1 k1) (VisF e2 k2)
  | EqTauL : forall (t1 : itree E1 R1) (ot2 : itree' E2 R2),
      ruttF sim (observe t1) ot2 ->
      ruttF sim (TauF t1) ot2
  | EqTauR : forall (ot1 : itree' E1 R1) (t2 : itree E2 R2),
      ruttF sim ot1 (observe t2) ->
      ruttF sim ot1 (TauF t2).
  Hint Constructors ruttF : itree.

  Definition rutt_ (sim : itree E1 R1 -> itree E2 R2 -> Prop)
             (t1 : itree E1 R1) (t2 : itree E2 R2) :=
    ruttF sim (observe t1) (observe t2).
  Hint Unfold rutt_ : itree.

  Lemma rutt_monot : monotone2 rutt_.
  Proof.
    red. intros. red; induction IN; eauto with itree.
  Qed.

  Definition rutt : itree E1 R1 -> itree E2 R2 -> Prop := paco2 rutt_ bot2.
  Hint Unfold rutt : itree.

  Lemma ruttF_inv_VisF_r {sim} t1 U2 (e2: E2 U2) (k2: U2 -> _):
    ruttF sim t1 (VisF e2 k2) ->
    (exists U1 (e1: E1 U1) k1, t1 = VisF e1 k1 /\
      forall v1 v2, RAns e1 v1 e2 v2 -> sim (k1 v1) (k2 v2))
    \/
    (exists t1', t1 = TauF t1' /\
      ruttF sim (observe t1') (VisF e2 k2)).
  Proof.
    refine (fun H =>
      match H in ruttF _ _ t2 return
        match t2 return Prop with
        | VisF e2 k2 => _
        | _ => True
        end
      with
      | EqVis _ _ _ _ _ _ _ _ _ => _
      | _ => _
      end); try exact I.
    - left; eauto.
    - destruct i0; eauto.
  Qed.

  Lemma ruttF_inv_VisF {sim}
      U1 U2 (e1 : E1 U1) (e2 : E2 U2) (k1 : U1 -> _) (k2 : U2 -> _)
    : ruttF sim (VisF e1 k1) (VisF e2 k2) ->
      forall v1 v2, RAns e1 v1 e2 v2 -> sim (k1 v1) (k2 v2).
  Proof.
    intros H. dependent destruction H. assumption.
  Qed.

  Ltac unfold_rutt :=
    (try match goal with [|- rutt_ _ _ _ _ _ _ _ ] => red end);
    (repeat match goal with [H: rutt_ _ _ _ _ _ _ _ |- _ ] => red in H end).

  Lemma fold_ruttF:
    forall (t1: itree E1 R1) (t2: itree E2 R2) ot1 ot2,
    ruttF (upaco2 rutt_ bot2) ot1 ot2 ->
    ot1 = observe t1 ->
    ot2 = observe t2 ->
    rutt t1 t2.
  Proof.
    intros * eq -> ->; pfold; auto.
  Qed.
End RuttF.

Tactic Notation "fold_ruttF" hyp(H) :=
  try punfold H;
  try red in H;
  match type of H with
  | ruttF ?_REV ?_RANS ?_RR (upaco2 (rutt_ ?_REV ?_RANS ?_RR) bot2) ?_OT1 ?_OT2 =>
      match _OT1 with
      | observe _ => idtac
      | ?_OT1 => rewrite (itree_eta' _OT1) in H
      end;
      match _OT2 with
      | observe _ => idtac
      | ?_OT2 => rewrite (itree_eta' _OT2) in H
      end;
      eapply fold_ruttF in H; [| eauto | eauto]
  end.

#[global] Hint Resolve rutt_monot : paco.

Section ConstructionInversion.
Variables (E1 E2: Type -> Type).
Variables (R1 R2: Type).
Variable (REv: forall T1 T2, E1 T1 -> E2 T2 -> Prop).
Variable (RAns: forall T1 T2, E1 T1 -> T1 -> E2 T2 -> T2 -> Prop).
Variable (RR: R1 -> R2 -> Prop).

Lemma rutt_Ret r1 r2:
  RR r1 r2 ->
  @rutt E1 E2 R1 R2 REv RAns RR (Ret r1: itree E1 R1) (Ret r2: itree E2 R2).
Proof. intros. pstep; constructor; auto. Qed.

Lemma rutt_inv_Ret r1 r2:
  rutt REv RAns RR (Ret r1) (Ret r2) -> RR r1 r2.
Proof.
  intros. punfold H. inv H. eauto.
Qed.

Lemma rutt_inv_Ret_l r1 t2:
  rutt REv RAns RR (Ret r1) t2 -> exists r2, t2 ≳ Ret r2 /\ RR r1 r2.
Proof.
  intros Hrutt; punfold Hrutt; red in Hrutt; cbn in Hrutt.
  setoid_rewrite (itree_eta t2). remember (RetF r1) as ot1; revert Heqot1.
  induction Hrutt; intros; try discriminate.
  - inversion Heqot1; subst. exists r2. split; [reflexivity|auto].
  - destruct (IHHrutt Heqot1) as [r2 [H1 H2]]. exists r2; split; auto.
    rewrite <- itree_eta in H1. now rewrite tau_euttge.
Qed.

Lemma rutt_inv_Ret_r t1 r2:
  rutt REv RAns RR t1 (Ret r2) -> exists r1, t1 ≳ Ret r1 /\ RR r1 r2.
Proof.
  intros Hrutt; punfold Hrutt; red in Hrutt; cbn in Hrutt.
  setoid_rewrite (itree_eta t1). remember (RetF r2) as ot2; revert Heqot2.
  induction Hrutt; intros; try discriminate.
  - inversion Heqot2; subst. exists r1. split; [reflexivity|auto].
  - destruct (IHHrutt Heqot2) as [r1 [H1 H2]]. exists r1; split; auto.
    rewrite <- itree_eta in H1. now rewrite tau_euttge.
Qed.

Lemma rutt_inv_Tau_l t1 t2 :
  rutt REv RAns RR (Tau t1) t2 -> rutt REv RAns RR t1 t2.
Proof.
  intros. punfold H. red in H. simpl in *.
  remember (TauF t1) as tt1. genobs t2 ot2.
  hinduction H before t1; intros; try discriminate.
  - inv Heqtt1. pclearbot. pstep. red. simpobs. econstructor; eauto. pstep_reverse.
  - inv Heqtt1. punfold_reverse H.
  - red in IHruttF. pstep. red; simpobs. econstructor; eauto. pstep_reverse.
Qed.

Lemma rutt_add_Tau_l t1 t2 :
  rutt REv RAns RR t1 t2 -> rutt REv RAns RR (Tau t1) t2.
Proof.
  intros. pfold. red. cbn. constructor. pstep_reverse.
Qed.

Lemma rutt_inv_Tau_r t1 t2 :
  rutt REv RAns RR t1 (Tau t2) -> rutt REv RAns RR t1 t2.
Proof.
  intros. punfold H. red in H. simpl in *.
  pstep. red. remember (TauF t2) as tt2 eqn:Ett2 in H.
  revert t2 Ett2; induction H; try discriminate; intros; inversion Ett2; subst; auto.
  - pclearbot. constructor. pstep_reverse.
  - constructor. eapply IHruttF; eauto.
Qed.

Lemma rutt_add_Tau_r t1 t2 :
  rutt REv RAns RR t1 t2 -> rutt REv RAns RR t1 (Tau t2).
Proof.
  intros. pfold. red. cbn. constructor. pstep_reverse.
Qed.

Lemma rutt_inv_Tau t1 t2 :
  rutt REv RAns RR (Tau t1) (Tau t2) -> rutt REv RAns RR t1 t2.
Proof.
  intros; apply rutt_inv_Tau_r, rutt_inv_Tau_l; assumption.
Qed.

Lemma rutt_Vis {T1 T2} (e1: E1 T1) (e2: E2 T2)
    (k1: T1 -> itree E1 R1) (k2: T2 -> itree E2 R2):
  REv _ _ e1 e2 ->
  (forall t1 t2, RAns _ _ e1 t1 e2 t2 -> rutt REv RAns RR (k1 t1) (k2 t2)) ->
  rutt REv RAns RR (Vis e1 k1) (Vis e2 k2).
Proof.
  intros He Hk. pstep; constructor; auto.
  intros; left. apply Hk; auto.
Qed.

Lemma rutt_inv_Vis_l {U1} (e1: E1 U1) k1 t2:
  rutt REv RAns RR (Vis e1 k1) t2 ->
  exists U2 (e2: E2 U2) k2,
    t2 ≈ Vis e2 k2 /\
    REv _ _ e1 e2 /\
    (forall v1 v2, RAns _ _ e1 v1 e2 v2 -> rutt REv RAns RR (k1 v1) (k2 v2)).
Proof.
  intros Hrutt; punfold Hrutt; red in Hrutt; cbn in Hrutt.
  setoid_rewrite (itree_eta t2). remember (VisF e1 k1) as ot1; revert Heqot1.
  induction Hrutt; intros; try discriminate; subst.
  - inversion Heqot1; subst A. inversion_sigma; rewrite <- eq_rect_eq in *;
    subst; rename B into U2.
    exists U2, e2, k2; split. reflexivity. split; auto.
    intros v1 v2 HAns. specialize (H0 v1 v2 HAns). red in H0. now pclearbot.
  - destruct (IHHrutt eq_refl) as (U2 & e2 & k2 & Ht0 & HAns).
    rewrite <- itree_eta in Ht0.
    exists U2, e2, k2; split; auto. now rewrite tau_eutt.
Qed.

Lemma rutt_inv_Vis_r {U2} t1 (e2: E2 U2) k2:
  rutt REv RAns RR t1 (Vis e2 k2) ->
  exists U1 (e1: E1 U1) k1,
    t1 ≈ Vis e1 k1 /\
    REv U1 U2 e1 e2 /\
    (forall v1 v2, RAns _ _ e1 v1 e2 v2 -> rutt REv RAns RR (k1 v1) (k2 v2)).
Proof.
  intros Hrutt; punfold Hrutt; red in Hrutt; cbn in Hrutt.
  setoid_rewrite (itree_eta t1). remember (VisF e2 k2) as ot2; revert Heqot2.
  induction Hrutt; intros; try discriminate; subst.
  - inversion Heqot2; subst B. inversion_sigma; rewrite <- eq_rect_eq in *;
    subst; rename A into U1.
    exists U1, e1, k1; split. reflexivity. split; auto.
    intros v1 v2 HAns. specialize (H0 v1 v2 HAns). red in H0. now pclearbot.
  - destruct (IHHrutt eq_refl) as (U1 & e1 & k1 & Ht0 & HAns).
    rewrite <- itree_eta in Ht0.
    exists U1, e1, k1; split; auto. now rewrite tau_eutt.
Qed.

Lemma rutt_inv_Vis U1 U2 (e1: E1 U1) (e2: E2 U2)
    (k1: U1 -> itree E1 R1) (k2: U2 -> itree E2 R2):
  rutt REv RAns RR (Vis e1 k1) (Vis e2 k2) ->
  forall u1 u2, RAns U1 U2 e1 u1 e2 u2 -> rutt REv RAns RR (k1 u1) (k2 u2).
Proof.
  intros H u1 u2 Hans. punfold H.
  apply ruttF_inv_VisF with (v1 := u1) (v2 := u2) in H. pclearbot; auto.
  assumption.
Qed.
End ConstructionInversion.

Section euttge_trans_clo.

  Context {E1 E2 : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop).

  (* Closing a relation over itrees under [euttge].
     Essentially the same closure as [eqit_trans_clo], but heterogeneous
     in the interface argument [E].
     We only define the closure under [euttge] as opposed to [eqit_trans_clo]
     capturing closure under [eq_itree] and [eutt] at the same time, since it's
     the only one we need.
   *)

  (* A transitivity functor *)
  Variant euttge_trans_clo (r : itree E1 R1 -> itree E2 R2 -> Prop) :
    itree E1 R1 -> itree E2 R2 -> Prop :=
    eqit_trans_clo_intro t1 t2 t1' t2' RR1 RR2
                         (EQVl: euttge RR1 t1 t1')
                         (EQVr: euttge RR2 t2 t2')
                         (REL: r t1' t2')
                         (LERR1: forall x x' y, RR1 x x' -> RR x' y -> RR x y)
                         (LERR2: forall x y y', RR2 y y' -> RR x y' -> RR x y) :
      euttge_trans_clo r t1 t2.
  Hint Constructors euttge_trans_clo : itree.

  Lemma euttge_trans_clo_mon r1 r2 t1 t2
        (IN : euttge_trans_clo r1 t1 t2)
        (LE : r1 <2= r2) :
    euttge_trans_clo r2 t1 t2.
  Proof.
    destruct IN; econstructor; eauto.
  Qed.

  Hint Resolve euttge_trans_clo_mon : paco.

End euttge_trans_clo.

(*replicate this proof for the models functor*)
(* Validity of the up-to [euttge] principle *)
Lemma euttge_trans_clo_wcompat E1 E2 R1 R2 (REv : forall A B, E1 A -> E2 B -> Prop)
      (RAns : forall A B, E1 A -> A -> E2 B -> B -> Prop ) (RR : R1 -> R2 -> Prop) :
  wcompatible2 (rutt_ REv RAns RR) (euttge_trans_clo RR).
Proof.
  constructor; eauto with paco.
  { red. intros. eapply euttge_trans_clo_mon; eauto. }
  intros.
  destruct PR. punfold EQVl. punfold EQVr. unfold_eqit.
  hinduction REL before r; intros; clear t1' t2'.
  - remember (RetF r1) as x. red.
    hinduction EQVl before r; intros; subst; try inv Heqx; eauto; (try constructor; eauto).
    remember (RetF r3) as x. hinduction EQVr before r; intros; subst; try inv Heqx; (try constructor; eauto).
  - red. remember (TauF m1) as x.
    hinduction EQVl before r; intros; subst; try inv Heqx; try inv CHECK; ( try (constructor; eauto; fail )).
    remember (TauF m3) as y.
    hinduction EQVr before r; intros; subst; try inv Heqy; try inv CHECK; (try (constructor; eauto; fail)).
    pclearbot. constructor. gclo. econstructor; eauto with paco.
  - remember (VisF e1 k1) as x. red.
    hinduction EQVl before r; intros; subst; try discriminate; try (constructor; eauto; fail).
    remember (VisF e2 k3) as y.
    hinduction EQVr before r; intros; subst; try discriminate; try (constructor; eauto; fail).
    dependent destruction Heqx.
    dependent destruction Heqy.
    constructor; auto. intros. apply H0 in H1. pclearbot.
    apply gpaco2_clo.
    econstructor; eauto with itree.
  - remember (TauF t1) as x. red.
    hinduction EQVl before r; intros; subst; try inv Heqx; try inv CHECK; (try (constructor; eauto; fail)).
    pclearbot. punfold REL. constructor. eapply IHREL; eauto.
  - remember (TauF t2) as y. red.
    hinduction EQVr before r; intros; subst; try inv Heqy; try inv CHECK; (try (constructor; eauto; fail)).
    pclearbot. punfold REL. constructor. eapply IHREL; eauto.
Qed.

#[global] Hint Resolve euttge_trans_clo_wcompat : paco.

(* The validity of the up-to [euttge] entails we can rewrite under [euttge]
   and hence also [eq_itree] during coinductive proofs of [rutt]
*)
#[global] Instance grutt_cong_eqit {R1 R2 : Type} {E1 E2 : Type -> Type} {REv : forall A B, E1 A -> E2 B -> Prop}
       {RAns : forall A B, E1 A -> A -> E2 B -> B -> Prop} {RR1 RR2} {RS : R1 -> R2 -> Prop} r rg
       (LERR1: forall x x' y, (RR1 x x': Prop) -> (RS x' y: Prop) -> RS x y)
       (LERR2: forall x y y', (RR2 y y': Prop) -> RS x y' -> RS x y) :
  Proper (eq_itree RR1 ==> eq_itree RR2 ==> flip impl)
         (gpaco2 (rutt_ REv RAns RS) (euttge_trans_clo RS) r rg).
Proof.
  repeat intro. gclo. econstructor; eauto;
    try eapply eqit_mon; try apply H; try apply H0; auto.
Qed.

Global Instance grutt_cong_euttge {R1 R2 : Type} {E1 E2 : Type -> Type} {REv : forall A B, E1 A -> E2 B -> Prop}
       {RAns : forall A B, E1 A -> A -> E2 B -> B -> Prop} {RR1 RR2} {RS : R1 -> R2 -> Prop} r rg
       (LERR1: forall x x' y, (RR1 x x': Prop) -> (RS x' y: Prop) -> RS x y)
       (LERR2: forall x y y', (RR2 y y': Prop) -> RS x y' -> RS x y) :
  Proper (euttge RR1 ==> euttge RR2 ==> flip impl)
         (gpaco2 (rutt_ REv RAns RS) (euttge_trans_clo RS) r rg).
Proof.
  repeat intro. gclo. econstructor; eauto.
Qed.

(* Provide these explicitly since typeclasses eauto cannot infer them *)

#[global] Instance grutt_cong_eqit_eq {R1 R2 : Type} {E1 E2 : Type -> Type} {REv : forall A B, E1 A -> E2 B -> Prop}
      {RAns : forall A B, E1 A -> A -> E2 B -> B -> Prop} {RS : R1 -> R2 -> Prop} r rg:
    Proper (eq_itree eq ==> eq_itree eq ==> flip impl)
         (gpaco2 (rutt_ REv RAns RS) (euttge_trans_clo RS) r rg).
Proof.
  apply grutt_cong_eqit; now intros * ->.
Qed.

#[global] Instance grutt_cong_euttge_eq {R1 R2 : Type} {E1 E2 : Type -> Type} {REv : forall A B, E1 A -> E2 B -> Prop}
      {RAns : forall A B, E1 A -> A -> E2 B -> B -> Prop} {RS : R1 -> R2 -> Prop} r rg:
    Proper (euttge eq ==> euttge eq ==> flip impl)
         (gpaco2 (rutt_ REv RAns RS) (euttge_trans_clo RS) r rg).
Proof.
  apply grutt_cong_euttge; now intros * ->.
Qed.


(* ** Axioms of PA *)
Require Export Undecidability.FOL.Arithmetics.Robinson.
Import Vector.VectorNotations.
Require Import List.

Definition ax_induction (phi : form) :=
  phi[zero..] → (∀ phi → phi[σ $0 .: S >> var]) → ∀ phi.

(* Full axiomatisation of the theory of PA *)
Inductive PA : form -> Prop :=
  PA_FA phi : In phi FA -> PA phi
| PA_discr : PA ax_zero_succ
| PA_inj : PA ax_succ_inj
| PA_induction phi : PA (ax_induction phi).

Inductive PAeq : form -> Prop :=
  PAeq_FA phi : In phi FAeq -> PAeq phi
| PAeq_discr : PAeq ax_zero_succ
| PAeq_inj : PAeq ax_succ_inj
| PAeq_induction phi : PAeq (ax_induction phi).


Require Import HoTT.
Require Import UnivalenceAxiom.

Definition push_fl {A B C : Type} (f : A -> B) (g : A -> C):
  B -> pushout f g := push o inl.
Definition push_fr {A B C : Type} (f : A -> B) (g : A -> C):
  C -> pushout f g := push o inr.

Definition pushout_ind' {A B C : Type} (f : A -> B) (g : A -> C)
           (P : pushout f g -> Type)
           (push_fl' : forall b : B, P (push_fl f g b))
           (push_fr' : forall c : C, P (push_fr f g c))
           (pp' : forall a : A, transport P (pp a) (push_fl' (f a)) = push_fr' (g a))
  : forall x : pushout f g, P x.
Proof.
  srapply @pushout_ind.
  - apply push_fl'.
  - apply push_fr'.
  - apply pp'.
Defined.

Definition pushout_rec' {A B C : Type} (f : A -> B) (g : A -> C)
           (P : Type)
           (push_fl' : B -> P)
           (push_fr' : C -> P)
           (pp' : forall a : A, push_fl' (f a) = push_fr' (g a))
  : pushout f g -> P.
Proof.
  srapply @pushout_rec.
  - intro b. exact (push_fl' b).
  - intro c. exact (push_fr' c).
  - apply pp'.
Defined.

Definition pushout_ind_beta_pp' {A B C} {f : A -> B} {g : A -> C}
           (P : pushout f g -> Type)
           (push_fl' : forall b : B, P (push_fl f g b))
           (push_fr' : forall c : C, P (push_fr f g c))
           (pp' : forall a : A, transport P (pp a) (push_fl' (f a)) = push_fr' (g a))
           (a : A)
  : apD (pushout_ind' f g P push_fl' push_fr' pp') (pp a) = pp' a.
Proof.
  apply pushout_ind_beta_pp.
Defined.                        (* perhaps not necessary. . . *)

Definition pushout_eta_homot {A B C : Type} {f : A -> B} {g : A -> C}
           {P : pushout f g -> Type} (h : forall x, P x)
  : h == pushout_ind' f g P (h o push_fl f g) (h o push_fr f g) (fun a => apD h (pp a)).
Proof.
  unfold pointwise_paths. srapply @pushout_ind'; try reflexivity.
  intro a.
  refine (transport_paths_FlFr_D
            (f := h)
            (g := pushout_ind' f g P (fun x0 : B => h (push_fl  f g x0)) (fun x0 : C => h (push_fr  f g x0))
                               (fun a0 : A => apD h (pp a0)))
            (pp a) ((fun b : B => 1) (f a)) @ _). simpl.
  apply moveR_Mp.
  - refine (pushout_ind_beta_pp P _ _ _ _ @ _).
    cut (forall q : transport P (pp a) (h (pushl (f a))) = h (pushr (g a)), q = ((q^@1)^@1)).
    { intro H. apply H. }
    intros []. reflexivity.
Defined.

Definition pushout_rec_eta_homot {A B C : Type} {f : A -> B} {g : A -> C}
           {P : Type} (h : pushout f g -> P)
  : h == pushout_rec' f g P (h o push_fl  f g) (h o push_fr  f g) (fun a => ap h (pp a)).
Proof.
  unfold pointwise_paths.
  srapply @pushout_ind'; try reflexivity.
  intro a.
  refine (transport_paths_FlFr
            (f := h)
            (g := pushout_rec' f g P (fun x0 : B => h (push_fl  f g x0)) (fun x0 : C => h (push_fr f g x0))
                               (fun a0 : A => ap h (pp a0)))
            (pp a) ((fun b : B => 1) (f a)) @ _).
  apply moveR_Mp. unfold pushout_rec'.
  refine (pushout_rec_beta_pp P (fun b : B => h (push_fl f g b)) (fun c : C => h (push_fr f g c))
                              (fun a0 : A => ap h (pp a0)) a @ _).
  cut (forall q : h (pushl (f a)) = h (pushr (g a)), q = ((q^ @ 1)^ @ 1)).
  { intro H. apply H. } intros []. reflexivity.
Defined.

Definition path_pushout_rec' {A B C : Type} {f : A -> B} {g : A -> C}
           (P : Type)
           (push_fl' : B -> P)
           (push_fr' : C -> P)
           (pp1 pp2: forall a : A, push_fl' (f a) = push_fr' (g a)) :
  pp1 = pp2 -> pushout_rec' f g P push_fl' push_fr' pp1 == pushout_rec' f g P push_fl' push_fr' pp2 :=
  fun q x => (ap (fun pp' : forall a : A, push_fl' (f a) = push_fr' (g a) =>
                    pushout_rec' f g P push_fl' push_fr' pp' x) q).

Definition functor_pushout {A1 B1 C1 A2 B2 C2}
           {f1 : A1 -> B1} {g1 : A1 -> C1} {f2 : A2 -> B2} {g2 : A2 -> C2}
           (hA : A1 -> A2) (hB : B1 -> B2) (hC : C1 -> C2) :
  (hB o f1 == f2 o hA) -> (hC o g1 == g2 o hA ) ->  pushout f1 g1 -> pushout f2 g2.
Proof.
  intros nat_f nat_g. srapply @pushout_rec'.
  - exact (fun b => push_fl  f2 g2 (hB b)).
  - exact (fun c => push_fr f2 g2 (hC c)).
  - exact (fun a => (ap (push_fl f2 g2) (nat_f a) @ pp (hA a)) @ (ap (push_fr f2 g2) (nat_g a)^)).
Defined.

Definition functor_pushout_beta_pp {A1 B1 C1 A2 B2 C2}
           {f1 : A1 -> B1} {g1 : A1 -> C1} {f2 : A2 -> B2} {g2 : A2 -> C2}
           (hA : A1 -> A2) (hB : B1 -> B2) (hC : C1 -> C2)
           (nat_f : hB o f1 == f2 o hA) (nat_g : hC o g1 == g2 o hA )
           (a : A1)
  : ap (functor_pushout hA hB hC nat_f nat_g) (pp a) =
    (ap (push_fl f2 g2) (nat_f a) @ pp (hA a)) @ (ap (push_fr f2 g2) (nat_g a)^).
Proof.
  unfold functor_pushout. unfold pushout_rec'. refine (pushout_rec_beta_pp (pushout f2 g2) _ _ _ a ).
Defined.

Definition functor_pushout_compose {A1 B1 C1 A2 B2 C2 A3 B3 C3}
           {f1 : A1 -> B1} {g1 : A1 -> C1} {f2 : A2 -> B2} {g2 : A2 -> C2} {f3 : A3 -> B3} {g3 : A3 -> C3}
           (hA1 : A1 -> A2) (hB1 : B1 -> B2) (hC1 : C1 -> C2)
           (hA2 : A2 -> A3) (hB2 : B2 -> B3) (hC2 : C2 -> C3)
           (nat_f1 : hB1 o f1 == f2 o hA1) (nat_g1 : hC1 o g1 == g2 o hA1 )
           (nat_f2 : hB2 o f2 == f3 o hA2) (nat_g2 : hC2 o g2 == g3 o hA2 )
  : functor_pushout (hA2 o hA1) (hB2 o hB1) (hC2 o hC1)
                    (fun a : A1 => ap (hB2) (nat_f1 a) @ (nat_f2 (hA1 a)))
                    (fun a : A1 => ap (hC2) (nat_g1 a) @ (nat_g2 (hA1 a))) ==
    (functor_pushout hA2 hB2 hC2 nat_f2 nat_g2) o (functor_pushout hA1 hB1 hC1 nat_f1 nat_g1).
Proof.
  intro x. apply inverse.
  refine ((pushout_rec_eta_homot
            ((functor_pushout hA2 hB2 hC2 nat_f2 nat_g2) o (functor_pushout hA1 hB1 hC1 nat_f1 nat_g1)) x) @ _).
  srapply @path_pushout_rec'. cbn.
  apply path_forall. intro a.
  refine (ap_compose _ _ _ @ _).
  refine (ap (fun q : functor_pushout hA1 hB1 hC1 nat_f1 nat_g1 (pushl (f1 a)) = functor_pushout hA1 hB1 hC1 nat_f1 nat_g1 (pushr (g1 a))
              => ap (functor_pushout hA2 hB2 hC2 nat_f2 nat_g2) q) (functor_pushout_beta_pp hA1 hB1 hC1 nat_f1 nat_g1 a) @ _).
  refine (ap_pp _ _ _ @ _).
  refine (whiskerR (ap_pp _ _ _) _ @ _).
  refine (whiskerR (whiskerL (ap (functor_pushout hA2 hB2 hC2 nat_f2 nat_g2) (ap (push_fl f2 g2) (nat_f1 a))) (functor_pushout_beta_pp hA2 hB2 hC2 nat_f2 nat_g2 (hA1 a)))
                    (ap (functor_pushout hA2 hB2 hC2 nat_f2 nat_g2) (ap (push_fr f2 g2) (nat_g1 a)^)) @ _).
  repeat rewrite ap_V. rewrite <- !ap_compose. simpl.
  repeat rewrite ap_pp. rewrite <- ap_compose.
  repeat rewrite concat_pp_p.
  apply whiskerL. apply whiskerL. apply whiskerL.
  rewrite inv_pp. apply whiskerL. apply (ap inverse).
  apply ap_compose.
Qed.                            (* that was a mess. . . *)


Require Import Omega.
Require Import Coq.Lists.List.
Require Import Coq.Sorting.Permutation.
Import ListNotations.

(* Minor results that _might_ be worth adding to stdlib.
   I've been pretty liberal in what I've included here. I will
   make a more careful pass in the future and consider a PR with
   some subset of these results, and cleaner proofs etc. *)

Lemma contrapositive : forall P Q : Prop, (* Surely in standard library but cannot find. *)
  (P -> Q) -> (~Q -> ~P).
Proof. intros P Q H H' p. apply H'. apply H. assumption. Qed.

Lemma list_in_nil : forall {A : Type} (l : list A),
  (forall a, ~In a l) -> l = [].
Proof.
  destruct l as [| a' l].
  - intros H. reflexivity.
  - intros H. exfalso. specialize H with (a:=a'). apply H. apply in_eq.
Qed.

Lemma filter_ext : forall (A : Type) (f g : A -> bool), (forall a, f a = g a) -> forall l, filter f l = filter g l.
Proof.
  intros A f g Hfg. induction l as [| a l]; [reflexivity|].
  specialize Hfg with (a:=a).
  destruct (f a) eqn:Hfa; simpl; rewrite <- Hfg; rewrite -> Hfa; rewrite IHl; reflexivity.
Qed.

Lemma filter_app : forall {A : Type} (f : A -> bool) (l l' : list A),
  filter f (l ++ l') = (filter f l) ++ (filter f l').
Proof.
  intros A f. induction l as [| x l IHl]; simpl; [reflexivity|].
  intros l'. destruct (f x) eqn:Hfx; specialize (IHl l'); rewrite IHl; auto.
Qed.

Lemma concat_nil' : forall {A : Type} (l : list (list A)),
  concat l = [] <-> (forall (m : list A), In m l -> m = []).
Proof.
  intros A. induction l as [| m' l IHl].
  - simpl. split; intros; [contradiction | reflexivity].
  - split; intros Hl.
    + intros m Hm. simpl in Hl. destruct (app_eq_nil _ _ Hl) as [Hm' Hl'].
      simpl in Hm. destruct Hm as [Hm | Hm].
      * subst. reflexivity.
      * apply IHl in Hm; assumption.
    + assert (Hl' : forall m, In m l -> m = []). { intros m Hm. apply Hl. right. assumption. }
      assert (Hm' : m' = []). { apply Hl. left. reflexivity. }
      simpl. apply IHl in Hl'. rewrite -> Hl'. rewrite -> Hm'. auto.
Qed.

Lemma concat_In : forall {A : Type} (l : list (list A)) (a : A),
  In a (concat l) <-> exists v, In v l /\ In a v.
Proof.
  intros A l a. induction l as [| v l Hv]; split.
  - simpl. contradiction.
  - intros [v [Hv _]]. inversion Hv.
  - simpl. intros Ha. rewrite in_app_iff in Ha. destruct Ha as [H | H].
    + exists v. auto.
    + apply Hv in H. destruct H as [v' [Hlv' Hav']]. exists v'. auto.
  - intros [v' [Hlv' Hav']]. simpl. rewrite in_app_iff. destruct Hlv' as [H | H].
    + subst. left. assumption.
    + right. rewrite Hv. exists v'. auto.
Qed.

Lemma concat_filter_map : forall {A : Type} (l : list (list A)) (f : A -> bool),
  concat (map (filter f) l) = filter f (concat l).
Proof.
  intros A l f. induction l as [| v l IHl]; [auto|].
  simpl. rewrite IHl. rewrite filter_app. reflexivity.
Qed.
Lemma nodup_empty_spec : forall {A : Type} (l : list A) (decA : forall x y, {x=y} + {x<>y}),
  nodup decA l = [] <-> l = [].
Proof.
  intros A l decA. split; intros H.
  - assert (H' : forall a, ~In a l). {
      intros a contra. rewrite <- (nodup_In decA) in contra.
      rewrite -> H in contra. apply in_nil in contra. contradiction.
    }
    apply list_in_nil. assumption.
  - subst. reflexivity.
Qed.

Lemma filter_empty_spec : forall (A : Type) (f : A -> bool) (l : list A),
  filter f l = [] <-> (forall x, In x l -> f x = false).
Proof.
  intros A f l. split.
  - intros H x Hx. destruct (f x) eqn:Hx'.
    + exfalso. assert (H' : In x (filter f l)). { rewrite filter_In. split; assumption. }
      rewrite -> H in H'. apply in_nil in H'. contradiction.
    + reflexivity.
  - intros H. apply list_in_nil. intros a. intros contra. rewrite filter_In in contra.
    destruct contra as [Ha Hf]. apply H in Ha. rewrite -> Hf in Ha. inversion Ha.
Qed.

Lemma filter_non_empty_spec : forall (A : Type) (f : A -> bool) (l : list A),
  filter f l <> [] <-> (exists x, In x l /\ f x = true).
Proof.
  intros A f l.
  assert (H_dec : forall x, {f x = true} + {f x <> true}). {
    intros x. destruct (f x) eqn:Hx; firstorder.
  }
  assert (H_dec' : forall x, f x = false \/ f x <> false). {
    intros x. destruct (f x) eqn:Hx; firstorder.
  }
  assert (DM : (exists x : A, In x l /\ f x = true) <-> ~(forall x, In x l -> f x = false)). {
    rewrite <- Forall_forall.
    rewrite <- Exists_exists.
    rewrite <- Exists_Forall_neg; try assumption.
    repeat (rewrite -> Exists_exists).
    split; intros [x Hx]; exists x.
    - rewrite -> Bool.not_false_iff_true; assumption.
    - rewrite -> Bool.not_false_iff_true in Hx; assumption.
  }
  rewrite -> DM. split; apply contrapositive; rewrite filter_empty_spec; trivial.
Qed.

Lemma combine_nil : forall {A B : Type} (l : list A),
  combine l (@nil B) = @nil (A*B).
Proof.
  intros A B l.
  apply length_zero_iff_nil.
  rewrite combine_length. simpl. rewrite Nat.min_0_r.
  reflexivity.
Qed.

Lemma filter_map_commute : forall {A B : Type} (g : A -> B) (fA : A -> bool) (fB : B -> bool) (l : list A),
  (forall x, In x l -> fB (g x) = fA x) -> filter fB (map g l) = map g (filter fA l).
Proof.
  induction l as [| y l IHl]; intros Hcomm; [reflexivity|].
  simpl; destruct (fB (g y)) eqn:HfB; destruct (fA y) eqn:HfA; simpl.
  - assert (filter fB (map g l) = map g (filter fA l)). {
      apply IHl. intros x Hx. apply Hcomm. apply in_cons. assumption.
    } rewrite H. reflexivity.
  - assert (contra : fB (g y) = fA y). { apply Hcomm. apply in_eq. }
    rewrite HfB in contra. rewrite HfA in contra. discriminate.
  - assert (contra : fB (g y) = fA y). { apply Hcomm. apply in_eq. }
    rewrite HfB in contra. rewrite HfA in contra. discriminate.
  - apply IHl. intros x Hx. apply Hcomm. apply in_cons. assumption.
Qed.

Lemma combine_firstn_l : forall {A B : Type} (l : list A) (l' : list B),
  length l <= length l' -> combine l l' = combine l (firstn (length l) l').
Proof.
  intros A B.
  induction l as [| x l IHl]; intros l' H; [reflexivity|].
  destruct l' as [| x' l']; [reflexivity|].
  simpl in H. apply le_S_n in H. apply IHl in H.
  simpl. rewrite H. reflexivity.
Qed.

Lemma combine_firstn_r : forall {A B : Type} (l : list A) (l' : list B),
  length l' <= length l -> combine l l' = combine (firstn (length l') l) l'.
Proof.
  intros A B l l'. generalize dependent l.
  induction l' as [| x' l' IHl']; intros l H.
  - simpl. apply combine_nil.
  - destruct l as [| x l]; [reflexivity|].
    simpl in H. apply le_S_n in H. apply IHl' in H.
    simpl. rewrite H. reflexivity.
Qed.

Lemma combine_firstn : forall {A B : Type} (l : list A) (l' : list B) (n : nat),
  firstn n (combine l l') = combine (firstn n l) (firstn n l').
Proof.
  intros A B. induction l as [| x l IHl]; intros l' n.
  - simpl. repeat (rewrite firstn_nil). reflexivity.
  - destruct l' as [| x' l'].
    + simpl. repeat (rewrite firstn_nil). rewrite combine_nil. reflexivity.
    + simpl. destruct n as [| n]; [reflexivity|].
      repeat (rewrite firstn_cons). simpl.
      rewrite IHl. reflexivity.
Qed.

Lemma nth_error_nth : forall {A : Type} (l : list A) (n : nat) (a : A),
  nth_error l n = Some a -> nth n l a = a.
Proof.
  intros A l n a H.
  apply nth_error_split in H. destruct H as [l1 [l2 [H H']]].
  subst. rewrite app_nth2; [|auto].
  rewrite Nat.sub_diag. reflexivity.
Qed.

Lemma nth_error_nth' : forall {A : Type} (l : list A) (n : nat) (a : A),
  n < length l -> nth_error l n = Some (nth n l a).
Proof.
  intros A l n a H.
  apply nth_split with (d:=a) in H. destruct H as [l1 [l2 [H H']]].
  subst. rewrite H. rewrite nth_error_app2; [|auto].
  rewrite app_nth2; [| auto]. repeat (rewrite Nat.sub_diag). reflexivity.
Qed.

Lemma permutation_filter : forall {A : Type} (f : A -> bool) (l l' : list A),
  Permutation l l' -> Permutation (filter f l) (filter f l').
Proof.
  intros A f.
  induction l as [| x l IHl]; intros l' Hl'.
  - apply Permutation_nil in Hl'. subst. apply Permutation_refl.
  - assert (Hx : In x l'). { apply Permutation_in with (l:=(x::l)) (x:=x) in Hl'; [assumption | apply in_eq]. }
    apply in_split in Hx. destruct Hx as [l1 [l2 H]].
    assert (H' : Permutation l (l1++l2)). { rewrite H in Hl'. apply Permutation_cons_app_inv in Hl'. assumption. }
    apply IHl in H'.
    simpl. destruct (f x) eqn:Hfx.
    + assert (Hfl : Permutation (filter f l') (x::filter f (l1++l2))). {
        rewrite H. repeat (rewrite filter_app). simpl. rewrite Hfx.
        apply Permutation_sym. apply Permutation_middle.
      }
      apply perm_skip with (x:=x) in H'. apply Permutation_sym in Hfl.
      apply (Permutation_trans H' Hfl).
    + assert (Hfl : filter f l' = filter f (l1 ++ l2)). {
        rewrite H. rewrite filter_app. simpl. rewrite Hfx. rewrite filter_app. reflexivity.
      }
      rewrite Hfl. assumption.
Qed.

Lemma nodup_fixed_point : forall {A : Type} (decA : forall x y, {x=y} + {x<>y}) (l : list A),
  NoDup l -> nodup decA l = l.
Proof.
  intros A decA. induction l as [| x l IHl]; [auto|]. intros H.
  simpl. destruct (in_dec decA x l) as [Hx | Hx]; rewrite NoDup_cons_iff in H.
  - destruct H as [H' _]. contradiction.
  - destruct H as [_ H']. apply IHl in H'. rewrite -> H'. reflexivity.
Qed.


(*********************************************************************************

 Closed monoidal categories

 A closed monoidal category is one for which tensoring with a fixed object has a
 right adjoint. Depending on whether the monoidal category is symmetric or not,
 there are different variations of this definition. If the monoidal category is
 not symmetric, then there are two variations, namely left closed and right
 closed, and their difference is whether we look at an adjoint for tensoring with
 an object on the left or on the right. For symmetric monoidal categories, these
 two definitions coincide.

 We also define accessors and a builder for symmetric monoidal categories. They
 are based on having lambda abstraction and application with the usual beta and
 eta laws. In addition, we define some standard functions and we prove some laws
 about them.

 Contents
 1. Basic definitions
 2. Accessors for symmetric monoidal categories
 3. Standard functions

 *********************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric.

Local Open Scope cat.
Local Open Scope moncat.
Import MonoidalNotations.

(**
 1. Basic definitions
 *)
Section ClosedMonoidalCategories.

  Definition monoidal_leftclosed {C : category} (M : monoidal C) : UU
    := ∏ X : C, ∑ homX : functor C C,
          are_adjoints
            (rightwhiskering_functor M X)
            homX.

  Definition monoidal_leftclosed_exp {C : category} {M : monoidal C}
             (LC : monoidal_leftclosed M) : C -> functor C C
    := λ X, pr1 (LC X).

  Definition monoidal_rightclosed {C : category} (M : monoidal C) : UU
    := ∏ X : C, ∑ homX : functor C C,
          are_adjoints
            (leftwhiskering_functor M X)
            homX.

  Definition monoidal_biclosed {C : category} (M : monoidal C) : UU
    := monoidal_leftclosed M × monoidal_rightclosed M.

  Lemma adj_unique_up_to_nat_z_iso
        {C D : category} {F1 F2 : functor C D} (α : nat_z_iso F1 F2) (G : functor D C)
    : are_adjoints F2 G -> are_adjoints F1 G.
  Proof.
    intro adj.
    repeat (use tpair).
    - exact (λ x, (pr1 (pr1 adj) x) · #G (pr1 (pr2 α x))).
    - intros x y f.
      etrans. {
        rewrite assoc.
        apply cancel_postcomposition.
        exact (pr211 adj x y f).
      }

      etrans. {
        rewrite assoc'.
        apply maponpaths.
        simpl.
        apply (! functor_comp _ _ _).
      }

      use pathscomp0.
      3: {
        rewrite assoc'.
        apply maponpaths.
        simpl.
        apply (functor_comp _ _ _).
      }

      do 2 apply maponpaths.

      etrans. {
        apply maponpaths.
        rewrite (! id_right _).
        apply maponpaths.
        exact (! pr12 (pr2 α y)).
      }
      etrans. {
        rewrite assoc.
        apply assoc.
      }

      use pathscomp0.
      3: {
        apply maponpaths.
        rewrite (! id_right _).
        apply maponpaths.
        exact (pr12 (pr2 α y)).
      }

      use pathscomp0.
      3: {
        rewrite assoc.
        rewrite (assoc ( pr1 (pr2 α x) · # F1 f)).
        apply idpath.
      }
      apply cancel_postcomposition.
      use pathscomp0.
      3: {
        rewrite assoc'.
        apply maponpaths.
        exact (! (pr21 α) x y f).
      }

      etrans. {
        rewrite assoc'.
        apply maponpaths.
        apply (pr22 (pr2 α y)).
      }

      use pathscomp0.
      3: {
        rewrite assoc.
        apply cancel_postcomposition.
        apply (! pr22 (pr2 α x)).
      }
      rewrite id_left.
      apply id_right.
    - exact (λ x, (pr1 α (G x)) · (pr2 (pr1 adj) x)).
    - intros x y f.

      etrans. {
        rewrite assoc.
        apply cancel_postcomposition.
        apply (pr21 α).
      }

      etrans. { apply assoc'. }
      use pathscomp0.
      3: { apply assoc. }
      apply maponpaths.
      exact (pr2 (pr21 adj) _ _ f).
    - intro x.
      simpl.

      etrans. {
        rewrite assoc.
        apply cancel_postcomposition.
        rewrite functor_comp.
        rewrite assoc'.
        apply cancel_precomposition.
        apply (pr21 α).
      }

      etrans. {
        rewrite assoc'.
        apply cancel_precomposition.
        rewrite assoc'.
        apply cancel_precomposition.
        apply (pr221 adj).
      }

      etrans. {
        rewrite assoc.
        apply cancel_postcomposition.
        apply (pr21 α).
      }

      etrans. {
        rewrite assoc.
        apply cancel_postcomposition.
        rewrite assoc'.
        apply cancel_precomposition.
        apply ((pr12 adj) x).
      }
      rewrite id_right.
      apply (pr2 α).
    - intro x.
      refine (_ @ (pr22 adj x)).
      cbn.
      rewrite assoc'.
      apply maponpaths.

      rewrite (! functor_comp _ _ _).
      etrans. {
        apply maponpaths.
        rewrite assoc.
        apply cancel_postcomposition.
        apply (pr2 α).
      }
      apply maponpaths.
      apply id_left.
  Defined.

  Lemma leftclosed_symmetric_is_rightclosed {C : category} (M : monoidal C)
    : symmetric M -> monoidal_leftclosed M -> monoidal_rightclosed M.
  Proof.
    intros B LC.
    intro x.
    exists (monoidal_leftclosed_exp LC x).
    apply (adj_unique_up_to_nat_z_iso (F2 := rightwhiskering_functor M x)).
    - apply symmetric_whiskers_swap_nat_z_iso.
      exact B.
    - exact (pr2 (LC x)).
  Defined.

  Lemma leftclosed_symmetric_is_biclosed {C : category} (M : monoidal C)
    : symmetric M -> monoidal_leftclosed M -> monoidal_biclosed M.
  Proof.
    exact (λ S LC, LC ,, leftclosed_symmetric_is_rightclosed M S LC).
  Defined.
End ClosedMonoidalCategories.

(**
 2. Accessors for symmetric monoidal categories
 *)
Definition sym_mon_closed_cat
  : UU
  := ∑ (V : sym_monoidal_cat), monoidal_leftclosed V.

Coercion sym_monoidal_closed_cat_to_sym_monoidal_cat
         (V : sym_mon_closed_cat)
  : sym_monoidal_cat
  := pr1 V.

Section Builder.
  Context (V : sym_monoidal_cat)
          (HomV : V → V → V)
          (eval : ∏ (x y : V), HomV x y ⊗ x --> y)
          (lam : ∏ (x y z : V) (f : z ⊗ x --> y), z --> HomV x y)
          (betaEq : ∏ (x y z : V) (f : z ⊗ x --> y),
                    lam x y z f #⊗ identity x · eval x y
                    =
                    f)
          (etaEq : ∏ (x y z : V) (g : z --> HomV x y),
                   g
                   =
                   lam x y z (g #⊗ identity _ · eval x y)).

  Definition make_left_closed_universal
             (x y : V)
    : is_universal_arrow_from
        (rightwhiskering_functor V x)
        y
        (HomV x y)
        (eval x y).
  Proof.
    intros z f.
    use iscontraprop1.
    - abstract
        (use invproofirrelevance ;
         intros φ₁ φ₂ ;
         use subtypePath ; [ intro ; apply homset_property | ] ;
         refine (etaEq _ _ _ _ @ _ @ !(etaEq _ _ _ _)) ;
         apply maponpaths ;
         refine (_ @ !(pr2 φ₁) @ pr2 φ₂ @ !_) ;
         apply maponpaths_2 ;
         refine (_ @ id_right _) ;
         unfold rightwhiskering_on_morphisms ;
         unfold monoidal_cat_tensor_mor ;
         unfold functoronmorphisms1 ;
         apply maponpaths ;
         apply (bifunctor_leftid V)).
    - simple refine (_ ,, _).
      + exact (lam x y z f).
      + abstract
          (refine (!(betaEq x y z f) @ _) ; cbn ;
           apply maponpaths_2 ;
           refine (_ @ id_right _) ;
           unfold rightwhiskering_on_morphisms ;
           unfold monoidal_cat_tensor_mor ;
           unfold functoronmorphisms1 ;
           apply maponpaths ;
           apply (bifunctor_leftid V)).
  Defined.

  Definition make_monoidal_leftclosed
    : monoidal_leftclosed V.
  Proof.
    intros x.
    pose (right_adjoint_from_partial
             (rightwhiskering_functor V x)
             (HomV x)
             (eval x)
             (make_left_closed_universal x))
      as A.
    exists (Core.G _ _ _ (make_left_closed_universal x)).
    exact (pr2 A).
  Defined.

  Definition make_sym_mon_closed_cat
    : sym_mon_closed_cat
    := V ,, make_monoidal_leftclosed.
End Builder.

Definition internal_hom
           {V : sym_mon_closed_cat}
           (x y : V)
  : V
  := pr1 (pr2 V x) y.

Notation "x ⊸ y" := (internal_hom x y) (at level 45, right associativity) : moncat.
(* \-o or \r-o *)

Section Accessors.
  Context {V : sym_mon_closed_cat}.

  Definition internal_eval
             (x y : V)
    : (x ⊸ y) ⊗ x --> y
    := counit_from_are_adjoints (pr2 (pr2 V x)) y.

  Definition internal_lam
             {x y z : V}
             (f : x ⊗ y --> z)
    : x --> y ⊸ z
    := unit_from_are_adjoints (pr2 (pr2 V y)) x · #(pr1 (pr2 V y)) f.

  Proposition internal_beta
              {x y z : V}
              (f : z ⊗ x --> y)
    : internal_lam f #⊗ identity x · internal_eval x y
      =
      f.
  Proof.
    unfold internal_lam.
    rewrite tensor_comp_r_id_l.
    rewrite !assoc'.
    unfold internal_eval.
    etrans.
    {
      apply maponpaths.
      pose (nat_trans_ax
              (counit_from_are_adjoints (pr2 (pr2 V x)))
              _
              _
              f)
        as p.
      refine (_ @ p).
      apply maponpaths_2.
      cbn.
      unfold rightwhiskering_on_morphisms.
      unfold monoidal_cat_tensor_mor.
      unfold functoronmorphisms1.
      refine (_ @ id_right _).
      apply maponpaths.
      apply (bifunctor_leftid V).
    }
    cbn.
    rewrite !assoc.
    refine (_ @ id_left _).
    apply maponpaths_2.
    refine (_ @ triangle_id_left_ad (pr2 (pr2 V x)) _).
    apply maponpaths_2.
    cbn.
    unfold rightwhiskering_on_morphisms.
    unfold monoidal_cat_tensor_mor.
    unfold functoronmorphisms1.
    refine (_ @ id_right _).
    apply maponpaths.
    apply (bifunctor_leftid V).
  Qed.

  Proposition internal_eta
              {x y z : V}
              (f : z --> x ⊸ y)
    : f
      =
      internal_lam (f #⊗ identity _ · internal_eval x y).
  Proof.
    unfold internal_lam.
    unfold internal_eval.
    refine (!_).
    rewrite functor_comp.
    rewrite !assoc.
    etrans.
    {
      apply maponpaths_2.
      pose (nat_trans_ax
              (unit_from_are_adjoints (pr2 (pr2 V x)))
              _
              _
              f)
        as p.
      cbn in p.
      refine (_ @ !p).
      do 2 apply maponpaths.
      unfold rightwhiskering_on_morphisms.
      unfold monoidal_cat_tensor_mor.
      unfold functoronmorphisms1.
      refine (_ @ id_right _).
      apply maponpaths.
      apply (bifunctor_leftid V).
    }
    refine (_ @ id_right _).
    rewrite !assoc'.
    apply maponpaths.
    exact (triangle_id_right_ad (pr2 (pr2 V x)) _).
  Qed.
End Accessors.

Definition sym_mon_closed_left_tensor_left_adjoint_universal
           (V : sym_mon_closed_cat)
           (x y : V)
  : is_universal_arrow_from
      (monoidal_left_tensor x)
      y
      (x ⊸ y)
      (sym_mon_braiding V x (x ⊸ y) · internal_eval x y).
Proof.
  intros z f.
  use iscontraprop1.
  - abstract
      (use invproofirrelevance ;
       intros φ₁ φ₂ ;
       use subtypePath ; [ intro ; apply homset_property | ] ;
       refine (internal_eta _ @ _ @ !(internal_eta _)) ;
       apply maponpaths ;
       refine (!(id_left _) @ _ @ id_left _) ;
       rewrite <- !sym_mon_braiding_inv ;
       rewrite !assoc' ;
       apply maponpaths ;
       rewrite !assoc ;
       rewrite <- !tensor_sym_mon_braiding ;
       rewrite !assoc' ;
       exact (!(pr2 φ₁) @ pr2 φ₂)).
  - refine (internal_lam (sym_mon_braiding V z x · f) ,, _).
    abstract
      (cbn -[sym_mon_braiding] ;
       rewrite !assoc ;
       rewrite tensor_sym_mon_braiding ;
       rewrite !assoc' ;
       rewrite internal_beta ;
       rewrite !assoc ;
       rewrite sym_mon_braiding_inv ;
       rewrite id_left ;
       apply idpath).
Defined.

Definition sym_mon_closed_left_tensor_left_adjoint
           (V : sym_mon_closed_cat)
           (x : V)
  : is_left_adjoint (monoidal_left_tensor x).
Proof.
  use left_adjoint_from_partial.
  - exact (λ y, x ⊸ y).
  - exact (λ y, sym_mon_braiding V _ _ · internal_eval _ _).
  - exact (sym_mon_closed_left_tensor_left_adjoint_universal V x).
Defined.

Definition sym_mon_closed_left_tensor_right_adjoint_universal
           (V : sym_mon_closed_cat)
           (x y : V)
  : is_universal_arrow_from
      (monoidal_right_tensor x)
      y
      (x ⊸ y)
      (internal_eval x y).
Proof.
  intros z f.
  use iscontraprop1.
  - abstract
      (use invproofirrelevance ;
       intros φ₁ φ₂ ;
       use subtypePath ; [ intro ; apply homset_property | ] ;
       refine (internal_eta _ @ _ @ !(internal_eta _)) ;
       apply maponpaths ;
       exact (!(pr2 φ₁) @ pr2 φ₂)).
  - refine (internal_lam f ,, _).
    abstract
      (cbn ;
       rewrite internal_beta ;
       apply idpath).
Defined.

Definition sym_mon_closed_right_tensor_left_adjoint
           (V : sym_mon_closed_cat)
           (x : V)
  : is_left_adjoint (monoidal_right_tensor x).
Proof.
  use left_adjoint_from_partial.
  - exact (λ y, x ⊸ y).
  - exact (λ y, internal_eval _ _).
  - exact (sym_mon_closed_left_tensor_right_adjoint_universal V x).
Defined.

(**
 3. Standard functions
 *)
Section StandardFunctions.
  Context {V : sym_mon_closed_cat}.

  Definition internal_id
             (x : V)
    : I_{V} --> x ⊸ x
    := internal_lam (mon_lunitor _).

  Definition internal_comp
             (x y z : V)
    : (y ⊸ z) ⊗ (x ⊸ y) --> x ⊸ z
    := internal_lam
         (mon_lassociator _ _ _
          · identity _ #⊗ internal_eval x y
          · internal_eval y z).

  Definition internal_from_arr
             {x y : V}
             (f : x --> y)
    : I_{V} --> x ⊸ y
    := internal_lam (mon_lunitor x · f).

  Definition internal_to_arr
             {x y : V}
             (f : I_{V} --> x ⊸ y)
    : x --> y
    := mon_linvunitor x · f #⊗ identity x · internal_eval x y.

  Definition internal_pair
             (x y : V)
    : x --> y ⊸ x ⊗ y
    := internal_lam (identity _).

  Definition internal_swap_arg
             (v₁ v₂ w : V)
    : v₁ ⊸ w ⊸ v₂ --> w ⊸ v₁ ⊸ v₂
    := internal_lam
         (internal_lam
            (mon_lassociator _ _ _
             · identity _ #⊗ sym_mon_braiding _ _ _
             · mon_rassociator _ _ _
             · internal_eval _ _ #⊗ identity _
             · internal_eval _ _)).

  Definition internal_curry
             (v₁ v₂ v₃ : V)
    : v₁ ⊗ v₂ ⊸ v₃ --> v₁ ⊸ v₂ ⊸ v₃
    := internal_lam (internal_lam (mon_lassociator _ _ _ · internal_eval _ _)).

  Definition internal_uncurry
             (v₁ v₂ v₃ : V)
    : v₁ ⊸ v₂ ⊸ v₃ --> v₁ ⊗ v₂ ⊸ v₃
    := internal_lam (mon_rassociator _ _ _
                     · internal_eval _ _ #⊗ identity _
                     · internal_eval _ _).

  Proposition internal_funext
              (w x y : V)
              (f g : w --> x ⊸ y)
              (p : ∏ (a : V)
                     (h : a --> x),
                   f #⊗ h · internal_eval x y
                   =
                   g #⊗ h · internal_eval x y)
    : f = g.
  Proof.
    refine (internal_eta f @ _ @ !(internal_eta g)).
    apply maponpaths.
    exact (p x (identity x)).
  Qed.

  Proposition internal_id_left
              (x y : V)
    : mon_lunitor _
      =
      internal_id y #⊗ identity _
      · internal_comp x y y.
  Proof.
    use internal_funext.
    intros w h.
    rewrite tensor_comp_r_id_r.
    rewrite !assoc'.
    unfold internal_comp.
    rewrite internal_beta.
    rewrite !assoc.
    rewrite tensor_lassociator.
    rewrite !assoc'.
    refine (!_).
    etrans.
    {
      apply maponpaths.
      rewrite !assoc.
      rewrite <- tensor_comp_mor.
      rewrite id_right.
      rewrite tensor_comp_l_id_l.
      rewrite !assoc'.
      apply maponpaths.
      rewrite tensor_split.
      rewrite !assoc'.
      apply maponpaths.
      unfold internal_id.
      apply internal_beta.
    }
    rewrite tensor_lunitor.
    rewrite !assoc.
    apply maponpaths_2.
    rewrite !assoc'.
    rewrite tensor_lunitor.
    rewrite !assoc.
    rewrite mon_lunitor_triangle.
    rewrite <- tensor_split'.
    apply idpath.
  Qed.

  Proposition internal_id_right
              (x y : V)
    : mon_runitor _
      =
      identity _ #⊗ internal_id x
      · internal_comp x x y.
  Proof.
    use internal_funext.
    intros w h.
    rewrite tensor_comp_r_id_r.
    rewrite !assoc'.
    unfold internal_comp.
    rewrite internal_beta.
    rewrite !assoc.
    rewrite tensor_lassociator.
    apply maponpaths_2.
    rewrite !assoc'.
    refine (!_).
    etrans.
    {
      apply maponpaths.
      rewrite <- tensor_comp_mor.
      rewrite id_right.
      apply maponpaths.
      rewrite tensor_split.
      rewrite !assoc'.
      apply maponpaths.
      unfold internal_id.
      apply internal_beta.
    }
    rewrite tensor_lunitor.
    rewrite tensor_comp_id_l.
    rewrite !assoc.
    rewrite <- mon_triangle.
    rewrite <- tensor_split'.
    apply idpath.
  Qed.

  Proposition internal_assoc
              (w x y z : V)
    : (internal_comp x y z #⊗ identity _)
      · internal_comp w x z
      =
      mon_lassociator _ _ _
      · (identity _ #⊗ internal_comp w x y)
      · internal_comp w y z.
  Proof.
    use internal_funext.
    intros a h.
    etrans.
    {
      rewrite tensor_comp_r_id_r.
      rewrite !assoc'.
      apply maponpaths.
      apply internal_beta.
    }
    etrans.
    {
      rewrite !assoc.
      rewrite tensor_lassociator.
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      rewrite <- tensor_comp_mor.
      rewrite id_right.
      rewrite tensor_split.
      rewrite !assoc'.
      apply maponpaths.
      apply internal_beta.
    }
    refine (!_).
    etrans.
    {
      rewrite tensor_comp_r_id_r.
      rewrite !assoc'.
      apply maponpaths.
      apply internal_beta.
    }
    rewrite !assoc.
    apply maponpaths_2.
    etrans.
    {
      rewrite !assoc'.
      rewrite tensor_comp_r_id_r.
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      rewrite tensor_lassociator.
      rewrite !assoc'.
      rewrite <- tensor_comp_id_l.
      do 2 apply maponpaths.
      apply internal_beta.
    }
    rewrite !tensor_comp_id_l.
    rewrite !assoc.
    apply maponpaths_2.
    rewrite !assoc'.
    refine (!_).
    etrans.
    {
      apply maponpaths.
      rewrite !assoc.
      rewrite <- tensor_comp_id_l.
      rewrite <- tensor_id_id.
      rewrite tensor_lassociator.
      rewrite !tensor_comp_id_l.
      apply idpath.
    }
    rewrite !assoc.
    apply maponpaths_2.
    rewrite mon_lassociator_lassociator.
    rewrite !assoc'.
    rewrite <- tensor_comp_id_l.
    rewrite <- tensor_lassociator.
    rewrite tensor_comp_id_l.
    rewrite !assoc.
    apply maponpaths_2.
    rewrite !assoc'.
    rewrite <- tensor_lassociator.
    rewrite !assoc.
    apply maponpaths_2.
    rewrite <- tensor_comp_mor.
    rewrite id_left.
    rewrite !tensor_id_id.
    rewrite id_right.
    apply idpath.
  Qed.

  Proposition internal_from_to_arr
              {x y : V}
              (f : I_{V} --> x ⊸ y)
    : internal_from_arr (internal_to_arr f) = f.
  Proof.
    unfold internal_from_arr, internal_to_arr.
    rewrite !assoc.
    rewrite mon_lunitor_linvunitor.
    rewrite id_left.
    exact (!(internal_eta f)).
  Qed.

  Proposition internal_to_from_arr
              {x y : V}
              (f : x --> y)
    : internal_to_arr (internal_from_arr f) = f.
  Proof.
    unfold internal_from_arr, internal_to_arr.
    rewrite !assoc'.
    rewrite internal_beta.
    rewrite !assoc.
    rewrite mon_linvunitor_lunitor.
    apply id_left.
  Qed.

  Proposition internal_to_arr_id
              (x : V)
    : internal_to_arr (internal_id x) = identity x.
  Proof.
    unfold internal_to_arr.
    rewrite !assoc'.
    unfold internal_id.
    rewrite internal_beta.
    apply mon_linvunitor_lunitor.
  Qed.

  Proposition internal_to_arr_comp
              {x y z : V}
              (f : x --> y)
              (g : y --> z)
    : f · g
      =
      internal_to_arr
        (mon_linvunitor I_{V}
         · internal_from_arr g #⊗ internal_from_arr f
         · internal_comp x y z).
  Proof.
    unfold internal_to_arr.
    rewrite tensor_comp_id_r.
    rewrite !assoc'.
    unfold internal_comp.
    rewrite internal_beta.
    rewrite tensor_comp_id_r.
    rewrite !assoc'.
    refine (!_).
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !assoc.
      rewrite tensor_lassociator.
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      rewrite <- tensor_comp_mor.
      rewrite id_right.
      unfold internal_from_arr.
      rewrite internal_beta.
      rewrite tensor_split.
      rewrite !assoc'.
      rewrite internal_beta.
      apply idpath.
    }
    rewrite !assoc.
    apply maponpaths_2.
    rewrite !assoc'.
    rewrite tensor_lunitor.
    rewrite !assoc.
    refine (_ @ id_left _).
    apply maponpaths_2.
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        rewrite !assoc.
        rewrite mon_lunitor_triangle.
        apply idpath.
      }
      rewrite !assoc.
      rewrite <- tensor_comp_id_r.
      rewrite mon_linvunitor_lunitor.
      rewrite tensor_id_id.
      apply id_left.
    }
    apply mon_linvunitor_lunitor.
  Qed.

  Proposition internal_eval_natural
              (x : V)
              {y₁ y₂ : V}
              (f : y₁ --> y₂)
    : internal_eval x y₁ · f
      =
      internal_lam (internal_eval _ _ · f) #⊗ identity x · internal_eval x y₂.
  Proof.
    rewrite internal_beta.
    apply idpath.
  Qed.

  Proposition internal_pair_natural
              {x₁ x₂ : V}
              (y : V)
              (f : x₁ --> x₂)
    : f · internal_pair x₂ y
      =
      internal_pair x₁ y · internal_lam (internal_eval _ _ · f #⊗ identity _).
  Proof.
    use internal_funext.
    intros w h.
    rewrite !tensor_comp_r_id_r.
    rewrite !assoc'.
    unfold internal_pair.
    rewrite !internal_beta.
    rewrite !assoc.
    rewrite id_right.
    refine (!_).
    etrans.
    {
      apply maponpaths_2.
      rewrite tensor_split.
      rewrite !assoc'.
      rewrite internal_beta.
      apply id_right.
    }
    rewrite <- tensor_split.
    apply idpath.
  Qed.

  Proposition internal_lam_natural
              {x₁ x₂ y z : V}
              (f : x₁ --> x₂)
              (g : x₂ ⊗ y --> z)
    : f · internal_lam g = internal_lam (f #⊗ identity y · g).
  Proof.
    use internal_funext.
    intros w h.
    etrans.
    {
      rewrite tensor_split.
      rewrite tensor_comp_id_r.
      rewrite !assoc'.
      rewrite internal_beta.
      rewrite !assoc.
      rewrite <- tensor_split.
      apply idpath.
    }
    refine (!_).
    etrans.
    {
      rewrite tensor_split.
      rewrite !assoc'.
      rewrite internal_beta.
      rewrite !assoc.
      rewrite <- tensor_split.
      apply idpath.
    }
    apply idpath.
  Qed.

  Proposition internal_pair_eval
              (x y : V)
    : (internal_pair x y) #⊗ identity y · internal_eval y (x ⊗ y) = identity (x ⊗ y).
  Proof.
    unfold internal_pair.
    rewrite internal_beta.
    apply idpath.
  Qed.

  Proposition internal_eval_pair
              (x y : V)
    : internal_pair (x ⊸ y) x · internal_lam (internal_eval _ _ · internal_eval _ _)
      =
      identity (x ⊸ y).
  Proof.
    use internal_funext.
    intros a h.
    rewrite tensor_comp_r_id_r.
    rewrite !assoc'.
    rewrite internal_beta.
    etrans.
    {
      rewrite !assoc.
      apply maponpaths_2.
      rewrite tensor_split.
      rewrite !assoc'.
      unfold internal_pair.
      rewrite internal_beta.
      apply id_right.
    }
    apply idpath.
  Qed.

  Proposition internal_curry_uncurry
              (v₁ v₂ v₃ : V)
    : internal_curry v₁ v₂ v₃ · internal_uncurry v₁ v₂ v₃ = identity _.
  Proof.
    use internal_funext.
    intros w h.
    rewrite tensor_comp_r_id_r.
    rewrite !assoc'.
    unfold internal_uncurry.
    rewrite internal_beta.
    rewrite tensor_split.
    rewrite <- tensor_id_id.
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      rewrite !assoc.
      rewrite tensor_rassociator.
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      rewrite <- tensor_comp_id_r.
      unfold internal_curry.
      rewrite !internal_beta.
      apply idpath.
    }
    rewrite !assoc.
    apply maponpaths_2.
    rewrite !assoc'.
    rewrite mon_rassociator_lassociator.
    apply id_right.
  Qed.

  Proposition internal_uncurry_curry
              (v₁ v₂ v₃ : V)
    : internal_uncurry v₁ v₂ v₃ · internal_curry v₁ v₂ v₃ = identity _.
  Proof.
    use internal_funext.
    intros w₁ h₁.
    rewrite tensor_comp_r_id_r.
    rewrite !assoc'.
    unfold internal_curry.
    rewrite internal_beta.
    use internal_funext.
    intros w₂ h₂.
    rewrite tensor_comp_r_id_r.
    rewrite !assoc'.
    rewrite internal_beta.
    rewrite !assoc.
    rewrite tensor_lassociator.
    rewrite tensor_split.
    rewrite !assoc'.
    unfold internal_uncurry.
    rewrite internal_beta.
    rewrite !assoc.
    apply maponpaths_2.
    rewrite <- tensor_lassociator.
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      rewrite !assoc.
      rewrite mon_lassociator_rassociator.
      apply id_left.
    }
    rewrite <- !tensor_comp_mor.
    rewrite id_right.
    apply idpath.
  Qed.

  Definition internal_hom_equiv
             (x y z : V)
    : (x --> y ⊸ z) ≃ (x ⊗ y --> z).
  Proof.
    use weq_iso.
    - exact (λ f, f #⊗ identity y · internal_eval y z).
    - exact (λ f, internal_lam f).
    - abstract
        (intro f ; cbn ;
         use internal_funext ;
         intros w h ;
         rewrite tensor_split ;
         rewrite !assoc' ;
         rewrite internal_beta ;
         rewrite !assoc ;
         rewrite <- tensor_split ;
         apply idpath).
    - abstract
        (intro f ; cbn ;
         apply internal_beta).
  Defined.
End StandardFunctions.


Require Import List.
Import ListNotations.
Require Import Coq.Lists.ListSet.
Require Import Arith.
Require Import Omega.

Require Import Unification.

Inductive goal : Set :=
| Fail   : goal
| Unify  : term -> term -> goal
| Disj   : goal -> goal -> goal
| Conj   : goal -> goal -> goal
| Fresh  : (name -> goal) -> goal
| Invoke : name -> term -> goal.

Definition rel : Set := term -> goal.

Inductive is_fv_of_goal (n : name) : goal -> Prop :=
| fvUnifyL : forall t1 t2 (IN_FV : In n (fv_term t1)),
                          is_fv_of_goal n (Unify t1 t2)
| fvUnifyR : forall t1 t2 (IN_FV : In n (fv_term t2)),
                          is_fv_of_goal n (Unify t1 t2)
| fvDisjL  : forall g1 g2 (IS_FV : is_fv_of_goal n g1),
                          is_fv_of_goal n (Disj g1 g2)
| fvDisjR  : forall g1 g2 (IS_FV : is_fv_of_goal n g2),
                          is_fv_of_goal n (Disj g1 g2)
| fvConjL  : forall g1 g2 (IS_FV : is_fv_of_goal n g1),
                          is_fv_of_goal n (Conj g1 g2)
| fvConjR  : forall g1 g2 (IS_FV : is_fv_of_goal n g2),
                          is_fv_of_goal n (Conj g1 g2)
| fvFresh  : forall fg n' (NEQ : n' <> n)
                          (IS_FV : is_fv_of_goal n (fg n')),
                          is_fv_of_goal n (Fresh fg)
| fvInvoke : forall r arg (IN_FV : In n (fv_term arg)),
                          is_fv_of_goal n (Invoke r arg).

Hint Constructors is_fv_of_goal : core.

(* Weak version of a variable renaming *)
Inductive renaming (old_x : name) (new_x : name) : goal -> goal -> Prop :=
| rFail : renaming old_x new_x Fail Fail
| rUnify : forall t1 t2, renaming old_x new_x (Unify t1 t2)
                                              (Unify (apply_subst [(old_x, Var new_x)] t1)
                                                     (apply_subst [(old_x, Var new_x)] t2))
| rDisj : forall g1 g2 rg1 rg2 (R_G1 : renaming old_x new_x g1 rg1)
                               (R_G2 : renaming old_x new_x g2 rg2),
                               renaming old_x new_x (Disj g1 g2) (Disj rg1 rg2)
| rConj : forall g1 g2 rg1 rg2 (R_G1 : renaming old_x new_x g1 rg1)
                               (R_G2 : renaming old_x new_x g2 rg2),
                               renaming old_x new_x (Conj g1 g2) (Conj rg1 rg2)
| rFreshNFV : forall fg (OLD_X_NOT_FV : ~ is_fv_of_goal old_x (Fresh fg)),
                        renaming old_x new_x (Fresh fg) (Fresh fg)
| rFreshFV : forall fg rfg (OLD_X_FV : is_fv_of_goal old_x (Fresh fg))
                           (R_FG : forall y (Y_NOT_FV : ~ is_fv_of_goal y (Fresh fg)),
                                            renaming old_x new_x (fg y) (rfg y)),
                           renaming old_x new_x (Fresh fg) (Fresh rfg)
| rInvoke : forall r arg, renaming old_x new_x (Invoke r arg)
                                               (Invoke r (apply_subst [(old_x, Var new_x)] arg)).

Hint Constructors renaming : core.

Definition consistent_binding (b : name -> goal) : Prop :=
  forall x y, (~ is_fv_of_goal x (Fresh b)) -> renaming x y (b x) (b y).

Inductive consistent_goal : goal -> Prop :=
| cgFail   : consistent_goal Fail
| cgUnify  : forall t1 t2, consistent_goal (Unify t1 t2)
| cgDisj   : forall g1 g2 (CG_G1 : consistent_goal g1)
                          (CG_G2 : consistent_goal g2),
                          consistent_goal (Disj g1 g2)
| cgConj   : forall g1 g2 (CG_G1 : consistent_goal g1)
                          (CG_G2 : consistent_goal g2),
                          consistent_goal (Conj g1 g2)
| cgFresh  : forall fg (CB_FG : consistent_binding fg)
                       (CG_BODY : forall n, consistent_goal (fg n)),
                       consistent_goal (Fresh fg)
| cgInvoke : forall r arg, consistent_goal (Invoke r arg).

Hint Constructors consistent_goal : core.

Definition consistent_function (f : term -> goal) : Prop :=
  forall a1 a2 t, renaming a1 a2 (f t) (f (apply_subst [(a1, Var a2)] t)).

Definition consistent_rel (r : rel) : Prop :=
  forall (arg : term), consistent_goal (r arg) /\ consistent_function r.

Definition closed_goal_in_context (c : list name) (g : goal) : Prop :=
  forall n, is_fv_of_goal n g -> In n c.

Definition closed_rel (r : rel) : Prop :=
  forall (arg : term), closed_goal_in_context (fv_term arg) (r arg).

Definition def : Set := {r : rel | closed_rel r /\ consistent_rel r}.

Definition spec : Set := name -> def.

Axiom Prog : spec.


Require Import FP.Data.Ascii.
Require Import FP.Data.Positive.
Require Import FP.Data.Nat.
Require Import FP.Data.Function.
Require Import FP.Relations.RelDec.
Require Import FP.Structures.EqDec.
Require Import FP.Structures.Eqv.
Require Import FP.Structures.Ord.
Require Import FP.Structures.Comonad.
Require Import FP.Structures.Peano.
Require Import FP.Structures.Monoid.
Require Import FP.Structures.Show.
Require Import FP.Structures.Additive.
Require Import FP.Structures.Lattice.
Require Import FP.Structures.Multiplicative.
Require Import FP.Structures.Convertible.

Import MonoidNotation.
Import FunctionNotation.
Import EqDecNotation.

Instance Z_nat_Convertible : Convertible Z nat :=
  { convert := BinInt.Z.to_nat }.
Instance nat_Z_Convertible : Convertible nat Z :=
  { convert := BinInt.Z.of_nat }.

Section EqDec.
  Global Instance Z_EqDec : EqDec Z := { eq_dec := BinInt.Z.eqb }.
End EqDec.

Section Eqv.
  Global Instance Z_Eqv : Eqv Z := { eqv := eq }.
End Eqv.

Section EqvDec.
  Global Instance Z_EqvDec : EqvDec Z := { eqv_dec := eq_dec }.
End EqvDec.

Section Ord.
  Global Instance Z_Ord : Ord Z := { lt := BinInt.Z.lt }.
End Ord.

Section OrdDec.
  Definition Z_ord_dec (z1:Z) (z2:Z) : comparison :=
    if z1 =! z2 then Eq
    else if BinInt.Z.ltb z1 z2 then Lt
    else Gt.
  Global Instance Z_OrdDec : OrdDec Z := { ord_dec := Z_ord_dec }.
End OrdDec.

Section Lattice.
  Global Instance Z_Lattice : Lattice Z :=
    { lmeet := BinInt.Z.min
    ; ljoin := BinInt.Z.max
    }.
End Lattice.

Section Show.
  Definition Z_show {R} {SR:ShowResult R} : Z -> R := show '.' convert_to nat.
  Global Instance Z_Show : Show Z := { show := @Z_show }.
End Show.

Section Additive.
  Definition Z_additive_InvMonoid : InvMonoid Z :=
    {| inv_monoid_times := BinInt.Z.add
     ; inv_monoid_unit := BinInt.Z.zero
     ; inv_monoid_inv := BinInt.Z.opp
     ; inv_monoid_div := BinInt.Z.sub
    |}.
  Global Instance Z_InverseAdditive : NegAdditive Z :=
    { neg_additive_InvMonoid := Z_additive_InvMonoid }.
End Additive.

Section Multiplicative.
  Definition Z_multiplicative_Monoid : Monoid Z :=
    {| monoid_times := BinInt.Z.mul
     ; monoid_unit := BinInt.Z.one
    |}.
  Global Instance Z_Multiplicative : Multiplicative Z :=
    { multiplicative_Monoid := Z_multiplicative_Monoid }.
End Multiplicative.

Definition Z_coloopr {m} {M:Comonad m} {A} (f:m A -> A) (aM:m A) (z:Z) : A :=
  match z with
  | Z0 => coret aM
  | Zpos p => coloopr f aM p
  | Zneg p => coloopr f aM p
  end.
Definition Z_coloopl {m} {M:Comonad m} {A} (f:m A -> A) (aM:m A) (z:Z) : A :=
  match z with
  | Z0 => coret aM
  | Zpos p => coloopl f aM p
  | Zneg p => coloopl f aM p
  end.
Instance Z_Peano : Peano Z :=
  { pzero := Z0
  ; psucc := BinInt.Z.succ
  ; coloopr := @Z_coloopr
  ; coloopl := @Z_coloopl
  }.


Require Export Dirac.

Lemma t4 :
(I_2 ⊗ TOF)
× (TOF ⊗ I_2)
× (CX ⊗ I_2 ⊗ I_2)
× (H ⊗ I_2 ⊗ I_2 ⊗ I_2)
× ∣0,0,0,0⟩
≡  / √ 2 .* ∣0,0,0,0⟩  .+ / √ 2 .* ∣1,1,1,1⟩.
Proof.
Time operate_reduce.
Qed.

Lemma t5 :
(I_2 ⊗ I_2 ⊗ TOF)
× (I_2 ⊗ TOF ⊗ I_2)
× (TOF ⊗ I_2 ⊗ I_2)
× (CX ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (H ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× ∣0,0,0,0,0⟩
≡  / √ 2 .* ∣0,0,0,0,0⟩  .+ / √ 2 .* ∣1,1,1,1,1⟩.
Proof.
Time operate_reduce.
Qed.

Lemma t6 :
(I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF)
× (I_2 ⊗ I_2 ⊗ TOF ⊗ I_2)
× (I_2 ⊗ TOF ⊗ I_2 ⊗ I_2)
× (TOF ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (CX ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (H ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× ∣0,0,0,0,0,0⟩
≡  / √ 2 .* ∣0,0,0,0,0,0⟩  .+ / √ 2 .* ∣1,1,1,1,1,1⟩.
Proof.
Time operate_reduce.
Qed.

Lemma t7 :
(I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (CX ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (H ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× ∣0,0,0,0,0,0,0⟩
≡  / √ 2 .* ∣0,0,0,0,0,0,0⟩  .+ / √ 2 .* ∣1,1,1,1,1,1,1⟩.
Proof.
Time operate_reduce.
Qed.

Lemma t8 :
(I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (CX ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (H ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× ∣0,0,0,0,0,0,0,0⟩
≡  / √ 2 .* ∣0,0,0,0,0,0,0,0⟩  .+ / √ 2 .* ∣1,1,1,1,1,1,1,1⟩.
Proof.
Time operate_reduce.
Qed.

Lemma t9 :
(I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (CX ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (H ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× ∣0,0,0,0,0,0,0,0,0⟩
≡  / √ 2 .* ∣0,0,0,0,0,0,0,0,0⟩  .+ / √ 2 .* ∣1,1,1,1,1,1,1,1,1⟩.
Proof.
Time operate_reduce.
Qed.

Lemma t10 :
(I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (CX ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (H ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× ∣0,0,0,0,0,0,0,0,0,0⟩
≡  / √ 2 .* ∣0,0,0,0,0,0,0,0,0,0⟩  .+ / √ 2 .* ∣1,1,1,1,1,1,1,1,1,1⟩.
Proof.
Time operate_reduce.
Qed.

Lemma t11 :
(I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (CX ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (H ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× ∣0,0,0,0,0,0,0,0,0,0,0⟩
≡  / √ 2 .* ∣0,0,0,0,0,0,0,0,0,0,0⟩  .+ / √ 2 .* ∣1,1,1,1,1,1,1,1,1,1,1⟩.
Proof.
Time operate_reduce.
Qed.

Lemma t12:
(I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (CX ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (H ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× ∣0,0,0,0,0,0,0,0,0,0,0,0⟩
≡  / √ 2 .* ∣0,0,0,0,0,0,0,0,0,0,0,0⟩  .+ / √ 2 .* ∣1,1,1,1,1,1,1,1,1,1,1,1⟩.
Proof.
Time operate_reduce.
Qed.

Lemma t13 :
(I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (CX ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (H ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× ∣0,0,0,0,0,0,0,0,0,0,0,0,0⟩
≡  / √ 2 .* ∣0,0,0,0,0,0,0,0,0,0,0,0,0⟩  .+ / √ 2 .* ∣1,1,1,1,1,1,1,1,1,1,1,1,1⟩.
Proof.
Time operate_reduce.
Qed.

Lemma t14 :
(I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (I_2 ⊗ TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (TOF ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (CX ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× (H ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2 ⊗ I_2)
× ∣0,0,0,0,0,0,0,0,0,0,0,0,0,0⟩
≡  / √ 2 .* ∣0,0,0,0,0,0,0,0,0,0,0,0,0,0⟩  .+ / √ 2 .* ∣1,1,1,1,1,1,1,1,1,1,1,1,1,1⟩.
Proof.
operate_reduce.
Qed.

Finished transaction in 40.489 secs (39.984u,0.171s) (successful)
Finished transaction in 75.822 secs (75.234u,0.093s) (successful)
Finished transaction in 146.741 secs (146.421u,0.062s) (successful)
Finished transaction in 253.366 secs (252.953u,0.078s) (successful)
Finished transaction in 408.839 secs (408.078u,0.187s) (successful)
Finished transaction in 602.075 secs (601.609u,0.265s) (successful)
Finished transaction in 959.732 secs (907.312u,0.171s) (successful)
Finished transaction in 1203.851 secs (1202.843u,0.64s) (successful)