(* Automatically Synthesized by Autosubst. Considered preliminaries **)
From Undecidability.HOU Require Import std.std.
From Undecidability.HOU Require Export unscoped.

Set Default Proof Using "Type".

Section Terms.

  Inductive type  : Type :=
  | typevar  : nat  -> type
  | arr  : type  -> type  -> type .

  Structure Const :=
  {
    const_type:> Type;
    const_dis: Dis const_type;
    ctype: const_type -> type
  }.

  Context {X: Const}.

Lemma congr_typevar  { s0 : nat  } { t0 : nat  } : s0 = t0 -> typevar s0 = typevar t0 .
Proof. congruence. Qed.

Lemma congr_arr  { s0 : type  } { s1 : type  } { t0 : type  } { t1 : type  } : s0 = t0 -> s1 = t1 -> arr s0 s1 = arr t0 t1 .
Proof. congruence. Qed.

Inductive exp  : Type :=
  | var_exp  : fin  -> exp
  | const  : X  -> exp
  | lam  : exp  -> exp
  | app  : exp  -> exp  -> exp .

Lemma congr_const  { s0 : X  } { t0 : X  } : s0 = t0 -> const  s0 = const  t0 .
Proof. congruence. Qed.

Lemma congr_lam  { s0 : exp  } { t0 : exp  } : s0 = t0 -> lam  s0 = lam  t0 .
Proof. congruence. Qed.

Lemma congr_app  { s0 : exp  } { s1 : exp  } { t0 : exp  } { t1 : exp  } : s0 = t0 -> s1 = t1 -> app  s0 s1 = app  t0 t1 .
Proof. congruence. Qed.

Definition upRen_exp_exp   (xi : fin  -> fin ) : _ :=
  up_ren xi.

Fixpoint ren_exp   (xiexp : fin  -> fin ) (s : exp ) : _ :=
    match s with
    | var_exp  s => (var_exp ) (xiexp s)
    | const  s0 => const  s0
    | lam  s0 => lam  (ren_exp (upRen_exp_exp xiexp) s0)
    | app  s0 s1 => app  (ren_exp xiexp s0) (ren_exp xiexp s1)
    end.

Definition up_exp_exp   (sigma : fin  -> exp ) : _ :=
  scons ((var_exp ) var_zero) (funcomp (ren_exp shift) sigma).

Fixpoint subst_exp   (sigmaexp : fin  -> exp ) (s : exp ) : _ :=
    match s with
    | var_exp  s => sigmaexp s
    | const  s0 => const  s0
    | lam  s0 => lam  (subst_exp (up_exp_exp sigmaexp) s0)
    | app  s0 s1 => app  (subst_exp sigmaexp s0) (subst_exp sigmaexp s1)
    end.

Definition upId_exp_exp  (sigma : fin  -> exp ) (Eq : forall x, sigma x = (var_exp ) x) : forall x, (up_exp_exp sigma) x = (var_exp ) x :=
  fun n => match n with
  | S n => ap (ren_exp shift) (Eq n)
  | 0 => eq_refl
  end.

Fixpoint idSubst_exp  (sigmaexp : fin  -> exp ) (Eqexp : forall x, sigmaexp x = (var_exp ) x) (s : exp ) : subst_exp sigmaexp s = s :=
    match s with
    | var_exp  s => Eqexp s
    | const  s0 => congr_const (eq_refl s0)
    | lam  s0 => congr_lam (idSubst_exp (up_exp_exp sigmaexp) (upId_exp_exp (_) Eqexp) s0)
    | app  s0 s1 => congr_app (idSubst_exp sigmaexp Eqexp s0) (idSubst_exp sigmaexp Eqexp s1)
    end.

Definition upExtRen_exp_exp   (xi : fin  -> fin ) (zeta : fin  -> fin ) (Eq : forall x, xi x = zeta x) : forall x, (upRen_exp_exp xi) x = (upRen_exp_exp zeta) x :=
  fun n => match n with
  | S n => ap shift (Eq n)
  | 0 => eq_refl
  end.

Fixpoint extRen_exp   (xiexp : fin  -> fin ) (zetaexp : fin  -> fin ) (Eqexp : forall x, xiexp x = zetaexp x) (s : exp ) : ren_exp xiexp s = ren_exp zetaexp s :=
    match s with
    | var_exp  s => ap (var_exp ) (Eqexp s)
    | const  s0 => congr_const (eq_refl s0)
    | lam  s0 => congr_lam (extRen_exp (upRen_exp_exp xiexp) (upRen_exp_exp zetaexp) (upExtRen_exp_exp (_) (_) Eqexp) s0)
    | app  s0 s1 => congr_app (extRen_exp xiexp zetaexp Eqexp s0) (extRen_exp xiexp zetaexp Eqexp s1)
    end.

Definition upExt_exp_exp   (sigma : fin  -> exp ) (tau : fin  -> exp ) (Eq : forall x, sigma x = tau x) : forall x, (up_exp_exp sigma) x = (up_exp_exp tau) x :=
  fun n => match n with
  | S n => ap (ren_exp shift) (Eq n)
  | 0 => eq_refl
  end.

Fixpoint ext_exp   (sigmaexp : fin  -> exp ) (tauexp : fin  -> exp ) (Eqexp : forall x, sigmaexp x = tauexp x) (s : exp ) : subst_exp sigmaexp s = subst_exp tauexp s :=
    match s with
    | var_exp  s => Eqexp s
    | const  s0 => congr_const (eq_refl s0)
    | lam  s0 => congr_lam (ext_exp (up_exp_exp sigmaexp) (up_exp_exp tauexp) (upExt_exp_exp (_) (_) Eqexp) s0)
    | app  s0 s1 => congr_app (ext_exp sigmaexp tauexp Eqexp s0) (ext_exp sigmaexp tauexp Eqexp s1)
    end.

Fixpoint compRenRen_exp    (xiexp : fin  -> fin ) (zetaexp : fin  -> fin ) (rhoexp : fin  -> fin ) (Eqexp : forall x, (funcomp zetaexp xiexp) x = rhoexp x) (s : exp ) : ren_exp zetaexp (ren_exp xiexp s) = ren_exp rhoexp s :=
    match s with
    | var_exp  s => ap (var_exp ) (Eqexp s)
    | const  s0 => congr_const (eq_refl s0)
    | lam  s0 => congr_lam (compRenRen_exp (upRen_exp_exp xiexp) (upRen_exp_exp zetaexp) (upRen_exp_exp rhoexp) (up_ren_ren (_) (_) (_) Eqexp) s0)
    | app  s0 s1 => congr_app (compRenRen_exp xiexp zetaexp rhoexp Eqexp s0) (compRenRen_exp xiexp zetaexp rhoexp Eqexp s1)
    end.

Definition up_ren_subst_exp_exp    (xi : fin  -> fin ) (tau : fin  -> exp ) (theta : fin  -> exp ) (Eq : forall x, (funcomp tau xi) x = theta x) : forall x, (funcomp (up_exp_exp tau) (upRen_exp_exp xi)) x = (up_exp_exp theta) x :=
  fun n => match n with
  | S n => ap (ren_exp shift) (Eq n)
  | 0 => eq_refl
  end.

Fixpoint compRenSubst_exp    (xiexp : fin  -> fin ) (tauexp : fin  -> exp ) (thetaexp : fin  -> exp ) (Eqexp : forall x, (funcomp tauexp xiexp) x = thetaexp x) (s : exp ) : subst_exp tauexp (ren_exp xiexp s) = subst_exp thetaexp s :=
    match s with
    | var_exp  s => Eqexp s
    | const  s0 => congr_const (eq_refl s0)
    | lam  s0 => congr_lam (compRenSubst_exp (upRen_exp_exp xiexp) (up_exp_exp tauexp) (up_exp_exp thetaexp) (up_ren_subst_exp_exp (_) (_) (_) Eqexp) s0)
    | app  s0 s1 => congr_app (compRenSubst_exp xiexp tauexp thetaexp Eqexp s0) (compRenSubst_exp xiexp tauexp thetaexp Eqexp s1)
    end.

Definition up_subst_ren_exp_exp    (sigma : fin  -> exp ) (zetaexp : fin  -> fin ) (theta : fin  -> exp ) (Eq : forall x, (funcomp (ren_exp zetaexp) sigma) x = theta x) : forall x, (funcomp (ren_exp (upRen_exp_exp zetaexp)) (up_exp_exp sigma)) x = (up_exp_exp theta) x :=
  fun n => match n with
  | S n => eq_trans (compRenRen_exp shift (upRen_exp_exp zetaexp) (funcomp shift zetaexp) (fun x => eq_refl) (sigma n)) (eq_trans (eq_sym (compRenRen_exp zetaexp shift (funcomp shift zetaexp) (fun x => eq_refl) (sigma n))) (ap (ren_exp shift) (Eq n)))
  | 0 => eq_refl
  end.

Fixpoint compSubstRen__exp    (sigmaexp : fin  -> exp ) (zetaexp : fin  -> fin ) (thetaexp : fin  -> exp ) (Eqexp : forall x, (funcomp (ren_exp zetaexp) sigmaexp) x = thetaexp x) (s : exp ) : ren_exp zetaexp (subst_exp sigmaexp s) = subst_exp thetaexp s :=
    match s with
    | var_exp  s => Eqexp s
    | const  s0 => congr_const (eq_refl s0)
    | lam  s0 => congr_lam (compSubstRen__exp (up_exp_exp sigmaexp) (upRen_exp_exp zetaexp) (up_exp_exp thetaexp) (up_subst_ren_exp_exp (_) (_) (_) Eqexp) s0)
    | app  s0 s1 => congr_app (compSubstRen__exp sigmaexp zetaexp thetaexp Eqexp s0) (compSubstRen__exp sigmaexp zetaexp thetaexp Eqexp s1)
    end.

Definition up_subst_subst_exp_exp    (sigma : fin  -> exp ) (tauexp : fin  -> exp ) (theta : fin  -> exp ) (Eq : forall x, (funcomp (subst_exp tauexp) sigma) x = theta x) : forall x, (funcomp (subst_exp (up_exp_exp tauexp)) (up_exp_exp sigma)) x = (up_exp_exp theta) x :=
  fun n => match n with
  | S n => eq_trans (compRenSubst_exp shift (up_exp_exp tauexp) (funcomp (up_exp_exp tauexp) shift) (fun x => eq_refl) (sigma n)) (eq_trans (eq_sym (compSubstRen__exp tauexp shift (funcomp (ren_exp shift) tauexp) (fun x => eq_refl) (sigma n))) (ap (ren_exp shift) (Eq n)))
  | 0 => eq_refl
  end.

Fixpoint compSubstSubst_exp    (sigmaexp : fin  -> exp ) (tauexp : fin  -> exp ) (thetaexp : fin  -> exp ) (Eqexp : forall x, (funcomp (subst_exp tauexp) sigmaexp) x = thetaexp x) (s : exp ) : subst_exp tauexp (subst_exp sigmaexp s) = subst_exp thetaexp s :=
    match s with
    | var_exp  s => Eqexp s
    | const  s0 => congr_const (eq_refl s0)
    | lam  s0 => congr_lam (compSubstSubst_exp (up_exp_exp sigmaexp) (up_exp_exp tauexp) (up_exp_exp thetaexp) (up_subst_subst_exp_exp (_) (_) (_) Eqexp) s0)
    | app  s0 s1 => congr_app (compSubstSubst_exp sigmaexp tauexp thetaexp Eqexp s0) (compSubstSubst_exp sigmaexp tauexp thetaexp Eqexp s1)
    end.

Definition rinstInst_up_exp_exp   (xi : fin  -> fin ) (sigma : fin  -> exp ) (Eq : forall x, (funcomp (var_exp ) xi) x = sigma x) : forall x, (funcomp (var_exp ) (upRen_exp_exp xi)) x = (up_exp_exp sigma) x :=
  fun n => match n with
  | S n => ap (ren_exp shift) (Eq n)
  | 0 => eq_refl
  end.

Fixpoint rinst_inst_exp   (xiexp : fin  -> fin ) (sigmaexp : fin  -> exp ) (Eqexp : forall x, (funcomp (var_exp ) xiexp) x = sigmaexp x) (s : exp ) : ren_exp xiexp s = subst_exp sigmaexp s :=
    match s with
    | var_exp  s => Eqexp s
    | const  s0 => congr_const (eq_refl s0)
    | lam  s0 => congr_lam (rinst_inst_exp (upRen_exp_exp xiexp) (up_exp_exp sigmaexp) (rinstInst_up_exp_exp (_) (_) Eqexp) s0)
    | app  s0 s1 => congr_app (rinst_inst_exp xiexp sigmaexp Eqexp s0) (rinst_inst_exp xiexp sigmaexp Eqexp s1)
    end.

Lemma instId_exp  : subst_exp (var_exp ) = id .
Proof. exact (FunctionalExtensionality.functional_extensionality _ _ (fun x => idSubst_exp (var_exp ) (fun n => eq_refl) (id x))). Qed.

Lemma varL_exp   (sigmaexp : fin  -> exp ) : funcomp (subst_exp sigmaexp) (var_exp ) = sigmaexp .
Proof. exact (FunctionalExtensionality.functional_extensionality _ _ (fun x => eq_refl)). Qed.

Lemma rinstInst_exp   (xiexp : fin  -> fin ) : ren_exp xiexp = subst_exp (funcomp (var_exp ) xiexp) .
Proof. exact (FunctionalExtensionality.functional_extensionality _ _ (fun x => rinst_inst_exp xiexp (_) (fun n => eq_refl) x)). Qed.

Lemma compComp_exp    (sigmaexp : fin  -> exp ) (tauexp : fin  -> exp ) (s : exp ) : subst_exp tauexp (subst_exp sigmaexp s) = subst_exp (funcomp (subst_exp tauexp) sigmaexp) s .
Proof. exact (compSubstSubst_exp sigmaexp tauexp (_) (fun n => eq_refl) s). Qed.

Lemma compComp'_exp    (sigmaexp : fin  -> exp ) (tauexp : fin  -> exp ) : funcomp (subst_exp tauexp) (subst_exp sigmaexp) = subst_exp (funcomp (subst_exp tauexp) sigmaexp) .
Proof. exact (FunctionalExtensionality.functional_extensionality _ _ (fun n => compComp_exp sigmaexp tauexp n)). Qed.

End Terms.

(* CUSTOM CHANGES *)
Definition beta {X} (s: exp) (t: exp) := @subst_exp X (t .: var_exp) s.
Global Hint Rewrite @instId_exp @rinstInst_exp @compComp_exp @compComp'_exp @varL_exp : asimpl.
#[export] Hint Unfold beta upRen_exp_exp up_exp_exp : asimpl.

Ltac asimpl := autounfold with asimpl; autorewrite with asimpl using (cbn [subst_exp ren_exp]; fsimpl).
Tactic Notation "asimpl" "in" hyp(J) :=
  autounfold with asimpl in J; autorewrite with asimpl in J using (cbn [subst_exp ren_exp] in J; fsimplin J).


From mathcomp Require Import all_ssreflect ssralg.

Section Tests.
Lemma test_orb (a b c d : bool) : (a || b) || (c || d) = (a || c) || (b || d).
Proof. time by rewrite orbACA. Restart.
Proof. time by rewrite (AC (2*2) ((1*3)*(2*4))). Restart.
Proof. time by rewrite orb.[AC (2*2) ((1*3)*(2*4))]. Qed.

Lemma test_addn (a b c d : nat) : a + b + c + d = a + c + b + d.
Proof. time by rewrite -addnA addnAC addnA addnAC. Restart.
Proof. time by rewrite (ACl (1*3*2*4)). Restart.
Proof. time by rewrite addn.[ACl 1*3*2*4]. Qed.

Lemma test_addr (R : comRingType) (a b c d : R) : (a + b + c + d = a + c + b + d)%R.
Proof. time by rewrite -GRing.addrA GRing.addrAC GRing.addrA GRing.addrAC. Restart.
Proof. time by rewrite (ACl (1*3*2*4)). Restart.
Proof. time by rewrite (@GRing.add R).[ACl 1*3*2*4]. Qed.

Local Open Scope ring_scope.
Import GRing.Theory.

Lemma test_mulr (R : comRingType) (x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 : R)
    (x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 : R) :
    (x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *
    (x10 * x11) * (x12 * x13) * (x14 * x15) * (x16 * x17 * x18 * x19) *
 (x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *
    (x10 * x11) * (x12 * x13) * (x14 * x15) * (x16 * x17 * x18 * x19) =
    (x0 * x2 * x4 * x9) * (x1 * x3 * x5 * x7) * x6 * x8 *
    (x10 * x12 * x14 * x19) * (x11 * x13 * x15 * x17) * x16 * x18 * (x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *
    (x10 * x11) * (x12 * x13) * (x14 * x15) * (x16 * x17 * x18 * x19)
   *(x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *
    (x10 * x11) * (x12 * x13) * (x14 * x15) * (x16 * x17 * x18 * x19) *
 (x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *(x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *
    (x10 * x11) * (x12 * x13) * (x14 * x15) * (x16 * x17 * x18 * x19) *
 (x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) * (x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *
    (x10 * x11) * (x12 * x13) * (x14 * x15) * (x16 * x17 * x18 * x19)
   *(x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *
    (x10 * x11) * (x12 * x13) * (x14 * x15) * (x16 * x17 * x18 * x19) *
 (x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *(x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *
    (x10 * x11) * (x12 * x13) * (x14 * x15) * (x16 * x17 * x18 * x19) *
 (x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) * (x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *
    (x10 * x11) * (x12 * x13) * (x14 * x15) * (x16 * x17 * x18 * x19)
   *(x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *
    (x10 * x11) * (x12 * x13) * (x14 * x15) * (x16 * x17 * x18 * x19) *
 (x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *(x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *
    (x10 * x11) * (x12 * x13) * (x14 * x15) * (x16 * x17 * x18 * x19) *
 (x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *
    (x10 * x11) * (x12 * x13) * (x14 * x15) * (x16 * x17 * x18 * x19) *
 (x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) * (x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *
    (x10 * x11) * (x12 * x13) * (x14 * x15) * (x16 * x17 * x18 * x19)
   *(x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *
    (x10 * x11) * (x12 * x13) * (x14 * x15) * (x16 * x17 * x18 * x19) *
 (x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *(x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *
    (x10 * x11) * (x12 * x13) * (x14 * x15) * (x16 * x17 * x18 * x19) *
 (x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) * (x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *
    (x10 * x11) * (x12 * x13) * (x14 * x15) * (x16 * x17 * x18 * x19)
   *(x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *
    (x10 * x11) * (x12 * x13) * (x14 * x15) * (x16 * x17 * x18 * x19) *
 (x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *(x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *
    (x10 * x11) * (x12 * x13) * (x14 * x15) * (x16 * x17 * x18 * x19) *
 (x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9)*
    (x10 * x11) * (x12 * x13) * (x14 * x15) * (x16 * x17 * x18 * x19) *
 (x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) * (x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *
    (x10 * x11) * (x12 * x13) * (x14 * x15) * (x16 * x17 * x18 * x19)
   *(x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *
    (x10 * x11) * (x12 * x13) * (x14 * x15) * (x16 * x17 * x18 * x19) *
 (x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *(x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *
    (x10 * x11) * (x12 * x13) * (x14 * x15) * (x16 * x17 * x18 * x19) *
 (x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) * (x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *
    (x10 * x11) * (x12 * x13) * (x14 * x15) * (x16 * x17 * x18 * x19)
   *(x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *
    (x10 * x11) * (x12 * x13) * (x14 * x15) * (x16 * x17 * x18 * x19) *
 (x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *(x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) *
    (x10 * x11) * (x12 * x13) * (x14 * x15) * (x16 * x17 * x18 * x19) *
 (x0 * x1) * (x2 * x3) * (x4 * x5) * (x6 * x7 * x8 * x9) .
Proof.
pose s := ((2 * 4 * 9 * 1 * 3 * 5 * 7 * 6 * 8 * 20 * 21 * 22 * 23) * 25 * 26 * 27 * 28
             * (29 * 30 * 31) * 32 * 33 * 34 * 35 * 36 * 37 *  38 * 39 * 40 * 41
             * (10 * 12 * 14 * 19 * 11 * 13 * 15 * 17 * 16 * 18 * 24)
                  * (42 * 43 * 44 * 45 * 46 * 47 *  48 * 49) * 50
                  * 52 * 53 * 54 * 55 * 56 * 57 *  58 * 59 * 51* 60
                  * 62 * 63 * 64 * 65 * 66 * 67 *  68 * 69 * 61* 70
                  * 72 * 73 * 74 * 75 * 76 * 77 *  78 * 79 * 71 * 80
                  * 82 * 83 * 84 * 85 * 86 * 87 *  88 * 89 * 81* 90
                  * 92 * 93 * 94 * 95 * 96 * 97 *  98 * 99 * 91 * 100 *
((102 * 104 * 109 * 101 * 103 * 105 * 107 * 106 * 108 * 120 * 121 * 122 * 123) * 125 * 126 * 127 * 128
             * (129 * 130 * 131) * 132 * 133 * 134 * 135 * 136 * 137 *  138 * 139 * 140 * 141
             * (110 * 112 * 114 * 119 * 111 * 113 * 115 * 117 * 116 * 118 * 124)
                  * (142 * 143 * 144 * 145 * 146 * 147 *  148 * 149) * 150
                  * 152 * 153 * 154 * 155 * 156 * 157 *  158 * 159 * 151* 160
                  * 162 * 163 * 164 * 165 * 166 * 167 *  168 * 169 * 161* 170
                  * 172 * 173 * 174 * 175 * 176 * 177 *  178 * 179 * 171 * 180
                  * 182 * 183 * 184 * 185 * 186 * 187 *  188 * 189 * 181* 190
                  * 192 * 193 * 194 * 195 * 196 * 197 *  198 * 199 * 191)

)%AC.
time have := (@GRing.mul R).[ACl s].
time rewrite (@GRing.mul R).[ACl s].
Abort.
End Tests.


(** * Homotopy PreCategory of Types *)
Require Import Category.Core.
Require Import HoTT.Basics HoTT.Truncations.

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

Local Open Scope path_scope.

Local Open Scope category_scope.

(** Quoting the HoTT Book:

    Example. There is a precategory whose type of objects is [U] and
    with [hom(X,Y) : ∥X → Y∥₀], and composition defined by induction
    on truncation from ordinary composition [(Y → Z) → (X → Y) → (X →
    Z)]. We call this the homotopy precategory of types. *)

(** We don't want access to all of the internals of this category at top level. *)
Module HomotopyPreCategoryInternals.
  Section homotopy_precategory.
    Local Notation object := Type (only parsing).
    Local Notation morphism s d := (Trunc 0 (s -> d)) (only parsing).

    Definition compose s d d' (m : morphism d d') (m' : morphism s d)
    : morphism s d'.
    Proof.
      revert m'; apply Trunc_rec; intro m'.
      revert m; apply Trunc_rec; intro m.
      apply tr.
      exact (m o m')%core.
    Defined.

    Definition identity x : morphism x x
      := tr idmap.

    Global Arguments compose [s d d'] m m' / .
    Global Arguments identity x / .
  End homotopy_precategory.
End HomotopyPreCategoryInternals.

(** ** The Homotopy PreCategory of Types *)
Definition homotopy_precategory : PreCategory.
Proof.
  refine (@Build_PreCategory
            Type
            _
            (@HomotopyPreCategoryInternals.identity)
            (@HomotopyPreCategoryInternals.compose)
            _
            _
            _
            _);
  simpl; intros;
  repeat match goal with
           | [ m : Trunc _ _ |- _ ]
             => revert m;
               apply Trunc_ind;
               [ intro;
                 match goal with
                   | [ |- IsHSet (?a = ?b :> ?T) ]
                     => generalize a b; intros;
                        let H := fresh in
                        assert (H : forall x y : T, IsHProp (x = y))
                 end;
                 typeclasses eauto
               | intro ]
         end;
  simpl;
  apply ap;
  exact idpath.
Defined.


Require Import LL.SL.FLL.Tactics.

Set Implicit Arguments.

(* Create HintDb LLBase.
 *)
Section FLLReasoning.
  Context `{OLS: OLSig}.

 Variable th : oo -> Prop.

 Lemma unRelease B M P:
 flls th B M (DW P) -> flls th B M (UP [P]).
 Proof with sauto;solveLL.
  intros.
  inversion H...
  all:LFocus.
Qed.

 Lemma select B M L P: positiveLFormula P ->
 flls th B M (UP (P::L)) -> flls th B (P::M) (UP L).
 Proof with sauto;solvePolarity;solveLL.
  intros.
  inversion H0...
Qed.

Lemma TensorCommN: forall n F G B M,
    (flln th n B M (DW (F ⊗ G))) -> (flln th n B M (DW (G ⊗ F))).
 Proof with sauto;solvePolarity;solveLL.
      intros.
      inversion H...
      FLLsplit N M0...
      rewrite H2...
 Qed.

Lemma TensorComm: forall F G B M,
    (flls th B M (DW (F ⊗ G))) -> (flls th B M (DW (G ⊗ F))).
 Proof with sauto;solvePolarity;solveLL.
      intros.
      inversion H...
      FLLsplit N M0...
      rewrite H2...
 Qed.

Lemma OplusCommN: forall n F G B M,
    (flln th n B M (DW (F ⊕ G))) -> (flln th n B M (DW (G ⊕ F))).
 Proof with sauto;solvePolarity;solveLL.
      intros.
      inversion H...
 Qed.

Lemma OplusComm: forall F G B M,
    (flls th B M (DW (F ⊕ G))) -> (flls th B M (DW (G ⊕ F))).
 Proof with sauto;solvePolarity;solveLL.
      intros.
      inversion H...
 Qed.

Lemma WithCommN: forall n F G B M L,
    flln th n B M (UP (F & G::L)) -> flln th n B M (UP (G & F::L)).
 Proof with sauto;solvePolarity;solveLL.
      intros.
      inversion H...
 Qed.

Lemma WithComm: forall F G B M L,
    flls th B M (UP (F & G::L)) -> flls th B M (UP (G & F::L)).
 Proof with sauto;solvePolarity;solveLL.
      intros.
      inversion H...
 Qed.

Lemma BangDistWith: forall F G B M,
    flls th B M (DW (! (F & G))) <-> flls th B M (DW (! F ⊗ ! G)).
 Proof with sauto;solvePolarity;solveLL.
    split;intros.
   *  inversion H...
       inversion H3...
       FLLsplit.
   *  inversion H...
       inversion H5...
       inversion H6...
 Qed.

  Example Tensor3 B L F: flls th B L (DW (F ⊗ Zero)) <-> flls th B L (DW Zero).
  Proof with sauto;solvePolarity.
    split;intros;
    inversion H...
    solveLL.
  Qed.

Theorem weakeningGenN (CC LC : list oo) CC' X n:
   flln th n CC LC X -> flln th n (CC'++ CC) LC X.
Proof.
      intro H.
      induction CC';simpl;auto.
      apply weakeningN;auto.
Qed.

Theorem weakeningGenN_rev (CC LC : list oo) CC' X n:
   flln th n CC LC X -> flln th n (CC++ CC') LC X.
Proof.
      intros.
      eapply exchangeCCN with (CC := CC' ++ CC);auto.
      apply Permutation_app_comm; auto.
      apply weakeningGenN;auto.
Qed.

Theorem weakening_swap (C LC : list oo) F G X:
   flls th (F::C) LC X -> flls th (F :: G:: C) LC X.
Proof with sauto;solveLL.
     intros.
      eapply exchangeCC.
     rewrite perm_swap;eauto.
     apply weakening;auto.
 Qed.

 Theorem weakening_middle (C1 C2 LC : list oo) F X:
   flls th (C1++ C2) LC X -> flls th (C1++F :: C2) LC X.
Proof.
      intros.
     eapply exchangeCC.
     rewrite <- Permutation_middle;eauto.
     apply weakening;auto.
Qed.

 Theorem weakening_last (C LC : list oo) F X:
   flls th C LC X -> flls th (C++[F]) LC X.
Proof.
      intros.
     eapply exchangeCC.
     rewrite <- Permutation_cons_append;eauto.
     apply weakening;auto.
Qed.

Theorem weakeningGen (CC LC : list oo) CC' X:
   flls th CC LC X -> flls th (CC' ++ CC) LC X.
Proof.
     intro H.
      induction CC';simpl;auto.
      apply weakening;auto.
Qed.

Theorem weakeningGen_rev (CC LC : list oo) CC' X:
   flls th CC LC X -> flls th (CC++CC') LC X.
Proof.
      intros.
      eapply exchangeCC with (CC := CC' ++ CC);auto.
      apply Permutation_app_comm; auto.
      apply weakeningGen;auto.
Qed.

Theorem weakeningHead (C1 C2 C1' C2' LC : list oo) X:
   flls th (C2++C2') LC X -> flls th ((C1++C2) ++ (C1'++C2')) LC X.
Proof.
     intro H.
     eapply exchangeCC with
     (CC:=(C2++C2') ++ (C1++C1')). perm.
     apply weakeningGen_rev;auto.
Qed.

Theorem weakeningTail (C1 C2 C1' C2' LC : list oo) X:
   flls th (C1++C1') LC X -> flls th ((C1++C2) ++ (C1'++C2')) LC X.
Proof.
     intro H.
     eapply exchangeCC with
     (CC:=(C2++C2') ++ (C1++C1')). perm.
     apply weakeningGen;auto.
Qed.

Lemma contraction : forall CC LC  F X ,
  flls th  (F :: F::CC) LC X -> flls th (F::CC) LC X.
Proof with sauto.
intros.
  apply contract with (F:=F)...
Qed.

Lemma contraction_middle : forall C1 C2 LC  F X ,
  flls th  (C1++F::F::C2) LC X -> flls th (C1++F::C2) LC X.
Proof with sauto.
intros.
  apply contract with (F:=F)...
  apply exchangeCC with (CC:= C1 ++ F :: F :: C2)...
Qed.

Lemma AbsorptionCSet : forall n C Gamma Delta X,
  flln th n (C++Gamma) (Delta++ C)  X ->
      flln th n (C ++ Gamma) Delta  X.
  Proof with sauto.
  induction C;simpl;intros...
  apply absorptionN.
  LLPerm (C ++ Gamma ++ [a]).
  eapply IHC.
  LLExact H...
  Qed.

    Lemma AbsorptionCSet' : forall  C Gamma Delta X,
  flls  th (C++Gamma) (Delta++ C)  X ->
      flls  th (C ++ Gamma) Delta  X.
  Proof with sauto.
  intros.
  apply seqtoSeqN in H...
  apply AbsorptionCSet in H...
  apply seqNtoSeq in H...
  Qed.

 Lemma AbsorptionCSet_rev : forall C Gamma Delta X,
  flls  th (Gamma++C) (Delta++C)  X ->
      flls  th (Gamma++C) Delta  X.
  Proof with sauto.
  intros.
  apply seqtoSeqN in H...
  LLPermH H1 (C++Gamma).
  eapply AbsorptionCSet in H...
  apply seqNtoSeq in H...
  LLPermH H1 (Gamma++C).
  auto.
  Qed.

 Lemma AbsorptionLSet : forall n C Gamma Delta X,
  flln th n (Gamma) (Delta++ C)  X ->
      flln th n (C ++ Gamma) Delta  X.
  Proof with sauto.
  induction C;simpl;intros...
  rewrite app_comm_cons.
  apply absorptionLN.
  apply IHC.

  LLExact H...
  Qed.

  Lemma AbsorptionLSet' : forall C Gamma Delta X,
  flls th (Gamma) (Delta++C)  X ->
      flls th (C ++ Gamma) Delta  X.
  Proof with sauto.
  intros.
  apply seqtoSeqN in H...
  apply AbsorptionLSet in H...
  apply seqNtoSeq in H...
  Qed.

(** Some inveribility lemmas *)

Theorem FocusAtom: forall n Gamma Delta A,
 (flln th n Gamma Delta (DW ((perp A ) ))) ->
    Delta = [ (atom A)] \/ (Delta = [] /\ In (atom A ) Gamma) .
 Proof with sauto.
      intros.
      inversion H ...
      inversion H1.
 Qed.

   Theorem FocusingClause : forall n B D A F,
     flln th n B D (DW ((perp A) ⊗ F)) ->
 (exists m N, n = S m /\ Permutation D ((atom A)::N) /\
                flln th m B N  (DW F)) \/
   (exists m, n = S m /\ In (atom A) B /\
                flln th m B D  (DW F)).
  Proof with sauto.
  intros.
  InvTriAll.
  - left.
    eexists. exists N...
  - right.
    eexists.
    split...  HProof.
 Qed.

  Lemma FocusingInitRuleU : forall h D A A' B,
      flln th h B D (DW ((perp A) ⊗ (perp A') ))  ->
      Permutation D ([atom A] ++ [atom A']) \/
      (D = [atom A] /\ In (atom A') B) \/
      (D = [atom A'] /\ In (atom A) B) \/
      (In (atom A) B /\ In (atom A') B /\ D = []).
  Proof with sauto.
    intros.
    InvTriAll.
    right. right.
    right...
    Qed.

   Theorem FocusingStruct : forall n D B A F,
   flln th n B D (DW ((perp A) ⊗ (? F))) ->
   (exists m N, n = S (S (S m)) /\  Permutation D ((atom A)::N) /\
                flln th m (B++[F]) N  (UP [] )) \/
    (exists m, n = S (S (S m))  /\ In (atom A) B /\

                flln th m (B++[F]) D  (UP [] )).
   Proof with sauto.
   intros.
   InvTriAll.
   left.
  exists n0. exists N...
  HProof. right.
  exists n0...
  HProof.
 Qed.

  Theorem FocusingPar :
    forall n A B D G,
    flln th n G D (DW ((atom A) ⅋ ( atom B))) ->
      exists m , n =  S (S(S(S m)))  /\
                 flln th m G (atom B::atom A::D) (UP []).
  Proof with sauto.
    intros.
    InvTriAll.
    eexists n.
    split;eauto.
  Qed.

  Theorem FocusingParPos :
    forall n A B D G, positiveLFormula A -> positiveLFormula B ->
    flln th n G D (DW (A ⅋ B)) ->
      exists m , n =  S (S(S(S m)))  /\
                 flln th m G (B::A::D) (UP []).
  Proof with sauto.
    intros.
    InvTriAll.
    inversion H5;solvePolarity.
    inversion H8;solvePolarity.
    eexists n.
    split;eauto.
  Qed.

  Theorem FocusingPlus:
    forall n A B D G ,
    flln th n G D (DW ( (atom A) ⊕ (atom B))) ->
     ( exists m , n = (S(S (S m)))  /\
                 (flln th m G (atom A ::D) (UP []) )) \/
    ( exists m , n = (S(S (S m)))  /\
                 flln th m G (atom B::D) (UP []) ).
  Proof with sauto.
    intros.
    InvTriAll.
    left.
    eexists n0.
    split;eauto.
    right.
    eexists n0.
    split;eauto.
  Qed.

  Theorem FocusingPlusPos:
    forall n A B D G ,
    flln th n G D (DW ( Bang (atom A) ⊕ Bang (atom B))) ->
     ( exists m , n = (S(S (S m)))  /\ D = [] /\
                 (flln th m G [atom A] (UP []) )) \/
    ( exists m , n = (S(S (S m)))  /\  D = [] /\
                 flln th m G [atom B] (UP []) ).
  Proof with sauto.
    intros.
    InvTriAll.
    left.
    eexists n0.
    split;eauto.
    right.
    eexists n0.
    split;eauto.
  Qed.

  Theorem FocusingWith :
    forall n A B D G,
      flln th n G D (DW ( (atom A) & (atom B))) ->
      exists m , n = S(S(S m))  /\
                 ( (flln th m G (atom A::D) (UP []) ) /\
                   (flln th m G (atom B::D) (UP []) )) .
  Proof with sauto.
    intros.
    InvTriAll.
    eexists n0.
    split;eauto.
  Qed.

  Theorem FocusingWithPos :
    forall n A B D G, positiveLFormula A -> positiveLFormula B ->
      flln th n G D (DW ( A & B)) ->
      exists m , n = S(S(S m))  /\
                 ( (flln th m G (A::D) (UP []) ) /\
                   (flln th m G (B::D) (UP []) )) .
  Proof with sauto.
    intros.
    InvTriAll.
    inversion H6;solvePolarity.
    inversion H9;solvePolarity.
    eexists n0.
    split;eauto.
  Qed.

  Theorem FocusingTensor :
    forall n A B D G,
      flln th n G D (DW ( (atom A) ⊗ (atom B))) ->
       exists m M N , n = S(S(S m))  /\ Permutation D (M++N) /\
                  ( flln th m G (atom A::M) (UP [])) /\
                  ( flln th m G (atom B::N) (UP [])).
   Proof with sauto.
    intros.
    InvTriAll.
    eexists n0.
    eexists M.
    eexists N.
    split;eauto.
   Qed.

  Theorem FocusingTensorPos :
    forall n A B D G,
      flln th n G D (DW ( Bang (atom A) ⊗ (atom B))) ->
       exists m , n = S(S(S m))  /\
                  ( flln th m G [atom A] (UP [])) /\
                  ( flln th m G (atom B::D) (UP [])).
   Proof with sauto.
    intros.
    InvTriAll.
    eexists n0.
    split;eauto.
split;eauto. rewrite H2...
   Qed.

   Theorem FocusingClauseL : forall B D A F,
     flls th B D (DW F) -> flls th B  (atom A::D) (DW ((perp A) ⊗ F)).
   Proof with sauto.
   intros.
   FLLsplit [atom A] D.
   Qed.

 Theorem FocusingClauseL' : forall B D D' A F,
   Permutation D (atom A::D') -> flls th B D' (DW F) -> flls th B  D (DW ((perp A) ⊗ F)).
   Proof with auto using FocusingClauseL.
   intros.
   rewrite H...
  Qed.

   Theorem FocusingClauseC : forall B D A F,
   In (atom A) B ->  flls th B D (DW F) -> flls th B  D (DW ((perp A) ⊗ F)).
   Proof with sauto.
   intros.
   rewrite <- (app_nil_l D).
   FLLsplit (nil (A:=oo)) D.
   Qed.

End FLLReasoning.


Require Import init.

Require Export set_base.
Require Export set_type.

(** To use a quotient, what you need to know is this:
- To define a quotient, make a value of type [equivalence U] (which we'll call
  [E]).  Then the quotient is [equiv_type E].
- To define an operation on a quotient, you need to prove it's well defined and
  then use either [unary_op] or [binary_op].  More complicated functions can be
  built from these as well.  For example, to convert a function [A → B → C] to
  [A → equiv_type B → C], you can use the old "fix an [a : A] and consider it a
  function [B → C]" trick.
- To pick a value from an equivalence class, use the tactic
  [equiv_get_value] on each equivalence class.  (To do it manually, use
  [from_equiv].)
- If you have operations you defined on equivalence classes and you need to
  prove something about them, use [equiv_get_value] to pick values from all
  relevant equivalence classes then use the [equiv_simpl] tactic.  It will
  use all of your proofs that things are well-defined automatically to
  simplify down to proving things just for the particular values from your
  equivalence classes.
*)

#[universes(template)]
Record equivalence U := make_equiv {
    eq_equal : U → U → Prop;
    eq_reflexive : Reflexive eq_equal;
    eq_symmetric : Symmetric eq_equal;
    eq_transitive : Transitive eq_equal;
}.
Arguments make_equiv {U}.
Arguments eq_equal {U}.
Arguments eq_reflexive {U}.
Arguments eq_symmetric {U}.
Arguments eq_transitive {U}.
Ltac unpack_equiv E :=
    pose proof (eq_reflexive E);
    pose proof (eq_symmetric E);
    pose proof (eq_transitive E).

Section Equivalence.

(** There are a few issues that must be understood before messing with the
details of this implementation of quotients:
- There can be loads of universe consistency issues if you don't define these
  things just right.  This is why [equiv_type] is actually a notation, not a
  definition.
- It is important that the definitions of [unary_op] and [binary_op] are
  completely opaque: If you try to give them their actual definitions, various
  theorems will accidentally look inside the definitions when you don't want to.
  For a concrete example, consider a term of the type [unary_op f_wd (unary_op
  f_wd (to_equiv E a))].  When simplifying, we would want to use unary_op_eq
  twice, once to convert it to [unary_op f_wd (f a)], and the second to convert
  it to [f (f a)].  However, if the unary operation was defined using [to_equiv]
  (as many of them are), then Coq would see that the term is [unary_op f_wd
  (to_equiv ...)] and would then use the first [unary_op_eq] rewrite to rewrite
  the first instance of [unary_op] rather than the second.  Because of this, the
  definitions of [unary_op] and [binary_op] are opaque.
*)

Context {U} (E : equivalence U).
Local Infix "~" := (eq_equal E).

Definition equiv_class (a : U) := λ x, a ~ x.
Definition equiv_set := λ S, ∃ x, equiv_class x = S.
Local Notation "'equiv_type'" := (set_type equiv_set).

Theorem equiv_ex : ∃ (ι : U → equiv_type),
    (∀ a b, ι a = ι b ↔ a ~ b) ∧
    (∀ A, ∃ a, ι a = A) ∧
    (∀ V (f : U → V),
    (∀ a b, a ~ b → f a = f b) → ∃ f' : equiv_type → V, ∀ x, f' (ι x) = f x).
Proof.
    unpack_equiv E.
    exists (λ x, [equiv_class x | ex_intro _ _ Logic.eq_refl]).
    assert (∀ a b, equiv_class a = equiv_class b → a ~ b) as lem.
    {
        intros a b eq.
        unfold equiv_class in eq.
        pose proof (func_eq _ _ eq) as eq2; cbn in eq2.
        rewrite (eq2 b).
        apply refl.
    }
    split; [>|split].
    -   intros a b.
        rewrite set_type_eq2.
        split; [>apply lem|].
        intros ab.
        apply predicate_ext.
        intros x.
        unfold equiv_class.
        split; intros eq.
        +   apply sym in ab.
            exact (trans ab eq).
        +   exact (trans ab eq).
    -   intros [A [x A_eq]].
        exists x.
        rewrite set_type_eq2.
        exact A_eq.
    -   intros V f f_wd.
        exists (λ (X : set_type equiv_set), f (ex_val [|X])).
        intros x.
        cbn.
        rewrite_ex_val y eq.
        apply f_wd.
        apply lem.
        exact eq.
Qed.

Definition to_equiv := ex_val equiv_ex : U → equiv_type.

Theorem equiv_eq : ∀ a b, (to_equiv a = to_equiv b) ↔ (a ~ b).
Proof.
    apply (ex_proof equiv_ex).
Qed.

Theorem to_equiv_ex : ∀ A, ∃ a, to_equiv a = A.
Proof.
    apply (ex_proof equiv_ex).
Qed.

Theorem unary_op_ex : ∀ V (f : U → V),
    (∀ a b, a ~ b → f a = f b) →
    ∃ f' : equiv_type → V, ∀ x, f' (to_equiv x) = f x.
Proof.
    apply (ex_proof equiv_ex).
Qed.

Definition unary_op {V} {f : U → V} (wd : ∀ a b, a ~ b → f a = f b)
    : equiv_type → V
    := ex_val (unary_op_ex V f wd).

Theorem unary_op_eq : ∀ {V} {f : U → V} {wd : ∀ a b, a ~ b → f a = f b},
    ∀ a, unary_op wd (to_equiv a) = f a.
Proof.
    intros V f wd.
    exact (ex_proof (unary_op_ex V f wd)).
Qed.

Definition from_equiv (A : equiv_type) := ex_val (to_equiv_ex A).

Theorem from_equiv_eq : ∀ A, to_equiv (from_equiv A) = A.
Proof.
    intros A.
    exact (ex_proof (to_equiv_ex A)).
Qed.

Theorem binary_op_ex : ∀ {V} {f : U → U → V}
    (wd : ∀ a b c d, a ~ b → c ~ d → f a c = f b d),
    ∃ f' : equiv_type → equiv_type → V,
    ∀ a b, f' (to_equiv a) (to_equiv b) = f a b.
Proof.
    intros V f f_wd.
    assert (∀ a b c, b ~ c → f a b = f a c) as wd1.
    {
        intros a b c.
        apply f_wd.
        apply eq_reflexive.
    }
    pose (f1 a := unary_op (wd1 a)).
    assert (∀ a b, a ~ b → f1 a = f1 b) as wd2.
    {
        intros a b ab.
        unfold f1.
        apply functional_ext.
        intros C.
        destruct (to_equiv_ex C) as [c C_eq]; subst C.
        do 2 rewrite unary_op_eq.
        apply f_wd.
        -   exact ab.
        -   apply eq_reflexive.
    }
    exists (unary_op wd2).
    intros a b.
    rewrite unary_op_eq.
    unfold f1.
    apply unary_op_eq.
Qed.

Definition binary_op {V} {f : U → U → V}
    (wd : ∀ a b c d, a ~ b → c ~ d → f a c = f b d)
    : equiv_type → equiv_type → V
    := ex_val (binary_op_ex wd).

Theorem binary_op_eq : ∀ {V} {f : U → U → V}
    {wd : ∀ a b c d, a ~ b → c ~ d → f a c = f b d},
    ∀ a b, binary_op wd (to_equiv a) (to_equiv b) = f a b.
Proof.
    intros V f wd.
    exact (ex_proof (binary_op_ex wd)).
Qed.

Theorem unary_self_wd : ∀ {f : U → U},
    (∀ a b, a ~ b → f a ~ f b) →
    ∀ a b, a ~ b → to_equiv (f a) = to_equiv (f b).
Proof.
    intros f f_wd a b ab.
    rewrite equiv_eq.
    apply f_wd; assumption.
Qed.

Theorem binary_self_wd : ∀ {f : U → U → U},
    (∀ a b c d, a ~ b → c ~ d → f a c ~ f b d) →
    ∀ a b c d, a ~ b → c ~ d → to_equiv (f a c) = to_equiv (f b d).
Proof.
    intros f f_wd a b c d ab cd.
    rewrite equiv_eq.
    apply f_wd; assumption.
Qed.

End Equivalence.

Notation "'equiv_type' E" := (set_type (equiv_set E)) (at level 10).
Arguments unary_op {U E V f}.
Arguments to_equiv_ex {U E}.
Arguments from_equiv {U E}.
Arguments equiv_eq {U E}.
Arguments binary_op {U E V f}.
Arguments unary_op_eq {U E V f wd}.
Arguments binary_op_eq {U E V f wd}.
Arguments unary_self_wd {U E f}.
Arguments binary_self_wd {U E f}.

Ltac equiv_get_value_single a := let a' := fresh in let a'_eq := fresh in
    destruct (ex_to_type (to_equiv_ex a)) as [a' a'_eq];
    subst a;
    rename a' into a.
Tactic Notation "equiv_get_value" constr(a) :=
    equiv_get_value_single a.
Tactic Notation "equiv_get_value" constr(a) constr(b) :=
    equiv_get_value a;
    equiv_get_value b.
Tactic Notation "equiv_get_value" constr(a) constr(b) constr(c) :=
    equiv_get_value a b;
    equiv_get_value c.
Tactic Notation "equiv_get_value" constr(a) constr(b) constr(c) constr(d) :=
    equiv_get_value a b c;
    equiv_get_value d.
Tactic Notation "equiv_get_value" constr(a) constr(b) constr(c) constr(d) constr(e) :=
    equiv_get_value a b c d;
    equiv_get_value e.
Tactic Notation "equiv_get_value" constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) :=
    equiv_get_value a b c d e;
    equiv_get_value f.
Ltac equiv_simpl :=
    cbn;
    repeat (rewrite binary_op_eq + rewrite unary_op_eq);
    repeat rewrite equiv_eq;
    cbn.
Tactic Notation "equiv_simpl" "in" ident(H) :=
    cbn in H;
    repeat (rewrite binary_op_eq in H + rewrite unary_op_eq in H);
    repeat rewrite equiv_eq in H;
    cbn in H.


From iris.base_logic.lib Require Import invariants.
From iris.program_logic Require Export weakestpre.
From iris.program_logic Require Import adequacy.
From iris.heap_lang Require Import notation lang proofmode.
From iris.heap_lang.lib Require Import par.

Definition incr2 : val :=
  rec: "loop" "l" :=
    (("l" <- !"l" + #2) ||| ("l" <- !"l" + #2)) ;;
    "loop" "l".

Open Scope Z.

Lemma Zeven_add_2 n : Z.even n -> Z.even (n + 2).
Proof.
  rewrite (ltac:(lia): n + 2 = Z.succ (Z.succ n))
          Z.even_succ_succ //.
Qed.

Section S.
  Context `{!heapG Σ} `{!spawnG Σ} (N : namespace).

  Lemma incr2_spec (ℓ: loc) :
    {{{ inv N (∃ (x:Z), ℓ ↦ #x ∗ ⌜Z.even x⌝)%I }}}
      incr2 #ℓ
    {{{ RET #(); True }}}.
  Proof.
    iIntros (φ) "#Hi Hφ". iLöb as "IH".
    wp_lam. wp_bind (_ ||| _)%E. wp_pures.
    (* specification for the two threads *)
    iAssert (WP #ℓ <- ! #ℓ + #2 {{ _, True }})%I with "[Hi]" as "#Ht".
    { wp_bind (!#ℓ)%E. iInv N as (x) ">[Hℓ %]" "Hclose". wp_load.
      iMod ("Hclose" with "[Hℓ]"). now eauto.
      iModIntro. wp_pures.
      iInv N as (x') ">[Hℓ %]" "Hclose". wp_store.
      iMod ("Hclose" with "[Hℓ]"); eauto.
      iNext. iExists (x+2). iFrame. eauto using Zeven_add_2. }
    iApply (wp_par (fun _ => ⌜True⌝)%I (fun _ => ⌜True⌝)%I);
      [ iApply "Ht" .. |].
    iIntros. iNext. wp_pures. iApply "IH". eauto.
  Qed.
End S.

Class heapPreG Σ := HeapPreG {
  heap_preG_iris :> invPreG Σ;
  heap_preG_heap :> gen_heapPreG loc (option val) Σ;
  heap_preG_inv_heap :> inv_heapPreG loc (option val) Σ;
  heap_preG_proph :> proph_mapPreG proph_id (val * val) Σ;
}.

Section S.
  Context (N: namespace).
  Context `{!spawnG Σ}.
  Context `{heapPreG Σ}.

  Lemma invariant_adequacy :
    forall (ℓ : loc) (σ1 σ2 : state) (es: list expr),
      let φ := (fun (σ: state) => ∃ (x:Z),
                  heap σ !! ℓ = Some (Some (#x)) ∧ Z.even x) in
      rtc erased_step ([incr2 #ℓ], σ1) (es, σ2) →
      φ σ1 →
      φ σ2.
  Proof.
    intros * Hstep Hσ1.
    pose proof (@incr2_spec Σ) as S.

    pose proof (wp_invariance Σ heap_lang NotStuck) as L. cbn in L.
    specialize (L (incr2 #ℓ) σ1 es σ2 (φ σ2)).
    eapply L; eauto. intros Hinv κs. clear L.

    (* Allocate heap resources corresponding to (heap σ1) *)
    iMod (gen_heap_init (delete ℓ (heap σ1))) as (Hheap) "Hσ1".
    (* Also allocate the prophecy-related resources, that appear in the standard
       state interpretation in heapG_irisG (this is needed for things to match
       later on). *)
    iMod (proph_map_init κs (used_proph_id σ1)) as (Hproph) "Hpr1".
    iMod (inv_heap_init loc (option val)) as (Hi) ">Hi1".
    (* /!\ do not use 'pose proof', as [heapG_invG HeapΣ] needs to
       stay convertible to Hinv for things to typecheck later on. *)
    set (HeapΣ := HeapG Σ Hinv Hheap Hi Hproph).

    (* Add ℓ back to the heap, so that we get a corresponding points-to *)
    destruct Hσ1 as [v1 [Hσ1 E1]].
    iMod (gen_heap_alloc (delete ℓ (heap σ1)) ℓ (Some #v1) with "Hσ1")
      as "(Hσ1 & Hℓ & ?)".
    by rewrite lookup_delete.

    (* Allocate the same invariant as in [incr2_spec], so that we can feed it to
       [S] *)
    iPoseProof (@inv_alloc Σ Hinv N ⊤
      (∃ (x:Z), ℓ ↦ #x ∗ ⌜Z.even x⌝)%I with "[Hℓ]") as ">#HI".
    by iExists v1; eauto.

    rewrite insert_delete insert_id //.
    specialize (S HeapΣ spawnG0 N ℓ (fun _ => True%I)).
    iPoseProof (S with "HI") as "S".

    iModIntro.

    (* /!\ this has to match exactly the state_interp of heapG_irisG *)
    iExists (fun σ 𝜅s _ =>
      gen_heap_ctx (heap σ) ∗ proph_map_ctx 𝜅s (used_proph_id σ))%I.
    iExists (fun _ => True%I).
    iSplitL "Hσ1 Hpr1"; [ by iFrame |].
    iSplitL "S". by iApply "S".
    iIntros "[Hheap ?]". iExists (⊤ ∖ ↑N).
    iInv N as (x) ">[Hℓ %]" "Hclose".
    iDestruct (gen_heap_valid with "Hheap Hℓ") as "%".
    iModIntro. iPureIntro. unfold φ. eauto.
  Qed.
End S.

Theorem invariant_adequacy' (ℓ : loc) (σ1 σ2 : state) (es: list expr) :
    let φ := (fun (σ: state) =>
              ∃ (x:Z), heap σ !! ℓ = Some (Some (#x)) ∧ Z.even x) in
    φ σ1 →
    rtc erased_step ([incr2 #ℓ], σ1) (es, σ2) →
    φ σ2.
Proof.
  set (Σ := #[invΣ; gen_heapΣ loc (option val); inv_heapΣ loc (option val); proph_mapΣ proph_id (val * val); spawnΣ]).
  set (HG := HeapPreG Σ _ _ _ _).
  intros. eapply (@invariant_adequacy nroot Σ); eauto.
  typeclasses eauto.
Qed.


Require Import HoTT.
Require Import UnivalenceAxiom.
Load stuff.

(* Another notation for pointed maps *)
Notation "X ->* Y" := (pMap (Build_pType X _) (Build_pType Y _)).
Infix "o*" := pmap_compose.
Definition add_pt : Type -> pType :=
  fun X => Build_pType (X + Unit) (inr tt).

(* Definition psusp_rec_beta_unit {X Y : pType} (p : X ->* loops Y) : *)
(*   forall x : X, loops_functor ((loop_susp_adjoint X Y)^-1 p) (loop_susp_unit X x) = p x. *)
(* Proof. *)
(*   intro x. cbn. *)
(*   refine (concat_1p _ @ _). refine (concat_p1 _ @ _). *)

(*   transitivity (ap (Susp_rec North North p *)
(*   refine (ap_compose (Susp_rec North South (fun x1 : X => merid (p x1))) *)
(*                      (Susp_rec (point Y) (point Y) idmap) (merid x @ (merid (point X))^)  @ _). *)

(*   refine (ap_pp *)
(*             (fun x0 : Susp X => Susp_rec (point Y) (point Y) idmap *)
(*                                          (Susp_rec North South (fun x1 : X => merid (p x1)) x0)) *)
(*             (merid x) *)
(*             (merid (point X))^ @ _). *)
(*   transitivity (p x @ 1). *)
(*   apply concat2. *)
(*   - refine (Susp_rec_beta_merid x @ _). *)

(*     loops_functor ( H_S p) (loop_susp_unit X x) = p x @ (p (point X))^. *)
(* Proof. *)

Definition psusp_rec {X Y : pType} (p : X -> loops Y) :
  psusp X ->* Y
    :=  Build_pMap (psusp X) Y (Susp_rec (point Y) (point Y) p) idpath.

(* Make another less intuitive version which is easier to work with *)
Definition psusp_rec' {X Y : pType} (H_S : Y) (p : X -> point Y = H_S) :
  psusp X ->* Y
  := Build_pMap (psusp X) Y (Susp_rec (point Y) H_S p) idpath.

Definition psusp_rec_beta_unit {X Y : pType} (p : X ->* loops Y) :
  forall x : X, loops_functor (psusp_rec p) (loop_susp_unit X x) = p x.
Proof.
  intro x. refine (concat_1p _ @ _). simpl. refine (concat_p1 _ @ _).
  refine (ap_pp (Susp_rec (point Y) (point Y) p) (merid x) (merid (point X))^ @ _).
  refine (_ @ concat_p1 _).
  apply concat2.
  - apply Susp_rec_beta_merid.
  - refine (ap_V _ _ @ _).
    apply (ap inverse (y:=idpath)).
    refine (_ @ point_eq p).
    apply Susp_rec_beta_merid.
Defined.

Definition psusp_rec_beta_unit' {X Y : pType} (H_S : Y) (p : X -> point Y = H_S) :
  forall x : X, loops_functor (psusp_rec' H_S p) (loop_susp_unit X x) = p x @ (p (point X))^.
Proof.
  intro x. cbn.
  refine (concat_1p _ @ _). refine (concat_p1 _ @ _).
  refine (ap_pp (Susp_rec (point Y) (point Y) p) (merid x) (merid (point X))^ @ _).
  apply concat2.
  - apply Susp_rec_beta_merid.
  - refine (ap_V _ _ @ _).
    apply (ap inverse).
    apply Susp_rec_beta_merid.
Defined.

(* (* This "psusp_rec" should be the same as the inverse in the adjointness proof *) *)
(* Definition eq_psusp_rec_adjoint_inverse {X Y : pType} (p : X ->* loops Y) : *)
(*   (loop_susp_adjoint X Y)^-1 p = psusp_rec p. *)
(* Proof. *)
(*   cbn. *)
(*   apply path_pmap. *)
(*   srapply @Build_pHomotopy. *)
(*   - srapply @Susp_ind; try reflexivity. *)
(*     intro x. refine (transport_paths_FlFr _ _ @ _). rewrite concat_p1. *)
(*     apply moveR_Vp. rewrite concat_p1. *)
(*     unfold psusp_rec. cbn. *)
(*     refine (Susp_rec_beta_merid x @ _). *)

(* Global Instance ispointed_ptype : IsPointed pType := Build_pType Unit _. *)

(* Definition psusp_ind {X : pType} (P : psusp X -> pType) (H_S : P South) : *)
(*   (forall x : X, transport P (merid x) (point (P North)) = H_S) -> forall y : psusp X, P y. *)
(* Proof. *)
(*   intro merid'. *)
(*   srapply @Susp_ind. *)
(*   - exact (point (P North)). *)
(*   - exact H_S. *)
(*   - exact merid'. *)
(* Defined. *)

Definition pconst (X Y : pType) : X ->* Y :=
  Build_pMap X Y (const (point Y)) idpath.

Definition loops_functor_pp {X Y : pType} (f : X ->*Y ) (p q : loops X) :
  loops_functor f (p @ q) = loops_functor f p @ loops_functor f q.
Proof.
  destruct X as [X x0]. destruct Y as [Y y0].
  destruct f as [f ispointed_f].
  cbn in *. destruct ispointed_f.
  cut (forall (x1 x2 : X) (p' : x0 = x1) (q' : x1 = x2),
              1^ @ (ap f (p' @  q') @ 1) = (1^ @ (ap f p' @ 1)) @ (1^ @ (ap f q' @ 1))).
  intro H. apply H. destruct p', q'. reflexivity.
Defined.

Definition loops_functor_V {X Y : pType} (f : X ->* Y) (p : loops X) :
  loops_functor f p^ = (loops_functor f p)^.
Proof.
  destruct X as [X x0]. destruct Y as [Y y0].
  destruct f as [f ispointed_f].
  cbn in *. destruct ispointed_f.
  cut (forall (x1 : X) (p' : x0 = x1),
          1^ @ (ap f p'^ @ 1) = (1^ @ (ap f p' @ 1))^).
  intro H. apply H. destruct p'. reflexivity.
Defined.

(* Fixpoint iterated_prod (A : Type) (m : nat) : Type := *)
(*   match m with *)
(*     | O => Unit (* A^0 := 1 *) *)
(*     | m.+1 => (iterated_prod A m) * A (* A^m+1 := A^m * A *) *)
(*   end. *)

(* Fixpoint iterated_concat {A : Type} {a0 : A} {m : nat} : iterated_prod (a0 = a0) m -> a0 = a0 := *)
(*   match m with *)
(*     | O => const idpath       (*  *) *)
(*     | m.+1 => fun p => match p with *)
(*                          (prod, p) => iterated_concat prod @ p *)
(*                        end *)
(*   end. *)

(* Fixpoint iterated_concat {X : pType} (l : list (loops X)) : loops X := *)
(*   match l with *)
(*   | nil => idpath *)
(*   | cons p l => p @ iterated_concat l *)
(*   end. *)

(* Fixpoint functor_list {X Y : Type} (f : X -> Y) (l : list X) : list Y := *)
(*   match l with *)
(*     | nil => nil *)
(*     | cons x l => cons (f x) (functor_list f l) *)
(*   end. *)

(* (* Fixpoint iterated_eComp {A : Type} (l : list (A <~> A)) : A <~> A := *) *)
(* (*   match l with *) *)
(* (*     | nil => equiv_idmap *) *)
(* (*     | cons e l => iterated_eComp l oE e *) *)
(* (*   end. *) *)

(* Definition functor_iterated_concat {X Y : pType} (f : pMap X Y) (l : list (loops X)) : *)
(*   loops_functor f (iterated_concat l) = iterated_concat (functor_list (loops_functor f) l). *)
(* Proof. *)
(*   induction l. *)
(*   - simpl. apply moveR_Vp. exact (concat_1p _ @ (concat_p1 _)^). *)
(*   - simpl. pointed_reduce. *)
(*     rename ispointed_type0 into a0. *)
(*     apply ap_pp. *)
(* Defined. *)

Section Plus_Construction.
  (* Assume that B is a pointed 1-type with perfect loop space *)
  (* This type does probably not exist, but we do this simplification for now. Refinement: the loop space contains a perfect subgroup *)
  Context {B : pType}.
  Context `{IsTrunc 1 B}.
  (* Want: P is a perfect subgroup of loops B *)
  (* Do for now: P is the whole of B *)
  Definition P := loops B.

  (* Context {isinP : loops B -> hProp}. *)
  (* Definition P := {b : loops B & isinP b}. Definition PtolB : P -> loops B := pr1. *)
  (* Coercion PtolB : P >-> pointed_type. *)
  (* Todo: Formulate how P is a subgroup of B. *)

  (* Context {P : pType}. *)
  (* Context {i : P -> loops B}. *)

  (* Context {inj_i : forall a b : P, i a = i b -> a = b}. *)
  (* Context {id_i : forall a b : P, i *)
  (* Context {supgroup_P : forall a b : P, exists c : P, i a @ i b = i c}. *)
  Context {perfect : forall alpha : P, exists s t : P, alpha = s^ @ t^ @ s @ t}.
  Variable perfect_1 : (idpath; (idpath; idpath)) = perfect idpath.

  (* Definition hprop_perfect : forall alpha : P, IsHProp (exists s t : P, alpha = s^ @ t^ @ s @ t). *)
  (* Proof. *)
  (*   intro alpha. *)
  (*   cut (IsHProp {st : P * P & alpha = (fst st)^ @ (snd st)^ @ (fst st) @ (snd st)}). *)
  (*   { apply trunc_equiv'. *)
  (*     (* Easier to prove directly. . . *) *)
  (*     srapply @equiv_adjointify. *)
  (*     - intros [[s t] p]. exact (s ; (t; p)). *)
  (*     - intros [s [t p]]. exact ((s,t);p). *)
  (*     - intros [s [t p]]. reflexivity. *)
  (*     - intros [[s t] p]. reflexivity. } *)
  (*   apply trunc_sigma'. *)
  (*   - intro a. apply (H (point B) (point B) alpha). *)
  (*   - intros [[s1 t1] p1]. intros [[s2 t2] p2]. cbn. *)
  (*     cut (Contr ((s1 = s2) * (t1 = t2))). *)
  (*     { apply trunc_equiv'. apply (equiv_path_prod (s1, t1) (s2, t2)). }       *)
  (*     apply contr_inhabited_hprop. *)
  (*     { apply (trunc_prod (n := -1)). } *)
  (*     apply pair. *)
  (*     + simpl in *. *)

  (*     +  *)

  (*   apply trunc_sigma'. *)

  (* Context (alpha : loops B). *)
  (* (* Perfect implies that there are elements s,t such that alpha = s@t@s^@t^ *) *)
  (* Variables s t : loops B. *)
  (* Context (perfect : alpha = s @ t @ s^ @ t^). *)
  (* (* Aut E is normally generated by alpha, so s and t are products of conjugates of alpha *) *)
  (* Variables s_list t_list : list (loops B). *)
  (* Context (normally_generated_s : s = iterated_concat (functor_list (fun p : loops B => p^ @ alpha @ p) s_list)). *)
  (* Context (normally_generated_t : t = iterated_concat (functor_list (fun p : loops B => p^ @ alpha @ p) t_list)). *)

  (* Now we should be able to define the plus construction in two steps. *)
  (* 1: Kill all alpha in BAut E *)
  (* 2: Find the correct 2-spheres in this type, and kill them *)

  (* (* The map E <~> E -> loops (BAut E) *) *)
  (* Definition loops_baut : E <~> E -> loops (Build_pType (BAut E) _). *)
  (* Proof. *)
  (*   intro e. apply path_baut. exact e. *)
  (* Defined.   *)

  (* Definition pconst (A B : pType) : pMap A B := *)
  (*   Build_pMap A B (const (point B)) idpath. *)

  (* X1 should be the pushout wedge (alpha : loops B) S1, but that corresponds to Susp ((loops B)_+) *)
  (* Don't need the extra point, as that only adds a path 1 = 1 *)
  Definition susp_P_to_B : psusp (P) ->* B.
  Proof.
    apply (psusp_rec' (point B)). exact (pmap_idmap P).
    (* exact (pmap_compose (loop_susp_counit B) (psusp_functor (pmap_idmap P))). *)
    (* Change this when P is properly defined *)
  Defined.

  (* Global Instance ispointed_S1 : IsPointed S1 := base. *)
  (* (* First the map S1 -> B corresponding to alpha *) *)
  (* Definition alpha_map : S1 ->* B. *)
  (* Proof. *)
  (*   srapply @Build_pMap. *)
  (*   - srapply @S1_rec. *)
  (*     (* Basepoint goes to basepoint *) *)
  (*     + exact (point B). *)
  (*     + exact alpha. *)
  (*   - reflexivity. *)
  (* Defined. *)

  (* X1 is the BAut E where we kill this map *)
  Definition X1 := Build_pType (pushout susp_P_to_B (const tt)) (push (inr tt)).
  Definition B_to_X1 : B ->* X1.
    srapply @Build_pMap.
    - exact (push o inl).
    - exact (pp North).
  Defined.

  Definition const_SP_to_X1 : B_to_X1 o* susp_P_to_B = pconst (psusp P) X1.
  Proof.
    apply path_pmap.
    srapply @Build_pHomotopy.
    - exact pp.
    - cbn. exact (concat_p1 _ @ (concat_1p _)^).
  Defined.

  (* Now we show that all loops in B are killed in X1 *)
  (* Instead: Use loops_functor, loops_functor_compose *)
  Definition kill_loop (alpha : P) : loops_functor B_to_X1 alpha = idpath.
  Proof.
    transitivity (loops_functor (pconst (psusp P) X1) (loop_susp_unit P alpha)).
    transitivity (loops_functor (B_to_X1 o* susp_P_to_B) (loop_susp_unit P alpha)).
    transitivity (loops_functor B_to_X1 (loops_functor susp_P_to_B (loop_susp_unit P alpha))).
    - apply (ap (loops_functor B_to_X1)).
      apply inverse. unfold susp_P_to_B.
      exact (psusp_rec_beta_unit _ alpha).
    - apply inverse. apply loops_functor_compose.
    - apply (ap (fun f : psusp P ->* X1 =>
             loops_functor f ((loop_susp_unit P) alpha))).
      exact const_SP_to_X1.
    - cbn. refine (concat_1p _ @ concat_p1 _ @ _). exact (ap_const _ _).
  Defined.

  Definition loops_functor_1 {X Y : pType} (f : X ->* Y) : loops_functor f idpath = idpath.
  Proof.
    unfold loops_functor. cbn.
    refine (ap (concat (point_eq f)^) (concat_1p _) @ _). apply concat_Vp.
  Defined.

  (* Definition kill_loop_1 : kill_loop 1 = loops_functor_1 _. *)
  (* Proof. *)
  (*   unfold kill_loop. unfold loops_functor_1. cbn. *)
  (*   unfold const. *)

  Definition loops_functor_VVpp {X Y : pType} (f : X ->* Y) (p q r s : loops X) :
    (loops_functor f) (p^ @ q^ @ r @ s) =
    (loops_functor f p)^ @ (loops_functor f q)^ @ (loops_functor f r) @ (loops_functor f s).
  Proof.
    destruct X as [X x0]. destruct Y as [Y y0]. destruct f as [f pf]. cbn in f, pf, p,q,r,s. cbn. destruct pf.
    cut (forall (x1 x2 x3 x4 : X) (p' : x1 = point X) (q' : x2 = x1) (r' : x2 = x3) (s' : x3 = x4),
            1^ @ (ap f (((p'^ @ q'^) @ r') @ s') @ 1) =
            (((1^ @ (ap f p' @ 1))^ @ (1^ @ (ap f q' @ 1))^) @ (1^ @ (ap f r' @ 1))) @ (1^ @ (ap f s' @ 1))).
    { intro gen. apply gen. }
    intros. path_induction. reflexivity.
  Defined.

  Definition P_to_loopsloopsX1 : P -> loops (loops X1).
  Proof.
    intro alpha. cbn.
    refine ((kill_loop alpha)^ @ _).
    refine (ap (loops_functor B_to_X1) (perfect alpha).2.2 @ _).
    refine (loops_functor_VVpp _ _ _ _ _ @ _).
    destruct (kill_loop (perfect alpha).1)^.
    destruct (kill_loop (perfect alpha).2.1)^. reflexivity.
  Defined.

  (* Definition P_to_loopsloopsX1_1 : P_to_loopsloopsX1 idpath = idpath. *)
  (* Proof. *)
  (*   unfold P_to_loopsloopsX1. *)
  (*   rewrite perfect_1. cbn. repeat rewrite concat_p1. apply moveR_Vp. *)
  (*   refine (concat_1p _ @ _). *)
  (*   refine (_ @ (concat_p1 _)^). *)
  (*   simpl. generalize (kill_loop 1).  *)
  (*   generalize (loops_functor B_to_X1). *)

  (* (* Now we show that s and t are killed in X1 *) *)
  (* Definition kill_s : ap (B_to_X1) s = idpath. *)
  (* Proof. *)
  (*   transitivity (loops_functor B_to_X1 s). *)
  (*   { simpl. *)
  (*     admit. } *)
  (*   refine (ap (loops_functor B_to_X1) normally_generated_s @ _). *)
  (*   refine (functor_iterated_concat B_to_X1 (functor_list (fun p : loops B => (p^ @ alpha) @ p) s_list) @ _). *)
  (*   clear perfect normally_generated_s normally_generated_t. *)
  (*   induction s_list. *)
  (*   - reflexivity. *)
  (*   - simpl. *)
  (*     repeat rewrite concat_p1. repeat rewrite concat_1p. *)
  (*     rewrite IHl. rewrite concat_p1.  *)
  (*     repeat rewrite ap_pp. *)
  (*     admit. *)
  (*     (* TODO : Gjør uten rewrite. *) *)

  (*   transitivity (iterated_concat (functor_list (fun p : loops B => *)
  (*                                                  loops_functor B_to_X1 (p^ @ alpha @ p)) s_list)). *)
  (*   { admit.                    (* functor_list is functorial *) } *)
  (*   cut ((fun p : loops B => (loops_functor B_to_X1) ((p^ @ alpha) @ p)) = fun p : loops B => idpath). *)
  (*   intro path. rewrite path. *)

  (*   simpl. *)

  (*   induction (functor_list (loops_functor B_to_X1) (functor_list (fun p : loops B => (p^ @ alpha) @ p) s_list)). *)
  (*   - reflexivity. *)
  (*   - simpl. destruct (IHl)^. *)

  (*   simpl. *)
  (*   induction (functor_list (fun p : point B = point B => 1 @ (ap (fun b : B => push (inl b)) p @ 1)) *)
  (*      (functor_list (fun p : point B = point B => (p^ @ alpha) @ p) s_list)). *)

  (* Now we want maps SSP -> X1 and X1 -> SSP such that the composition is the identity *)
  Definition SSP_to_X1 : psusp (psusp P) ->* X1 :=
    psusp_rec (psusp_rec P_to_loopsloopsX1).

    (* - cbn. cut (IsTrunc 1 X1). intro H'. apply H'. (* not true *) *)
    (*   refine (H (point B) (point B) _ _ _ _). *)

    (*   apply moveR_Vp. refine (_ @ (concat_p1 _)^). refine (_ @ concat_1p _). *)
    (*   apply whiskerR. *)
    (*    refine (_ @ concat_p1 _). apply concat2. *)
    (*   refine (ap_pp  _ _  _@ _).  *)
    (*   refine (ap_pp  _ _  _@ _). refine (_ @ concat_p1 _). apply concat2. *)
    (*   refine (ap_V _ _ @ _). refine (ap inverse (kill_ *)

  Definition X1_to_SSP : X1 ->* psusp (psusp P).
  Proof.
    srapply @Build_pMap. cbn.
    srapply @pushout_rec.
    - exact (const North).
    - intro p. unfold const.
      apply (loop_susp_unit (psusp P)). exact p.
    - reflexivity.
  Defined.

  Definition id_comp : (X1_to_SSP o SSP_to_X1) == idmap.
  Proof.
    srapply @Susp_ind.
    - reflexivity.
    - apply (merid North).
    - intro x.
      refine (transport_paths_FlFr _ _ @ _). cbn. rewrite concat_p1. rewrite ap_idmap.
      revert x. srapply @Susp_ind.
      + cbn.
        apply moveR_pM. rewrite concat_pV.
        refine (ap inverse (y := 1) _).
        rewrite ap_compose.
        rewrite Susp_rec_beta_merid. reflexivity.
      + cbn.
        apply moveR_Vp. apply moveL_pM. apply inverse.
        rewrite ap_compose. rewrite Susp_rec_beta_merid. cbn.
        apply moveL_pV. rewrite concat_1p.
        apply (ap merid). apply merid. exact idpath.
      +

        refine (pushout_rec_beta_pp North @ _).

  (* Now we want to show that the composition is the identity. . . *)
  Definition id_comp : (X1_to_SSP o* SSP_to_X1) = pmap_idmap _.
  Proof.
    apply (equiv_inj (loop_susp_adjoint (psusp P) (psusp (psusp P))) ).
    apply (equiv_inj (loop_susp_adjoint P (loops (psusp (psusp P))))).
    cbn.
    rewrite (path_pmap (loops_functor_compose X1_to_SSP SSP_to_X1)).
    rewrite (path_pmap (pmap_compose_assoc _ _ _)).
    rewrite (path_pmap (loops_functor_compose _ _)).
    rewrite (path_pmap (pmap_compose_assoc _ _ _)).
    cut (loops_functor (loops_functor SSP_to_X1 o* loop_susp_unit (psusp P)) o* loop_susp_unit P =
         P_to_loopsloopsX1).

    refine ((ap (fun f => loops_functor (f o* loop_susp_unit (psusp P)) o* loop_susp_unit P)
                (path_pmap (loops_functor_compose _ _))) @ _).

    refine (path_pmap (pmap_compose_assoc _ _ _) @ _).

    refine (path_pmap (pmap_compose_assoc _ _ _) @ _).

    transitivity (loops_functor (loops_functor (X1_to_SSP o* SSP_to_X1)) o* (fun alpha =>

    refine ((path_pmap (loops_functor_compose _ _)) @ _).
    refine (_ @ (path_pmap (loops_functor_compose _ _))^).
    apply (ap (fun f => f o* loops_functor (loop_susp_unit (psusp P)))).
    refine (ap loops_functor (path_pmap (loops_functor_compose _ _)) @ _).
    refine (path_pmap (loops_functor_compose _ _ ) @ _ ).
    apply path_pmap.
    srapply @Build_pHomotopy.
    - intro alpha. cbn. repeat rewrite concat_p1. repeat rewrite concat_1p.

    refine

    apply (ap (fun f => loops_functor (loo

    unfold pointwise_paths. intro x. simpl in x. revert x.
    srapply @Susp_ind.
    - reflexivity.
    - exact (merid (point _)).
    - intro x.
      refine (transport_paths_FlFr (f:= X1_to_SSP o SSP_to_X1) (merid x) idpath @ _).
      rewrite concat_p1.
      rewrite ap_idmap. rewrite ap_compose.
      rewrite Susp_rec_beta_merid.
      apply moveR_Vp. apply inverse.
      revert x.
      srapply @Susp_ind.
      + cbn. apply concat_1p.
      + cbn. refine (concat_1p _ @ _). apply (ap merid).  exact (merid (point _)).
      + cbn. intro p.
        refine (transport_paths_FlFr (merid p) (concat_1p (merid North)) @ _).

        rewrite <- ap_compose.

        cbn.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

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

          Buchberger : final reduction algorithm

          Laurent Thery April 98 (revised Mai 98)

****************************************************************************)
Section Reduce.
Variable poly : Set.
Require Import List.
Variable cb : list poly -> poly -> Prop.
Variable divp : poly -> poly -> Prop.
Variable reduce : list poly -> poly -> poly -> Prop.
Variable nf : list poly -> poly -> poly.
Variable stable : list poly -> list poly -> Prop.
Variable grobner : list poly -> Prop.
Variable zero : poly.
Variable zerop : poly -> Prop.
Variable zerop_dec : forall p : poly, {zerop p} + {~ zerop p}.
Require Import LetP.
Hypothesis cb_id : forall (L : list poly) (p : poly), In p L -> cb L p.
Hypothesis cb_zerop : forall (L : list poly) (p : poly), zerop p -> cb L p.
Hypothesis
  cb_incl :
    forall (L1 L2 : list poly) (p : poly), incl L1 L2 -> cb L1 p -> cb L2 p.
Hypothesis nf_cb : forall (p : poly) (L : list poly), cb (p :: L) (nf L p).
Hypothesis
  cb_trans :
    forall (L : list poly) (p q : poly), cb (p :: L) q -> cb L p -> cb L q.
Hypothesis
  cb_comp :
    forall L1 L2 : list poly,
    (forall p : poly, In p L1 -> cb L2 p) ->
    forall q : poly, cb L1 q -> cb L2 q.
Hypothesis cb_nf : forall (p : poly) (L : list poly), cb (nf L p :: L) p.
Hypothesis
  cb_compo :
    forall (p : poly) (L1 : list poly),
    cb L1 p ->
    forall L2 : list poly, (forall q : poly, In q L1 -> cb L2 q) -> cb L2 p.
Hypothesis
  zerop_elim_cb :
    forall (L : list poly) (p q : poly), zerop p -> cb (p :: L) q -> cb L q.
Hypothesis
  grobner_def :
    forall L : list poly,
    grobner L ->
    forall p : poly, cb L p -> zerop p \/ (exists q : poly, reduce L p q).
Hypothesis
  def_grobner :
    forall L : list poly,
    (forall p : poly, cb L p -> zerop p \/ (exists q : poly, reduce L p q)) ->
    grobner L.
Hypothesis
  nf_div :
    forall (p : poly) (L : list poly),
    ~ zerop p ->
    ~ zerop (nf L p) ->
    exists q : poly, In q (nf L p :: L) /\ divp p q /\ ~ zerop q.
Hypothesis
  div_reduce :
    forall (p : poly) (L1 L2 : list poly),
    (forall r1 : poly,
     In r1 L1 -> ~ zerop r1 -> exists r2 : poly, In r2 L2 /\ divp r1 r2) ->
    forall q : poly, reduce L1 p q -> exists r : poly, reduce L2 p r.
Hypothesis divp_id : forall p : poly, divp p p.
Require Import Relation_Definitions.
Hypothesis divp_trans : transitive poly divp.
Hypothesis
  nf_div_zero :
    forall (p : poly) (L : list poly),
    ~ zerop p ->
    zerop (nf L p) -> exists q : poly, In q L /\ divp p q /\ ~ zerop q.

Theorem zerop_nf_cb :
 forall (L : list poly) (p : poly), zerop (nf L p) -> cb L p.
intros L p H'.
apply zerop_elim_cb with (p := nf L p); auto.
Qed.
Hint Resolve zerop_nf_cb.

Definition redacc : list poly -> list poly -> list poly.
intros H'; elim H'.
intros L; exact (nil (A:=poly)).
intros a p Rec Acc.
apply LetP with (A := poly) (h := nf (p ++ Acc) a).
intros u H'0; case (zerop_dec u); intros Z.
exact (Rec Acc).
exact (u :: Rec (u :: Acc)).
Defined.

Definition red (L : list poly) : list poly := redacc L nil.
Hint Resolve incl_refl incl_tl incl_appr incl_appl incl_cons incl_app
  in_or_app.

Theorem redacc_cb :
 forall (L1 L2 : list poly) (p : poly),
 In p (redacc L1 L2) -> cb (L1 ++ L2) p.
intros L1; elim L1; auto.
simpl in |- *; auto.
simpl in |- *; unfold LetP in |- *; intros a l H' L2 p.
case (zerop_dec (nf (l ++ L2) a)).
intros H'0 H'1.
apply cb_incl with (L1 := l ++ L2); auto.
simpl in |- *.
intros H'0 H'1; case H'1;
 [ intros H'2; rewrite <- H'2; clear H'1 | intros H'2; clear H'1 ];
 auto.
apply cb_trans with (p := nf (l ++ L2) a); auto.
apply cb_incl with (L1 := l ++ nf (l ++ L2) a :: L2); auto.
apply incl_app; auto with datatypes.
Qed.

Theorem red_cb : forall (L : list poly) (p : poly), In p (red L) -> cb L p.
unfold red in |- *.
intros L p H'.
generalize (redacc_cb L nil); simpl in |- *; auto.
rewrite <- app_nil_end; auto.
Qed.

Theorem cb_redacc :
 forall (L1 L2 : list poly) (p : poly), In p L1 -> cb (redacc L1 L2 ++ L2) p.
intros L1; elim L1; simpl in |- *; auto.
intros L2 p H'; elim H'; auto.
unfold LetP in |- *.
intros a l H' L2 p H'0; case H'0;
 [ intros H'1; rewrite H'1; clear H'0 | intros H'1; clear H'0 ];
 auto.
case (zerop_dec (nf (l ++ L2) p)); auto.
intros H'0.
apply cb_comp with (L1 := l ++ L2); auto.
intros p0 H'2.
lapply (in_app_or l L2 p0); auto.
intros H'3; case H'3; auto.
intros H'0.
2: case (zerop_dec (nf (l ++ L2) a)); auto.
2: intros H'0.
2: apply
    cb_incl
     with (L1 := redacc l (nf (l ++ L2) a :: L2) ++ nf (l ++ L2) a :: L2);
    auto with datatypes.
apply cb_compo with (L1 := nf (l ++ L2) p :: l ++ L2); simpl in |- *; auto.
intros q H'2; case H'2;
 [ intros H'3; rewrite <- H'3; clear H'2 | intros H'3; clear H'2 ];
 auto with datatypes.
case (in_app_or l L2 q H'3); auto with datatypes.
intros H'2.
apply
 cb_incl with (L1 := redacc l (nf (l ++ L2) p :: L2) ++ nf (l ++ L2) p :: L2);
 auto with datatypes.
Qed.

Theorem cb_red : forall (L : list poly) (p : poly), In p L -> cb (red L) p.
intros L p H'.
lapply (cb_redacc L nil p); [ intros H'3; generalize H'3 | idtac ];
 simpl in |- *; auto.
rewrite <- app_nil_end; auto.
Qed.

Theorem cb_red_cb1 :
 forall (p : poly) (L : list poly), cb L p -> cb (red L) p.
intros p L H'.
apply cb_compo with (L1 := L); auto.
intros q H'0.
apply cb_red; auto.
Qed.

Theorem cb_red_cb2 :
 forall (p : poly) (L : list poly), cb (red L) p -> cb L p.
intros p L H'.
apply cb_compo with (L1 := red L); auto.
intros q H'0.
apply red_cb; auto.
Qed.
Hypothesis
  nf_div_zero1 :
    forall (p : poly) (L : list poly),
    ~ zerop p ->
    zerop (nf L p) -> ex (fun q : poly => In q L /\ divp p q /\ ~ zerop q).

Theorem redacc_divp :
 forall (L1 L2 : list poly) (p : poly),
 ~ zerop p ->
 In p (L1 ++ L2) ->
 exists q : poly, In q (redacc L1 L2 ++ L2) /\ divp p q /\ ~ zerop q.
intros L1; elim L1; simpl in |- *; auto.
intros L2 p H' H'0; exists p; split; auto.
unfold LetP in |- *.
intros a l H' L2 p H'0 H'1; case H'1;
 [ intros H'2; rewrite <- H'2; clear H'1 | intros H'2; clear H'1 ];
 auto.
case (zerop_dec (nf (l ++ L2) a)); simpl in |- *; auto.
intros Z1.
lapply (nf_div_zero1 a (l ++ L2));
 [ intros H'5; lapply H'5; [ intros H'6; clear H'5 | clear H'5 ] | idtac ];
 auto.
case H'6; intros q E; case E; intros H'3 H'4; case H'4; intros H'5 H'7;
 clear H'4 E H'6.
lapply (H' L2 q);
 [ intros H'8; lapply H'8; [ intros H'9; clear H'8 | clear H'8 ] | idtac ];
 auto.
case H'9; intros q0 E; case E; intros H'4 H'6; case H'6; intros H'8 H'10;
 clear H'6 E H'9.
exists q0; split; [ idtac | split ]; auto.
apply divp_trans with (y := q); auto.
rewrite H'2; auto.
intros Z1.
lapply (nf_div a (l ++ L2));
 [ intros H'5; lapply H'5; [ intros H'6; clear H'5 | clear H'5 ] | idtac ];
 auto.
case H'6; intros q E; case E; intros H'3 H'4; case H'4; intros H'5 H'7;
 clear H'4 E H'6.
simpl in H'3.
case H'3; [ intros H'4; clear H'3 | intros H'4; clear H'3 ].
exists q; split; [ idtac | split ]; auto.
lapply (H' (nf (l ++ L2) a :: L2) q);
 [ intros H'8; lapply H'8; [ intros H'9; clear H'8 | clear H'8 ] | idtac ];
 auto.
case H'9; intros q0 E; case E; intros H'3 H'6; case H'6; intros H'8 H'10;
 clear H'6 E H'9.
exists q0; split; [ idtac | split ]; auto.
case
 (in_app_or (redacc l (nf (l ++ L2) a :: L2)) (nf (l ++ L2) a :: L2) q0 H'3);
 auto.
simpl in |- *; auto.
intros H'6; case H'6; [ intros H'9; clear H'6 | intros H'9; clear H'6 ]; auto.
apply divp_trans with (y := q); auto.
case (in_app_or l L2 q H'4); auto with datatypes.
rewrite H'2; auto.
case (zerop_dec (nf (l ++ L2) a)); simpl in |- *; auto.
intros Z1.
case (in_app_or l L2 p H'2); auto.
intros H'3.
lapply (H' (nf (l ++ L2) a :: L2) p);
 [ intros H'6; lapply H'6; [ intros H'7; clear H'6 | clear H'6 ] | idtac ];
 auto.
case H'7; intros q E; case E; intros H'4 H'5; case H'5; intros H'6 H'8;
 clear H'5 E H'7.
exists q; split; auto.
case
 (in_app_or (redacc l (nf (l ++ L2) a :: L2)) (nf (l ++ L2) a :: L2) q H'4);
 auto.
simpl in |- *; auto.
intros H; case H; intros H1; auto.
intros H; exists p; split; [ right | idtac ]; auto.
Qed.

Theorem red_divp :
 forall (L : list poly) (p : poly),
 In p L ->
 ~ zerop p -> exists q : poly, In q (red L) /\ divp p q /\ ~ zerop q.
intros L p H' H'0.
lapply (redacc_divp L nil p); auto.
simpl in |- *; auto.
rewrite <- app_nil_end; auto.
rewrite <- app_nil_end; auto.
Qed.

Theorem red_grobner : forall L : list poly, grobner L -> grobner (red L).
intros L H'.
apply def_grobner; auto.
intros p H'0.
lapply (grobner_def L);
 [ intros H'2; lapply (H'2 p); [ intros H'4 | idtac ] | idtac ];
 auto.
case H'4; auto.
intros H'1; case H'1; intros q E; clear H'1.
right.
apply div_reduce with (L1 := L) (q := q); auto.
intros r1 H'1 H'3.
lapply (red_divp L r1);
 [ intros H'7; lapply H'7; [ intros H'8; clear H'7 | clear H'7 ] | idtac ];
 auto.
case H'8; intros q0 E0; case E0; intros H'5 H'6; case H'6; intros H'7 H'9;
 clear H'6 E0 H'8.
exists q0; split; auto.
apply cb_red_cb2; auto.
Qed.
End Reduce.