From Coq Require Import Bool String List BinPos Compare_dec Lia Arith.
Require Import Equations.Prop.DepElim.
From Equations Require Import Equations.
From MetaCoq Require Import Ast utils Typing.
From Translation
Require Import util Sorts SAst SLiftSubst Equality SCommon XTyping Conversion ITyping
               ITypingInversions ITypingLemmata ITypingAdmissible Optim
               Uniqueness SubjectReduction PackLifts.
Import ListNotations.

Open Scope type_scope.
Open Scope x_scope.
Open Scope i_scope.

(*! Relation for translated expressions *)

Section Sim.

Context `{Sort_notion : Sorts.notion}.

Reserved Notation " t1 ∼ t2 " (at level 20).

Inductive trel : sterm -> sterm -> Type :=
| trel_Rel x :
    sRel x ∼ sRel x

| trel_Transport_l t1 t2 T1 T2 p :
    t1 ∼ t2 ->
    sTransport T1 T2 p t1 ∼ t2

| trel_Transport_r t1 t2 T1 T2 p :
    t1 ∼ t2 ->
    t1 ∼ sTransport T1 T2 p t2

| trel_Prod n1 n2 A1 A2 B1 B2 :
    A1 ∼ A2 ->
    B1 ∼ B2 ->
    sProd n1 A1 B1 ∼ sProd n2 A2 B2

| trel_Sum n1 n2 A1 A2 B1 B2 :
    A1 ∼ A2 ->
    B1 ∼ B2 ->
    sSum n1 A1 B1 ∼ sSum n2 A2 B2

| trel_Eq A1 A2 u1 u2 v1 v2 :
    A1 ∼ A2 ->
    u1 ∼ u2 ->
    v1 ∼ v2 ->
    sEq A1 u1 v1 ∼ sEq A2 u2 v2

| trel_Sort s :
    sSort s ∼ sSort s

| trel_Lambda n1 n2 A1 A2 B1 B2 u1 u2 :
    A1 ∼ A2 ->
    B1 ∼ B2 ->
    u1 ∼ u2 ->
    sLambda n1 A1 B1 u1 ∼ sLambda n2 A2 B2 u2

| trel_App u1 u2 A1 A2 B1 B2 v1 v2 :
    u1 ∼ u2 ->
    A1 ∼ A2 ->
    B1 ∼ B2 ->
    v1 ∼ v2 ->
    sApp u1 A1 B1 v1 ∼ sApp u2 A2 B2 v2

| trel_Pair A1 A2 B1 B2 u1 u2 v1 v2 :
    A1 ∼ A2 ->
    B1 ∼ B2 ->
    u1 ∼ u2 ->
    v1 ∼ v2 ->
    sPair A1 B1 u1 v1 ∼ sPair A2 B2 u2 v2

| trel_Pi1 A1 A2 B1 B2 p1 p2 :
    A1 ∼ A2 ->
    B1 ∼ B2 ->
    p1 ∼ p2 ->
    sPi1 A1 B1 p1 ∼ sPi1 A2 B2 p2

| trel_Pi2 A1 A2 B1 B2 p1 p2 :
    A1 ∼ A2 ->
    B1 ∼ B2 ->
    p1 ∼ p2 ->
    sPi2 A1 B1 p1 ∼ sPi2 A2 B2 p2

| trel_Refl A1 A2 u1 u2 :
    A1 ∼ A2 ->
    u1 ∼ u2 ->
    sRefl A1 u1 ∼ sRefl A2 u2

| trel_Ax id :
    sAx id ∼ sAx id

where " t1 ∼ t2 " := (trel t1 t2).

End Sim.

Notation " t1 ∼ t2 " := (trel t1 t2) (at level 20).
Derive Signature for trel.

Section In.

Context `{Sort_notion : Sorts.notion}.

(* We also define a biased relation that only allows transports on one side,
   the idea being that the term on the other side belongs to the source.
   This might be unnecessary as transport isn't typable in the source but
   hopefully this is more straightforward.
 *)
Reserved Notation " t ⊏ t' " (at level 20).

(* The first is in the source, the second in the target. *)
Inductive inrel : sterm -> sterm -> Type :=
| inrel_Rel x :
    sRel x ⊏ sRel x

| inrel_Transport t t' T1 T2 p :
    t ⊏ t' ->
    t ⊏ sTransport T1 T2 p t'

| inrel_Prod n n' A A' B B' :
    A ⊏ A' ->
    B ⊏ B' ->
    sProd n A B ⊏ sProd n' A' B'

| inrel_Sum n n' A A' B B' :
    A ⊏ A' ->
    B ⊏ B' ->
    sSum n A B ⊏ sSum n' A' B'

| inrel_Eq A A' u u' v v' :
    A ⊏ A' ->
    u ⊏ u' ->
    v ⊏ v' ->
    sEq A u v ⊏ sEq A' u' v'

| inrel_Sort s :
    sSort s ⊏ sSort s

| inrel_Lambda n n' A A' B B' u u' :
    A ⊏ A' ->
    B ⊏ B' ->
    u ⊏ u' ->
    sLambda n A B u ⊏ sLambda n' A' B' u'

| inrel_App u u' A A' B B' v v' :
    u ⊏ u' ->
    A ⊏ A' ->
    B ⊏ B' ->
    v ⊏ v' ->
    sApp u A B v ⊏ sApp u' A' B' v'

| inrel_Pair A A' B B' u u' v  v' :
    A ⊏ A' ->
    B ⊏ B' ->
    u ⊏ u' ->
    v ⊏ v' ->
    sPair A B u v ⊏ sPair A' B' u' v'

| inrel_Pi1 A A' B B' p p' :
    A ⊏ A' ->
    B ⊏ B' ->
    p ⊏ p' ->
    sPi1 A B p ⊏ sPi1 A' B' p'

| inrel_Pi2 A A' B B' p p' :
    A ⊏ A' ->
    B ⊏ B' ->
    p ⊏ p' ->
    sPi2 A B p ⊏ sPi2 A' B' p'

| inrel_Refl A A' u u' :
    A ⊏ A' ->
    u ⊏ u' ->
    sRefl A u ⊏ sRefl A' u'

| inrel_Ax id :
    sAx id ⊏ sAx id

where " t ⊏ t' " := (inrel t t').

Lemma inrel_trel :
  forall {t t'}, t ⊏ t' -> t ∼ t'.
Proof.
  intros t t' h.
  induction h ; now constructor.
Defined.

Lemma inrel_optTransport :
  forall {A B p t t'},
    t ⊏ t' ->
    t ⊏ optTransport A B p t'.
Proof.
  intros A B p t t' h.
  unfold optTransport.
  destruct (DecideConversion.isconv (2 ^ 18) A B).
  - assumption.
  - constructor. assumption.
Defined.

End In.

Notation " t ⊏ t' " := (inrel t t') (at level 20).

Ltac lift_sort :=
  match goal with
  | |- _ ;;; _ |-i lift ?n ?k ?t : ?S => change S with (lift n k S)
  | |- _ ;;; _ |-i llift ?n ?k ?t : ?S => change S with (llift n k S)
  | |- _ ;;; _ |-i rlift ?n ?k ?t : ?S => change S with (rlift n k S)
  | |- _ ;;; _ |-i ?t { ?n := ?u } : ?S => change S with (S {n := u})
  | |- sSort ?s ≡ lift ?n ?k ?t =>
    change (sSort s) with (lift n k (sSort s))
  | |- sSort ?s ≡ llift ?n ?k ?t =>
    change (sSort s) with (llift n k (sSort s))
  | |- sSort ?s ≡ rlift ?n ?k ?t =>
    change (sSort s) with (rlift n k (sSort s))
  | |- sSort ?s ≡ ?t{ ?n := ?u } =>
    change (sSort s) with ((sSort s){ n := u })
  | |- lift ?n ?k ?t ≡ sSort ?s =>
    change (sSort s) with (lift n k (sSort s))
  | |- llift ?n ?k ?t ≡ sSort ?s =>
    change (sSort s) with (llift n k (sSort s))
  | |- rlift ?n ?k ?t ≡ sSort ?s =>
    change (sSort s) with (rlift n k (sSort s))
  | |- ?t{ ?n := ?u } ≡ sSort ?s =>
    change (sSort s) with ((sSort s){ n := u })
  end.

Section Fundamental.

Context `{Sort_notion : Sorts.notion}.

Lemma trel_to_heq' :
  forall {Σ t1 t2},
    type_glob Σ ->
    t1 ∼ t2 ->
    forall Γ Γ1 Γ2,
      ∑ p,
        forall {Γm T1 T2},
          ismix Σ Γ Γ1 Γ2 Γm ->
          Σ ;;; Γ ,,, Γ1 |-i t1 : T1 ->
          Σ ;;; Γ ,,, Γ2 |-i  t2 : T2 ->
          Σ ;;; Γ ,,, Γm |-i p : sHeq (llift0 #|Γm| T1)
                                     (llift0 #|Γm| t1)
                                     (rlift0 #|Γm| T2)
                                     (rlift0 #|Γm| t2).
Proof.
  intros Σ t1 t2 hg sim.
  induction sim ; intros Γ Γ1 Γ2.

  (* Variable *)
  - case_eq (x <? #|Γ1|) ; intro e0 ; bprop e0.
    + (* The variable is located in the mixed part.
         We use the available equality.
       *)
      exists (sProjTe (sRel x)).
      intros Γm U1 U2 hm h1 h2.
      unfold llift at 2. unfold rlift at 2.
      case_eq (x <? 0) ; intro e ; bprop e ; try mylia. clear e2.
      pose proof (mix_length1 hm) as ml. rewrite <- ml in e0, e1.
      change (0 + #|Γm|)%nat with #|Γm|.
      rewrite e0.
      (* Now for the specifics *)
      apply type_ProjTe' ; try assumption.
      ttinv h1. ttinv h2.
      rename is into is1, is0 into is2, h into hx1, h0 into hx2.
      assert (is1' : x < #|Γ1|) by (erewrite mix_length1 in e1 ; eassumption).
      assert (is2' : x < #|Γ2|) by (erewrite mix_length2 in e1 ; eassumption).
      cbn in hx1. erewrite @safe_nth_lt with (isdecl' := is1') in hx1.
      cbn in hx2. erewrite @safe_nth_lt with (isdecl' := is2') in hx2.
      destruct (istype_type hg h1) as [s1 ?].
      destruct (istype_type hg h2) as [s2 ?].
      destruct (ismix_nth_sort hg hm x is1' is2') as [ss [? ?]].
      eapply type_conv.
      * eapply type_Rel.
        eapply (@wf_llift Sort_notion) with (Δ := []) ; try eassumption.
        eapply typing_wf ; eassumption.
      * instantiate (1 := ss).
        eapply type_Pack.
        -- lift_sort.
           eapply type_llift0 ; try eassumption.
           eapply type_conv ; try eassumption.
           ++ econstructor. eapply typing_wf. eassumption.
           ++ eapply subj_conv.
              ** eassumption.
              ** apply conv_sym. exact hx1.
              ** eassumption.
              ** assumption.
        -- lift_sort.
           eapply type_rlift0 ; try eassumption.
           eapply type_conv ; try eassumption.
           ++ econstructor. eapply typing_wf. eassumption.
           ++ eapply subj_conv.
              ** eassumption.
              ** apply conv_sym. exact hx2.
              ** eassumption.
              ** assumption.
      * erewrite safe_nth_lt. erewrite safe_nth_mix by eassumption.
        cbn. apply cong_Pack.
        -- rewrite lift_llift.
           replace (S x + (#|Γm| - S x))%nat with #|Γm| by mylia.
           eapply llift_conv. eassumption.
        -- rewrite lift_rlift.
           replace (S x + (#|Γm| - S x))%nat with #|Γm| by mylia.
           eapply rlift_conv. eassumption.
    + (* Unless it is ill-typed, the variable is in Γ, reflexivity will do.
         To type reflexivity properly we still need a proof that
         x - #|Γ1| < #|Γ|. We have to consider both cases.
       *)
      case_eq ((x - #|Γ1|) <? #|Γ|) ; intro isdecl ; bprop isdecl.
      * (* The variable is indeed in the context. *)
        set (y := x - #|Γ1|) in *.
        set (A := lift0 (S x) (safe_nth Γ (exist _ y isdecl0))).
        exists (sHeqRefl A (sRel x)).
        intros Γm U1 U2 hm h1 h2.
        unfold llift at 2. unfold rlift at 2.
        case_eq (x <? 0) ; intro e ; bprop e ; try mylia. clear e2.
        pose proof (mix_length1 hm) as ml. rewrite <- ml in e0, e1.
        change (0 + #|Γm|)%nat with #|Γm|.
        rewrite e0.
        (* Now for the specifics *)
        assert (h1' : Σ ;;; Γ ,,, Γm |-i sRel x : llift0 #|Γm| U1).
        { replace (sRel x) with (llift0 #|Γm| (sRel x)).
          2:{
            unfold llift. rewrite e. simpl. rewrite e0. reflexivity.
          }
          eapply type_llift0 ; eassumption.
        }
        assert (h2' : Σ ;;; Γ ,,, Γm |-i sRel x : rlift0 #|Γm| U2).
        { replace (sRel x) with (rlift0 #|Γm| (sRel x))
            by (unfold rlift ; rewrite e ; simpl ; rewrite e0 ; reflexivity).
          eapply type_rlift0 ; eassumption.
        }
        pose proof (uniqueness hg h1' h2').
        destruct (istype_type hg h1').
        destruct (istype_type hg h2').
        eapply type_conv.
        -- eapply type_HeqRefl' ; try eassumption.
           subst y A. revert isdecl0. rewrite <- ml. intro isdecl0.
           eapply meta_conv.
           ++ eapply type_Rel. eapply typing_wf. eassumption.
           ++ erewrite @safe_nth_ge with (isdecl' := isdecl0) by mylia.
              reflexivity.
        -- eapply type_Heq ; try eassumption.
           eapply type_conv ; try eassumption.
           ++ econstructor. eapply typing_wf. eassumption.
           ++ apply conv_sym. eapply subj_conv ; eassumption.
        -- ttinv h1'. ttinv h2'.
           apply cong_Heq. all: try (apply conv_refl).
           ++ eapply conv_trans ; try eassumption.
              subst y A. revert isdecl0. rewrite <- ml. intro isdecl0.
              apply conv_eq. f_equal. f_equal.
              erewrite @safe_nth_ge with (isdecl' := isdecl0) by mylia.
              reflexivity.
           ++ eapply conv_trans ; try eassumption.
              subst y A. revert isdecl0. rewrite <- ml. intro isdecl0.
              apply conv_eq. f_equal. f_equal.
              erewrite @safe_nth_ge with (isdecl' := isdecl0) by mylia.
              reflexivity.
      * (* In case the variable isn't in the context at all,
           it is bound to be ill-typed and we can return garbage.
         *)
        exists (sRel 0).
        intros Γm U1 U2 hm h1 h2.
        exfalso. ttinv h1. clear h. rewrite length_cat in is. mylia.

  (* Left transport *)
  - destruct (IHsim Γ Γ1 Γ2) as [q hq].
    exists (optHeqTrans (optHeqSym (optHeqTransport (llift0 #|Γ1| p) (llift0 #|Γ1| t1))) q).
    intros Γm U1 U2 hm h1 h2.
    pose proof (mix_length1 hm) as ml. rewrite <- ml.
    ttinv h1.
    specialize (hq _ _ _ hm h h2).
    destruct (istype_type hg hq) as [s' h'].
    ttinv h'. pose proof (sort_conv_inv h11). subst. clear h11.
    eapply opt_HeqTrans ; try assumption.
    + eapply opt_HeqSym ; try assumption.
      eapply type_conv.
      * eapply opt_HeqTransport ; try assumption.
        -- eapply type_llift0 ; eassumption.
        -- instantiate (2 := s). instantiate (1 := llift0 #|Γm| T2).
           change (sEq (sSort s) (llift0 #|Γm| T1) (llift0 #|Γm| T2))
             with (llift0 #|Γm| (sEq (sSort s) T1 T2)).
           eapply type_llift0 ; eassumption.
      * instantiate (1 := s).
        instantiate (1 := llift0 #|Γm| t1).
        instantiate (1 := llift0 #|Γm| T1).
        match goal with
        | |- ?Σ ;;; ?Γ |-i ?T : ?s =>
          change T with (llift0 #|Γm| (sHeq T1 t1 U1 (sTransport T1 T2 p t1)))
        end.
        lift_sort.
        eapply type_llift0 ; try eassumption.
        apply type_Heq ; try assumption.
        destruct (istype_type hg h1).
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym. eapply subj_conv ; eassumption.
      * apply cong_Heq.
        all: try (apply conv_refl).
        eapply llift_conv. assumption.
    + assumption.

  (* Right transport *)
  - destruct (IHsim Γ Γ1 Γ2) as [q hq].
    exists (optHeqTrans q (optHeqTransport (rlift0 #|Γ1| p) (rlift0 #|Γ1| t2))).
    intros Γm U1 U2 hm h1 h2.
    pose proof (mix_length1 hm) as ml. rewrite <- ml.
    ttinv h2.
    specialize (hq _ _ _ hm h1 h).
    destruct (istype_type hg hq) as [s' h'].
    ttinv h'. pose proof (sort_conv_inv h11). subst. clear h11.
    cbn.
    eapply opt_HeqTrans ; try assumption.
    + eassumption.
    + eapply type_conv.
      * eapply opt_HeqTransport ; try assumption.
        -- eapply type_rlift0 ; eassumption.
        -- instantiate (2 := s). instantiate (1 := rlift0 #|Γm| T2).
           change (sEq (sSort s) (rlift0 #|Γm| T1) (rlift0 #|Γm| T2))
             with (rlift0 #|Γm| (sEq (sSort s) T1 T2)).
           eapply type_rlift0 ; eassumption.
      * instantiate (1 := s).
        match goal with
        | |- ?Σ ;;; ?Γ |-i ?T : ?s =>
          change T with (rlift0 #|Γm| (sHeq T1 t2 U2 (sTransport T1 T2 p t2)))
        end.
        lift_sort.
        eapply type_rlift0 ; try eassumption.
        apply type_Heq ; try assumption.
        destruct (istype_type hg h2).
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym. eapply subj_conv ; eassumption.
      * apply cong_Heq.
        all: try (apply conv_refl).
        eapply rlift_conv. assumption.

  (* Prod *)
  - destruct (IHsim1 Γ Γ1 Γ2) as [pA hpA].
    destruct (IHsim2 Γ (Γ1,, A1) (Γ2,, A2)) as [pB hpB].
    exists (optCongProd (llift #|Γ1| 1 B1) (rlift #|Γ1| 1 B2) pA pB).
    intros Γm U1 U2 hm h1 h2.
    pose proof (mix_length1 hm) as ml. rewrite <- ml.
    ttinv h1. ttinv h2.
    specialize (hpA _ _ _ hm h0 h5).
    destruct (istype_type hg hpA) as [s iA].
    ttinv iA. pose proof (sort_conv_inv h12). subst. clear h12.
    assert (s1 = s0).
    { eapply sorts_in_sort ; eassumption. }
    subst.
    assert (hm' :
              ismix Σ Γ
                    (Γ1 ,, A1)
                    (Γ2 ,, A2)
                    (Γm ,, (sPack (llift0 #|Γm| A1) (rlift0 #|Γm| A2)))
    ).
    { econstructor ; eassumption. }
    specialize (hpB _ _ _ hm' h h3).
    destruct (istype_type hg hpB) as [? iB]. ttinv iB.
    pose proof (sort_conv_inv h16) as hh. symmetry in hh. subst. clear h16.
    assert (s3 = s2).
    { eapply sorts_in_sort ; eassumption. }
    subst.
    destruct (istype_type hg h1).
    destruct (istype_type hg h2).
    eapply type_conv.
    + eapply opt_CongProd ; try assumption.
      * eassumption.
      * rewrite llift_substProj, rlift_substProj.
        apply hpB.
      * lift_sort.
        eapply (@type_llift1 Sort_notion) ; eassumption.
      * lift_sort.
        eapply (@type_rlift1 Sort_notion) ; eassumption.
    + instantiate (1 := Sorts.succ (Sorts.prod_sort s0 s2)).
      eapply type_Heq.
      * lift_sort. eapply type_llift0 ; try eassumption.
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym.
           eapply subj_conv ; [ eassumption | .. | eassumption ] ;
           try eassumption.
           econstructor. eapply typing_wf. eassumption.
      * lift_sort. eapply type_rlift0 ; try eassumption.
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym.
           eapply subj_conv ; [ eassumption | .. | eassumption ] ;
           try eassumption.
           econstructor. eapply typing_wf. eassumption.
      * eapply type_llift0 ; eassumption.
      * eapply type_rlift0 ; eassumption.
    + cbn. apply cong_Heq.
      all: try (apply conv_refl).
      * lift_sort. apply llift_conv. assumption.
      * lift_sort. apply rlift_conv. assumption.

  (* Sum *)
  - destruct (IHsim1 Γ Γ1 Γ2) as [pA hpA].
    destruct (IHsim2 Γ (Γ1,, A1) (Γ2,, A2)) as [pB hpB].
    exists (sCongSum (llift #|Γ1| 1 B1) (rlift #|Γ1| 1 B2) pA pB).
    intros Γm U1 U2 hm h1 h2.
    pose proof (mix_length1 hm) as ml. rewrite <- ml.
    ttinv h1. ttinv h2.
    specialize (hpA _ _ _ hm h0 h5).
    destruct (istype_type hg hpA) as [s iA].
    ttinv iA. pose proof (sort_conv_inv h12). subst. clear h12.
    assert (s1 = s0).
    { eapply sorts_in_sort ; eassumption. }
    subst.
    assert (hm' :
              ismix Σ Γ
                    (Γ1 ,, A1)
                    (Γ2 ,, A2)
                    (Γm ,, (sPack (llift0 #|Γm| A1) (rlift0 #|Γm| A2)))
    ).
    { econstructor ; eassumption. }
    specialize (hpB _ _ _ hm' h h3).
    destruct (istype_type hg hpB) as [? iB]. ttinv iB.
    pose proof (sort_conv_inv h16) as hh. symmetry in hh. subst. clear h16.
    assert (s3 = s2).
    { eapply sorts_in_sort ; eassumption. }
    subst.
    destruct (istype_type hg h1).
    destruct (istype_type hg h2).
    eapply type_conv.
    + eapply type_CongSum' ; try assumption.
      * eassumption.
      * rewrite llift_substProj, rlift_substProj.
        apply hpB.
      * lift_sort.
        eapply (@type_llift1 Sort_notion) ; eassumption.
      * lift_sort.
        eapply (@type_rlift1 Sort_notion) ; eassumption.
    + instantiate (1 := Sorts.succ (Sorts.sum_sort s0 s2)).
      eapply type_Heq.
      * lift_sort. eapply type_llift0 ; try eassumption.
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym.
           eapply subj_conv ; [ eassumption | .. | eassumption ] ;
           try eassumption.
           econstructor. eapply typing_wf. eassumption.
      * lift_sort. eapply type_rlift0 ; try eassumption.
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym.
           eapply subj_conv ; [ eassumption | .. | eassumption ] ;
           try eassumption.
           econstructor. eapply typing_wf. eassumption.
      * eapply type_llift0 ; eassumption.
      * eapply type_rlift0 ; eassumption.
    + cbn. apply cong_Heq.
      all: try (apply conv_refl).
      * lift_sort. apply llift_conv. assumption.
      * lift_sort. apply rlift_conv. assumption.

  (* Eq *)
  - destruct (IHsim1 Γ Γ1 Γ2) as [pA hpA].
    destruct (IHsim2 Γ Γ1 Γ2) as [pu hpu].
    destruct (IHsim3 Γ Γ1 Γ2) as [pv hpv].
    exists (optCongEq pA pu pv).
    intros Γm U1 U2 hm h1 h2.
    ttinv h1. ttinv h2.
    specialize (hpA _ _ _ hm h0 h6).
    specialize (hpu _ _ _ hm h h4).
    specialize (hpv _ _ _ hm h3 h7).
    destruct (istype_type hg hpA) as [? ipA]. ttinv ipA.
    apply conv_sym in h14. pose proof (sort_conv_inv h14). subst. clear h14.
    assert (s0 = s).
    { eapply sorts_in_sort ; eassumption. }
    subst.
    eapply type_conv.
    + eapply opt_CongEq ; eassumption.
    + instantiate (1 := Sorts.succ (Sorts.eq_sort s)).
      eapply type_Heq.
      * destruct (istype_type hg h1). lift_sort.
        eapply type_llift0 ; try eassumption.
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym.
           eapply subj_conv ; [ eassumption | .. | eassumption ] ;
           try eassumption.
           econstructor. eapply typing_wf. eassumption.
      * destruct (istype_type hg h2). lift_sort.
        eapply type_rlift0 ; try eassumption.
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym.
           eapply subj_conv ; [ eassumption | .. | eassumption ] ;
           try eassumption.
           econstructor. eapply typing_wf. eassumption.
      * eapply type_llift0 ; eassumption.
      * eapply type_rlift0 ; eassumption.
    + apply cong_Heq.
      all: try (apply conv_refl).
      * lift_sort. apply llift_conv. assumption.
      * lift_sort. apply rlift_conv. assumption.

  (* Sort *)
  - exists (sHeqRefl (sSort (Sorts.succ s)) (sSort s)).
    intros Γm U1 U2 hm h1 h2.
    ttinv h1. ttinv h2.
    assert (hwf : wf Σ (Γ ,,, Γm)).
    { eapply (@wf_llift Sort_notion) with (Δ := []) ; try eassumption.
      eapply typing_wf ; eassumption.
    }
    eapply type_conv.
    + eapply type_HeqRefl' ; try assumption.
      apply type_Sort. eassumption.
    + instantiate (1 := Sorts.succ (Sorts.succ s)).
      eapply type_Heq.
      * lift_sort. eapply type_llift0 ; try eassumption.
        destruct (istype_type hg h1).
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym.
           eapply subj_conv ; [ eassumption | .. | eassumption ] ;
           try eassumption.
           econstructor. eapply typing_wf. eassumption.
      * lift_sort. eapply type_rlift0 ; try eassumption.
        destruct (istype_type hg h2).
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym.
           eapply subj_conv ; [ eassumption | .. | eassumption ] ;
           try eassumption.
           econstructor. eapply typing_wf. eassumption.
      * eapply type_llift0 ; eassumption.
      * eapply type_rlift0 ; eassumption.
    + cbn. apply cong_Heq. all: try (apply conv_refl).
      * lift_sort. apply llift_conv. assumption.
      * lift_sort. apply rlift_conv. assumption.

  (* Lambda *)
  - destruct (IHsim1 Γ Γ1 Γ2) as [pA hpA].
    destruct (IHsim2 Γ (Γ1,, A1) (Γ2,, A2)) as [pB hpB].
    destruct (IHsim3 Γ (Γ1,, A1) (Γ2,, A2)) as [pu hpu].
    exists (optCongLambda (llift #|Γ1| 1 B1) (rlift #|Γ1| 1 B2)
                   (llift #|Γ1| 1 u1) (rlift #|Γ1| 1 u2) pA pB pu).
    intros Γm U1 U2 hm h1 h2.
    pose proof (mix_length1 hm) as ml. rewrite <- ml.
    ttinv h1. ttinv h2.
    specialize (hpA _ _ _ hm h0 h6).
    destruct (istype_type hg hpA) as [? iA]. ttinv iA.
    pose proof (sort_conv_inv h14). subst. clear h14.
    assert (s1 = s0).
    { eapply sorts_in_sort ; eassumption. }
    subst.
    assert (hm' :
              ismix Σ Γ
                    (Γ1 ,, A1)
                    (Γ2 ,, A2)
                    (Γm ,, (sPack (llift0 #|Γm| A1) (rlift0 #|Γm| A2)))
    ).
    { econstructor ; eassumption. }
    specialize (hpB _ _ _ hm' h h4).
    specialize (hpu _ _ _ hm' h3 h7).
    assert (s3 = s2).
    { destruct (istype_type hg hpB) as [? ipB]. ttinv ipB.
      apply conv_sym in h18. pose proof (sort_conv_inv h18). subst. clear h18.
      eapply sorts_in_sort ; eassumption.
    } subst.
    eapply type_conv.
    + eapply opt_CongLambda ; try assumption.
      * eassumption.
      * rewrite llift_substProj, rlift_substProj. apply hpB.
      * rewrite !llift_substProj, !rlift_substProj. apply hpu.
      * lift_sort.
        eapply (@type_llift1 Sort_notion) ; eassumption.
      * lift_sort.
        eapply (@type_rlift1 Sort_notion) ; eassumption.
      * eapply (@type_llift1 Sort_notion) ; eassumption.
      * eapply (@type_rlift1 Sort_notion) ; eassumption.
    + instantiate (1 := Sorts.prod_sort s0 s2).
      eapply type_Heq.
      * lift_sort. eapply type_llift0 ; try eassumption.
        destruct (istype_type hg h1).
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym.
           eapply subj_conv ; [ eassumption | .. | eassumption ] ;
           try eassumption.
           econstructor ; eassumption.
      * lift_sort. eapply type_rlift0 ; try eassumption.
        destruct (istype_type hg h2).
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym.
           eapply subj_conv ; [ eassumption | .. | eassumption ] ;
           try eassumption.
           econstructor ; eassumption.
      * eapply type_llift0 ; eassumption.
      * eapply type_rlift0 ; eassumption.
    + cbn. apply cong_Heq.
      * match goal with
        | |- ?T ≡ _ =>
          match T with
          | sProd ?nx _ _ =>
            change T with (llift0 #|Γm| (sProd nx A1 B1))
          end
        end.
        apply llift_conv. eassumption.
      * apply conv_eq. cbn. reflexivity.
      * match goal with
        | |- ?T ≡ _ =>
          match T with
          | sProd ?ny _ _ =>
            change T with (rlift0 #|Γm| (sProd ny A2 B2))
          end
        end.
        apply rlift_conv. eassumption.
      * apply conv_eq. cbn. reflexivity.

  (* App *)
  - destruct (IHsim1 Γ Γ1 Γ2) as [pu hpu].
    destruct (IHsim2 Γ Γ1 Γ2) as [pA hpA].
    destruct (IHsim3 Γ (Γ1,, A1) (Γ2,, A2)) as [pB hpB].
    destruct (IHsim4 Γ Γ1 Γ2) as [pv hpv].
    exists (optCongApp (llift #|Γ1| 1 B1) (rlift #|Γ1| 1 B2) pu pA pB pv).
    intros Γm U1 U2 hm h1 h2.
    pose proof (mix_length1 hm) as ml. rewrite <- ml.
    ttinv h1. ttinv h2.
    specialize (hpu _ _ _ hm h3 h8).
    specialize (hpA _ _ _ hm h0 h7).
    destruct (istype_type hg hpA) as [? iA].
    ttinv iA. pose proof (sort_conv_inv h16) as hh. symmetry in hh. subst.
    clear h16.
    assert (s1 = s0).
    { eapply sorts_in_sort ; eassumption. }
    subst.
    assert (hm' :
              ismix Σ Γ
                    (Γ1 ,, A1)
                    (Γ2 ,, A2)
                    (Γm ,, (sPack (llift0 #|Γm| A1) (rlift0 #|Γm| A2)))
    ).
    { econstructor ; eassumption. }
    specialize (hpB _ _ _ hm' h h5).
    specialize (hpv _ _ _ hm h4 h9).
    assert (s3 = s2).
    { destruct (istype_type hg hpB) as [? ipB]. ttinv ipB.
      apply conv_sym in h20. pose proof (sort_conv_inv h20). subst. clear h20.
      eapply sorts_in_sort ; eassumption.
    } subst.
    eapply type_conv.
    + eapply opt_CongApp ; try assumption.
      * apply hpA.
      * rewrite llift_substProj, rlift_substProj.
        apply hpB.
      * apply hpu.
      * apply hpv.
      * lift_sort.
        eapply (@type_llift1 Sort_notion) ; eassumption.
      * lift_sort.
        eapply (@type_rlift1 Sort_notion) ; eassumption.
    + instantiate (1 := s2).
      eapply type_Heq.
      * lift_sort. eapply type_llift0 ; try eassumption.
        destruct (istype_type hg h1).
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym.
           eapply subj_conv ; [ eassumption | .. | eassumption ] ;
           try eassumption.
           lift_sort. eapply typing_subst ; eassumption.
      * lift_sort. eapply type_rlift0 ; try eassumption.
        destruct (istype_type hg h2).
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym.
           eapply subj_conv ; [ eassumption | .. | eassumption ] ;
           try eassumption.
           lift_sort. eapply typing_subst ; eassumption.
      * eapply type_llift0 ; eassumption.
      * eapply type_rlift0 ; eassumption.
    + cbn. apply cong_Heq.
      all: try (apply conv_refl).
      * rewrite <- llift_subst. cbn.
        apply llift_conv. assumption.
      * rewrite <- rlift_subst. cbn.
        apply rlift_conv. assumption.

  (* Pair *)
  - destruct (IHsim1 Γ Γ1 Γ2) as [pA hpA].
    destruct (IHsim2 Γ (Γ1,, A1) (Γ2,, A2)) as [pB hpB].
    destruct (IHsim3 Γ Γ1 Γ2) as [pu hpu].
    destruct (IHsim4 Γ Γ1 Γ2) as [pv hpv].
    clear IHsim1 IHsim2 IHsim3 IHsim4.
    exists (sCongPair (llift #|Γ1| 1 B1) (rlift #|Γ1| 1 B2) pA pB pu pv).
    intros Γm U1 U2 hm h1 h2.
    pose proof (mix_length1 hm) as ml. rewrite <- ml.
    ttinv h1. ttinv h2.
    specialize (hpA _ _ _ hm h0 h7).
    destruct (istype_type hg hpA) as [? iA].
    ttinv iA. pose proof (sort_conv_inv h16) as hh. symmetry in hh. subst.
    clear h16.
    assert (s1 = s0).
    { eapply sorts_in_sort ; eassumption. }
    subst.
    assert (hm' :
              ismix Σ Γ
                    (Γ1 ,, A1)
                    (Γ2 ,, A2)
                    (Γm ,, (sPack (llift0 #|Γm| A1) (rlift0 #|Γm| A2)))
    ).
    { econstructor ; eassumption. }
    specialize (hpB _ _ _ hm' h h5).
    assert (s3 = s2).
    { destruct (istype_type hg hpB) as [? ipB]. ttinv ipB.
      apply conv_sym in h20. pose proof (sort_conv_inv h20). subst. clear h20.
      eapply sorts_in_sort ; eassumption.
    } subst.
    specialize (hpu _ _ _ hm h3 h8).
    specialize (hpv _ _ _ hm h4 h9).
    eapply type_conv.
    + eapply type_CongPair' ; try assumption.
      * apply hpA.
      * rewrite llift_substProj, rlift_substProj.
        apply hpB.
      * apply hpu.
      * replace 0 with (0 + 0)%nat in hpv by mylia.
        rewrite llift_subst, rlift_subst in hpv.
        apply hpv.
      * lift_sort. eapply (@type_llift1 Sort_notion) ; eassumption.
      * lift_sort. eapply (@type_rlift1 Sort_notion) ; eassumption.
    + instantiate (1 := sum_sort s0 s2).
      apply type_Heq.
      * lift_sort. eapply type_llift0 ; try eassumption.
        destruct (istype_type hg h1).
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym.
           eapply subj_conv ; [ eassumption | .. | eassumption ] ;
           try eassumption.
           econstructor ; eassumption.
      * lift_sort. eapply type_rlift0 ; try eassumption.
        destruct (istype_type hg h2).
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym.
           eapply subj_conv ; [ eassumption | .. | eassumption ] ;
           try eassumption.
           econstructor ; eassumption.
      * eapply type_llift0 ; eassumption.
      * eapply type_rlift0 ; eassumption.
    + cbn. apply cong_Heq.
      all: try apply conv_refl.
      * match goal with
        | |- ?t ≡ _ =>
          match t with
          | sSum ?nx (llift ?n ?k ?A) (llift _ _ ?B) =>
            change t with (llift n k (sSum nx A B))
          end
        end.
        apply llift_conv. eassumption.
      * match goal with
        | |- ?t ≡ _ =>
          match t with
          | sSum ?nx (rlift ?n ?k ?A) (rlift _ _ ?B) =>
            change t with (rlift n k (sSum nx A B))
          end
        end.
        apply rlift_conv. eassumption.

  (* Pi1 *)
  - destruct (IHsim1 Γ Γ1 Γ2) as [pA hpA].
    destruct (IHsim2 Γ (Γ1,, A1) (Γ2,, A2)) as [pB hpB].
    destruct (IHsim3 Γ Γ1 Γ2) as [pp hpp].
    exists (sCongPi1 (llift #|Γ1| 1 B1) (rlift #|Γ1| 1 B2) pA pB pp).
    intros Γm U1 U2 hm h1 h2.
    pose proof (mix_length1 hm) as ml. rewrite <- ml.
    ttinv h1. ttinv h2.
    specialize (hpA _ _ _ hm h h4).
    destruct (istype_type hg hpA) as [? iA].
    ttinv iA. pose proof (sort_conv_inv h14) as hh. symmetry in hh. subst.
    clear h14.
    assert (s1 = s0).
    { eapply sorts_in_sort ; eassumption. }
    subst.
    assert (hm' :
              ismix Σ Γ
                    (Γ1 ,, A1)
                    (Γ2 ,, A2)
                    (Γm ,, (sPack (llift0 #|Γm| A1) (rlift0 #|Γm| A2)))
    ).
    { econstructor ; eassumption. }
    specialize (hpB _ _ _ hm' h3 h7).
    assert (s3 = s2).
    { destruct (istype_type hg hpB) as [? ipB]. ttinv ipB.
      apply conv_sym in h18. pose proof (sort_conv_inv h18). subst. clear h18.
      eapply sorts_in_sort ; eassumption.
    } subst.
    specialize (hpp _ _ _ hm h0 h6).
    eapply type_conv.
    + eapply type_CongPi1' ; try assumption.
      * apply hpA.
      * rewrite llift_substProj, rlift_substProj.
        apply hpB.
      * apply hpp.
      * lift_sort. eapply (@type_llift1 Sort_notion) ; eassumption.
      * lift_sort. eapply (@type_rlift1 Sort_notion) ; eassumption.
    + instantiate (1 := s0).
      apply type_Heq.
      * lift_sort. eapply type_llift0 ; try eassumption.
        destruct (istype_type hg h1).
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym.
           eapply subj_conv ; [ eassumption | .. | eassumption ] ;
           eassumption.
      * lift_sort. eapply type_rlift0 ; try eassumption.
        destruct (istype_type hg h2).
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym.
           eapply subj_conv ; [ eassumption | .. | eassumption ] ;
           eassumption.
      * eapply type_llift0 ; eassumption.
      * eapply type_rlift0 ; eassumption.
    + cbn. apply cong_Heq.
      all: try apply conv_refl.
      * apply llift_conv. assumption.
      * apply rlift_conv. assumption.

  (* Pi2 *)
  - destruct (IHsim1 Γ Γ1 Γ2) as [pA hpA].
    destruct (IHsim2 Γ (Γ1,, A1) (Γ2,, A2)) as [pB hpB].
    destruct (IHsim3 Γ Γ1 Γ2) as [pp hpp].
    exists (sCongPi2 (llift #|Γ1| 1 B1) (rlift #|Γ1| 1 B2) pA pB pp).
    intros Γm U1 U2 hm h1 h2.
    pose proof (mix_length1 hm) as ml. rewrite <- ml.
    ttinv h1. ttinv h2.
    specialize (hpA _ _ _ hm h h4).
    destruct (istype_type hg hpA) as [? iA].
    ttinv iA. pose proof (sort_conv_inv h14) as hh. symmetry in hh. subst.
    clear h14.
    assert (s1 = s0).
    { eapply sorts_in_sort ; eassumption. }
    subst.
    assert (hm' :
              ismix Σ Γ
                    (Γ1 ,, A1)
                    (Γ2 ,, A2)
                    (Γm ,, (sPack (llift0 #|Γm| A1) (rlift0 #|Γm| A2)))
    ).
    { econstructor ; eassumption. }
    specialize (hpB _ _ _ hm' h3 h7).
    assert (s3 = s2).
    { destruct (istype_type hg hpB) as [? ipB]. ttinv ipB.
      apply conv_sym in h18. pose proof (sort_conv_inv h18). subst. clear h18.
      eapply sorts_in_sort ; eassumption.
    } subst.
    specialize (hpp _ _ _ hm h0 h6).
    eapply type_conv.
    + eapply type_CongPi2' ; try assumption.
      * apply hpA.
      * rewrite llift_substProj, rlift_substProj.
        apply hpB.
      * apply hpp.
      * lift_sort. eapply (@type_llift1 Sort_notion) ; eassumption.
      * lift_sort. eapply (@type_rlift1 Sort_notion) ; eassumption.
    + instantiate (1 := s2).
      apply type_Heq.
      * lift_sort. eapply type_llift0 ; try eassumption.
        destruct (istype_type hg h1).
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym.
           eapply subj_conv ; [ eassumption | .. | eassumption ] ;
           try eassumption.
           lift_sort. eapply typing_subst ; try eassumption.
           eapply type_Pi1' ; eassumption.
      * lift_sort. eapply type_rlift0 ; try eassumption.
        destruct (istype_type hg h2).
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym.
           eapply subj_conv ; [ eassumption | .. | eassumption ] ;
           try eassumption.
           lift_sort. eapply typing_subst ; try eassumption.
           eapply type_Pi1' ; eassumption.
      * eapply type_llift0 ; eassumption.
      * eapply type_rlift0 ; eassumption.
    + cbn. apply cong_Heq.
      all: try apply conv_refl.
      * match goal with
        | |- _ { 0 := ?t } ≡ _ =>
          match t with
          | sPi1 (llift ?n ?k ?A) (llift _ _ ?B) (llift _ _ ?p) =>
            change t with (llift n k (sPi1 A B p))
          end
        end.
        rewrite <- llift_subst. cbn.
        apply llift_conv. assumption.
      * match goal with
        | |- _ { 0 := ?t } ≡ _ =>
          match t with
          | sPi1 (rlift ?n ?k ?A) (rlift _ _ ?B) (rlift _ _ ?p) =>
            change t with (rlift n k (sPi1 A B p))
          end
        end.
        rewrite <- rlift_subst. cbn.
        apply rlift_conv. assumption.

  (* Refl *)
  - destruct (IHsim1 Γ Γ1 Γ2) as [pA hpA].
    destruct (IHsim2 Γ Γ1 Γ2) as [pu hpu].
    exists (optCongRefl pA pu).
    intros Γm U1 U2 hm h1 h2.
    ttinv h1. ttinv h2.
    specialize (hpA _ _ _ hm h0 h5).
    specialize (hpu _ _ _ hm h h3).
    assert (s0 = s).
    { destruct (istype_type hg hpA) as [? ipA]. ttinv ipA.
      eapply sorts_in_sort ; eassumption.
    } subst.
    eapply type_conv.
    + eapply opt_CongRefl ; eassumption.
    + instantiate (1 := eq_sort s).
      eapply type_Heq.
      * lift_sort. eapply type_llift0 ; try eassumption.
        destruct (istype_type hg h1).
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym.
           eapply subj_conv ; [ eassumption | .. | eassumption ] ;
           try eassumption.
           econstructor ; eassumption.
      * lift_sort. eapply type_rlift0 ; try eassumption.
        destruct (istype_type hg h2).
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym.
           eapply subj_conv ; [ eassumption | .. | eassumption ] ;
           try eassumption.
           econstructor ; eassumption.
      * eapply type_llift0 ; eassumption.
      * eapply type_rlift0 ; eassumption.
    + apply cong_Heq.
      all: try apply conv_refl.
      * match goal with
        | |- ?u ≡ ?v =>
          change u with (llift0 #|Γm| (sEq A1 u1 u1))
        end.
        apply llift_conv. assumption.
      * match goal with
        | |- ?u ≡ ?v =>
          change u with (rlift0 #|Γm| (sEq A2 u2 u2))
        end.
        apply rlift_conv. assumption.

  (* Ax *)
  - case_eq (lookup_glob Σ id).
    + (* The axiom is in the global context *)
      intros ty eq.
      exists (sHeqRefl ty (sAx id)).
      intros Γm U1 U2 hm h1 h2.
      assert (h1' : Σ ;;; Γ ,,, Γm |-i sAx id : llift0 #|Γm| U1).
      { change (sAx id) with (llift0 #|Γm| (sAx id)).
        eapply type_llift0 ; eassumption.
      }
      assert (h2' : Σ ;;; Γ ,,, Γm |-i sAx id : rlift0 #|Γm| U2).
      { change (sAx id) with (rlift0 #|Γm| (sAx id)).
        eapply type_rlift0 ; eassumption.
      }
      pose proof (uniqueness hg h1' h2').
      destruct (istype_type hg h1).
      destruct (istype_type hg h2).
      eapply type_conv.
      * eapply type_HeqRefl' ; try assumption.
        econstructor ; try eassumption.
        eapply typing_wf. eassumption.
      * eapply type_Heq.
        -- lift_sort. eapply type_llift0 ; eassumption.
        -- lift_sort. eapply type_conv.
           ++ eapply type_rlift0 ; eassumption.
           ++ cbn. econstructor. eapply typing_wf. eassumption.
           ++ apply conv_sym. eapply subj_conv ; try eassumption.
              ** cbn. lift_sort.
                 eapply type_llift0 ; eassumption.
              ** eapply type_rlift0 ; eassumption.
        -- eapply type_llift0 ; eassumption.
        -- eapply type_rlift0 ; eassumption.
      * ttinv h1'. ttinv h2'.
        rewrite h0 in h4. inversion h4. subst.
        rewrite h0 in eq. inversion eq. subst.
        eapply cong_Heq.
        all: try (apply conv_refl). all: assumption.
    + (* The axiom isn't declared. We return garbage. *)
      intro neq.
      exists (sRel 0).
      intros Γm U1 U2 hm h1 h2.
      exfalso. ttinv h1.
      rewrite h0 in neq. discriminate neq.

  Unshelve.
  all: cbn ; try rewrite !length_cat ; mylia.
Defined.

Corollary trel_to_heq :
  forall {Σ} Γ {t1 t2 : sterm},
    type_glob Σ ->
    t1 ∼ t2 ->
    ∑ p,
      forall {T1 T2},
        Σ ;;; Γ |-i t1 : T1 ->
        Σ ;;; Γ |-i t2 : T2 ->
        Σ ;;; Γ |-i p : sHeq T1 t1 T2 t2.
Proof.
  intros Σ Γ t1 t2 hg h.
  destruct (trel_to_heq' hg h Γ [] []) as [p hp].
  exists p. intros T1 T2 h1 h2. specialize (hp _ _ _ (mixnil _ _) h1 h2).
  cbn in hp. rewrite !llift00, !rlift00 in hp.
  apply hp.
Defined.

Lemma inrel_lift :
  forall {t t'},
    t ⊏ t' ->
    forall n k, lift n k t ⊏ lift n k t'.
Proof.
  intros t t'. induction 1 ; intros m k.
  all: try (cbn ; now constructor).
  cbn. destruct (k <=? x) ; now constructor.
Defined.

Lemma inrel_subst :
  forall {t t'},
    t ⊏ t' ->
    forall {u u'},
      u ⊏ u' ->
      forall n, t{ n := u } ⊏ t'{ n := u' }.
Proof.
  intros t t'. induction 1 ; intros v1 v2 hu m.
  all: try (cbn ; constructor ; easy).
  cbn. destruct (m ?= x).
  - now apply inrel_lift.
  - constructor.
  - constructor.
Defined.

Lemma inrel_nl :
  forall {u u' v},
    u ⊏ u' ->
    nl u = nl v ->
    v ⊏ u'.
Proof.
  intros u u' v h eq.
  revert v eq. induction h.
  all: intros w eq.
  2:{ constructor. eapply IHh. assumption. }
  all: destruct w ; try discriminate eq.
  all: cbn in eq ; inversion eq ; now constructor.
Defined.

Lemma trel_lift :
  forall {t1 t2},
    t1 ∼ t2 ->
    forall n k, lift n k t1 ∼ lift n k t2.
Proof.
  intros t1 t2. induction 1 ; intros n k.
  all: try (cbn ; now constructor).
  cbn. destruct (k <=? x) ; now constructor.
Defined.

Lemma trel_subst :
  forall {t1 t2},
    t1 ∼ t2 ->
    forall {u1 u2},
      u1 ∼ u2 ->
      forall n, t1{ n := u1 } ∼ t2{ n := u2 }.
Proof.
  intros t1 t2. induction 1 ; intros m1 m2 hu n.
  all: try (cbn ; constructor ; easy).
  unfold subst. destruct (n ?= x).
  - now apply trel_lift.
  - apply trel_Rel.
  - apply trel_Rel.
Defined.

(* Reflexivity is restricted to the syntax that makes sense in ETT. *)
Lemma trel_refl :
  forall {t},
    Xcomp t ->
    t ∼ t.
Proof.
  intros t h. dependent induction h.
  all: constructor. all: assumption.
Defined.

Lemma inrel_refl :
  forall {t},
    Xcomp t ->
    t ⊏ t.
Proof.
  intros t h. dependent induction h.
  all: constructor. all: assumption.
Defined.

Lemma trel_sym : forall {t1 t2}, t1 ∼ t2 -> t2 ∼ t1.
Proof.
  intros t1 t2. induction 1 ; (now constructor).
Defined.

Lemma inversion_trel_transport :
  forall {A B p t1 t2},
    sTransport A B p t1 ∼ t2 ->
    t1 ∼ t2.
Proof.
  intros A B p t1 t2 h.
  dependent induction h.
  - assumption.
  - constructor. eapply IHh.
Defined.

Lemma trel_trans :
  forall {t1 t2},
    t1 ∼ t2 ->
    forall {t3},
      t2 ∼ t3 ->
      t1 ∼ t3.
Proof.
  intros t1 t2. induction 1 ; intros t3 h.
  all: try (
    dependent induction h ; [
      constructor ; eapply IHh ; assumption
    | now constructor
    ]
  ).
  - constructor. now apply IHX.
  - apply IHX. eapply inversion_trel_transport. eassumption.
Defined.

Reserved Notation " Γ ≈ Δ " (at level 19).

Inductive crel : scontext -> scontext -> Type :=
| crel_empty : nil ≈ nil
| crel_snoc Γ Δ t u : Γ ≈ Δ -> t ∼ u -> (Γ ,, t) ≈ (Δ ,, u)

where " Γ ≈ Δ " := (crel Γ Δ).

Reserved Notation " Γ ⊂ Γ' " (at level 19).

Inductive increl : scontext -> scontext -> Type :=
| increl_empty : nil ⊂ nil
| increl_snoc Γ Γ' T T' :
    Γ ⊂ Γ' -> T ⊏ T' -> (Γ ,, T) ⊂ (Γ' ,, T')

where " Γ ⊂ Γ' " := (increl Γ Γ').

(*! Notion of translation *)
Definition trans Σ Γ A t Γ' A' t' :=
  Γ ⊂ Γ' *
  A ⊏ A' *
  t ⊏ t' *
  (Σ ;;; Γ' |-i t' : A').

End Fundamental.

Notation " Γ ≈ Δ " := (crel Γ Δ) (at level 19).

Notation " Γ ⊂ Γ' " := (increl Γ Γ') (at level 19).

Notation " Σ ;;;; Γ' ⊢ [ t' ] : A' ∈ ⟦ Γ ⊢ [ t ] : A ⟧ " :=
  (trans Σ Γ A t Γ' A' t')
    (at level 7) : i_scope.

Definition ctxtrans `{Sort_notion : Sorts.notion} Σ Γ Γ' :=
  Γ ⊂ Γ' * (wf Σ Γ').

Notation " Σ |--i Γ' ∈ ⟦ Γ ⟧ " := (ctxtrans Σ Γ Γ') (at level 7) : i_scope.

Section Head.

Context `{Sort_notion : Sorts.notion}.

(* Notion of head *)
Inductive head_kind :=
| headRel
| headSort (s : sort)
| headProd
| headLambda
| headApp
| headSum
| headPi1
| headPi2
| headEq
| headRefl
| headJ
| headTransport
| headHeq
| headOther
.

Definition head (t : sterm) : head_kind :=
  match t with
  | sRel x => headRel
  | sSort s => headSort s
  | sProd n A B => headProd
  | sLambda n A B t => headLambda
  | sApp u A B v => headApp
  | sSum _ _ _ => headSum
  | sPi1 _ _ _ => headPi1
  | sPi2 _ _ _ => headPi2
  | sEq A u v => headEq
  | sRefl A u => headRefl
  | sJ A u P w v p => headJ
  | sTransport A B p t => headTransport
  | sHeq A a B b => headHeq
  (* We actually only care about type heads in the source *)
  | _ => headOther
  end.

Inductive transport_data :=
| trd (T1 T2 p : sterm).

Definition transport_data_app (td : transport_data) (t : sterm) : sterm :=
  match td with
  | trd T1 T2 p => sTransport T1 T2 p t
  end.

Definition transport_seq := list transport_data.

Definition transport_seq_app (tr : transport_seq) (t : sterm) : sterm :=
  List.fold_right transport_data_app t tr.

Lemma trel_transport_seq :
  forall {A A'},
    A ⊏ A' ->
    ∑ A'' (tseq : transport_seq),
      (head A'' = head A) *
      (A' = transport_seq_app tseq A'') *
      (A ⊏ A'').
Proof.
  intros A A' h.
  induction h.
 all : try (eexists ; exists nil ; split;  [split ; [idtac | reflexivity]| idtac]; [reflexivity | now constructor ]).

  destruct IHh as [A'' [tseq [[hh he] hsub]]].
  exists A'', (trd T1 T2 p :: tseq). split ; [split | idtac].
  assumption.
  cbn. now f_equal.
  assumption.
Defined.

(* We only need it for heads in the source *)
Inductive type_head : head_kind -> Type :=
| type_headSort s : type_head (headSort s)
| type_headProd : type_head headProd
| type_headSum : type_head headSum
| type_headEq : type_head headEq
.

Lemma inversion_transportType :
  forall {Σ tseq Γ' A' T},
    type_glob Σ ->
    type_head (head A') ->
    Σ ;;; Γ' |-i transport_seq_app tseq A' : T ->
    exists s,
      (Σ ;;; Γ' |-i A' : sSort s) /\
      (Σ ;;; Γ' |-i T : sSort (Sorts.succ s)).
Proof.
  intros Σ tseq. induction tseq ; intros Γ' A' T hg hh ht.

  - cbn in *. destruct A' ; try (now inversion hh).
    + exists (Sorts.succ s). split.
      * apply type_Sort. apply (typing_wf ht).
      * ttinv ht. destruct (istype_type hg ht).
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym. eapply subj_conv ; try eassumption.
           econstructor. eapply typing_wf. eassumption.
    + ttinv ht.
      exists (Sorts.prod_sort s1 s2). split.
      * now apply type_Prod.
      * destruct (istype_type hg ht).
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym. eapply subj_conv ; try eassumption.
           econstructor. eapply typing_wf. eassumption.
    + ttinv ht.
      exists (Sorts.sum_sort s1 s2). split.
      * now apply type_Sum.
      * destruct (istype_type hg ht).
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym. eapply subj_conv ; try eassumption.
           econstructor. eapply typing_wf. eassumption.
    + ttinv ht.
      exists (eq_sort s). split.
      * now apply type_Eq.
      * destruct (istype_type hg ht).
        eapply type_conv ; try eassumption.
        -- econstructor. eapply typing_wf. eassumption.
        -- apply conv_sym. eapply subj_conv ; try eassumption.
           econstructor. eapply typing_wf. eassumption.

  - destruct a. cbn in ht.
    change (fold_right transport_data_app A' tseq)
      with (transport_seq_app tseq A') in ht.
    ttinv ht.
    destruct (IHtseq Γ' A' T1 hg hh h) as [s' [hAs hT1s]].
    exists s'. split.
    + assumption.
    + pose proof (uniqueness hg h1 hT1s) as hs.
      apply conv_sym in hs. pose proof (sort_conv_inv hs) as es.
      rewrite es in *. clear hs.
      destruct (istype_type hg ht).
      eapply type_conv ; try eassumption.
      * econstructor. eapply typing_wf. eassumption.
      * apply conv_sym. eapply subj_conv ; eassumption.
Defined.

Lemma choose_type' :
  forall {Σ A A' t t'} Γ',
    type_glob Σ ->
    type_head (head A) ->
    A ⊏ A' ->
    t ⊏ t' ->
    ∑ A'',
      (∑ t'',
         (t ⊏ t'') *
         (A ⊏ A'') *
         (Σ ;;; Γ' |-i t' : A' -> Σ;;; Γ' |-i t'' : A'')) *
      (head A'' = head A).
Proof.
  intros Σ A A' t t' Γ' hg hth hA ht.
  destruct (trel_transport_seq hA) as [A'' [tseq [[hh heq] hrel]]].
  exists A''. split.
  - case_eq (DecideConversion.isconv (2 ^ 18) A' A'').
    + intro eq. exists t'. repeat split ; try assumption.
      intro h.
      rewrite heq in h.
      destruct (istype_type hg h) as [s hs].
      assert (hth' : type_head (head A'')) by (now rewrite hh).
      destruct (inversion_transportType hg hth' hs) as [s' [h' hss']].
      apply @DecideConversion.isconv_sound in eq.
      rewrite <- heq in h.
      eapply type_conv ; eassumption.
    + intros _.
      assert (simA : A' ∼ A'').
      { apply trel_sym.
        eapply trel_trans.
        - apply trel_sym. apply inrel_trel. eassumption.
        - apply inrel_trel. assumption.
      }
      { destruct (trel_to_heq Γ' hg simA) as [p hp].
        exists (optTransport A' A'' (optHeqToEq p) t').
        repeat split.
        + apply inrel_optTransport. assumption.
        + assumption.
        + intro h.
          rewrite heq in h.
          destruct (istype_type hg h) as [s hs].
          assert (hth' : type_head (head A'')) by (now rewrite hh).
          destruct (inversion_transportType hg hth' hs) as [s' [h' hss']].
          specialize (hp (sSort s) (sSort s)).
          rewrite <- heq in hs.
          assert (hAs : Σ ;;; Γ' |-i A'' : sSort s).
          { eapply type_conv.
            - eassumption.
            - eapply type_Sort. eapply typing_wf. eassumption.
            - cut (s' = s).
              + intro. subst. apply conv_refl.
              + eapply sorts_in_sort ; try eassumption.
                apply type_Sort. apply (typing_wf h').
          }
          specialize (hp hs hAs).
          pose proof (opt_sort_heq hg hp) as hq.
          destruct (istype_type hg hp) as [? hEq].
          ttinv hEq.
          eapply opt_Transport ; try eassumption.
          subst. assumption.
      }
  - assumption.
Defined.

Lemma choose_type :
  forall {Σ Γ A t Γ' A' t'},
    type_glob Σ ->
    type_head (head A) ->
    Σ ;;;; Γ' ⊢ [ t' ] : A' ∈ ⟦ Γ ⊢ [t] : A ⟧ ->
    ∑ A'',
      (∑ t'', Σ ;;;; Γ' ⊢ [ t'' ] : A'' ∈ ⟦ Γ ⊢ [t] : A ⟧) *
      (head A'' = head A).
Proof.
  intros Σ Γ A t Γ' A' t' hg htt [[[hΓ hA] ht] h].
  destruct (choose_type' Γ' hg htt hA ht) as [A'' [[t'' [[? ?] hh]] ?]].
  exists A''. split.
  - exists t''. repeat split ; try assumption.
    apply hh. assumption.
  - assumption.
Defined.

Lemma change_type :
  forall {Σ Γ A t Γ' A' t' s A''},
    type_glob Σ ->
    Σ ;;;; Γ' ⊢ [ t' ] : A' ∈ ⟦ Γ ⊢ [t] : A ⟧ ->
    Σ ;;;; Γ' ⊢ [ A'' ] : sSort s ∈ ⟦ Γ ⊢ [A] : sSort s ⟧ ->
    ∑ t'', Σ ;;;; Γ' ⊢ [ t'' ] : A'' ∈ ⟦ Γ ⊢ [t] : A ⟧.
Proof.
  intros Σ Γ A t Γ' A' t' s A'' hg [[[rΓ' rA'] rt'] ht'] [[[rΓ'' _] rA''] hA''].
  assert (simA : A' ∼ A'').
  { eapply trel_trans.
    - eapply trel_sym. eapply inrel_trel. eassumption.
    - eapply inrel_trel. eassumption.
  }
  destruct (trel_to_heq Γ' hg simA) as [p hp].
  case_eq (DecideConversion.isconv (2 ^ 18) A' A'').
  - intro eq. exists t'. repeat split ; try assumption.
    apply @DecideConversion.isconv_sound in eq.
    eapply type_conv ; eassumption.
  - exists (optTransport A' A'' (optHeqToEq p) t').
    repeat split.
    + assumption.
    + assumption.
    + apply inrel_optTransport. assumption.
    + destruct (istype_type hg ht') as [s2 hA'].
      specialize (hp (sSort s2) (sSort s) hA' hA'').
      destruct (istype_type hg hp) as [s1 hheq].
      assert (Σ ;;; Γ' |-i sSort s : sSort (Sorts.succ s)).
      { apply type_Sort. apply (typing_wf hp). }
      ttinv hheq.
      assert (s2 = s).
      { eapply sorts_in_sort ; eassumption. } subst.
      eapply opt_Transport ; try assumption.
      eapply opt_HeqToEq ; eassumption.
Defined.

End Head.


(** This file has been manually derived from UniqSet.hs, with modifications in support of
    the UniqSet invariant. *)

(* Default settings (from HsToCoq.Coq.Preamble) *)

Generalizable All Variables.

Unset Implicit Arguments.
Set Maximal Implicit Insertion.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Coq.Program.Tactics.
Require Coq.Program.Wf.

(* Converted imports: *)

Require Data.Foldable.
Require GHC.Base.
Require GHC.Prim.
Require UniqFM.
Require Unique.
Import GHC.Base.Notations.
Import GHC.Base.ManualNotations.

Import Unique.
Import UniqFM.
Import GHC.Base.

(* Converted type declarations: *)

Require Proofs.GHC.List.
Require Proofs.Data.Foldable.
Require Import Data.IntMap.Internal.

Require Import Proofs.ContainerAxioms.
Require Import Proofs.Unique.

(* Properties about Uniques that we need. *)

Lemma lookup_delFromUFM:
  forall A (H: Uniquable A) z (s : UniqFM A) (x y: A),
   (lookupUFM s x = Some y ->
       getUnique x = getUnique y) ->
      lookupUFM (delFromUFM s z) x = Some y ->
      getUnique x = getUnique y.
Proof.
  intros A H z s x y Hu.
  unfold lookupUFM in *.
  destruct s; unfold delFromUFM in *.
  destruct (eqUnique (getUnique z) (getUnique x)) eqn:EQ.
  - apply eqUnique_eq in EQ. rewrite <- EQ in *.
    rewrite delete_eq.
    intro C. inversion C.
  - apply eqUnique_neq in EQ.
    intro L.
    rewrite delete_neq in L.
    + apply (Hu L).
    + unfold getWordKey.
      unfold getKey.
      unfold not in *.
      intro h.
      apply EQ.
      destruct (getUnique x).
      destruct (getUnique z).
      subst.
      auto.
Qed.

Lemma lookup_fold_left_app_delFromUFM:
  forall {A} {H: Uniquable A} (s : UniqFM A) (x y: A) (zs: list A),
    (lookupUFM s x = Some y ->
     getUnique x = getUnique y) ->
    lookupUFM (fold_left delFromUFM zs s) x = Some y ->
    getUnique x = getUnique y.
Proof.
  intros A H s x y zs.
  revert s.
  induction zs as [ | z zs']; intros s.
  - rewrite List.List_foldl_foldr.
    unfold Datatypes.id.
    simpl.
    intros.
    auto.
  - simpl.
    intros Hl Hf.
    apply (IHzs' (delFromUFM s z)); [|auto].
    apply lookup_delFromUFM.
    auto.
Qed.

Lemma lookup_delFromUFM_Directly:
  forall A (H: Uniquable A) z (s : UniqFM A) (x y: A),
   (lookupUFM s x = Some y ->
       getUnique x = getUnique y) ->
      lookupUFM (delFromUFM_Directly s z) x = Some y ->
      getUnique x = getUnique y.
Proof.
  intros A H z s x y Hu.
  unfold lookupUFM in *.
  destruct s; unfold delFromUFM_Directly in *.
  destruct (eqUnique (getUnique x) z) eqn:EQ.
  - apply eqUnique_eq in EQ. rewrite <- EQ in *.
    rewrite delete_eq.
    intro C. inversion C.
  - apply eqUnique_neq in EQ.
    intro L.
    rewrite delete_neq in L.
    + apply (Hu L).
    + unfold getWordKey.
      unfold getKey.
      unfold not in *.
      destruct (getUnique x).
      destruct z as [n'].
      intros Hg.
      apply EQ.
      f_equal.
      assumption.
Qed.

Lemma lookup_fold_left_app_delFromUFM_Directly:
  forall {A} {H: Uniquable A} (s : UniqFM A) (x y: A)
    (zs: list Unique),
    (lookupUFM s x = Some y ->
     getUnique x = getUnique y) ->
    lookupUFM (fold_left delFromUFM_Directly zs s) x = Some y ->
    getUnique x = getUnique y.
Proof.
  intros A H s x y zs.
  revert s.
  induction zs as [ | z zs']; intros s.
  - rewrite List.List_foldl_foldr.
    unfold Datatypes.id.
    simpl.
    intros.
    auto.
  - simpl.
    intros Hl Hf.
    apply (IHzs' (delFromUFM s z)); [|auto].
    apply lookup_delFromUFM_Directly.
    auto.
Qed.

Lemma lookup_difference:
  forall A (H: Uniquable A) (i i' : IntMap A) (n:N) (y:A),
    (forall y, lookup n i = Some y -> MkUnique n = getUnique y) ->
    (forall y, lookup n i' = Some y -> MkUnique n = getUnique y) ->
    lookup n (difference i i') = Some y ->
    MkUnique n = getUnique y.
Proof.
  intros A H i i' n y Hi Hi' Hd.
  destruct (lookup n i') eqn:Hli'.
  - erewrite lookup_difference_in_snd in Hd;
      [|eassumption].
    inversion Hd.
  - erewrite lookup_difference_not_in_snd in Hd;
      try eassumption.
    auto.
Qed.

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

(** The invariant is that for any unique, the result that we get out has
    the same unique stored.
*)
Polymorphic Definition UniqInv@{i} {a:Type@{i}} (fm : UniqFM.UniqFM a) `{Unique.Uniquable a} : Type@{i} :=
  forall (x:a)(y:a),
    UniqFM.lookupUFM fm x = Some y -> getUnique x = getUnique y.

Polymorphic Definition UniqSet@{i} (a:Type@{i}) `{Unique.Uniquable a} : Type@{i} :=
  sigT (fun fm => UniqInv fm).

Local Notation Mk_UniqSet s:= (@existT _ _ s _).

Definition getUniqSet' {a}`{Uniquable a} (arg_0__ : UniqSet a) :=
  let 'existT _ getUniqSet' _ := arg_0__ in
  getUniqSet'.

(* Converted value declarations: *)

(* SCW we DON'T want to coerce *)
(*
Instance Unpeel_UniqSet ele
   : GHC.Prim.Unpeel (UniqSet ele) (UniqFM.UniqFM ele) :=
  GHC.Prim.Build_Unpeel _ _ (fun '(Mk_UniqSet y) => y) Mk_UniqSet.
*)

(* Skipping instance Eq___UniqSet *)

(* Skipping instance Outputable__UniqSet of class Outputable *)

(* SCW: Monoid instances added by hand. *)

Program Definition Monoid__UniqSet_mempty {inst_a} `{Uniquable inst_a} : UniqSet inst_a :=
  Mk_UniqSet GHC.Base.mempty.

Program Definition Semigroup__UniqSet_op_zlzlzgzg__ {inst_a}`{Unique.Uniquable inst_a}
   : UniqSet inst_a -> UniqSet inst_a -> UniqSet inst_a :=
  fun m1 m2 => Mk_UniqSet (plusUFM (getUniqSet' m1) (getUniqSet' m2)).
Next Obligation.
  destruct m1. destruct m2.
  simpl.
  unfold UniqInv in *.
  intros y1 y2 Hu.
  unfold lookupUFM, plusUFM in *.
  destruct x. destruct x0.
  rewrite <- lookup_union in Hu.
  destruct Hu as [Hl |[_ Hr]].
  eauto.
  eauto.
Qed.

Program Instance Semigroup__UniqSet {a}`{Unique.Uniquable a} : GHC.Base.Semigroup (UniqSet a) :=
  fun _ k => k {| GHC.Base.op_zlzlzgzg____ := Semigroup__UniqSet_op_zlzlzgzg__ |}.

Local Definition Monoid__UniqSet_mappend {inst_a}`{Unique.Uniquable inst_a}
   : UniqSet inst_a -> UniqSet inst_a -> UniqSet inst_a :=
  Semigroup__UniqSet_op_zlzlzgzg__ .

Local Definition Monoid__UniqSet_mconcat {inst_a}`{Unique.Uniquable inst_a}
  : list (UniqSet inst_a) -> UniqSet inst_a :=
  GHC.Base.foldr Monoid__UniqSet_mappend Monoid__UniqSet_mempty.

Program Instance Monoid__UniqSet {a}`{Unique.Uniquable a} : GHC.Base.Monoid (UniqSet a) :=
  fun _ k =>
    k {| GHC.Base.mappend__ := Monoid__UniqSet_mappend ;
         GHC.Base.mconcat__ := Monoid__UniqSet_mconcat ;
         GHC.Base.mempty__ := Monoid__UniqSet_mempty |}.

(* Skipping instance Data__UniqSet of class Data *)

Program Definition addOneToUniqSet {a} `{Unique.Uniquable a}
   : UniqSet a -> a -> UniqSet a :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | Mk_UniqSet set, x => Mk_UniqSet (UniqFM.addToUFM set x x)
    end.
Next Obligation.
unfold UniqInv in *.
unfold UniqFM.addToUFM.
unfold UniqFM.lookupUFM in *.
intros.
destruct set.
rename arg_1__ into z.
destruct (eqUnique (getUnique z) (getUnique x)) eqn:EQ.
- apply eqUnique_eq in EQ. rewrite <- EQ in *.
  rewrite lookup_insert in H0.
  inversion H0.
  auto.
- apply eqUnique_neq in EQ.
  rewrite lookup_insert_neq in H0.
  apply wildcard'.
  auto.
  unfold getWordKey.
  unfold getKey.
  unfold not in *.
  intro h.
  apply EQ.
  destruct (getUnique x).
  destruct (getUnique z).
  subst.
  auto.
Defined.

Definition addListToUniqSet {a} `{Unique.Uniquable a}
   : UniqSet a -> list a -> UniqSet a :=
  Data.Foldable.foldl' addOneToUniqSet.

Program Definition delListFromUniqSet {a} `{Unique.Uniquable a}
   : UniqSet a -> list a -> UniqSet a :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | Mk_UniqSet s, l => Mk_UniqSet (UniqFM.delListFromUFM s l)
    end.
Next Obligation.
  unfold UniqInv in *.
  intros x y.
  specialize (wildcard' x y).
  unfold delListFromUFM in *.
  rewrite Foldable.hs_coq_foldl_list.
  apply lookup_fold_left_app_delFromUFM.
  assumption.
Qed.

Program Definition delListFromUniqSet_Directly {a} `{Unique.Uniquable a}
   : UniqSet a -> list Unique.Unique -> UniqSet a :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | Mk_UniqSet s, l => Mk_UniqSet (UniqFM.delListFromUFM_Directly s l)
    end.
Next Obligation.
  unfold UniqInv in *.
  intros x y.
  specialize (wildcard' x y).
  unfold delListFromUFM_Directly in *.
  rewrite Foldable.hs_coq_foldl_list.
  apply lookup_fold_left_app_delFromUFM_Directly.
  assumption.
Qed.

Program Definition delOneFromUniqSet {a} `{Unique.Uniquable a}
   : UniqSet a -> a -> UniqSet a :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | Mk_UniqSet s, a => Mk_UniqSet (UniqFM.delFromUFM s a)
    end.
Next Obligation.
  unfold UniqInv in *.
  intros x y.
  specialize (wildcard' x y).
  apply lookup_delFromUFM.
  assumption.
Defined.

Program Definition delOneFromUniqSet_Directly {a} `{Unique.Uniquable a}
   : UniqSet a -> Unique.Unique -> UniqSet a :=
  fun x y =>
    match x, y with
    | Mk_UniqSet s, u => Mk_UniqSet (UniqFM.delFromUFM_Directly s u)
    end.

Program Definition delOneFromUniqSet_Directly {a} `{Unique.Uniquable a}
   : UniqSet a -> Unique.Unique -> UniqSet a :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | Mk_UniqSet s, u => Mk_UniqSet (UniqFM.delFromUFM_Directly s u)
    end.
Next Obligation.
  unfold UniqInv in *.
  intros x y.
  specialize (wildcard' x y).
  apply lookup_delFromUFM_Directly.
  assumption.
Qed.

Definition elemUniqSet_Directly {a} `{Unique.Uniquable a} : Unique.Unique -> UniqSet a -> bool :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | a, Mk_UniqSet s => UniqFM.elemUFM_Directly a s
    end.

Definition elementOfUniqSet {a} `{Unique.Uniquable a}
   : a -> UniqSet a -> bool :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | a, Mk_UniqSet s => UniqFM.elemUFM a s
    end.

Program Definition emptyUniqSet {a} `{Unique.Uniquable a}: UniqSet a :=
  Mk_UniqSet UniqFM.emptyUFM.

Definition mkUniqSet {a} `{Unique.Uniquable a} : list a -> UniqSet a :=
  Data.Foldable.foldl' addOneToUniqSet emptyUniqSet.

Program Definition filterUniqSet {a} `{Unique.Uniquable a} : (a -> bool) -> UniqSet a -> UniqSet a :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | p, Mk_UniqSet s => Mk_UniqSet (UniqFM.filterUFM p s)
    end.
Next Obligation.
  unfold UniqInv in *.
  intros x y.
  unfold lookupUFM, filterUFM in *. unfold IntMap.Internal.filter.
  destruct s.
  intro h.
  apply wildcard'.
  eapply lookup_filterWithKey.
  eauto.
Defined.

Program Definition filterUniqSet_Directly {elt} `{Unique.Uniquable elt}
   : (Unique.Unique -> elt -> bool) -> UniqSet elt -> UniqSet elt :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | f, Mk_UniqSet s => Mk_UniqSet (UniqFM.filterUFM_Directly f s)
    end.
Next Obligation.
  unfold UniqInv in *.
  intros x y.
  unfold lookupUFM, filterUFM_Directly in *.
  destruct s.
  intro h.
  apply wildcard'.
  eapply lookup_filterWithKey.
  eauto.
Defined.

Definition getUniqSet {a} `{Unique.Uniquable a} : UniqSet a -> UniqFM.UniqFM a :=
  getUniqSet'.

Program Definition intersectUniqSets {a} `{Unique.Uniquable a} : UniqSet a -> UniqSet a -> UniqSet a :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | Mk_UniqSet s, Mk_UniqSet t => Mk_UniqSet (UniqFM.intersectUFM s t)
    end.
Next Obligation.
  unfold UniqInv in *.
  intros x y.
  unfold lookupUFM, intersectUFM in *.
  destruct s. destruct t.
  intro h.
  eapply lookup_intersection in h. destruct h.
  eauto.
Defined.

Definition isEmptyUniqSet {a} `{Unique.Uniquable a} : UniqSet a -> bool :=
  fun '(Mk_UniqSet s) => UniqFM.isNullUFM s.

Definition lookupUniqSet {a} {b} `{Unique.Uniquable a} `{Unique.Uniquable b}
   : UniqSet b -> a -> option b :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | Mk_UniqSet s, k => UniqFM.lookupUFM s k
    end.

Definition lookupUniqSet_Directly {a} `{Unique.Uniquable a}
   : UniqSet a -> Unique.Unique -> option a :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | Mk_UniqSet s, k => UniqFM.lookupUFM_Directly s k
    end.

Program Definition minusUniqSet {a} `{Unique.Uniquable a} : UniqSet a -> UniqSet a -> UniqSet a :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | Mk_UniqSet s, Mk_UniqSet t => Mk_UniqSet (UniqFM.minusUFM s t)
    end.
Next Obligation.
  unfold UniqInv in *.
  intros x y.
  unfold lookupUFM, minusUFM in *.
  destruct s. destruct t.
  unfold getWordKey in *.
  unfold getKey in *.
  specialize (wildcard'0 x).
  specialize (wildcard' x).
  destruct (getUnique x) in *.
  apply lookup_difference; auto.
Qed.

Definition nonDetEltsUniqSet {elt} `{Unique.Uniquable elt} : UniqSet elt -> list elt :=
  UniqFM.nonDetEltsUFM GHC.Base.∘ getUniqSet'.

Definition mapUniqSet {b} {a} `{Unique.Uniquable a} `{Unique.Uniquable b}
   : (a -> b) -> UniqSet a -> UniqSet b :=
  fun f => mkUniqSet GHC.Base.∘ (GHC.Base.map f GHC.Base.∘ nonDetEltsUniqSet).

Definition nonDetFoldUniqSet {elt} {a} `{Unique.Uniquable elt}
   : (elt -> a -> a) -> a -> UniqSet elt -> a :=
  fun arg_0__ arg_1__ arg_2__ =>
    match arg_0__, arg_1__, arg_2__ with
    | c, n, Mk_UniqSet s => UniqFM.nonDetFoldUFM c n s
    end.

Definition nonDetFoldUniqSet_Directly {elt} {a} `{Unique.Uniquable elt} `{Unique.Uniquable a}
   : (Unique.Unique -> elt -> a -> a) -> a -> UniqSet elt -> a :=
  fun arg_0__ arg_1__ arg_2__ =>
    match arg_0__, arg_1__, arg_2__ with
    | f, n, Mk_UniqSet s => UniqFM.nonDetFoldUFM_Directly f n s
    end.

Definition nonDetKeysUniqSet {elt} `{Unique.Uniquable elt} : UniqSet elt -> list Unique.Unique :=
  UniqFM.nonDetKeysUFM GHC.Base.∘ getUniqSet'.

Program Definition partitionUniqSet {a} `{Unique.Uniquable a}
   : (a -> bool) -> UniqSet a -> (UniqSet a * UniqSet a)%type :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | p, existT _ s _ => let '(x,y):= (UniqFM.partitionUFM p s) in (existT _ x _, existT _ y _)
    end.
Next Obligation.
  unfold UniqInv in *.
  intros x' y' Hl.
  apply wildcard'.
  destruct x as [m'].
  destruct s as [m].
  eapply lookup_partition; eauto.
Defined.

Next Obligation.
  unfold UniqInv in *.
  intros x' y' Hl.
  apply wildcard'.
  destruct y as [m'].
  destruct s as [m].
  eapply lookup_partition; eauto.
Defined.

Program Definition restrictUniqSetToUFM {a} {b} `{Unique.Uniquable a} `{Unique.Uniquable b}
   : UniqSet a -> UniqFM.UniqFM b -> UniqSet a :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | Mk_UniqSet s, m => Mk_UniqSet (UniqFM.intersectUFM s m)
    end.
Next Obligation.
  unfold UniqInv in *.
  intros x' y'.
  unfold lookupUFM, intersectUFM in *.
  destruct s.
  destruct arg_1__.
  intro h.
  rewrite <- lookup_intersection in h. destruct h.
  eauto.
Defined.

Definition sizeUniqSet {a} `{Unique.Uniquable a} : UniqSet a -> nat :=
  fun '(Mk_UniqSet s) => UniqFM.sizeUFM s.

Program Definition unionUniqSets {a} `{Unique.Uniquable a} : UniqSet a -> UniqSet a -> UniqSet a :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | Mk_UniqSet s, Mk_UniqSet t => Mk_UniqSet (UniqFM.plusUFM s t)
    end.
Next Obligation.
  unfold UniqInv in *.
  intros x y.
  unfold lookupUFM, plusUFM in *.
  destruct s. destruct t.
  intro h.
  rewrite <- lookup_union in h.
  destruct h as [h | [h1 h2]]; auto.
Qed.

Definition unionManyUniqSets {a} `{Unique.Uniquable a} (xs : list (UniqSet a)) : UniqSet a :=
  match xs with
  | nil => emptyUniqSet
  | cons set sets => Data.Foldable.foldr unionUniqSets set sets
  end.

Definition uniqSetAll {a} `{Unique.Uniquable a} : (a -> bool) -> UniqSet a -> bool :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | p, Mk_UniqSet s => UniqFM.allUFM p s
    end.

Definition uniqSetAny {a} `{Unique.Uniquable a} : (a -> bool) -> UniqSet a -> bool :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | p, existT _ s _ => UniqFM.anyUFM p s
    end.

(*
Program Definition uniqSetMinusUFM {a} {b} `{Unique.Uniquable a} `{Unique.Uniquable b}
   : UniqSet a -> UniqFM.UniqFM b -> UniqSet a :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | existT _ s _, t => Mk_UniqSet (UniqFM.minusUFM s t) _
    end.
Next Obligation.
Admitted. *)

Program Definition unitUniqSet {a} `{Unique.Uniquable a} : a -> UniqSet a :=
  fun x => Mk_UniqSet (UniqFM.unitUFM x x).
Next Obligation.
  unfold UniqInv.
  intros x0 y.
  unfold lookupUFM, unitUFM.
  unfold singleton.
  simpl.
  destruct (_GHC.Base.==_ (getWordKey (getUnique x0)) (getWordKey (getUnique x))) eqn:EQ.
  unfold Internal.Key, Num.Word in *.
  rewrite EQ.
  intro h. inversion h. subst.
  apply eq_getWordKey. auto.
  unfold Internal.Key, Num.Word in *.
  rewrite EQ.
  intro h. inversion h.
Defined.

(* Definition unsafeUFMToUniqSet {a} : UniqFM.UniqFM a -> UniqSet a :=
  Mk_UniqSet. *)

(* External variables:
     bool cons list nat op_zt__ option Data.Foldable.foldl' Data.Foldable.foldr
     GHC.Base.Monoid GHC.Base.Semigroup GHC.Base.map GHC.Base.mappend
     GHC.Base.mappend__ GHC.Base.mconcat GHC.Base.mconcat__ GHC.Base.mempty
     GHC.Base.mempty__ GHC.Base.op_z2218U__ GHC.Base.op_zlzlzgzg__
     GHC.Base.op_zlzlzgzg____ GHC.Prim.Build_Unpeel GHC.Prim.Unpeel GHC.Prim.coerce
     UniqFM.UniqFM UniqFM.addToUFM UniqFM.allUFM UniqFM.anyUFM UniqFM.delFromUFM
     UniqFM.delFromUFM_Directly UniqFM.delListFromUFM UniqFM.delListFromUFM_Directly
     UniqFM.elemUFM UniqFM.elemUFM_Directly UniqFM.emptyUFM UniqFM.filterUFM
     UniqFM.filterUFM_Directly UniqFM.intersectUFM UniqFM.isNullUFM UniqFM.lookupUFM
     UniqFM.lookupUFM_Directly UniqFM.minusUFM UniqFM.nonDetEltsUFM
     UniqFM.nonDetFoldUFM UniqFM.nonDetFoldUFM_Directly UniqFM.nonDetKeysUFM
     UniqFM.partitionUFM UniqFM.plusUFM UniqFM.sizeUFM UniqFM.unitUFM
     Unique.Uniquable Unique.Unique
*)


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B Aprime Bprime M1 Bprimeprime M2 Aprimeprime I : Universe, ((wd_ M1 I /\ (wd_ Bprimeprime M1 /\ (wd_ Bprime Aprimeprime /\ (wd_ Aprime Bprime /\ (wd_ Aprime Aprimeprime /\ (wd_ Bprimeprime I /\ (wd_ M1 B /\ (wd_ B Bprimeprime /\ (wd_ Bprime Bprimeprime /\ (wd_ Aprime Bprimeprime /\ (wd_ A B /\ (wd_ A Aprime /\ (wd_ A Bprime /\ (wd_ B Aprime /\ (wd_ B Bprime /\ (col_ Bprimeprime Aprime Bprime /\ (col_ Aprimeprime Aprime Bprime /\ (col_ M1 I B /\ (col_ Bprimeprime M1 I /\ (col_ Bprime I A /\ (col_ B M2 Aprimeprime /\ (col_ A M2 Bprime /\ (col_ B M1 Bprimeprime /\ (col_ A M1 Aprime /\ col_ Aprimeprime A Bprime)))))))))))))))))))))))) -> col_ A Aprime Bprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


(** Congruence relation of algebras *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Groupoids.
Require Import UniMath.CategoryTheory.whiskering.

Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.
Require Import UniMath.Bicategories.Core.Examples.Groupoids.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Algebras.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.DispDepProd.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Add2Cell.
Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction.
Require Import UniMath.Bicategories.Colimits.Initial.

Require Import UniMath.Bicategories.PseudoFunctors.Display.Base.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.

Require Import prelude.all.
Require Import signature.hit_signature.
Require Import signature.hit.
Require Import algebra.one_types_polynomials.
Require Import algebra.one_types_endpoints.
Require Import algebra.one_types_homotopies.
Require Import algebra.groupoid_polynomials.
Require Import algebra.groupoid_endpoints.
Require Import algebra.groupoid_homotopies.
Require Import hit_biadjunction.gquot_commute.
Require Import hit_biadjunction.gquot_natural.
Require Import hit_biadjunction.hit_algebra_biadj.lift_gquot.
Require Import hit_biadjunction.hit_path_algebra_biadj.lift_gquot.
Require Import hit_biadjunction.hit_path_algebra_biadj.counit.
Require Import hit_biadjunction.hit_path_algebra_biadj.unit.
Require Import hit_biadjunction.hit_algebra_biadj.lift_path_groupoid.
Require Import hit_biadjunction.hit_algebra_biadj.
Require Import existence.initial_algebra.

Local Open Scope cat.

Section CongruenceRelation.
  Context {Σ : hit_signature}
          {X : hit_algebra_one_types Σ}.

  (** Definition of congruence relation *)
  Definition congruence_relation_groupoid
    : UU
    := ∑ (R : alg_carrier X → alg_carrier X → hSet),
       ∑ (R_id : ∏ x : alg_carrier X, R x x),
       ∑ (R_inv : ∏ x y : alg_carrier X, R x y → R y x),
       ∑ (R_comp : ∏ x y z : alg_carrier X, R x y → R y z → R x z),
       (∏ x y : alg_carrier X, ∏ r : R x y,
          R_comp x x y (R_id x) r = r)
       ×
       (∏ x y : alg_carrier X, ∏ r : R x y,
          R_comp x y y r (R_id y) = r)
       ×
       (∏ x y z w : alg_carrier X, ∏ r1 : R x y, ∏ r2 : R y z, ∏ r3 : R z w,
          R_comp x y w r1 (R_comp y z w r2 r3) = R_comp x z w (R_comp x y z r1 r2) r3)
       ×
       (∏ x y : alg_carrier X, ∏ r : R x y,
          R_comp y x y (R_inv x y r) r = R_id y)
       ×
       (∏ x y : alg_carrier X, ∏ r : R x y,
          R_comp x y x r (R_inv x y r) = R_id x).

  Definition make_congruence_relation_groupoid
             (R : alg_carrier X → alg_carrier X → UU)
             (Risaset : ∏ (x y : alg_carrier X), isaset (R x y))
             (R_id : ∏ (x : alg_carrier X), R x x)
             (R_inv : ∏ (x y : alg_carrier X), R x y → R y x)
             (R_comp : ∏ (x y z : alg_carrier X), R x y → R y z → R x z)
             (R_idl : ∏ (x y : alg_carrier X) (r : R x y),
                      R_comp x x y (R_id x) r = r)
             (R_idr : ∏ (x y : alg_carrier X) (r : R x y),
                      R_comp x y y r (R_id y) = r)
             (R_assoc : ∏ (x y z w : alg_carrier X)
                          (r1 : R x y) (r2 : R y z) (r3 : R z w),
                        R_comp x y w r1 (R_comp y z w r2 r3)
                        =
                        R_comp x z w (R_comp x y z r1 r2) r3)
             (R_invl : ∏ (x y : alg_carrier X) (r : R x y),
                       R_comp y x y (R_inv x y r) r = R_id y)
             (R_invr : ∏ (x y : alg_carrier X) (r : R x y),
                       R_comp x y x r (R_inv x y r) = R_id x)
    : congruence_relation_groupoid
    := (λ x y, make_hSet (R x y) (Risaset x y))
       ,, R_id
       ,, R_inv
       ,, R_comp
       ,, R_idl
       ,, R_idr
       ,, R_assoc
       ,, R_invl
       ,, R_invr.

  (** Projections *)
  Section ProjectionsCarrier.
    Variable (R : congruence_relation_groupoid).

    Definition cong_rel_carrier : alg_carrier X → alg_carrier X → hSet
      := pr1 R.

    Definition cong_rel_id
               (x : alg_carrier X)
      : cong_rel_carrier x x
      := pr12 R x.

    Definition eq_to_cong_rel
               {x y : alg_carrier X}
               (p : x = y)
      : cong_rel_carrier x y.
    Proof.
      induction p.
      exact (cong_rel_id x).
    Defined.

    Definition cong_rel_inv
               {x y : alg_carrier X}
               (r : cong_rel_carrier x y)
      : cong_rel_carrier y x
      := pr122 R x y r.

    Definition cong_rel_comp
               {x y z : alg_carrier X}
               (r1 : cong_rel_carrier x y)
               (r2 : cong_rel_carrier y z)
      : cong_rel_carrier x z
      := pr1 (pr222 R) x y z r1 r2.

    Definition cong_rel_lid
               {x y : alg_carrier X}
               (r : cong_rel_carrier x y)
      : cong_rel_comp (cong_rel_id x) r = r.
    Proof.
      exact (pr12 (pr222 R) x y r).
    Qed.

    Definition cong_rel_rid
               {x y : alg_carrier X}
               (r : cong_rel_carrier x y)
      : cong_rel_comp r (cong_rel_id y) = r.
    Proof.
      exact (pr122 (pr222 R) x y r).
    Qed.

    Definition cong_rel_assoc
               {x y z w : alg_carrier X}
               (r1 : cong_rel_carrier x y)
               (r2 : cong_rel_carrier y z)
               (r3 : cong_rel_carrier z w)
      : cong_rel_comp r1 (cong_rel_comp r2 r3)
        = cong_rel_comp (cong_rel_comp r1 r2) r3.
    Proof.
      exact (pr1 (pr222 (pr222 R)) x y z w r1 r2 r3).
    Qed.

    Definition cong_rel_linv
               {x y : alg_carrier X}
               (r : cong_rel_carrier x y)
      : cong_rel_comp (cong_rel_inv r) r = cong_rel_id y.
    Proof.
      exact (pr12 (pr222 (pr222 R)) x y r).
    Qed.

    Definition cong_rel_rinv
               {x y : alg_carrier X}
               (r : cong_rel_carrier x y)
      : cong_rel_comp r (cong_rel_inv r) = cong_rel_id x.
    Proof.
      exact (pr22 (pr222 (pr222 R)) x y r).
    Qed.
  End ProjectionsCarrier.

  Section MakeGroupoidFromCongruence.
    Variable (R : congruence_relation_groupoid).

    Definition make_groupoid_algebra_carrier_precategory_data
      : precategory_data.
    Proof.
      use make_precategory_data.
      - use make_precategory_ob_mor.
        + exact (alg_carrier X).
        + exact (cong_rel_carrier R).
      - exact (cong_rel_id R).
      - exact (@cong_rel_comp R).
    Defined.

    Definition make_groupoid_algebra_carrier_is_precategory
      : is_precategory make_groupoid_algebra_carrier_precategory_data.
    Proof.
      use make_is_precategory.
      - exact (@cong_rel_lid R).
      - exact (@cong_rel_rid R).
      - exact (@cong_rel_assoc R).
      - intros.
        refine (!_).
        apply cong_rel_assoc.
    Qed.

    Definition make_groupoid_algebra_carrier_precategory
      : precategory.
    Proof.
      use make_precategory.
      - exact make_groupoid_algebra_carrier_precategory_data.
      - exact make_groupoid_algebra_carrier_is_precategory.
    Defined.

    Definition make_groupoid_algebra_carrier_has_homsets
      : has_homsets make_groupoid_algebra_carrier_precategory.
    Proof.
      intros x y.
      apply (cong_rel_carrier R).
    Qed.

    Definition make_groupoid_algebra_carrier_category
      : category.
    Proof.
      use make_category.
      - exact make_groupoid_algebra_carrier_precategory.
      - exact make_groupoid_algebra_carrier_has_homsets.
    Defined.

    Definition make_groupoid_algebra_carrier_is_pregroupoid
      : is_pregroupoid make_groupoid_algebra_carrier_category.
    Proof.
      intros x y f.
      use make_is_z_isomorphism.
      - exact (cong_rel_inv R f).
      - split.
        + exact (cong_rel_rinv R f).
        + exact (cong_rel_linv R f).
    Defined.

    Definition make_groupoid_algebra_carrier
      : groupoid.
    Proof.
      use make_groupoid.
      - exact make_groupoid_algebra_carrier_category.
      - exact make_groupoid_algebra_carrier_is_pregroupoid.
    Defined.
  End MakeGroupoidFromCongruence.

  Definition is_congruence_relation_ops
             (R : congruence_relation_groupoid)
    : UU
    := ∑ (R_ops : ∏ x y : poly_act (point_constr Σ) (alg_carrier X),
            poly_act_rel (point_constr Σ) (pr1 R) x y →
            cong_rel_carrier R (alg_constr X x) (alg_constr X y)),
       (∏ x : poly_act (point_constr Σ) (alg_carrier X),
          R_ops x x (poly_act_rel_identity _ _ (pr12 R) x)
          =
          pr12 R (alg_constr X x))
        ×
       (∏ x y z : poly_act (point_constr Σ) (alg_carrier X),
          ∏ (r1 : poly_act_rel (point_constr Σ) (pr1 R) x y),
          ∏ (r2 : poly_act_rel (point_constr Σ) (pr1 R) y z),
          R_ops x z
               (poly_act_rel_comp (point_constr Σ) _ (pr1 (pr222 R)) r1 r2)
          =
          pr1 (pr222 R) (alg_constr X x) (alg_constr X y) (alg_constr X z)
              (R_ops x y r1) (R_ops y z r2)).

  Definition congruence_relation_ops
    : UU
    := ∑ (R : congruence_relation_groupoid),
       is_congruence_relation_ops R.

  Definition make_congruence_relation_ops
             (R : congruence_relation_groupoid)
             (R_ops : ∏ (x y : poly_act (point_constr Σ) (alg_carrier X)),
                      poly_act_rel (point_constr Σ) (pr1 R) x y
                      →
                      cong_rel_carrier R (alg_constr X x) (alg_constr X y))
             (R_opsid : ∏ (x : poly_act (point_constr Σ) (alg_carrier X)),
                        R_ops x x (poly_act_rel_identity _ _ (pr12 R) x)
                        =
                        pr12 R (alg_constr X x))
             (R_opscomp : (∏ (x y z : poly_act (point_constr Σ) (alg_carrier X))
                             (r1 : poly_act_rel (point_constr Σ) (pr1 R) x y)
                             (r2 : poly_act_rel (point_constr Σ) (pr1 R) y z),
                           R_ops
                             x z
                             (poly_act_rel_comp (point_constr Σ) _ (pr1 (pr222 R)) r1 r2)
                           =
                           pr1 (pr222 R)
                               (alg_constr X x) (alg_constr X y) (alg_constr X z)
                               (R_ops x y r1) (R_ops y z r2)))
    : congruence_relation_ops
    := (R ,, R_ops ,, R_opsid ,, R_opscomp).

  Definition congruence_relation_ops_to_congruence_relation_groupoid
    : congruence_relation_ops → congruence_relation_groupoid
    := λ z, pr1 z.

  Coercion congruence_relation_ops_to_congruence_relation_groupoid
    : congruence_relation_ops >-> congruence_relation_groupoid.

  (** Projections involving the operation (functor) *)
  Section ProjectionsOperation.
    Variable (R : congruence_relation_ops).

    Definition cong_rel_ops
               (x y : poly_act (point_constr Σ) (alg_carrier X))
               (r : poly_act_rel (point_constr Σ) (cong_rel_carrier R) x y)
      : cong_rel_carrier R (alg_constr X x) (alg_constr X y)
      := pr12 R x y r.

    Definition cong_rel_ops_idax
               (x : poly_act (point_constr Σ) (alg_carrier X))
      : cong_rel_ops x x (poly_act_rel_identity _ _ (cong_rel_id R) x)
        =
        cong_rel_id R (alg_constr X x).
    Proof.
      exact (pr122 R x).
    Qed.

    Definition cong_rel_ops_compax
               (x y z : poly_act (point_constr Σ) (alg_carrier X))
               (r1 : poly_act_rel (point_constr Σ) (cong_rel_carrier R) x y)
               (r2 : poly_act_rel (point_constr Σ) (cong_rel_carrier R) y z)
      : cong_rel_ops
          x z
          (poly_act_rel_comp
             (point_constr Σ)
             _
             (λ x y z r1 r2, cong_rel_comp R r1 r2) r1 r2)
        = cong_rel_comp
            R
            (cong_rel_ops x y r1)
            (cong_rel_ops y z r2).
    Proof.
      exact (pr222 R x y z r1 r2).
    Qed.
  End ProjectionsOperation.

  Section MakeGroupoidPrealgebraFromCongruence.
    Variable (R : congruence_relation_ops).

    Definition make_groupoid_algebra_operations_functor_data
      : functor_data
          (⦃ point_constr Σ ⦄ (make_groupoid_algebra_carrier R) : groupoid)
          (make_groupoid_algebra_carrier R).
    Proof.
      use make_functor_data.
      - exact (alg_constr X).
      - exact (cong_rel_ops R).
    Defined.

    Definition make_groupoid_algebra_operations_is_functor
      : is_functor make_groupoid_algebra_operations_functor_data.
    Proof.
      split.
      - exact (cong_rel_ops_idax R).
      - exact (cong_rel_ops_compax R).
    Qed.

    Definition make_groupoid_algebra_operations
      : (⦃ point_constr Σ ⦄ (make_groupoid_algebra_carrier R) : groupoid)
          ⟶
          make_groupoid_algebra_carrier R.
    Proof.
      use make_functor.
      - exact make_groupoid_algebra_operations_functor_data.
      - exact make_groupoid_algebra_operations_is_functor.
    Defined.

    Definition make_groupoid_prealgebra
      : hit_prealgebra_grpd Σ.
    Proof.
      use make_hit_prealgebra_grpd.
      - exact (make_groupoid_algebra_carrier R).
      - exact make_groupoid_algebra_operations.
    Defined.
  End MakeGroupoidPrealgebraFromCongruence.

  Definition is_congruence_relation_nat
             (R : congruence_relation_ops)
    := ∏ (j : path_label Σ)
         (x y : poly_act (path_source Σ j) (alg_carrier X))
         (f : poly_act_rel (path_source Σ j) (cong_rel_carrier R) x y),
       cong_rel_comp
         R
         (sem_endpoint_grpd_data_functor_morphism
            (path_left Σ j)
            (make_groupoid_algebra_operations R)
            f)
         (eq_to_cong_rel R (alg_path X j y))
       = cong_rel_comp
           R
           (eq_to_cong_rel R (alg_path X j x))
           (sem_endpoint_grpd_data_functor_morphism
              (path_right Σ j)
              (make_groupoid_algebra_operations R)
              f).

  Definition congruence_relation_nat
    : UU
    := ∑ (R : congruence_relation_ops),
       is_congruence_relation_nat R.

  Definition make_congruence_relation_nat
             (R : congruence_relation_ops)
             (R_nat :  is_congruence_relation_nat R)
    : congruence_relation_nat
    := R ,, R_nat.

  Definition congruence_relation_nat_to_congruence_relation_ops
    : congruence_relation_nat → congruence_relation_ops
    := λ z, pr1 z.

  Coercion congruence_relation_nat_to_congruence_relation_ops
    : congruence_relation_nat >-> congruence_relation_ops.

  Section ProjectionsNatTrans.
    Variable (R : congruence_relation_nat).

    Definition cong_rel_nat
               (j : path_label Σ)
               (x y : poly_act (path_source Σ j) (alg_carrier X))
               (f : poly_act_rel (path_source Σ j) (cong_rel_carrier R) x y)
      : cong_rel_comp
          R
          (sem_endpoint_grpd_data_functor_morphism
             (path_left Σ j)
             (make_groupoid_algebra_operations R)
             f)
          (eq_to_cong_rel R (alg_path X j y))
        = cong_rel_comp
            R
            (eq_to_cong_rel R (alg_path X j x))
            (sem_endpoint_grpd_data_functor_morphism
               (path_right Σ j)
               (make_groupoid_algebra_operations R)
               f).
    Proof.
      exact (pr2 R j x y f).
    Qed.
  End ProjectionsNatTrans.

  Section MakeGroupoidPathalgebraFromCongruence.
    Variable (R : congruence_relation_nat).

    Definition make_groupoid_path_algebra_nat_trans_data
               (j : path_label Σ)
      : nat_trans_data
          (sem_endpoint_grpd_data_functor
             (path_left Σ j)
             (make_groupoid_prealgebra R))
          (sem_endpoint_grpd_data_functor
             (path_right Σ j)
             (make_groupoid_prealgebra R)).
    Proof.
      intro x ; cbn.
      apply eq_to_cong_rel.
      exact (alg_path X j x).
    Defined.

    Definition make_groupoid_path_algebra_is_nat_trans
               (j : path_label Σ)
      : is_nat_trans
          _ _
          (make_groupoid_path_algebra_nat_trans_data j).
    Proof.
      exact (cong_rel_nat R j).
    Qed.

    Definition make_groupoid_path_algebra_path
               (j : path_label Σ)
      : sem_endpoint_grpd_data_functor
          (path_left Σ j)
          (make_groupoid_prealgebra R)
        ⟹
        sem_endpoint_grpd_data_functor
          (path_right Σ j)
          (make_groupoid_prealgebra R).
    Proof.
      use make_nat_trans.
      - exact (make_groupoid_path_algebra_nat_trans_data j).
      - exact (make_groupoid_path_algebra_is_nat_trans j).
    Defined.

    Definition make_groupoid_path_algebra
      : hit_path_algebra_grpd Σ.
    Proof.
      use make_hit_path_algebra_grpd.
      - exact (make_groupoid_prealgebra R).
      - exact make_groupoid_path_algebra_path.
    Defined.
  End MakeGroupoidPathalgebraFromCongruence.

  Definition is_congruence_relation
             (R : congruence_relation_nat)
    : UU
    := ∏ (j : homot_label Σ)
         (x : poly_act (homot_point_arg Σ j) (pr111 (make_groupoid_path_algebra R)))
         (p : poly_act_rel
                (homot_path_arg_target Σ j)
                (cong_rel_carrier R)
                (sem_endpoint_UU
                   (homot_path_arg_left Σ j)
                   (alg_constr X)
                   x)
                (sem_endpoint_UU
                   (homot_path_arg_right Σ j)
                   (alg_constr X)
                   x)),
       sem_homot_endpoint_grpd
         (homot_left_path Σ j)
         (make_groupoid_prealgebra R)
         (make_groupoid_path_algebra_path R) x p
       =
       sem_homot_endpoint_grpd
         (homot_right_path Σ j)
         (make_groupoid_prealgebra R)
         (make_groupoid_path_algebra_path R) x p.

  Definition congruence_relation
    : UU
    := ∑ (R : congruence_relation_nat),
       is_congruence_relation R.

  Definition make_congruence_relation
             (R : congruence_relation_nat)
             (HR : is_congruence_relation R)
    : congruence_relation
    := R ,, HR.

  Definition congruence_relation_to_congruence_relation_nat
    : congruence_relation → congruence_relation_nat
    := λ z, pr1 z.

  Coercion congruence_relation_to_congruence_relation_nat
    : congruence_relation >-> congruence_relation_nat.

  Section ProjectionsIsAlgebra.
    Variable (R : congruence_relation).

    Definition cong_rel_is_alg_homot
               (j : homot_label Σ)
               (x : poly_act (homot_point_arg Σ j) (pr111 (make_groupoid_path_algebra R)))
               (p : poly_act_rel
                      (homot_path_arg_target Σ j)
                      (cong_rel_carrier R)
                      (sem_endpoint_UU
                         (homot_path_arg_left Σ j)
                         (alg_constr X)
                         x)
                      (sem_endpoint_UU
                         (homot_path_arg_right Σ j)
                         (alg_constr X)
                         x))
      : sem_homot_endpoint_grpd
          (homot_left_path Σ j)
          (make_groupoid_prealgebra R)
          (make_groupoid_path_algebra_path R) x p
        =
        sem_homot_endpoint_grpd
          (homot_right_path Σ j)
          (make_groupoid_prealgebra R)
          (make_groupoid_path_algebra_path R) x p.
    Proof.
      exact (pr2 R j x p).
    Qed.
  End ProjectionsIsAlgebra.

  Section MakeGroupoidAlgebraFromCongruence.
    Variable (R : congruence_relation).

    Definition make_groupoid_algebra_is_hit_algebra
      : is_hit_algebra_grpd Σ (make_groupoid_path_algebra R).
    Proof.
      exact (cong_rel_is_alg_homot R).
    Qed.

    Definition make_groupoid_algebra
      : hit_algebra_grpd Σ.
    Proof.
      use make_algebra_grpd.
      - exact (make_groupoid_path_algebra R).
      - exact make_groupoid_algebra_is_hit_algebra.
    Defined.
  End MakeGroupoidAlgebraFromCongruence.

  Definition quotient_of_congruence
             (R : congruence_relation)
    : hit_algebra_one_types Σ
    := _ ,, gquot_is_hit_algebra Σ _ (pr2 (make_groupoid_algebra R)).
End CongruenceRelation.

Arguments congruence_relation_groupoid {_} _ .
Arguments congruence_relation_ops {_} _ .
Arguments congruence_relation_nat {_} _.
Arguments congruence_relation {_} _.


Section Monads.
  Variables M1 M2 : Type -> Type.

  Variable ret1 : forall {a}, a -> M1 a.
  Variable bind1 : forall {a b}, (a -> M1 b) -> M1 a -> M1 b.
  Definition join1 {c} := bind1 (fun x: M1 c => x).

  Variable ret2 : forall {a}, a -> M2 a.
  Variable bind2 : forall {a b}, (a -> M2 b) -> M2 a -> M2 b.

  Variable swap : forall {a}, M1 (M2 a) -> M2 (M1 a).

  Definition M a := M2 (M1 a).
  Notation "g >> f" := (fun x => f(g x)) (at level 70).

  Goal forall a b, (a -> M b) -> M a -> M b.
  Proof.
    intros a b. unfold M. intros f.
    refine (_ >> bind2 (join1 >> ret2)).
    refine (bind2 (_ >> swap)).
    refine (bind1 (f >> ret1)).
    Show Proof.
Admitted.

End Monads.


Set Warnings "-notation-overridden,-parsing".
From mathcomp Require Import ssreflect ssrbool eqtype div ssralg.
From Tweetnacl.High Require Import mc.
From Tweetnacl.High Require Import mcgroup.
From Tweetnacl.High Require Import montgomery.
From Tweetnacl.High Require Import curve25519_Fp.
From Tweetnacl.High Require Import twist25519_Fp.
From Tweetnacl.High Require Import opt_ladder.
From Tweetnacl.High Require Import prime_and_legendre.
From Tweetnacl.High Require Import prime_ssrprime.
From Reciprocity Require Import Reciprocity.Reciprocity.
From Tweetnacl.High Require Import Zmodp2.
From Tweetnacl.High Require Import Zmodp2_rules.
From Tweetnacl.High Require Import curve25519_Fp2.
From Tweetnacl.High Require Import curve25519_Fp_twist25519_Fp_eq.
From Tweetnacl.High Require Import curve25519_Fp_incl_Fp2.
From Tweetnacl.High Require Import twist25519_Fp_incl_Fp2.
From Tweetnacl.High Require Import Zmodp.
From Tweetnacl.High Require Import GRing_tools.
Require Import Ring.
Require Import ZArith.

Open Scope ring_scope.
Import GRing.Theory.

Local Notation "p '#x0'" := (point_x0 p) (at level 30).

Local Lemma oncurve_00 : (oncurve curve25519_Fp2_mcuType (EC_In 0 0)).
Proof.
  simpl; rewrite /a /b ; apply/eqP.
  have ->: (0 ^+ 2)%R = 0 :> Zmodp2.type by ring_simplify_this.
  have ->: (0 ^+ 3)%R = 0 :> Zmodp2.type by ring_simplify_this.
  rewrite ?Zmodp2_mulE /= ?Zmodp2_addE /=.
  f_equal; f_equal; apply/eqP ; zmodp_compute => //=.
Qed.

Local Lemma oncurve25519_Fp : forall x k k0 : Zmodp.type,
curve25519_Fp.b * k0 ^+ 2 == k ^+ 3 + curve25519_Fp.a * k ^+ 2 + k ->
k = x -> exists p0 : mc curve25519_Fp2_mcuType, p0 #x0 = Zmodp2.Zmodp2 x 0.
Proof.
move => x k k' Hx <-. clear x.
have : oncurve curve25519_Fp_mcuType (EC_In k k') => //.
move/oncurve25519_Fp_impl => HOC.
exists (MC HOC) => /=.
have ->: Zmodp.pi 0 = Zmodp.zero => //=.
Qed.

Local Lemma ontwist25519_Fp : forall x k k0 : Zmodp.type,
twist25519_Fp.b * k0 ^+ 2 == k ^+ 3 + twist25519_Fp.a * k ^+ 2 + k ->
k = x -> exists p0 : mc curve25519_Fp2_mcuType, p0 #x0 = Zmodp2.Zmodp2 x 0.
Proof.
move => x k k' Hx <-. clear x.
have : oncurve twist25519_Fp_mcuType (EC_In k k') => //.
move/ontwist25519_Fp_impl => HOC.
exists (MC HOC) => /=.
have ->: Zmodp.pi 0 = Zmodp.zero => //=.
Qed.

(* May actually not be in the right direction... *)
Theorem x_is_on_curve_or_twist_implies_x_in_Fp2: forall (x:Zmodp.type),
  exists (p: mc curve25519_Fp2_mcuType), p#x0 = Zmodp2.Zmodp2 x 0.
Proof.
  move=> x.
  have := x_is_on_curve_or_twist x.
  move=> [] [] [] [] /=.
  - move=> _ <- ; exists (MC oncurve_00) => //=.
  - apply oncurve25519_Fp.
  - move=> _ <- ; exists (MC oncurve_00) => //=.
  - apply ontwist25519_Fp.
Qed.

Definition Fp2_to_Fp p := match p with
  | Zmodp2.Zmodp2 x y => x
  end.

Lemma Fp2_to_Fp_eq_C: Fp2_to_Fp = cFp2_to_Fp.
Proof. reflexivity. Qed.

Lemma Fp2_to_Fp_eq_T: Fp2_to_Fp = tFp2_to_Fp.
Proof. reflexivity. Qed.

Local Notation "p '/p'" := (Fp2_to_Fp p) (at level 40).

Local Lemma temp: forall x xp yp1 yp2,
xp = Zmodp2.Zmodp2 x 0 ->
oncurve curve25519_Fp2_mcuType (|xp, Zmodp2.Zmodp2 yp1 yp2|) ->
yp1 ^+ 2 + 2%:R * yp2 ^+ 2 = x * (x * x) + Zmodp.pi 486662 * (x * x) + x /\
2%:R * (yp1 * yp2) = 0.
Proof.
move => x xp yp1 yp2 Hx.
rewrite /oncurve /= /a /b => Hp'.
have : (Zmodp2.Zmodp2 yp1 yp2) ^+ 2 == (Zmodp2.Zmodp2 x 0) ^+ 3 + Zmodp2.pi (Zmodp.pi 486662, 0) * (Zmodp2.Zmodp2 x 0) ^+ 2 + (Zmodp2.Zmodp2 x 0).
  rewrite -Hx -(GRing.mul1r (Zmodp2.Zmodp2 yp1 yp2 ^+ 2)) //.
  ring_simplify_this.
  Zmodpify => /=.
have ->: Zmodp2.Zmodp2 yp1 yp2 * Zmodp2.Zmodp2 yp1 yp2 = Zmodp2.Zmodp2 (yp1^+2 + 2%:R * yp2^+2) (2%:R * yp1 * yp2).
  rewrite /GRing.mul /= /Zmodp2.mul /Zmodp2.pi expr2 /=.
  ringify; f_equal; rewrite /GRing.mul /= (Zmodp_ring.mul_comm yp2) ; symmetry ; rewrite -Zmodp_ring.mul_assoc; ringify; apply add_eq_mul2.
move/eqP.
move/Zmodp2.Zmodp2_inv => [].
ring_simplify_this.
move => Hxy.
rewrite -GRing.mulrA.
move: Hxy.
done.
Qed.

Lemma Fp2_to_Fp_eq :
  forall (x: Zmodp.type) (p : mc curve25519_Fp2_mcuType),
  p #x0 = Zmodp2.Zmodp2 x 0 ->
  (exists c:mc curve25519_Fp_mcuType, curve25519_Fp_to_Fp2 c = p) \/ (exists t:mc twist25519_Fp_mcuType, twist25519_Fp_to_Fp2 t = p).
Proof.
  move => x [[|xp yp] Hp] /= => Hx.
  + (* is p is at infinity *)
  left; have Hc : oncurve curve25519_Fp_mcuType ∞ => //=.
  exists (MC Hc) => /= ; apply mc_eq => //.
  + (* if p is (x,y) *)
  destruct yp as [yp1 yp2].
  have [Hxy] := temp x xp yp1 yp2 Hx Hp.
  move/time_2_eq_0/mult_xy_eq_0 => [] Hy; rewrite Hy in Hxy;
  move: Hxy ; ring_simplify_this => Hxy.
  - right.
  have OC : oncurve twist25519_Fp_mcuType (| x, yp2 |).
    by apply/eqP => /= ; rewrite /twist25519_Fp.a /twist25519_Fp.b ?expr2 ?expr3' ; ringify.
  exists (MC OC) => /=.
  apply mc_eq ; congruence.
  - left.
  have OC : oncurve curve25519_Fp_mcuType (| x, yp1 |).
    by apply/eqP => /= ; rewrite /curve25519_Fp.a /curve25519_Fp.b ?expr2 ?expr3' mul1r; ringify.
  exists (MC OC) => /=.
  apply mc_eq ; congruence.
Qed.

From mathcomp Require Import ssrnat.

Lemma curve25519_Fp2_ladder_ok (n : nat) (x:Zmodp.type) :
    (n < 2^255)%nat ->
    forall (p  : mc curve25519_Fp2_mcuType),
    p #x0 = Zmodp2.Zmodp2 x 0 ->
    curve25519_Fp_ladder n x = (p *+ n)#x0 /p.
Proof.
  move => Hn p Hp.
  have [[c] Hc|[t] Ht] := Fp2_to_Fp_eq x p Hp.
  + have Hcx0: curve25519_Fp_to_Fp2 c #x0 = Zmodp2.Zmodp2 x 0 by rewrite Hc.
    rewrite (curve25519_ladder_Fp_Fp2 n x Hn c Hcx0) -Fp2_to_Fp_eq_C Hc //.
  + have Htx0: twist25519_Fp_to_Fp2 t #x0 = Zmodp2.Zmodp2 x 0 by rewrite Ht.
    rewrite curve25519_twist25519_Fp_eq.
    rewrite (twist25519_ladder_Fp_Fp2 n x Hn t Htx0) -Fp2_to_Fp_eq_T Ht //.
Qed.

Close Scope ring_scope.