Require Import Coq.Lists.List.
Import ListNotations.
Require Import Tactics.
Require Import Sequence.
Require Import Syntax.
Require Import Subst.
Require Import SimpSub.
Require Import Promote.
Require Import Hygiene.
Require Import Rules.
Require Import DerivedRules.
Require Defs.
Require Import Obligations.
Require Import Morphism.
Require Import DefsEquiv.
Require Import Equivalence.
Require Import Dots.

Require Import ValidationUtil.

Hint Rewrite def_pi def_arrow def_tarrow def_karrow : prepare.

Lemma forallForm_valid : forallForm_obligation.
Proof.
prepare.
intros G a b m n Ha Hb.
apply tr_pi_formation; auto.
Qed.

Lemma forallEq_valid: forallEq_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a a' b b' m n Ha Hb.
  valid_rewrite.
  apply tr_pi_formation; eauto using deqtype_intro.
Qed.

Lemma forallFormUniv_valid : forallFormUniv_obligation.
Proof.
prepare.
intros G a b i ext1 ext0 Ha Hb.
apply tr_pi_formation_univ; auto.
Qed.

Lemma forallEqUniv_valid : forallEqUniv_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a a' b b' i triv0 triv1 Ha Hb.
  valid_rewrite.
  constructor.
  apply tr_pi_formation_univ; eauto using deq_intro.
  Qed.

Lemma tr_pi_sub :
  forall G a a' b b',
    tr G (dsubtype a' a)
    -> tr (hyp_tm a' :: G) (dsubtype b b')
    -> tr (hyp_tm a :: G) (deqtype b b)
    -> tr G (dsubtype (pi a b) (pi a' b')).
Proof.
intros G a a' b b' Hsuba Hsubb Hb.
apply tr_subtype_intro.
  {
  apply tr_pi_formation; auto.
  eapply tr_subtype_istype2; eauto.
  }

  {
  apply tr_pi_formation.
    {
    eapply tr_subtype_istype1; eauto.
    }

    {
    eapply tr_subtype_istype2; eauto.
    }
  }
simpsub.
eapply tr_pi_ext; eauto.
3:{
  eapply hypothesis; eauto using index_0.
  simpsub.
  auto.
  }

3:{
  eapply hypothesis; eauto using index_0.
  simpsub.
  auto.
  }

  {
  apply (weakening _ [_] []).
    {
    simpsub.
    auto.
    }

    {
    simpsub.
    cbn [length unlift].
    simpsub.
    auto.
    }
  cbn [length unlift].
  simpsub.
  cbn [List.app].
  eapply tr_subtype_istype1; eauto.
  }

  {
  simpsub.
  cbn [Nat.add].
  apply (tr_subtype_elim _ (subst (dot (var 0) (sh 2)) b)).
    {
    eapply (weakening _ [_] [_]).
      {
      cbn [length unlift].
      simpsub.
      auto.
      }

      {
      cbn [length unlift].
      simpsub.
      auto.
      }
    cbn [length unlift].
    simpsub.
    cbn [List.app].
    rewrite -> !subst_var0_sh1; auto.
    }

    {
    eapply tr_pi_elim'.
      {
      eapply hypothesis; eauto using index_S, index_0.
      simpsub; auto.
      }

      {
      eapply (tr_subtype_elim _ (subst (sh 2) a')).
        {
        eapply (weakening _ [_; _] []).
          {
          simpsub; auto.
          }

          {
          cbn [length unlift].
          simpsub.
          reflexivity.
          }
        cbn [length unlift].
        simpsub.
        cbn [List.app].
        auto.
        }

        {
        eapply hypothesis; eauto using index_0.
        simpsub; auto.
        }
      }

      {
      simpsub.
      cbn [Nat.add].
      simpsub.
      auto.
      }
    }
  }
Qed.

Lemma forallSub_valid : forallSub_obligation.
Proof.
prepare.
intros G a a' b b' ext2 ext1 ext0 Hsuba Hsubb Hb.
apply tr_pi_sub; auto.
Qed.

Lemma forallIntroOf_valid : forallIntroOf_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a b m triv0 triv1 Ha Hb.
  valid_rewrite.
  constructor.
  apply tr_pi_intro.
    - eauto using deqtype_intro.
    - eauto using deq_intro.
  Qed.

Lemma forallIntroEq_valid : forallIntroEq_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a b m n triv0 triv1 Ha Hb.
  valid_rewrite.
  constructor.
  apply tr_pi_intro.
    - eauto using deqtype_intro.
    - eauto using deq_intro.
  Qed.

Lemma forallIntro_valid : forallIntro_obligation.
Proof.
prepare.
intros G a b ext0 m Ha Hb.
apply tr_pi_intro; auto.
Qed.

Lemma forallElimOf_valid : forallElimOf_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a b m p triv0 triv1 Ha Hforall.
  valid_rewrite.
  constructor.
  eapply tr_pi_elim; eauto using deq_intro.
  Qed.

Lemma forallElimEq_valid : forallElimEq_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a b m n p q triv0 triv1 H1 H2.
  valid_rewrite.
  constructor.
  eapply tr_pi_elim; eauto using deq_intro.
  Qed.

Lemma forallElim_valid : forallElim_obligation.
Proof.
prepare.
intros G a b p m ext0 Hm Hp.
eapply tr_pi_elim; eauto.
Qed.

Lemma forallEta_valid : forallEta_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a b m triv0 Hforall.
  valid_rewrite.
  constructor.
  apply tr_pi_eta. eauto using deq_intro.
  Qed.

Lemma forallExt_valid : forallExt_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b m n ext2 ext1 ext0 Hm Hn Hmn.
rewrite -> def_eq in Hmn |- *.
rewrite -> def_of in Hm, Hn.
rewrite -> def_pi in Hm, Hn |- *.
unfold Defs.triv.
apply tr_equal_intro.
eapply tr_pi_ext; eauto.
3:{
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }

3:{
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }

  {
  eapply tr_pi_formation_invert1.
  eapply tr_equal_formation_invert1.
  eapply tr_inhabitation_formation; eauto.
  }

  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }
Qed.

Lemma forallOfExt_valid : forallOfExt_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a a' b b' m ext2 ext1 ext0 Ha Hm Happ.
rewrite -> def_istp in Ha.
rewrite -> def_of in * |- *.
rewrite -> def_pi in Hm |- *.
unfold Defs.triv.
apply tr_equal_intro.
eapply tr_pi_ext; eauto.
3:{
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }

3:{
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }

  {
  eapply tr_eqtype_eta2; eauto.
  }

  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }
Qed.

Lemma forallFormInv1_valid : forallFormInv1_obligation.
Proof.
prepare.
intros G a b ext0 Histp.
eapply tr_pi_formation_invert1; eauto.
Qed.

Lemma forallFormInv2_valid : forallFormInv2_obligation.
Proof.
prepare.
intros G a b m ext1 ext0 Hpi Hm.
simpsub.
cut (tr (hyp_tm a :: G) (deqtype b b)).
  {
  intro Hb.
  so (tr_generalize _#4 Hm Hb) as H.
  simpsubin H.
  exact H.
  }
eapply tr_pi_formation_invert2; eauto.
Qed.

Lemma arrowForm_valid : arrowForm_obligation.
Proof.
prepare.
intros G a b ext1 ext0 H0 H1.
apply tr_pi_formation; auto.
Qed.

Lemma arrowEq_valid : arrowEq_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a a' b b' triv0 triv1 H1 H2.
  valid_rewrite.
  constructor; eauto using deqtype_intro.
  Qed.

Lemma arrowFormUniv_valid : arrowFormUniv_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a b i triv0 triv1 H1 H2.
  valid_rewrite.
  constructor.
  apply tr_pi_formation_univ; eauto using deq_intro.
  Qed.

Lemma arrowEqUniv_valid : arrowEqUniv_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a a' b b' i triv0 triv1 H1 H2.
  valid_rewrite.
  constructor.
  apply tr_pi_formation_univ; eauto using deq_intro.
Qed.

Lemma arrowSub_valid : arrowSub_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a a' b b' ext1 ext0 Hsuba Hsubb.
unfold Defs.triv.
rewrite -> def_subtype in Hsuba, Hsubb |- *.
rewrite -> !def_arrow.
apply tr_pi_sub.
  {
  eapply tr_subtype_eta2; eauto.
  }

  {
  apply (weakening _ [_] []).
    {
    cbn [length unlift].
    simpsub.
    auto.
    }

    {
    cbn [length unlift].
    simpsub.
    auto.
    }
  cbn [length unlift].
  simpsub.
  cbn [List.app].
  eapply tr_subtype_eta2; eauto.
  }

  {
  apply (weakening _ [_] []).
    {
    cbn [length unlift].
    simpsub.
    auto.
    }

    {
    cbn [length unlift].
    simpsub.
    auto.
    }
  cbn [length unlift].
  simpsub.
  cbn [List.app].
  eapply tr_subtype_istype1.
  eapply tr_subtype_eta2; eauto.
  }
Qed.

Lemma arrowForallSub_valid : arrowForallSub_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a a' b b' ext2 ext1 ext0 Hsuba Hsubb Hb.
unfold Defs.triv.
rewrite -> def_subtype in Hsuba, Hsubb |- *.
rewrite -> def_istp in Hb.
rewrite -> def_arrow.
rewrite -> def_pi.
apply tr_pi_sub.
  {
  eapply tr_subtype_eta2; eauto.
  }

  {
  eapply tr_subtype_eta2; eauto.
  }

  {
  apply (weakening _ [_] []).
    {
    cbn [length unlift].
    simpsub.
    auto.
    }

    {
    cbn [length unlift].
    simpsub.
    auto.
    }
  cbn [length unlift].
  simpsub.
  cbn [List.app].
  eapply tr_eqtype_eta2; eauto.
  }
Qed.

Lemma forallArrowSub_valid : forallArrowSub_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a a' b b' ext2 ext1 ext0 Hsuba Hsubb Hb.
unfold Defs.triv.
rewrite -> def_subtype in Hsuba, Hsubb |- *.
rewrite -> def_istp in Hb.
rewrite -> def_arrow.
rewrite -> def_pi.
apply tr_pi_sub.
  {
  eapply tr_subtype_eta2; eauto.
  }

  {
  eapply tr_subtype_eta2; eauto.
  }

  {
  eapply tr_eqtype_eta2; eauto.
  }
Qed.

Lemma arrowIntroOf_valid: arrowIntroOf_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a b m triv0 triv1 H1 H2.
  valid_rewrite.
  constructor.
  apply tr_pi_intro; eauto using deq_intro;
    eauto using deqtype_intro.
Qed.

Lemma arrowIntroEq_valid: arrowIntroEq_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a b m n triv0 triv1 H1 H2.
  valid_rewrite.
  constructor.
  apply tr_pi_intro; eauto using deq_intro;
    eauto using deqtype_intro.
Qed.

Lemma arrowIntro_valid : arrowIntro_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b ext0 m Ha Hm.
rewrite -> def_arrow.
rewrite -> def_istp in Ha.
apply tr_pi_intro; auto.
eapply tr_eqtype_eta2; eauto.
Qed.

Lemma arrowElimOf_valid: arrowElimOf_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a b m p triv0 triv1 H1 H2.
  valid_rewrite.
  constructor.
  assert ((subst1 p (subst sh1 b)) = b) as Heq.
  { simpsub. auto. }
  rewrite <- Heq.
  eapply tr_pi_elim; eauto using deq_intro;
    eauto using deqtype_intro.
Qed.

Lemma arrowElimEq_valid: arrowElimEq_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a b m n p q triv0 triv1 H1 H2.
  valid_rewrite.
  constructor.
  assert ((subst1 p (subst sh1 b)) = b) as Heq.
  { simpsub. auto. }
  rewrite <- Heq.
  eapply tr_pi_elim; eauto using deq_intro;
    eauto using deqtype_intro.
Qed.

Lemma arrowElim_valid : arrowElim_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b m p Hm Hp.
rewrite -> def_arrow in Hm.
replace b with (subst1 p (subst sh1 b)) by (simpsub; auto).
eapply tr_pi_elim; eauto.
Qed.

Lemma arrowEta_valid : arrowEta_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a b m triv0 Harrow.
  valid_rewrite.
  constructor.
  apply tr_pi_eta. eauto using deq_intro.
Qed.

Lemma arrowExt_valid : arrowExt_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b m n ext2 ext1 ext0 Hm Hn Heq.
rewrite -> def_eq in Heq |- *.
rewrite -> def_of in Hm, Hn.
rewrite -> def_arrow in Hm, Hn |- *.
unfold Defs.triv.
apply tr_equal_intro.
apply (tr_pi_ext _#5 a a (subst sh1 b) (subst sh1 b)).
  {
  apply (tr_pi_formation_invert1 _#3 (subst sh1 b) (subst sh1 b)).
  eapply tr_equal_formation_invert1.
  eapply tr_inhabitation_formation; eauto.
  }

  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }

  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }

  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }
Qed.

Lemma arrowOfExt_valid : arrowOfExt_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a a' b b' m ext2 ext1 ext0 Ha Halt Hof.
rewrite -> def_of in Halt, Hof |- *.
rewrite -> def_istp in Ha.
rewrite -> def_pi in Halt.
rewrite -> def_arrow.
unfold Defs.triv.
apply tr_equal_intro.
apply (tr_pi_ext _#5 a' a' b' b').
  {
  eapply tr_eqtype_eta2; eauto.
  }

  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }

  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }

  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }
Qed.

Lemma arrowFormInv1_valid : arrowFormInv1_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b ext0 Hab.
rewrite -> def_istp in Hab |- *.
rewrite -> def_arrow in Hab.
unfold Defs.triv.
eapply tr_pi_formation_invert1.
eapply tr_eqtype_eta2; eauto.
Qed.

Lemma arrowFormInv2_valid : arrowFormInv2_obligation.
Proof.
prepare.
intros G a b m ext1 ext2 Hpi Hm.
so (tr_pi_formation_invert2 _#5 Hpi) as Hb.
cut (tr G (substj (dot m id) (deqtype (subst sh1 b) (subst sh1 b)))).
  {
  simpsub.
  auto.
  }
eapply tr_generalize; eauto.
Qed.

Lemma tarrowKind_valid : tarrowKind_obligation.
Proof.
prepare.
intros G a i k ext1 ext0 H0 H1.
apply tr_arrow_kind_formation; auto.
Qed.

Lemma tarrowKindEq_valid : tarrowKindEq_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a a' i k k' triv0 triv1 H1 H2.
  valid_rewrite.
  constructor.
  apply tr_arrow_kind_formation; eauto using deq_intro.
  Qed.

Lemma tarrowForm_valid : tarrowForm_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a b triv0 triv1 H1 H2.
  valid_rewrite.
  constructor; eauto using deqtype_intro.
  Qed.

Lemma tarrowEq_valid : tarrowEq_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a a' b b' triv0 triv1 H1 H2.
  valid_rewrite.
  constructor; eauto using deqtype_intro.
  Qed.

Lemma tarrowFormUniv_valid : tarrowFormUniv_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a b i triv0 triv1 H1 H2.
  valid_rewrite.
  constructor.
  apply tr_arrow_formation_univ; eauto using deq_intro.
  Qed.

Lemma tarrowEqUniv_valid : tarrowEqUniv_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a a' b b' i triv0 triv1 H1 H2.
  valid_rewrite.
  constructor.
  apply tr_arrow_formation_univ; eauto using deq_intro.
Qed.

Lemma tarrowArrowEq_valid : tarrowArrowEq_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a a' b b' ext1 ext0 Ha Hb.
rewrite -> def_eqtp in Ha, Hb |- *.
rewrite -> def_tarrow.
rewrite -> def_arrow.
unfold Defs.triv.
apply (tr_eqtype_transitivity _ _ (arrow a' b')).
  {
  apply tr_arrow_formation; eapply tr_eqtype_eta2; eauto.
  }
apply tr_arrow_pi_equal.
  {
  apply (tr_eqtype_transitivity _ _ a); [apply tr_eqtype_symmetry |]; eapply tr_eqtype_eta2; eauto.
  }

  {
  apply (tr_eqtype_transitivity _ _ b); [apply tr_eqtype_symmetry |]; eapply tr_eqtype_eta2; eauto.
  }
Qed.

Lemma tarrowArrowEqUniv_valid : tarrowArrowEqUniv_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a a' b b' i ext1 ext0 Ha Hb.
rewrite -> def_eq, -> def_univ in Ha, Hb |- *.
rewrite -> def_tarrow.
rewrite -> def_arrow.
unfold Defs.triv.
apply tr_equal_intro.
apply (tr_transitivity _ _ (arrow a' b')).
  {
  apply tr_arrow_formation_univ; apply tr_equal_elim; eapply tr_equal_eta2; eauto.
  }
apply tr_arrow_pi_equal_univ.
  {
  apply (tr_transitivity _ _ a); [apply tr_symmetry |]; apply tr_equal_elim; eapply tr_equal_eta2; eauto.
  }

  {
  apply (tr_transitivity _ _ b); [apply tr_symmetry |]; apply tr_equal_elim; eapply tr_equal_eta2; eauto.
  }
Qed.

Lemma tarrowIntroOf_valid: tarrowIntroOf_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a b m triv0 triv1 triv2 H1 H2 H3.
  valid_rewrite.
  constructor.
  eapply tr_eqtype_convert.
  apply tr_eqtype_symmetry.
  apply tr_arrow_pi_equal; eauto using deqtype_intro.
  eapply tr_pi_intro; eauto using deq_intro, deqtype_intro. Qed.

Lemma tarrowIntroEq_valid : tarrowIntroEq_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b m n ext2 ext1 ext0 Ha Hb Hmn.
rewrite -> def_istp in Ha, Hb.
rewrite -> def_eq in Hmn |- *.
rewrite -> def_tarrow.
unfold Defs.triv.
apply tr_equal_intro.
apply (tr_eqtype_convert _#3 (pi a (subst sh1 b))).
  {
  apply tr_eqtype_symmetry.
  apply tr_arrow_pi_equal; eapply tr_eqtype_eta2; eauto.
  }
apply tr_pi_intro.
  {
  eapply tr_eqtype_eta2; eauto.
  }

  {
  apply tr_equal_elim; eapply tr_equal_eta2; eauto.
  }
Qed.

Lemma tarrowIntro_valid : tarrowIntro_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b ext1 ext0 m Ha Hb Hm.
rewrite -> def_istp in Ha, Hb.
rewrite -> def_tarrow.
apply (tr_eqtype_convert _#3 (pi a (subst sh1 b))).
  {
  apply tr_eqtype_symmetry.
  apply tr_arrow_pi_equal; eapply tr_eqtype_eta2; eauto.
  }
apply tr_pi_intro; auto.
eapply tr_eqtype_eta2; eauto.
Qed.

Lemma tarrowElimOf_valid : tarrowElimOf_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b m p ext1 ext0 Hm Hp.
rewrite -> def_of in Hm, Hp |- *.
rewrite -> def_tarrow in Hm.
unfold Defs.triv.
apply tr_equal_intro.
eapply tr_pi_elim'.
  {
  apply (tr_eqtype_convert _#3 (arrow a b)).
    {
    apply tr_arrow_pi_equal.
      {
      eapply tr_equal_formation_invert1.
      eapply tr_inhabitation_formation; eauto.
      }

      {
      replace (deqtype b b) with (substj (dot p id) (deqtype (subst sh1 b) (subst sh1 b))) by (simpsub; auto).
      eapply tr_generalize.
        {
        apply tr_equal_elim.
        eapply tr_equal_eta2; eauto.
        }
      apply (tr_arrow_formation_invert2 _ a a).
      eapply tr_equal_formation_invert1.
      eapply tr_inhabitation_formation; eauto.
      }
    }

    {
    apply tr_equal_elim.
    eapply tr_equal_eta2; eauto.
    }
  }

  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }

  {
  simpsub; auto.
  }
Qed.

Lemma tarrowElimEq_valid : tarrowElimEq_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b m n p q ext1 ext0 Hm Hp.
rewrite -> def_eq in Hm, Hp |- *.
rewrite -> def_tarrow in Hm.
unfold Defs.triv.
apply tr_equal_intro.
eapply tr_pi_elim'.
  {
  apply (tr_eqtype_convert _#3 (arrow a b)).
    {
    apply tr_arrow_pi_equal.
      {
      eapply tr_equal_formation_invert1.
      eapply tr_inhabitation_formation; eauto.
      }

      {
      replace (deqtype b b) with (substj (dot p id) (deqtype (subst sh1 b) (subst sh1 b))) by (simpsub; auto).
      eapply tr_generalize.
        {
        apply (tr_transitivity _ _ q); [| apply tr_symmetry]; apply tr_equal_elim; eapply tr_equal_eta2; eauto.
        }
      apply (tr_arrow_formation_invert2 _ a a).
      eapply tr_equal_formation_invert1.
      eapply tr_inhabitation_formation; eauto.
      }
    }

    {
    apply tr_equal_elim.
    eapply tr_equal_eta2; eauto.
    }
  }

  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }

  {
  simpsub; auto.
  }
Qed.

Lemma tarrowElim_valid : tarrowElim_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b m p Hm Hp.
rewrite -> def_tarrow in Hm.
eapply tr_pi_elim'.
  {
  apply (tr_eqtype_convert _#3 (arrow a b)).
    {
    apply tr_arrow_pi_equal.
      {
      eapply tr_inhabitation_formation; eauto.
      }

      {
      replace (deqtype b b) with (substj (dot p id) (deqtype (subst sh1 b) (subst sh1 b))) by (simpsub; auto).
      eapply tr_generalize; eauto.
      apply (tr_arrow_formation_invert2 _ a a).
      eapply tr_inhabitation_formation; eauto.
      }
    }

    {
    auto.
    }
  }

  {
  auto.
  }

  {
  simpsub; auto.
  }
Qed.

Lemma tarrowEta_valid : tarrowEta_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b m ext0 Hm.
rewrite -> def_of in Hm.
rewrite -> def_eq.
rewrite -> def_tarrow in Hm |- *.
unfold Defs.triv.
apply tr_equal_intro.
apply tr_arrow_eta.
apply tr_equal_elim.
eapply tr_equal_eta2; eauto.
Qed.

Lemma tarrowExt_valid : tarrowExt_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b m n ext3 ext2 ext1 ext0 Hb Hm Hn Heq.
rewrite -> def_istp in Hb.
rewrite -> def_of in Hm, Hn.
rewrite -> def_eq in Heq |- *.
rewrite -> def_tarrow in Hm, Hn |- *.
unfold Defs.triv.
apply tr_equal_intro.
eapply tr_transitivity.
  {
  apply tr_arrow_eta.
  apply tr_equal_elim; eapply tr_equal_eta2; eauto.
  }
eapply tr_transitivity.
2:{
  apply tr_symmetry.
  apply tr_arrow_eta.
  apply tr_equal_elim; eapply tr_equal_eta2; eauto.
  }
apply (tr_eqtype_convert _#3 (pi a (subst sh1 b))).
  {
  apply tr_eqtype_symmetry.
  apply tr_arrow_pi_equal.
    {
    apply (tr_arrow_formation_invert1 _ _ _ b b).
    eapply tr_equal_formation_invert1.
    eapply tr_inhabitation_formation; eauto.
    }

    {
    eapply tr_eqtype_eta2; eauto.
    }
  }
apply tr_pi_intro.
  {
  apply (tr_arrow_formation_invert1 _ _ _ b b).
  eapply tr_equal_formation_invert1.
  eapply tr_inhabitation_formation; eauto.
  }

  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }
Qed.

Lemma karrowKind_valid : karrowKind_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a i k triv0 triv1 H1 H2.
  valid_rewrite.
  constructor.
  rewrite -> def_karrow.
  apply tr_karrow_kind_formation; eauto using deq_intro.
  Qed.

Lemma karrowKindEq_valid : karrowKindEq_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G i k k' l l' ext1 ext0 Hk Hl.
rewrite -> def_eq in Hk, Hl |- *.
rewrite -> def_kind in Hk, Hl |- *.
rewrite -> !def_karrow.
unfold Defs.triv.
apply tr_equal_intro.
apply tr_karrow_kind_formation; apply tr_equal_elim; eapply tr_equal_eta2; eauto.
Qed.

Lemma karrowForm_valid : karrowForm_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a b triv0 triv1 H1 H2.
  valid_rewrite.
  rewrite -> !def_karrow.
  constructor; eauto using deqtype_intro.
  Qed.

Lemma karrowEq_valid : karrowEq_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a a' b b' triv0 triv1 H1 H2.
  valid_rewrite.
  rewrite -> !def_karrow.
  constructor; eauto using deqtype_intro.
  Qed.

Lemma karrowFormUniv_valid : karrowFormUniv_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a b i triv0 triv1 H1 H2.
  valid_rewrite.
  rewrite -> !def_karrow.
  constructor.
  eapply tr_karrow_formation_univ; eauto using deq_intro.
  Qed.

Lemma karrowEqUniv_valid : karrowEqUniv_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a a' b b' i triv0 triv1 H1 H2.
  valid_rewrite.
  rewrite -> !def_karrow.
  constructor.
  eapply tr_karrow_formation_univ; eauto using deq_intro.
Qed.

Lemma karrowArrowEq_valid : karrowArrowEq_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a a' b b' ext1 ext0 Ha Hb.
rewrite -> def_eqtp in Ha, Hb |- *.
rewrite -> def_karrow.
rewrite -> def_arrow.
unfold Defs.triv.
apply (tr_eqtype_transitivity _ _ (karrow a' b')).
  {
  apply tr_karrow_formation; eapply tr_eqtype_eta2; eauto.
  }
apply tr_karrow_pi_equal.
  {
  apply (tr_eqtype_transitivity _ _ a); [apply tr_eqtype_symmetry |]; eapply tr_eqtype_eta2; eauto.
  }

  {
  apply (tr_eqtype_transitivity _ _ b); [apply tr_eqtype_symmetry |]; eapply tr_eqtype_eta2; eauto.
  }
Qed.

Lemma karrowArrowEqUniv_valid : karrowArrowEqUniv_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a a' b b' i ext1 ext0 Ha Hb.
rewrite -> def_eq, -> def_univ in Ha, Hb |- *.
rewrite -> def_karrow.
rewrite -> def_arrow.
unfold Defs.triv.
apply tr_equal_intro.
apply (tr_transitivity _ _ (karrow a' b')).
  {
  apply tr_karrow_formation_univ; apply tr_equal_elim; eapply tr_equal_eta2; eauto.
  }
apply tr_karrow_pi_equal_univ.
  {
  apply (tr_transitivity _ _ a); [apply tr_symmetry |]; apply tr_equal_elim; eapply tr_equal_eta2; eauto.
  }

  {
  apply (tr_transitivity _ _ b); [apply tr_symmetry |]; apply tr_equal_elim; eapply tr_equal_eta2; eauto.
  }
Qed.

Lemma karrowIntroOf_valid: karrowIntroOf_obligation.
  unfoldtop. autounfold with valid_hint.
  intros G a b m triv0 triv1 triv2 H1 H2 H3.
  valid_rewrite.
  constructor.
  rewrite -> def_karrow.
  eapply tr_eqtype_convert.
  apply tr_eqtype_symmetry.
  apply tr_karrow_pi_equal; eauto using deqtype_intro.
  eapply tr_pi_intro; eauto using deq_intro, deqtype_intro. Qed.

Lemma karrowIntroEq_valid : karrowIntroEq_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b m n ext2 ext1 ext0 Ha Hb Hmn.
rewrite -> def_istp in Ha, Hb.
rewrite -> def_eq in Hmn |- *.
rewrite -> def_karrow.
unfold Defs.triv.
apply tr_equal_intro.
apply (tr_eqtype_convert _#3 (pi a (subst sh1 b))).
  {
  apply tr_eqtype_symmetry.
  apply tr_karrow_pi_equal; eapply tr_eqtype_eta2; eauto.
  }
apply tr_pi_intro.
  {
  eapply tr_eqtype_eta2; eauto.
  }

  {
  apply tr_equal_elim; eapply tr_equal_eta2; eauto.
  }
Qed.

Lemma karrowIntro_valid : karrowIntro_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b ext1 ext0 m Ha Hb Hm.
rewrite -> def_istp in Ha, Hb.
rewrite -> def_karrow.
apply (tr_eqtype_convert _#3 (pi a (subst sh1 b))).
  {
  apply tr_eqtype_symmetry.
  apply tr_karrow_pi_equal; eapply tr_eqtype_eta2; eauto.
  }
apply tr_pi_intro; auto.
eapply tr_eqtype_eta2; eauto.
Qed.

Lemma karrowElimOf_valid : karrowElimOf_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b m p ext1 ext0 Hm Hp.
rewrite -> def_of in Hm, Hp |- *.
rewrite -> def_karrow in Hm.
unfold Defs.triv.
apply tr_equal_intro.
eapply tr_pi_elim'.
  {
  apply (tr_eqtype_convert _#3 (karrow a b)).
    {
    apply tr_karrow_pi_equal.
      {
      eapply tr_equal_formation_invert1.
      eapply tr_inhabitation_formation; eauto.
      }

      {
      replace (deqtype b b) with (substj (dot p id) (deqtype (subst sh1 b) (subst sh1 b))) by (simpsub; auto).
      eapply tr_generalize.
        {
        apply tr_equal_elim.
        eapply tr_equal_eta2; eauto.
        }
      apply (tr_karrow_formation_invert2 _ a a).
      eapply tr_equal_formation_invert1.
      eapply tr_inhabitation_formation; eauto.
      }
    }

    {
    apply tr_equal_elim.
    eapply tr_equal_eta2; eauto.
    }
  }

  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }

  {
  simpsub; auto.
  }
Qed.

Lemma karrowElimEq_valid : karrowElimEq_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b m n p q ext1 ext0 Hm Hp.
rewrite -> def_eq in Hm, Hp |- *.
rewrite -> def_karrow in Hm.
unfold Defs.triv.
apply tr_equal_intro.
eapply tr_pi_elim'.
  {
  apply (tr_eqtype_convert _#3 (karrow a b)).
    {
    apply tr_karrow_pi_equal.
      {
      eapply tr_equal_formation_invert1.
      eapply tr_inhabitation_formation; eauto.
      }

      {
      replace (deqtype b b) with (substj (dot p id) (deqtype (subst sh1 b) (subst sh1 b))) by (simpsub; auto).
      eapply tr_generalize.
        {
        apply (tr_transitivity _ _ q); [| apply tr_symmetry]; apply tr_equal_elim; eapply tr_equal_eta2; eauto.
        }
      apply (tr_karrow_formation_invert2 _ a a).
      eapply tr_equal_formation_invert1.
      eapply tr_inhabitation_formation; eauto.
      }
    }

    {
    apply tr_equal_elim.
    eapply tr_equal_eta2; eauto.
    }
  }

  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }

  {
  simpsub; auto.
  }
Qed.

Lemma karrowElim_valid : karrowElim_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b m p Hm Hp.
rewrite -> def_karrow in Hm.
eapply tr_pi_elim'.
  {
  apply (tr_eqtype_convert _#3 (karrow a b)).
    {
    apply tr_karrow_pi_equal.
      {
      eapply tr_inhabitation_formation; eauto.
      }

      {
      replace (deqtype b b) with (substj (dot p id) (deqtype (subst sh1 b) (subst sh1 b))) by (simpsub; auto).
      eapply tr_generalize; eauto.
      apply (tr_karrow_formation_invert2 _ a a).
      eapply tr_inhabitation_formation; eauto.
      }
    }

    {
    auto.
    }
  }

  {
  auto.
  }

  {
  simpsub; auto.
  }
Qed.

Lemma karrowEta_valid : karrowEta_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b m ext0 Hm.
rewrite -> def_of in Hm.
rewrite -> def_eq.
rewrite -> def_karrow in Hm |- *.
unfold Defs.triv.
apply tr_equal_intro.
apply tr_karrow_eta.
apply tr_equal_elim.
eapply tr_equal_eta2; eauto.
Qed.

Lemma karrowExt_valid : karrowExt_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b m n ext3 ext2 ext1 ext0 Hb Hm Hn Heq.
rewrite -> def_istp in Hb.
rewrite -> def_of in Hm, Hn.
rewrite -> def_eq in Heq |- *.
rewrite -> def_karrow in Hm, Hn |- *.
unfold Defs.triv.
apply tr_equal_intro.
eapply tr_transitivity.
  {
  apply tr_karrow_eta.
  apply tr_equal_elim; eapply tr_equal_eta2; eauto.
  }
eapply tr_transitivity.
2:{
  apply tr_symmetry.
  apply tr_karrow_eta.
  apply tr_equal_elim; eapply tr_equal_eta2; eauto.
  }
apply (tr_eqtype_convert _#3 (pi a (subst sh1 b))).
  {
  apply tr_eqtype_symmetry.
  apply tr_karrow_pi_equal.
    {
    apply (tr_karrow_formation_invert1 _ _ _ b b).
    eapply tr_equal_formation_invert1.
    eapply tr_inhabitation_formation; eauto.
    }

    {
    eapply tr_eqtype_eta2; eauto.
    }
  }
apply tr_pi_intro.
  {
  apply (tr_karrow_formation_invert1 _ _ _ b b).
  eapply tr_equal_formation_invert1.
  eapply tr_inhabitation_formation; eauto.
  }

  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }
Qed.

Lemma intersectForm_valid : intersectForm_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b m n Ha Hb.
rewrite -> def_istp in * |- *.
unfold Defs.triv.
rewrite -> def_intersect.
apply tr_intersect_formation; eauto using deqtype_intro.
Qed.

Lemma intersectEq_valid: intersectEq_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a a' b b' m n Ha Hb.
rewrite -> !def_eqtp in * |- *.
unfold Defs.triv.
rewrite -> !def_intersect.
apply tr_intersect_formation; eauto using deqtype_intro.
Qed.

Lemma intersectFormUniv_valid : intersectFormUniv_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b i m n Ha Hb.
rewrite -> def_of in * |- *.
rewrite -> def_univ in * |- *.
unfold Defs.triv.
rewrite -> def_intersect.
apply tr_equal_intro.
apply tr_intersect_formation_univ; eauto using deq_intro.
Qed.

Lemma intersectEqUniv_valid : intersectEqUniv_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a a' b b' i m n Ha Hb.
rewrite -> def_eq in * |- *.
rewrite -> def_univ in * |- *.
unfold Defs.triv.
rewrite -> !def_intersect.
apply tr_equal_intro.
apply tr_intersect_formation_univ; eauto using deq_intro.
Qed.

Lemma intersectIntroOf_valid : intersectIntroOf_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b m ext1 ext0 Hab Hm.
rewrite -> def_istp in Hab.
rewrite -> def_of in Hm |- *.
rewrite -> def_intersect.
unfold Defs.triv.
apply tr_equal_intro.
apply tr_intersect_intro.
  {
  eapply tr_eqtype_eta2; eauto.
  }

  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }
Qed.

Lemma intersectIntroEq_valid : intersectIntroEq_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b m n ext1 ext0 Hab Hmn.
rewrite -> def_istp in Hab.
rewrite -> def_eq in Hmn |- *.
rewrite -> def_intersect.
unfold Defs.triv.
apply tr_equal_intro.
apply tr_intersect_intro.
  {
  eapply tr_eqtype_eta2; eauto.
  }

  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }
Qed.

Lemma intersectIntro_valid : intersectIntro_obligation.
Proof.
prepare.
intros G a b ext m Hhyg Ha Hb.
rewrite -> def_intersect.
apply tr_intersect_intro; auto.
simpsub.
replace (subst (dot triv sh1) m) with m; auto.
so (subst_into_absent_single _ _ _ triv Hhyg) as H.
simpsubin H.
symmetry.
auto.
Qed.

Lemma intersectElimOf_valid : intersectElimOf_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b m p ext1 ext0 Hm Hp.
rewrite -> def_of in Hp, Hm |- *.
rewrite -> def_intersect in Hm.
unfold Defs.triv.
simpsub.
apply tr_equal_intro.
eapply tr_intersect_elim.
  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }

  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }
Qed.

Lemma intersectElimEq_valid : intersectElimEq_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b m n p ext1 ext0 Hm Hp.
rewrite -> def_of in Hp.
rewrite -> def_eq in Hm |- *.
rewrite -> def_intersect in Hm.
unfold Defs.triv.
simpsub.
apply tr_equal_intro.
eapply tr_intersect_elim.
  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }

  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }
Qed.

Lemma intersectElim_valid : intersectElim_obligation.
Proof.
prepare.
intros G a b p m ext Hm Hp.
rewrite -> def_intersect in Hm.
so (tr_intersect_elim _#7 Hm Hp) as H.
simpsub.
auto.
Qed.

Lemma intersectFormInv1_valid : intersectFormInv1_obligation.
Proof.
prepare.
intros G a b ext H.
rewrite -> def_intersect in H.
eapply tr_intersect_formation_invert1; eauto.
Qed.

Lemma intersectFormInv2_valid : intersectFormInv2_obligation.
Proof.
prepare.
intros G a b m ext1 ext0 Hpi Hm.
rewrite -> def_intersect in Hpi.
simpsub.
cut (tr (hyp_tm a :: G) (deqtype b b)).
  {
  intro Hb.
  so (tr_generalize _#4 Hm Hb) as H.
  simpsubin H.
  exact H.
  }
eapply tr_intersect_formation_invert2; eauto.
Qed.

Hint Rewrite def_guard : prepare.

Lemma guardForm_valid : guardForm_obligation.
Proof.
prepare.
intros G a b ext1 ext0 Ha Hb.
apply tr_guard_formation; auto.
Qed.

Lemma guardFormUniv_valid : guardFormUniv_obligation.
Proof.
prepare.
intros G a b lv ext1 ext0 Ha Hb.
apply tr_guard_formation_univ; auto.
Qed.

Lemma guardEq_valid : guardEq_obligation.
Proof.
prepare.
intros G a a' b b' ext1 ext0 Ha Hb.
apply tr_guard_formation; auto.
Qed.

Lemma guardEqUniv_valid : guardEqUniv_obligation.
Proof.
prepare.
intros G a a' b b' lv ext1 ext0 Ha Hb.
apply tr_guard_formation_univ; auto.
Qed.

Lemma guardIntroOf_valid : guardIntroOf_obligation.
Proof.
prepare.
intros G a b m ext1 ext0 Ha Hm.
apply tr_guard_intro; auto.
Qed.

Lemma guardIntroEq_valid : guardIntroEq_obligation.
Proof.
prepare.
intros G a b m n ext1 ext0 Ha Hmn.
apply tr_guard_intro; auto.
Qed.

Lemma guardIntro_valid : guardIntro_obligation.
Proof.
prepare.
intros G a b ext0 m Hhide Ha Hm.
apply tr_guard_intro; auto.
simpsub.
replace (subst (dot triv sh1) m) with m; auto.
so (subst_into_absent_single _#3 triv Hhide) as Heq.
simpsubin Heq.
symmetry; auto.
Qed.

Lemma guardElimOf_valid : guardElimOf_obligation.
Proof.
prepare.
intros G a b m ext1 n Hm Hn.
eapply tr_guard_elim; eauto.
Qed.

Lemma guardElimEq_valid : guardElimEq_obligation.
Proof.
prepare.
intros G a b m n ext1 p Hmn Hp.
eapply tr_guard_elim; eauto.
Qed.

Lemma guardElim_valid : guardElim_obligation.
Proof.
prepare.
intros G a b m n Hm Hn.
eapply tr_guard_elim; eauto.
Qed.

Lemma guardSatEq_valid : guardSatEq_obligation.
Proof.
prepare.
intros G a b ext1 m Hb Hm.
eapply tr_guard_sat_eq; eauto.
Qed.


Require Import HoTT.
Require Import Syntax.ScopeSystem.
Require Import Auxiliary.General.
Require Import Auxiliary.Closure.
Require Import Auxiliary.Family.
Require Import Auxiliary.Coproduct.
Require Import Syntax.All.
Require Import Typing.Context.
Require Import Typing.Judgement.
Require Import Typing.RawRule.

(**
  This module defines the _standard structural rules_ — the rules which are not
  specified separately for every type theory, but are always provided
  automatically. These fall into several groups:

  - variable-renaming rules: [rename]
  - substitution rules: [subst_apply], [subst_equal]
  - variable rule: [variable_rule]
  - equality rules:
      [tyeq_refl, tyeq_sym, tyeq_trans,
      tmeq_refl, tmeq_sym, tmeq_trans,
      term_convert, tmeq_convert].

  All of the above are then collected as a single family [structural_rule].

  Each rule, e.g. [variable_rule] — which formally is not just a single rule,
  but a family of rules, one for each raw context [Γ] and position [i] of it
  — has two things one might want to call [variable_rule]:

  - the definition of it as a family of rules;
  - the access function picking it out in the family [structural_rule].

  We use [variable_rule] for the access function, and call the family
  [variable_rule_instance], since an element of the family is a specific
  instance of the rule.  So when using this rule in a derivation, one will first
  say [apply variable_rule] to select the context extension rule, and then
  specify the particular instance desired, i.e. the earlier context and the type
  to extend by.

  (An alternative convention could be to use [variable_rule] for the family,
  and [select_variable_rule] or similar for the access function.)
*)

Section StructuralRules.

Context {σ : scope_system}.
Context (Σ : signature σ).

Section RenamingRules.
(** Renaming of variables:

given a variable-renaming f : Γ -> Δ respecting types up to literal sytnactic
equality (e.g. a weakening), if J is derivable over Γ, then f_* J is derivable
over Δ.

  Γ |- J   [J any hypothetical judgement over Γ]
  -------------------- [f : Γ -> Γ' a renaming respcting types]
  Γ' |- f_* J

This is not a traditional rule.  We need it since, in our setup, instantiations
of raw rules will always have conclusion context scope of the form γ+δ, where
δ is the conclusion context scope of the raw rule; this lets us go from such
conclusions to arbitrary contexts.

The specific instances we really use are isomorphisms of the form γ <~> γ+0 and
(γ+δ)+χ <~> γ+(δ+χ), used for instance in the instantiation of derivations,
Over some specific scope systems, e.g. de Bruijn scopes, these isomorphisms are
identities, so this rule should never be required over such scope systems.
*)

(* TODO: naming of this rule not ideal.  Keep seeking better options? *)
(* TODO: would it work more cleanly if the direction of this rule was reversed? *)
(* TODO: add restriction to equivalences! *)
Definition rename_instance : Closure.system (judgement Σ).
Proof.
  exists { Γ : raw_context Σ
    & { Γ' : raw_context Σ
    & { f : typed_renaming Γ Γ'
    & hypothetical_judgement Σ Γ}}}.
  intros [Γ [Γ' [f J]]]. split.
  - (* premises: *)
    refine [< _ >]. exists Γ; exact J.
  - (* conclusion: *)
    exists Γ'. exact (rename_hypothetical_judgement f J).
Defined.

End RenamingRules.

Section SubstitutionRules.

(** General substitution along (weakly typed) substitutions:

 [for each i in Γ,
    either “f acts trivially at i”, i.e.[f i = x_j] and [Γ' j = f^* Γ i],
    _or_ have a premise: ]
  Γ' |- f i : f^* (Γ i)
  Γ |- J   [for J any hypothetical judgement]
  --------------------
  Γ' |- f^*J

  The idea is that typically, substitution only acts non-trivially on some detachable part of the context; and typechecking is only required for this non-trivial part.
*)

Definition subst_apply_instance : Closure.system (judgement Σ).
Proof.
  exists { Γ : raw_context Σ
    & { Γ' : raw_context Σ
    & hypothetical_judgement Σ Γ
    * { f : raw_substitution Σ Γ' Γ
    & forall i : Γ, option
             { j : Γ' & (f i = raw_variable j) * (Γ' j = substitute f (Γ i)) }
    }}}.
  intros [Γ [Γ' [J [f f_triv]]]].
  split.
  (* premises: *)
  - refine (Family.adjoin _ _).
    (* all components of [f] are suitably typed: *)
    + exists {i : Γ & is_none (f_triv i)}.
      intros [i _]. refine [! Γ' |- _ ; _ !].
      * exact (f i).
      * exact (substitute f (Γ i)).
    (* the target judgement holds over Γ *)
    + exists Γ; exact J.
  (* conclusion: *)
  - exists Γ'.
    exact (substitute_hypothetical_judgement f J).
Defined.

(** Substitution respects *equality* of context morphisms:

  Γ' |- f(x) = g(x) : A   [for each x in Γ, A := type of x in Γ]
  Γ |- J   [for J any hypothetical object judgement]
  --------------------
  Γ' |- f^*J = g^*J  [ over f* of boundary of J ]
 *)
Definition subst_equal_instance : Closure.system (judgement Σ).
Proof.
  exists {   Γ : raw_context Σ
    & { Γ' : raw_context Σ
    & { fg : raw_substitution Σ Γ' Γ * raw_substitution Σ Γ' Γ
    & (forall i:Γ, option
           { j : Γ' & ((fst fg i = raw_variable j)
                      * (snd fg i = raw_variable j))
                      * ((Γ' j = substitute (fst fg) (Γ i))
                      * (Γ' j = substitute (snd fg) (Γ i)))})
    * { cl : syntactic_class
        & hypothetical_judgement_expressions Σ (form_object cl) Γ}}}}.
  intros [Γ [Γ' [[f g] [fg_triv [cl J]]]]].
  split.
  (* premises: *)
  - refine (Family.adjoin _ _).
    (* the target judgement holds over Γ *)
    2: { exists Γ, (form_object cl); exact J. }
    (* remaning premises say fg forms a “weakly equal pair”,
     i.e. for each index i on which fg does not act trivially,
     [f i] and [g i] are each well-typed and are equal. *)
    eapply (@Family.bind Γ).
    { exists {i : Γ & is_none (fg_triv i) }.
      intros [i _]; exact i. }
    intros i. refine [< _ ; _ ; _ >]; exists Γ'.
    * exact [! Γ' |- f i ; substitute f (Γ i) !].
    * exact [! Γ' |- g i ; substitute g (Γ i) !].
    * exact [! Γ' |- f i ≡ g i ; substitute f (Γ i) !].
  (* conclusion: *)
  - exists Γ'.
    simple refine (substitute_equal_hypothetical_judgement f g _ _).
    { refine (Build_hypothetical_judgement _ J). }
    apply tt.
Defined.

Definition substitution_instance : Closure.system (judgement Σ)
  := subst_apply_instance + subst_equal_instance.

End SubstitutionRules.

Section HypotheticalStructuralRules.

(* Hypothetical structural rules:

  - var rule
  - equality rules

*)

(* The general variable rule:

  Γ |- A type
  ------------- (x in Γ, A := type of x in Γ)
  Γ |- x : A

*)

Definition variable_instance : Closure.system (judgement Σ).
Proof.
  exists { Γ : raw_context Σ & Γ }.
  intros [Γ x]. set (A := Γ x). split.
  (* premises *)
  - exact [< [! Γ |- A !] >].
  (*conclusion *)
  - exact [! Γ |- (raw_variable x) ; A !].
Defined.

Section Equality.
(** The equality structural rules can all be specified as raw rules over the empty signature.

(One could specify them directly over arbitrary signatures, but then one would have to prove naturality for them afterwards.)*)

(* rule tyeq_refl
    ⊢ A type
-----------------
    ⊢ A ≡ A
*)

Definition tyeq_refl_rule : raw_rule (Signature.empty σ).
Proof.
  (* arity/metavariables of rule *)
  pose (Metas := [<
      (class_type, scope_empty σ )    (* [ A ] *)
    >] : arity _).
  (* Name the symbols. *)
  pose (A := tt : Metas).
  exists Metas.
  (* Premise *)
  - refine [< _ >].
    + (* Premise ⊢ A type *)
      simple refine [! _ |- _ !].
      * exact [::].
      * exact [M/ A /].
  (* Conclusion : ⊢ A ≡ A *)
  - simple refine [! _ |- _ ≡ _ !].
    + exact [::].
    + exact [M/ A /].
    + exact [M/ A /].
Defined.

(* rule tyeq_sym
   ⊢ A ≡ B
--------------
   ⊢ B ≡ A
*)

Definition tyeq_sym_rule : raw_rule (Signature.empty σ).
Proof.
  (* arity / metavariables of rule *)
  pose (Metas := [<
      (class_type, scope_empty σ )    (* [ A ] *)
    ; (class_type, scope_empty σ )    (* [ B ] *)
    >] : arity _).
  (* Name the symbols. *)
  pose (B := None : Metas).
  pose (A := Some tt : Metas).
  exists Metas.
  (* Premise *)
  - refine [< _ >].
    + (* Premise ⊢ A ≡ B *)
      simple refine [! _ |- _ ≡ _ !].
      * exact [::].
      * exact [M/ A /].
      * exact [M/ B /].
  (* Conclusion : ⊢ B ≡ A *)
  - simple refine [! _ |- _ ≡ _ !].
    + exact [::].
    + exact [M/ B /].
    + exact [M/ A /].
Defined.

(* rule tyeq_trans
  ⊢ A ≡ B     ⊢ B ≡ C
-----------------------
       ⊢ A ≡ C
*)

Definition tyeq_trans_rule : raw_rule (Signature.empty σ).
Proof.
  (* arity / metavariables of rule *)
  pose (Metas := [<
      (class_type, scope_empty σ )    (* [ A ] *)
    ; (class_type, scope_empty σ )    (* [ B ] *)
    ; (class_type, scope_empty σ )    (* [ C ] *)
    >] : arity _).
  (* Name the symbols. *)
  pose (C := None : Metas).
  pose (B := Some None : Metas).
  pose (A := Some (Some tt) : Metas).
  exists Metas.
  (* Premise *)
  - refine [< _ ; _ >].
    + (* Premise ⊢ A ≡ B *)
      simple refine [! _ |- _ ≡ _ !].
      * exact [::].
      * exact [M/ A /].
      * exact [M/ B /].
    + (* Premise ⊢ B ≡ C *)
      simple refine [! _ |- _ ≡ _ !].
      * exact [::].
      * exact [M/ B /].
      * exact [M/ C /].
  (* Conclusion : ⊢ A ≡ C *)
  - simple refine [! _ |- _ ≡ _ !].
    + exact [::].
    + exact [M/ A /].
    + exact [M/ C /].
Defined.

(* rule tmeq_refl
  ⊢ u : A
-----------
⊢ u ≡ u : A
*)

Definition tmeq_refl_rule : raw_rule (Signature.empty σ).
Proof.
  (* arity/metavariables of rule *)
  pose (Metas := [<
      (class_type, scope_empty σ)    (* [ A ] *)
    ; (class_term, scope_empty σ)    (* [ u ] *)
    >] : arity _).
  (* Name the symbols. *)
  pose (u := None : Metas).
  pose (A := Some tt : Metas).
  exists Metas.
  (* Premise *)
  - refine [< _ >].
    + (* Premise ⊢ u : A type *)
      simple refine [! _ |- _ ; _ !].
      * exact [::].
      * exact [M/ u /].
      * exact [M/ A /].
  (* Conclusion : ⊢ u ≡ u : A *)
  - simple refine [! _ |- _ ≡ _ ; _ !].
    + exact [::].
    + exact [M/ A /].
    + exact [M/ u /].
    + exact [M/ u /].
Defined.

(* rule tmeq_sym
   ⊢ u ≡ v : A
----------------
   ⊢ v ≡ u : A
*)

Definition tmeq_sym_rule : raw_rule (Signature.empty σ).
Proof.
  (* arity/metavariables of rule *)
  pose (Metas := [<
      (class_type, scope_empty σ)    (* [ A ] *)
    ; (class_term, scope_empty σ)    (* [ u ] *)
    ; (class_term, scope_empty σ)    (* [ v ] *)
    >] : arity _).
  (* Name the symbols. *)
  pose (v := None : Metas).
  pose (u := Some None : Metas).
  pose (A := Some (Some tt) : Metas).
  exists Metas.
  (* Premise *)
  - refine [< _ >].
    + (* Premise ⊢ u ≡ v : A type *)
      simple refine [! _ |- _ ≡ _ ; _ !].
      * exact [::].
      * exact [M/ A /].
      * exact [M/ u /].
      * exact [M/ v /].
  (* Conclusion : ⊢ v ≡ u : A *)
  - simple refine [! _ |- _ ≡ _ ; _ !].
    + exact [::].
    + exact [M/ A /].
    + exact [M/ v /].
    + exact [M/ u /].
Defined.

(* rule tmeq_trans
  ⊢ u ≡ v : A     ⊢ v ≡ w : A
-------------------------------
         ⊢ u ≡ w : A
*)

Definition tmeq_trans_rule : raw_rule (Signature.empty σ).
Proof.
  (* arity/metavariables of rule *)
  pose (Metas := [<
      (class_type, scope_empty σ)    (* [ A ] *)
    ; (class_term, scope_empty σ)    (* [ u ] *)
    ; (class_term, scope_empty σ)    (* [ v ] *)
    ; (class_term, scope_empty σ)    (* [ w ] *)
    >] : arity _).
  (* Name the symbols. *)
  pose (w := None : Metas).
  pose (v := Some None : Metas).
  pose (u := Some (Some None) : Metas).
  pose (A := Some (Some (Some tt)) : Metas).
  exists Metas.
  (* Premise *)
  - refine [< _ ; _ >].
    + (* Premise ⊢ u ≡ v : A type *)
      simple refine [! _ |- _ ≡ _ ; _ !].
      * exact [::].
      * exact [M/ A /].
      * exact [M/ u /].
      * exact [M/ v /].
    + (* Premise ⊢ v ≡ w : A type *)
      simple refine [! _ |- _ ≡ _ ; _ !].
      * exact [::].
      * exact [M/ A /].
      * exact [M/ v /].
      * exact [M/ w /].
  (* Conclusion : ⊢ u ≡ w : A *)
  - simple refine [! _ |- _ ≡ _ ; _ !].
    + exact [::].
    + exact [M/ A /].
    + exact [M/ u /].
    + exact [M/ w /].
Defined.

(* rule term_convert

 ⊢ A, B type
 ⊢ A ≡ B type
 ⊢ u : A
-------------
 ⊢ u : B
*)

Definition term_convert_rule : raw_rule (Signature.empty σ).
Proof.
  (* arity/metavariables of rule *)
  pose (Metas := [<
      (class_type, scope_empty σ)    (* [ A ] *)
    ; (class_type, scope_empty σ)    (* [ B ] *)
    ; (class_term, scope_empty σ)    (* [ u ] *)
    >] : arity _).
  (* Name the symbols. *)
  pose (u := None : Metas).
  pose (B := Some None : Metas).
  pose (A := Some (Some tt) : Metas).
  exists Metas.
  (* Premise *)
  - refine [< _ ; _ ; _ ; _ >].
    + (* Premise ⊢ A type *)
      simple refine [! _ |- _ !].
      * exact [::].
      * exact [M/ A /].
    + (* Premise ⊢ B type *)
      simple refine [! _ |- _ !].
      * exact [::].
      * exact [M/ B /].
    + (* Premise ⊢ A ≡ B *)
      simple refine [! _ |- _ ≡ _ !].
      * exact [::].
      * exact [M/ A /].
      * exact [M/ B /].
    + (* Premise ⊢ u : A *)
      simple refine [! _ |- _ ; _ !].
      * exact [::].
      * exact [M/ u /].
      * exact [M/ A /].
  (* Conclusion: ⊢ u : B *)
  - simple refine [! _ |- _ ; _ !].
    + exact [::].
    + exact [M/ u /].
    + exact [M/ B /].
Defined.

(* rule tmeq_convert

 ⊢ A, B type
 ⊢ A ≡ B type
 ⊢ u, u' : A
 ⊢ u = u' : A
-------------
 ⊢ u = u' : B
*)

Definition tmeq_convert_rule : raw_rule (Signature.empty σ).
Proof.
  (* arity/metavariables of rule *)
  pose (Metas := [<
      (class_type, scope_empty σ)    (* [ A ] *)
    ; (class_type, scope_empty σ)    (* [ B ] *)
    ; (class_term, scope_empty σ)    (* [ u ] *)
    ; (class_term, scope_empty σ)    (* [ u' ] *)
    >] : arity _).
  (* Name the symbols. *)
  pose (A := Some (Some (Some tt)) : Metas).
  pose (B := Some (Some None) : Metas).
  pose (u := Some None : Metas).
  pose (u' := None : Metas).
  exists Metas.
  (* Premise *)
  - refine [< _ ; _ ; _ ; _ ; _ ; _ >].
    + (* Premise ⊢ A type *)
      exact [! [::] |- [M/ A /] !].
    + (* Premise ⊢ B type *)
      exact [! [::] |- [M/ B /] !].
    + (* Premise ⊢ A ≡ B *)
      exact [! [::] |- [M/ A /] ≡ [M/ B /] !].
    + (* Premise ⊢ u : A *)
      exact [! [::] |- [M/ u /] ; [M/ A /] !].
    + (* Premise ⊢ u' : A *)
      exact [! [::] |- [M/ u' /] ; [M/ A /] !].
    + (* Premise ⊢ u ≡ u' : A *)
      exact [! [::] |- [M/ u /] ≡ [M/ u' /] ; [M/ A /] !].
  (* Conclusion: ⊢ u ≡ u' : B *)
  - exact [! [::] |- [M/ u /] ≡ [M/ u' /] ; [M/ B /] !].
Defined.

Definition equality_raw_rule : family (raw_rule (Signature.empty σ))
  := [< tyeq_refl_rule
    ; tyeq_sym_rule
    ; tyeq_trans_rule
    ; tmeq_refl_rule
    ; tmeq_sym_rule
    ; tmeq_trans_rule
    ; term_convert_rule
    ; tmeq_convert_rule
    >].

Definition equality_instance : family (rule (judgement Σ))
  := Family.bind
       (Family.fmap (RawRule.fmap (Signature.empty_rect _)) equality_raw_rule)
       RawRule.closure_system.

End Equality.

End HypotheticalStructuralRules.

Definition structural_rule_without_subst : Closure.system (judgement Σ)
  := rename_instance + variable_instance + equality_instance.

Definition structural_rule : Closure.system (judgement Σ)
  := structural_rule_without_subst + substitution_instance.

End StructuralRules.

Section StructuralRuleAccessors.
  (** Access functions, for selcting structural rules in derivations *)

  (* Note: in a separate section just so that [Σ] can be declared as implicit
   argument for them all, rather than needing to be all redeclared with
   [Arguments] afterwards. *)

Context {σ : scope_system} {Σ : signature σ}.

Local Definition rename : rename_instance Σ -> structural_rule Σ
  := fun i => inl (inl (inl i)).
Definition subst_apply : subst_apply_instance Σ -> structural_rule Σ
  := fun i => inr (inl i).
Definition subst_equal : subst_equal_instance Σ -> structural_rule Σ
  := fun i => inr (inr i).
Definition variable_rule : variable_instance Σ -> structural_rule Σ
  := fun i => inl (inl (inr i)).
Definition equality_rule : equality_instance Σ -> structural_rule Σ
  := fun i => inl (inr i).
Definition tyeq_refl : RawRule.closure_system
      (RawRule.fmap (Signature.empty_rect _) tyeq_refl_rule)
    -> structural_rule Σ
  := fun i => equality_rule (Some (Some (Some (Some (Some (Some (Some tt)))))) ; i).
Definition tyeq_sym : RawRule.closure_system
      (RawRule.fmap (Signature.empty_rect _) tyeq_sym_rule)
    -> structural_rule Σ
  := fun i => equality_rule (Some (Some (Some (Some (Some (Some None))))) ; i).
Definition tyeq_trans : RawRule.closure_system
      (RawRule.fmap (Signature.empty_rect _) tyeq_trans_rule)
    -> structural_rule Σ
  := fun i => equality_rule (Some (Some (Some (Some (Some None)))) ; i).
Definition tmeq_refl : RawRule.closure_system
      (RawRule.fmap (Signature.empty_rect _) tmeq_refl_rule)
    -> structural_rule Σ
  := fun i => equality_rule (Some (Some (Some (Some None))) ; i).
Definition tmeq_sym : RawRule.closure_system
      (RawRule.fmap (Signature.empty_rect _) tmeq_sym_rule)
    -> structural_rule Σ
  := fun i => equality_rule (Some (Some (Some None)) ; i).
Definition tmeq_trans : RawRule.closure_system
      (RawRule.fmap (Signature.empty_rect _) tmeq_trans_rule)
    -> structural_rule Σ
  := fun i => equality_rule (Some (Some None) ; i).
Definition term_convert : RawRule.closure_system
      (RawRule.fmap (Signature.empty_rect _) term_convert_rule)
    -> structural_rule Σ
  := fun i => equality_rule (Some None ; i).
Definition tmeq_convert : RawRule.closure_system
      (RawRule.fmap (Signature.empty_rect _) tmeq_convert_rule)
    -> structural_rule Σ
  := fun i => equality_rule (None ; i).

(* TODO: for testing! remove this, or replace the above with this *)
Definition term_convert' : RawRule.closure_system
      (RawRule.fmap (Signature.empty_rect _) term_convert_rule)
    -> equality_instance Σ
  := fun i => (Some None ; i).

End StructuralRuleAccessors.

Section StructuralRuleInd.

Context {σ : scope_system}.
Context {Σ : signature σ}.

Definition structural_rule_rect
  : forall (P : structural_rule Σ -> Type),
     (forall i_rename : rename_instance Σ, P (rename i_rename))
  -> (forall i_sub_ap : subst_apply_instance Σ, P (subst_apply i_sub_ap))
  -> (forall i_sub_eq : subst_equal_instance Σ, P (subst_equal i_sub_eq))
  -> (forall i_var : variable_instance Σ, P (variable_rule i_var))
  -> (forall i_eq : equality_instance Σ, P (equality_rule i_eq))
  -> forall s : structural_rule Σ, P s.
Proof.
  intros P ? ? ? ? ? s.
  destruct s as
      [ [ [ i_rename
          | i_var ]
        | i_eq ]
      | [i_sub_ap | i_sub_eq] ]
  ; eauto.
Defined.

Definition equality_instance_rect :
  forall (P : structural_rule Σ -> Type),
       (forall i_tyeq_refl : RawRule.closure_system
           (RawRule.fmap (Signature.empty_rect _) tyeq_refl_rule),
         P (tyeq_refl i_tyeq_refl))
    -> (forall tyeq_sym_rule : RawRule.closure_system
           (RawRule.fmap (Signature.empty_rect _) tyeq_sym_rule),
         P (tyeq_sym tyeq_sym_rule))
    -> (forall tyeq_trans_rule : RawRule.closure_system
           (RawRule.fmap (Signature.empty_rect _) tyeq_trans_rule),
         P (tyeq_trans tyeq_trans_rule))
    -> (forall i_tmeq_refl : RawRule.closure_system
          (RawRule.fmap (Signature.empty_rect _) tmeq_refl_rule),
         P (tmeq_refl i_tmeq_refl))
    -> (forall i_tmeq_sym : RawRule.closure_system
           (RawRule.fmap (Signature.empty_rect _) tmeq_sym_rule),
         P (tmeq_sym i_tmeq_sym))
    -> (forall i_tmeq_trans : RawRule.closure_system
           (RawRule.fmap (Signature.empty_rect _) tmeq_trans_rule),
         P (tmeq_trans i_tmeq_trans))
    -> (forall i_term_convert : RawRule.closure_system
           (RawRule.fmap (Signature.empty_rect _) term_convert_rule),
         P (term_convert i_term_convert))
    -> (forall i_tmeq_convert : RawRule.closure_system
           (RawRule.fmap (Signature.empty_rect _) tmeq_convert_rule),
         P (tmeq_convert i_tmeq_convert))
  -> forall e : equality_instance Σ, P (equality_rule e).
Proof.
  intros P X X0 X1 X2 X3 X4 X5 X6.
  intros [ index element ].
  repeat destruct index as [ index | ];
  try destruct index; eauto.
Defined.

End StructuralRuleInd.

(** For using the structural rules conveniently in derivations, we provide functions [derive_rename], [derive_variable] etc below.

To make those functions usable not just over the standard structural rules but also over the subst-free structural rules and other variants, we base them on a type-class [has_derivable].  [has_derivable R C] should be thought of as: the structural rules [R] have a canonical inclusion into the closure system [C], and so are available for derivaitons there. *)

Section Structural_Rule_Classes.

  Context `{H_Funext : Funext}
        {σ : scope_system} {Σ : signature σ}.

  Class has_derivable (Rs C : Closure.system (judgement Σ))
    := { use_derivable : Closure.map Rs C }.

  Global Arguments use_derivable _ {_ _}.

  Global Instance trivial_has_derivable {Rs}
    : has_derivable Rs Rs.
  Proof.
    constructor. apply Closure.idmap.
  Defined.

  Global Instance sum_left_has_derivable {Rs}
      {C D : Closure.system (judgement Σ)}
      `{ H_C : has_derivable Rs C }
    : has_derivable Rs (C + D).
  Proof.
    constructor.
    eapply Closure.compose.
    2: { apply Closure.inl. }
    apply (use_derivable Rs).
  Defined.

  Global Instance sum_right_has_derivable {Rs}
      {C D : Closure.system (judgement Σ)}
      `{ H_D : has_derivable Rs D }
    : has_derivable Rs (C + D).
  Proof.
    constructor.
    eapply Closure.compose.
    2: { apply Closure.inr. }
    apply (use_derivable Rs).
  Defined.

End Structural_Rule_Classes.

Section Renaming_Interface.
  (** Interface to the renaming structural rule,
   and some frequently-used special cases. *)

  Context
    `{H_Funext : Funext}
    {σ : scope_system} {Σ : signature σ}
    {T : Closure.system (judgement Σ)}
    `{H_T : has_derivable _ _ (rename_instance Σ) T}
    {H : family (judgement Σ) }.

  Lemma derive_rename
      (Γ Γ' : raw_context Σ)
      (f : typed_renaming Γ Γ')
      (J : hypothetical_judgement Σ Γ)
    : Closure.derivation T H (Build_judgement Γ J)
    -> Closure.derivation T H
      (Build_judgement Γ' (rename_hypothetical_judgement f J)).
  Proof.
    intros D.
    simple refine (Closure.deduce'_via_map (use_derivable _) _ _ _).
    { exists Γ, Γ', f; exact J. }
    { apply idpath. }
    { intros; apply D. }
  Defined.

  Lemma derive_rename'
      (J J' : judgement Σ)
      (f : typed_renaming
             (context_of_judgement J') (context_of_judgement J))
      (e : hypothetical_part J
           = rename_hypothetical_judgement f (hypothetical_part J'))
    : Closure.derivation T H J'
    -> Closure.derivation T H J.
  Proof.
    intros D.
    simple refine (Closure.deduce'_via_map (use_derivable _) _ _ _).
    { refine (_;(_;(f;_))). exact J'. }
    { apply (ap (Build_judgement _)), inverse, e. }
    { intros; apply D. }
  Defined.

  Lemma derive_renaming_along_equiv
      (J : judgement Σ)
      {γ' : σ} (e : γ' <~> scope_of_judgement J)
    : Closure.derivation T H J
    -> Closure.derivation T H (Judgement.rename J e).
  Proof.
    simple refine (derive_rename' _ _ _ _).
    - apply Context.typed_renaming_to_rename_context.
    - apply idpath.
  Defined.

  Lemma derive_from_renaming_along_equiv
      (J : judgement Σ)
      {γ' : σ} (e : γ' <~> scope_of_judgement J)
    : Closure.derivation T H (Judgement.rename J e)
      -> Closure.derivation T H J.
  Proof.
    simple refine (derive_rename' _ _ _ _).
    - apply Context.typed_renaming_from_rename_context.
    - apply inverse, eq_by_expressions_hypothetical_judgement; intros s.
      eapply concat. { apply rename_rename. }
      eapply concat. 2: { apply rename_idmap. }
      apply (ap_2back Expression.rename), path_forall, (eisretr e).
  Defined.

(** A particularly common case: renaming along the equivalence [ Γ <~> Γ+0 ].

This arises with instantiations of raw rules: their conclusion is typically
over a context [ Γ + 0 ], not just [ Γ ] as one would want. *)

  Definition derive_reindexing_to_empty_sum
      (J : judgement Σ)
    : Closure.derivation T H J
    -> Closure.derivation T H
         (Judgement.rename J (equiv_inverse (scope_sum_empty_inl _))).
  Proof.
    apply derive_renaming_along_equiv.
  Defined.

  Definition derive_from_reindexing_to_empty_sum
      {Γ : raw_context Σ}
      (J : hypothetical_judgement Σ Γ)
    : Closure.derivation T H
          (Judgement.rename
             (Build_judgement Γ J) (equiv_inverse (scope_sum_empty_inl _)))
    -> Closure.derivation T H (Build_judgement Γ J).
  Proof.
    apply derive_from_renaming_along_equiv.
  Defined.

End Renaming_Interface.

Section Variable_Interface.
  (** Interface to the variable structural rule *)

  Context
    `{H_Funext : Funext}
    {σ : scope_system} {Σ : signature σ}
    {T : Closure.system (judgement Σ)}
    `{H_T : has_derivable _ _ (variable_instance Σ) T}
    {H : family (judgement Σ) }.

  Lemma derive_variable
      (Γ : raw_context Σ) (i : Γ)
      (d_Γi : derivation T H [! Γ |- Γ i !])
    : derivation T H [! Γ |- raw_variable i ; Γ i !].
  Proof.
    simple refine (Closure.deduce'_via_map (use_derivable _) _ _ _).
    { exists Γ; exact i. }
    { apply idpath. }
    { intros; assumption. }
  Defined.

  Lemma derive_variable'
      (Γ : raw_context Σ)
      (Je : hypothetical_judgement_expressions Σ (form_object class_term) Γ)
      (J := Build_judgement Γ (Build_hypothetical_judgement _ Je) : judgement Σ)
      (i : Γ)
      (e_tm : Je (@the_boundary_slot
                     (form_object class_term) the_type_slot) = Γ i)
      (e_ty : Je (the_head_slot _) = raw_variable i)
      (d_Γi : derivation T H [! Γ |- Γ i !])
    : derivation T H J.
  Proof.
    simple refine (Closure.deduce'_via_map (use_derivable _) _ _ _).
    { exists Γ; exact i. }
    { apply Judgement.eq_by_eta; simpl.
      apply ap, ap2; apply inverse; assumption.
    }
    { intros; assumption. }
  Defined.

End Variable_Interface.

Section Substitution_Interface.
  (** Interface to the substitution structural rules *)

  Context
    `{H_Funext : Funext}
    {σ : scope_system} {Σ : signature σ}
    {T : Closure.system (judgement Σ)}
    `{H_T : has_derivable _ _ (substitution_instance Σ) T}
    {H : family (judgement Σ) }.

  Definition derive_subst_apply'
      ( J J' : judgement Σ )
      ( Γ := context_of_judgement J )
      ( Γ' := context_of_judgement J' )
      ( f : raw_substitution Σ Γ' Γ )
      ( e : hypothetical_part J' = substitute_hypothetical_judgement f J)
      ( d_f : forall i,
        { j : Γ' & (f i = raw_variable j) * (Γ' j = substitute f (Γ i)) }
        + derivation T H [! Γ' |- f i ; substitute f (Γ i) !])
      ( d_J : derivation T H J)
    : derivation T H J'.
  Proof.
    simple refine (Closure.deduce'_via_map (use_derivable _) _ _ _).
    { apply inl.
      exists Γ, Γ'. split. { exact J. } exists f.
      intros i.
      destruct (d_f i) as [ fi_triv | _ ].
      + exact (Some fi_triv).
      + exact None.
    }
    { apply (ap (Build_judgement _)), inverse, e. }
    simpl. intros [ [ i fi_nontriv ] | ].
    - destruct (d_f i) as [ ? | d_fi ].
      + destruct fi_nontriv.
      + apply d_fi.
    - apply d_J.
  Defined.

  Definition derive_subst_apply
      ( Γ Δ : raw_context Σ )
      ( f : raw_substitution Σ Δ Γ )
      ( J : hypothetical_judgement Σ Γ )
      ( d_f : forall i,
        { j : Δ & (f i = raw_variable j) * (Δ j = substitute f (Γ i)) }
        + derivation T H [! Δ |- f i ; substitute f (Γ i) !])
      ( d_J : derivation T H (Build_judgement Γ J))
    : derivation T H
             (Build_judgement Δ (substitute_hypothetical_judgement f J)).
  Proof.
    srapply derive_subst_apply'.
    1: exists Γ.
    3: apply idpath.
    1, 2: assumption.
  Defined.

  Definition derive_subst_equal'
      ( J J' : judgement Σ )
      ( Γ := context_of_judgement J )
      ( Γ' := context_of_judgement J' )
      ( f g : raw_substitution Σ Γ' Γ )
      ( J_obj : Judgement.is_object J )
      ( e : hypothetical_part J'
            = substitute_equal_hypothetical_judgement f g J J_obj)
      ( d_fg : forall i,
        { j : Γ' & ((f i = raw_variable j)
                 * (g i = raw_variable j))
                 * ((Γ' j = substitute f (Γ i))
                 * (Γ' j = substitute g (Γ i))) }
        + (derivation T H [! Γ' |- f i ; substitute f (Γ i) !]
          * derivation T H [! Γ' |- g i ; substitute g (Γ i) !]
          * derivation T H [! Γ' |- f i ≡ g i ; substitute f (Γ i) !]))
      ( d_J : derivation T H (Build_judgement Γ J))
    : derivation T H J'.
  Proof.
    subst Γ; destruct J as [Γ [[cl | cl] J]]; [ | destruct J_obj].
    simpl in *.
    simple refine (Closure.deduce'_via_map (use_derivable _) _ _ _).
    { apply inr.
      exists Γ, Γ', (f, g). refine (_,(cl; J)).
      intros i. destruct (d_fg i) as [ fgi_triv | _ ].
      + exact (Some fgi_triv).
      + exact None.
    }
    { apply (ap (Build_judgement _)), inverse, e. }
    intros [ i | ]; try assumption.
    simpl in i |- *. destruct i as [[i i_nontriv] j].
    destruct (d_fg i) as [ ? | d_fgi ]; destruct i_nontriv.
    recursive_destruct j; apply d_fgi.
  Defined.

  Definition derive_subst_equal
      ( Γ Γ' : raw_context Σ )
      ( f g : raw_substitution Σ Γ' Γ )
      ( J : hypothetical_judgement Σ Γ )
      ( J_obj : Judgement.is_object J )
      ( d_fg : forall i,
        { j : Γ' & ((f i = raw_variable j)
                 * (g i = raw_variable j))
                 * ((Γ' j = substitute f (Γ i))
                 * (Γ' j = substitute g (Γ i))) }
        + (derivation T H [! Γ' |- f i ; substitute f (Γ i) !]
          * derivation T H [! Γ' |- g i ; substitute g (Γ i) !]
          * derivation T H [! Γ' |- f i ≡ g i ; substitute f (Γ i) !]))
      ( d_J : derivation T H (Build_judgement Γ J))
    : derivation T H (Build_judgement Γ'
                         (substitute_equal_hypothetical_judgement f g J J_obj)).
  Proof.
    eapply (derive_subst_equal' (Build_judgement Γ J));
      try apply idpath;
      assumption.
  Defined.

End Substitution_Interface.

Section Equality_Interface.
  (** Interface to the equality structural rules *)

  Context
    `{H_Funext : Funext}
    {σ : scope_system} {Σ : signature σ}
    {T : Closure.system (judgement Σ)}
    `{H_ren : has_derivable _ _ (rename_instance Σ) T}
    `{H_eq : has_derivable _ _ (equality_instance Σ) T}
    {H : family (judgement Σ) }.

  Definition derive_tyeq_refl
      (Γ : raw_context Σ) (A : raw_expression Σ class_type Γ)
      (d_A : derivation T H [! Γ |- A !])
    : derivation T H [! Γ |- A ≡ A !].
  Proof.
    apply derive_from_reindexing_to_empty_sum.
    simple refine (Closure.deduce'_via_map
                            (use_derivable (equality_instance _)) _ _ _).
    { exists (Some (Some (Some (Some (Some (Some (Some tt))))))), Γ.
      intros i; recursive_destruct i. cbn.
      refine (Expression.rename _ A).
      apply scope_sum_empty_inl. }
    { refine (Judgement.eq_by_expressions _ _).
      - intros i. apply @instantiate_empty_ptwise.
      - intros i; recursive_destruct i;
          refine (instantiate_binderless_metavariable _).
    }
    intros [].
    refine (transport _ _
                      (derive_reindexing_to_empty_sum _ d_A)).
    apply Judgement.eq_by_expressions.
    - intros i. apply inverse, @instantiate_empty_ptwise.
    - intros i; recursive_destruct i;
        apply inverse, instantiate_binderless_metavariable.
  Defined.

  Definition derive_tyeq_sym
      (Γ : raw_context Σ) (A B : raw_expression Σ class_type Γ)
      (d_AB : derivation T H [! Γ |- A ≡ B !])
    : derivation T H [! Γ |- B ≡ A !].
  Proof.
    apply derive_from_reindexing_to_empty_sum.
    simple refine (Closure.deduce'_via_map
                             (use_derivable (equality_instance _)) _ _ _).
    { exists (Some (Some (Some (Some (Some (Some None)))))), Γ.
      intros i; recursive_destruct i;
        refine (Expression.rename (scope_sum_empty_inl _) _);
        [ exact A | exact B ].
    }
    { refine (Judgement.eq_by_expressions _ _).
      - apply @instantiate_empty_ptwise.
      - intros i; recursive_destruct i;
          apply instantiate_binderless_metavariable.
    }
    intros [].
    refine (transport _ _
                      (derive_reindexing_to_empty_sum _ d_AB)).
    apply Judgement.eq_by_expressions.
    - intros i. apply inverse, @instantiate_empty_ptwise.
    - intros i; recursive_destruct i;
        apply inverse, instantiate_binderless_metavariable.
  Defined.

(* TODO: derive_tyeq_trans *)

  Definition derive_tmeq_refl
      (Γ : raw_context Σ)
      (A : raw_type Σ Γ) (a : raw_term Σ Γ)
      (d_a : derivation T H [! Γ |- a ; A !])
    : derivation T H [! Γ |- a ≡ a ; A !].
  Proof.
    apply derive_from_reindexing_to_empty_sum.
    simple refine (Closure.deduce'_via_map
                             (use_derivable (equality_instance _)) _ _ _).
    { exists (Some (Some (Some (Some None)))), Γ.
      intros i; recursive_destruct i;
        refine (Expression.rename (scope_sum_empty_inl _) _);
        assumption.
    }
    { refine (Judgement.eq_by_expressions _ _).
      - intros i. apply @instantiate_empty_ptwise.
      - intros i; recursive_destruct i;
          refine (instantiate_binderless_metavariable _).
    }
    intros [].
    refine (transport _ _
                      (derive_reindexing_to_empty_sum _ d_a)).
    rapply @Judgement.eq_by_expressions.
    - intros i. apply inverse, @instantiate_empty_ptwise.
    - intros i; recursive_destruct i;
        apply inverse, instantiate_binderless_metavariable.
  Defined.

  Definition derive_tmeq_refl'
      (Γ : raw_context Σ)
      (Je : hypothetical_judgement_expressions Σ (form_equality class_term) Γ)
      (A : raw_type Σ Γ) (a : raw_term Σ Γ)
      (e_A : Je (the_equality_boundary_slot class_term the_type_slot)
             = A)
      (e_lhs : Je (the_lhs_slot _) = a)
      (e_rhs : Je (the_rhs_slot _) = a)
      (d_a : derivation T H [! Γ |- a ; A !])
    : derivation T H (Build_judgement Γ (Build_hypothetical_judgement _ Je)).
  Proof.
    refine (transport _ _ (derive_tmeq_refl _ _ _ d_a)).
    apply Judgement.eq_by_eta; simpl.
    apply ap, ap3; apply inverse; assumption.
  Defined.

(* TODO: derive_tmeq_sym *)

(* TODO: derive_tmeq_trans *)

  (* rule term_convert

     ⊢ A, B type
     ⊢ A ≡ B type
     ⊢ u : A
   -------------
     ⊢ u : B
   *)
  Definition derive_term_convert
      ( Γ : raw_context Σ )
      ( A B : raw_expression Σ class_type Γ )
      ( u : raw_expression Σ class_term Γ )
      ( d_A : derivation T H [! Γ |- A !] )
      ( d_B : derivation T H [! Γ |- B !] )
      ( d_AB : derivation T H [! Γ |- A ≡ B !] )
      ( d_u : derivation T H [! Γ |- u ; A !] )
    : derivation T H [! Γ |- u ; B !].
  Proof.
    apply derive_from_reindexing_to_empty_sum.
    simple refine (Closure.deduce'_via_map
                             (use_derivable (equality_instance _)) _ _ _).
    { exists (Some None), Γ.
      intros i; recursive_destruct i;
        refine (Expression.rename (scope_sum_empty_inl _) _).
      + exact A.
      + exact B.
      + exact u.
    }
    { refine (Judgement.eq_by_expressions _ _).
      - apply @instantiate_empty_ptwise.
      - intros i; recursive_destruct i;
          apply instantiate_binderless_metavariable.
    }
    intros p.
    recursive_destruct p;
      [ set (d := d_A) | set (d := d_B) | set (d := d_AB) | set (d := d_u) ];
      refine (transport _ _ (derive_reindexing_to_empty_sum _ d));
      (apply Judgement.eq_by_expressions;
       [ intros; apply inverse, @instantiate_empty_ptwise
       | intros i; recursive_destruct i;
         apply inverse, instantiate_binderless_metavariable]).
  Defined.

  Definition derive_tmeq_convert
      ( Γ : raw_context Σ )
      ( A B : raw_expression Σ class_type Γ )
      ( u v : raw_expression Σ class_term Γ )
      ( d_A : derivation T H [! Γ |- A !] )
      ( d_B : derivation T H [! Γ |- B !] )
      ( d_AB : derivation T H [! Γ |- A ≡ B !] )
      ( d_u : derivation T H [! Γ |- u ; A !] )
      ( d_v : derivation T H [! Γ |- v ; A !] )
      ( d_uv : derivation T H [! Γ |- u ≡ v ; A !] )
    : derivation T H [! Γ |- u ≡ v ; B !].
  Proof.
    apply derive_from_reindexing_to_empty_sum.
    simple refine (Closure.deduce'_via_map
                             (use_derivable (equality_instance _)) _ _ _).
    { exists None, Γ.
      intros i; recursive_destruct i;
        refine (Expression.rename (scope_sum_empty_inl _) _).
      + exact A.
      + exact B.
      + exact u.
      + exact v.
    }
    { refine (Judgement.eq_by_expressions _ _).
      - apply @instantiate_empty_ptwise.
      - intros i; recursive_destruct i;
          apply instantiate_binderless_metavariable.
    }
    intros p; recursive_destruct p;
      [ set (d := d_A) | set (d := d_B) | set (d := d_AB)
        | set (d := d_u) | set (d := d_v) | set (d := d_uv) ];
      refine (transport _ _ (derive_reindexing_to_empty_sum _ d));
      (apply Judgement.eq_by_expressions;
       [ intros; apply inverse, @instantiate_empty_ptwise
       | intros i; recursive_destruct i;
         apply inverse, instantiate_binderless_metavariable]).
  Defined.

End Equality_Interface.

Section SignatureMaps.

  Context `{H : Funext}.
  Context {σ : scope_system}.

  (** For a given signature map [f] from [Σ] to [Σ'],
     the translations of structural rules of [Σ] are structural rules of [Σ']. *)
  Local Definition fmap
      {Σ Σ' : signature σ}
      (f : Signature.map Σ Σ')
    : Family.map_over (Closure.rule_fmap (Judgement.fmap f))
        (structural_rule Σ)
        (structural_rule Σ').
  Proof.
    repeat apply Family.sum_fmap.
    - (* rename *)
      apply Family.Build_map'.
      intros [Γ [Γ' [α J]]].
      simple refine (_;_).
      + exists (Context.fmap f Γ).
        exists (Context.fmap f Γ').
        exists (fmap_typed_renaming f α).
        exact (fmap_hypothetical_judgement f J).
      + apply Closure.rule_eq.
        * apply idpath.
        * refine (Judgement.eq_by_expressions _ _); intros i.
          -- apply idpath.
          -- apply inverse, fmap_rename.
    - (* var rule *)
      apply Family.Build_map'.
      intros [Γ x].
      simple refine (_;_).
      + exists (Context.fmap f Γ). exact x.
      + cbn. apply Closure.rule_eq; cbn.
        * apply inverse.
          eapply concat. { apply Family.fmap_singleton. }
          apply ap.
          apply Judgement.eq_by_eta, idpath.
        * apply Judgement.eq_by_eta, idpath.
    - (* equality rules *)
      apply Family.Build_map'.
      intros [r ΓI].
      simple refine (_;_).
      + exists r.
        simple refine (RawRule.closure_system_fmap' f _ ΓI).
        refine (_ @ _). { apply inverse, RawRule.fmap_compose. }
        rapply @ap_1back.
        apply Signature.empty_rect_unique.
      + refine (Family.map_over_commutes
                  (RawRule.closure_system_fmap' f _) _).
    - (* subst_apply *)
      apply Family.Build_map'.
      intros [ Γ [Δ [J [g g_triv]]]].
      simple refine (_;_).
      + exists (Context.fmap f Γ).
        exists (Context.fmap f Δ).
        split. { exact (Judgement.fmap_hypothetical_judgement f J). }
        exists (raw_substitution_fmap f g).
        intros i. refine (fmap_option _ (g_triv i)).
        intros [j [e_gi e_Δi]].
        exists j; split.
        * refine (ap (Expression.fmap f) e_gi).
        * eapply concat. { simpl. apply ap, e_Δi. }
          apply fmap_substitute.
      + apply Closure.rule_eq; cbn.
        * apply inverse.
          eapply concat. { apply Family.fmap_adjoin. }
          apply ap2; try apply idpath.
          simple refine (Family.eq _ _).
          { apply sigma_type_eq; intros i.
            apply inverse, is_none_fmap. }
          intros i; simpl in i; rewrite equiv_path_sigma_type_eq.
          refine (Judgement.eq_by_expressions _ _);
            intros j; try apply idpath; recursive_destruct j;
            try apply idpath; apply fmap_substitute.
        * refine (Judgement.eq_by_expressions _ _);
            intros; try apply idpath.
          refine (fmap_substitute _ _ _)^.
    - (* subst_equal *)
      apply Family.Build_map'.
      intros [ Γ [Γ' [[g h] [gh_triv [jf hj]]]]].
      simple refine (_;_).
      + exists (Context.fmap f Γ).
        exists (Context.fmap f Γ').
        exists (raw_substitution_fmap f g, raw_substitution_fmap f h).
        split.
        2: { exists jf. intro; apply (Expression.fmap f), hj. }
        intros i. refine (fmap_option _ (gh_triv i)).
        simpl; intros [ j [[e_g e_h] [e_gΓ e_hΓ]]].
        exists j; split.
        * split; [ set (e := e_g) | set (e := e_h) ];
            exact (ap (Expression.fmap _) e).
        * split; [ set (e := e_gΓ) | set (e := e_hΓ) ];
          refine (ap _ e @ _);
          apply fmap_substitute.
      + apply Closure.rule_eq; cbn.
        * apply inverse.
          eapply concat. { apply Family.fmap_adjoin. }
          apply ap2; try apply idpath.
          eapply concat. { apply Family.fmap_bind. }
          apply ap2.
          -- simple refine (Family.eq _ _).
            { apply sigma_type_eq; intros i. apply inverse, is_none_fmap. }
            intros i; rewrite equiv_path_sigma_type_eq; apply idpath.
          -- apply path_forall; intros i.
            repeat rewrite Family.fmap_adjoin.
            repeat apply ap2;
            try (rewrite Family.fmap_singleton; apply ap);
            refine (Judgement.eq_by_expressions _ _);
            intros j; recursive_destruct j;
              try apply idpath; apply fmap_substitute.
        * refine (Judgement.eq_by_expressions _ _);
            intros; try apply idpath.
          recursive_destruct i; refine (fmap_substitute _ _ _)^.
  Defined.

End SignatureMaps.

Section Instantiation.

  Context `{Funext} {σ : scope_system} {Σ : signature σ}.

  (** Given a raw rule [R] over a signature [Σ], an arity [a] specifying a
  metavariable extension, and an instantiation [I] of [a] in [Σ] over some
  context [Γ],

  any instance of [R] over the extended signature [extend Σ a] gets translated
  under [I] into an instance of [R] over [Σ], modulo renaming.

  Note: this can’t be in [Typing.RawRule], since it uses the structural rules,
  specifically the rule for renaming along scope isomorphisms.  Morally perhaps
  that should be seen as more primitive than the other structural rules, and be
  baked into the notion of derivations earlier, as e.g. “closure systems on a
  groupoid”.  (Indeed, if the scope system is univalent then this rule _will_
  come for free.)
  *)
  Definition instantiate_raw_rule_closure_system
      {Γ : raw_context Σ} {a : arity σ} (I : Metavariable.instantiation a Σ Γ)
      (r : raw_rule Σ)
    : Closure.map_over
        (Judgement.instantiate Γ I)
        (RawRule.closure_system (RawRule.fmap include_symbol r))
        (structural_rule Σ + RawRule.closure_system r).
  Proof.
    intros [Δ J].
    (* The derivation essentially consists of the instance
     [(Context.instantiate _ I Δ
     ; instantiate_instantiation I J)]
     of the same raw rule, wrapped in renamings along [scope_assoc].
     *)
    simple refine (derive_rename' _ _ _ _ _).
    4: simple refine (Closure.deduce' _ _ _);
       [ apply inr;
         exists (Context.instantiate _ I Δ);
         exact (instantiate_instantiation I J)
       | apply idpath | ].
    { apply Context.instantiate_instantiate_ltor. }
    { apply instantiate_instantiate_hypothetical_judgement. }
    intros p.
    simple refine (derive_rename' _ _ _ _ _).
    4: refine (Closure.hypothesis _ _ _); apply p.
    { apply Context.instantiate_instantiate_rtol. }
    apply eq_by_expressions_hypothetical_judgement; intros i.
    apply instantiate_instantiate_expression.
  Defined.

(** Structural rules in a metavariable extension,
  translated under an instantiation,
  can always be derived from structural rules over the base signature.

  Essentially, any structural rule gets translated into an instance of the same structural rule, possibly wrapped in a variable-renaming to reassociate iterated context extensions *)
  Local Definition instantiate
      {Γ : raw_context Σ} {a : arity σ} (I : Metavariable.instantiation a Σ Γ)
    : Closure.map_over (@Judgement.instantiate σ _ Σ Γ I)
        (structural_rule (Metavariable.extend Σ a))
        (structural_rule Σ).
  Proof.
    unfold Closure.map_over.
    apply structural_rule_rect.
    - (* rename*)
      intros [Δ [Δ' [α J]]].
      simple refine (derive_rename' _ _ _ _ _).
      4: { refine (Closure.hypothesis _ _ _). exact tt. }
      { apply instantiate_typed_renaming, α. }
      apply eq_by_expressions_hypothetical_judgement; intro.
      apply instantiate_rename.
    - (* subst_apply *)
      intros [Δ [Δ' [J [f f_triv]]]].
      simple refine (derive_subst_apply' _ _ _ _ _ _).
      + apply (Judgement.instantiate Γ I).
        exists Δ. exact J.
      + exact (instantiate_raw_substitution I f).
      + apply instantiate_substitute_hypothetical_judgement.
      + simpl. refine (coproduct_rect scope_is_sum _ _ _).
        * intros i; simpl.
          unfold instantiate_raw_substitution.
          repeat rewrite coproduct_comp_inj1.
          apply inl.
          exists (coproduct_inj1 scope_is_sum i).
          split; try apply idpath.
          eapply concat. { rapply coproduct_comp_inj1. }
          eapply concat. { apply inverse, substitute_raw_variable. }
          eapply concat. 2: { apply inverse, substitute_rename. }
          apply (ap_2back substitute), path_forall.
          intros j; apply inverse. rapply coproduct_comp_inj1.
        * intros i.
          destruct (some_or_is_none (f_triv i))
                     as [ [j [e_fi e_Γ'j]]| fi_nontriv ].
          -- apply inl.
            exists (coproduct_inj2 scope_is_sum j); split;
              refine (coproduct_comp_inj2 _ @ _).
            ++ eapply concat. { apply ap, e_fi. }
              apply idpath.
            ++ eapply concat. { apply ap, e_Γ'j. }
              eapply concat. { apply instantiate_substitute. }
              apply ap, inverse. rapply coproduct_comp_inj2.
          -- apply inr.
            simple refine (Closure.hypothesis' _ _).
            { apply Some. exists i. apply fi_nontriv. }
            apply Judgement.eq_by_expressions.
            { intros; apply idpath. }
            intros j; recursive_destruct j; simpl.
            ++ repeat rewrite coproduct_comp_inj2.
              apply instantiate_substitute.
            ++ unfold instantiate_raw_substitution.
              apply inverse; rapply coproduct_comp_inj2.
      + simple refine (Closure.hypothesis' _ _).
        { apply None. }
        apply idpath.
    - (* subst_equal *)
      simpl. intros [Δ [Δ' [[f g] [fg_triv [cl J]]]]].
      simple refine (derive_subst_equal' _ _ _ _ _ _ _ _).
      + apply (Judgement.instantiate Γ I).
        exists Δ. exact (Build_hypothetical_judgement _ J).
      + exact (instantiate_raw_substitution I f).
      + exact (instantiate_raw_substitution I g).
      + constructor.
      + apply eq_by_expressions_hypothetical_judgement.
        intros i; destruct cl; recursive_destruct i;
        apply instantiate_substitute.
      (* TODO: abstract as [instantiate_substitute_equal_hypothetical_judgement]? *)
      + simpl. refine (coproduct_rect scope_is_sum _ _ _).
        * intros i; simpl.
          unfold instantiate_raw_substitution.
          repeat rewrite coproduct_comp_inj1.
          apply inl.
          exists (coproduct_inj1 scope_is_sum i).
          repeat split; try apply idpath;
            refine (coproduct_comp_inj1 _ @ _);
            refine ((substitute_raw_variable _ _)^ @ _);
            refine (_ @ (substitute_rename _ _ _)^);
            apply (ap_2back substitute), path_forall;
            intros j; apply inverse; rapply coproduct_comp_inj1.
        * intros i.
          destruct (some_or_is_none (fg_triv i)) as [ fgi_triv | fgi_nontriv ].
          -- apply inl.
            destruct fgi_triv as [j [[e_fi e_gi] [e_fΓi e_gΓi]]].
            exists (coproduct_inj2 scope_is_sum j); split.
            ++ split; refine (coproduct_comp_inj2 _ @ _);
              (refine (ap _ _ @ _); [ try eassumption | ]); apply idpath.
            ++ split; refine (coproduct_comp_inj2 _ @ _);
                 refine (_ @ ap _ (coproduct_comp_inj2 _)^);
                 refine (_ @ instantiate_substitute _ _ _);
                 apply ap; assumption.
          -- apply inr.
            repeat split;
            (simple refine (Closure.hypothesis' _ _);
            [ apply Some; exists (i; fgi_nontriv) | ]);
            [ apply Some, Some, tt | | apply Some, None | | apply None | ];
            apply Judgement.eq_by_eta;
            unfold instantiate_raw_substitution;
              repeat rewrite coproduct_comp_inj2; simpl;
              rewrite instantiate_substitute;
              apply idpath.
      + simple refine (Closure.hypothesis' _ _).
        { apply None. }
        apply idpath.
    - (* variable_rule *)
      intros [Δ i]; simpl.
      simple refine (derive_variable' _ _ _ _ _ _); try apply idpath.
      { apply inverse; refine (coproduct_comp_inj2 _). }
      simple refine (Closure.hypothesis' _ _).
      + exact tt.
      + apply Judgement.eq_by_expressions; intros j; try apply idpath.
        recursive_destruct j; apply inverse; refine (coproduct_comp_inj2 _).
    - (* equality_rule *)
      intros i_eq.
      destruct i_eq as [i [Δ J]].
      set (F := instantiate_raw_rule_closure_system I
                  ((RawRule.fmap (Signature.empty_rect _))
                     (equality_raw_rule i))).
      assert (D := F (Δ;J)); clear F.
      refine (Closure.derivation_fmap1 _ _).
      { refine (Closure.sum_rect _ _).
        - apply Closure.idmap.
        - refine (Closure.compose _ Closure.inl).
          refine (Closure.compose _ Closure.inr).
          apply Closure.map_from_family_map.
          refine (Family.bind_include _ _ _).
          exact i.
      }
      (* TODO: can we streamline the following somehow with e.g. [RawRule.fmap_compose]? *)
      refine (transport (fun c => derivation _ _ c) _
             (transport (fun H => derivation _ H _) _ D)).
      + apply (ap (Judgement.instantiate _ _)).
        apply (ap (Judgement.instantiate _ _)).
        eapply concat. { apply inverse, Judgement.fmap_compose. }
        rapply @ap_1back.
        apply Family.sum_unique.
        * apply Family.empty_rect_unique.
        * apply idpath.
      + eapply concat. { apply inverse, Family.fmap_compose. }
        eapply concat. { apply inverse, Family.fmap_compose. }
        eapply concat. { apply inverse, Family.fmap_compose. }
        eapply concat. 2: { apply Family.fmap_compose. }
        eapply concat. 2: { apply Family.fmap_compose. }
        apply (ap_1back Family.fmap), path_forall; intros j.
        apply (ap (Judgement.instantiate _ _)).
        apply (ap (Judgement.instantiate _ _)).
        eapply concat. { apply inverse, Judgement.fmap_compose. }
        apply (ap_1back Judgement.fmap).
        apply Family.sum_unique.
        * apply Family.empty_rect_unique.
        * apply idpath.
  Defined.

End Instantiation.


(** * Grothendieck Construction of a functor to Set *)
Require Import Category.Core Functor.Core.
Require Import SetCategory.Core.
Require Import Basics.Trunc Types.Sigma.
Require Import Basics.Tactics.

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

Local Open Scope morphism_scope.

Section Grothendieck.
  Context `{Funext}.

  (**
     Quoting Wikipedia:

     The Grothendieck construction is an auxiliary construction used
     in the mathematical field of category theory.

     Let

<<
     F : C → Set
>>

     be a functor from any small category to the category of sets.
     The Grothendieck construct for [F] is the category [Γ F] whose
     objects are pairs [(c, x)], where [c : C] is an object and [x : F
     c] is an element, and for which the set [Hom (Γ F) (c1, x1) (c2,
     x2)] is the set of morphisms [f : c1 → c2] in [C] such that
     [F₁ f x1 = x2].  *)

  Variable C : PreCategory.
  Variable F : Functor C set_cat.

  Record Pair :=
    {
      c : C;
      x : F c
    }.

  Definition issig_pair : { c : C | F c } <~> Pair.
  Proof.
    issig.
  Defined.

  Local Notation morphism s d :=
    { f : morphism C s.(c) d.(c)
    | F _1 f s.(x) = d.(x) }.

  Definition compose_H s d d'
             (m1 : morphism d d')
             (m2 : morphism s d)
  : (F _1 (m1 .1 o m2 .1)) s.(x) = d'.(x).
  Proof.
    etransitivity; [ | exact (m1.2) ].
    etransitivity; [ | apply ap; exact (m2.2) ].
    match goal with
      | [ |- ?f ?x = ?g (?h ?x) ] => change (f x = (g o h) x)
    end.
    match goal with
      | [ |- ?f ?x = ?g ?x ] => apply (@apD10 _ _ f g)
    end.
    apply (composition_of F).
  Defined.

  Definition compose s d d'
             (m1 : morphism d d')
             (m2 : morphism s d)
  : morphism s d'.
  Proof.
    exists (m1.1 o m2.1).
    apply compose_H.
  Defined.

  Definition identity_H s
    := apD10 (identity_of F s.(c)) s.(x).

  Definition identity s : morphism s s.
  Proof.
    exists 1.
    apply identity_H.
  Defined.

  Global Arguments compose_H : simpl never.
  Global Arguments identity_H : simpl never.
  Global Arguments identity _ / .
  Global Arguments compose _ _ _ _ _ / .

  (** ** Category of elements *)
  Definition category : PreCategory.
  Proof.
    refine (@Build_PreCategory
              Pair
              (fun s d => morphism s d)
              identity
              compose
              _
              _
              _
              _);
    abstract (
        repeat intro;
        apply path_sigma_uncurried; simpl;
        ((exists (associativity _ _ _ _ _ _ _ _))
           || (exists (left_identity _ _ _ _))
           || (exists (right_identity _ _ _ _)));
        exact (center _)
      ).
  Defined.

  (** ** First projection functor *)
  Definition pr1 : Functor category C
    := Build_Functor
         category C
         c
         (fun s d => @pr1 _ _)
         (fun _ _ _ _ _ => idpath)
         (fun _ => idpath).
End Grothendieck.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(************************************************************************)
(*   This file has been modified for the purposes of the HoTT library.  *)
(************************************************************************)

Set Implicit Arguments.

Require Export Notations.

Global Set Universe Polymorphism.
Global Set Asymmetric Patterns.

Notation "A -> B" := (forall (_ : A), B) : type_scope.

(** * Propositional connectives *)

(** [True] is the unit type. *)
Inductive True : Type :=
  I : True.

(** [False] is the empty type. *)
Inductive False : Type :=.

(** [proof_admitted] is used to implement the admit tactic *)
Axiom proof_admitted : False.

(** [not A], written [~A], is the negation of [A] *)
Definition not (A:Type) : Type := A -> False.

Notation "~ x" := (not x) : type_scope.

Hint Unfold not: core.

Hint Resolve I : core.


Require Import ZArith.
Require Import Coq.Strings.String.
Require Import NPeano.

From QuickChick Require Import QuickChick.

Require Export Utils.
Require Export Labels.
Require Export Instructions.
Require Export Memory.
Require Export Indist.
Require Export Machine.

Definition pure {A : Type} (x : A) : G A := returnGen x.

(*
Fixpoint foldGen {A B : Type} (f : A -> B -> G A) (l : list B) (a : A)
: G A :=
  match l with
    | [] => returnGen a
    | (x :: xs) => bindGen (f a x) (foldGen f xs)
  end.
*)

(* Variation stuff - should be deleted -- CH: ha? it seems used *)
Inductive Variation {A : Type} :=
| Var : Label -> A -> A -> Variation.

Class ShrinkV (A : Type) := { shrinkV : @Variation A -> list (@Variation A) }.
(* End of to be deleted *)

Definition validJump (st : SState) (addr : Z) :=
  let '(St imem _ _ _ _) := st in
  ((Z.to_nat addr) <? (List.length imem))%nat.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              Nov 29th 1994                               *)
(*                                                                          *)
(****************************************************************************)
(*                                Alter.v                                   *)
(****************************************************************************)

Section Alter_I.

(*****************************************************************)
(* A proof of the extensional equality of two different versions *)
(* of the stream that infinitely alternates the values true and  *)
(* false, using F. Leclerc and C. Paulin representation.         *)
(*****************************************************************)

Require Import Bool.

Inductive St : Set :=
    build : forall X : Set, (X -> bool * X) -> X -> St.
(*
Definition hd :=
  [H:St]
 <[_:St]bool>Case H of
    ([X:Set][p:X->bool*X][y:X](fst bool X (p y)))
    end.
*)
Definition hd (H : St) := match H with
                          | build X p y => fst (p y)
                          end.

(*
Definition tl :=
[H:St]
 <[_:St]St>Case H of
    ([X:Set][p:X->bool*X][y:X](build X p (snd bool X (p y))))
    end.
*)

Definition tl (H : St) :=
  match H with
  | build X p y => build X p (snd (p y))
  end.

(* The quality between streams is the gfp of this operator T *)

Definition T (R : St -> St -> Prop) (z1 z2 : St) :=
  hd z1 = hd z2 /\ R (tl z1) (tl z2).

Inductive EqSt : St -> St -> Prop :=
    buildeq :
      forall R : St -> St -> Prop,
      (forall x y : St, R x y -> T R x y) ->
      forall s1 s2 : St, R s1 s2 -> EqSt s1 s2.

(* Two process generating the same stream *)

Let gen1 := build bool (fun b : bool => pair b (negb b)).
Let gen2 := build bool (fun b : bool => pair (negb b) (negb b)).

Let alter1 := gen1 true.
Let alter2 := gen2 false.

(* An invariant relation in the generation *)

Definition Invariant (s1 s2 : St) :=
  exists b : bool, s1 = gen1 (negb b) /\ s2 = gen2 b.

(* The proof that both processes generate the same stream *)

Theorem eqalters_I : EqSt alter1 alter2.
apply (buildeq Invariant).

intros.
case H.
intros.
case H0.
intros.
rewrite H1; rewrite H2.
simpl in |- *.
split.
trivial.
unfold Invariant in |- *.
exists (negb x0).
unfold gen1 in |- *.
unfold gen2 in |- *.
split.
trivial.
trivial.

unfold Invariant in |- *.
exists false.
split.
trivial.
trivial.
Qed.

(* An easier way of definig the same invariant relation presented above *)

Inductive SimplerInvariant : St -> St -> Prop :=
    makeinv : forall b : bool, SimplerInvariant (gen1 (negb b)) (gen2 b).

Theorem eqalters_I_bis : EqSt alter1 alter2.
apply (buildeq SimplerInvariant).
intros.
case H.
unfold T in |- *.
intros.
split.
trivial.
apply (makeinv (negb b)).
apply (makeinv false).
Qed.

(***********************************************************************)
(*  A different proof using the method of translation described in the *)
(*  paper "Codifying guarded definitions with recursive schemes"       *)
(***********************************************************************)

(* The invariant relation *)

Inductive Cls : St -> St -> Prop :=
    cls : Cls alter1 alter2.

Inductive EqSt1 : St -> St -> Prop :=
    eqst1 :
      forall z1 z2 : St,
      hd z1 = hd z2 ->
      Cls (tl z1) (tl z2) \/ EqSt1 (tl z1) (tl z2) -> EqSt1 z1 z2.

(* The streams alter1 and alter2 verify the relation EqSt1 *)

Lemma eqalters_body : EqSt1 alter1 alter2.
apply eqst1.
trivial.
right.
apply eqst1.
trivial.
left.
apply cls.
Qed.

(* EqSt1 is a  bisimulation *)

Lemma H : forall z1 z2 : St, EqSt1 z1 z2 -> T EqSt1 z1 z2.
intros z1 z2 x.
red in |- *.
case x.
intros z3 z4 H0 H1.
split.
assumption.
case H1.
intro H2.
case H2.
apply eqalters_body.
intros.
assumption.
Qed.

(* The proof of the extensional equality of alter1 and alter2 *)

Theorem eqalters_II : EqSt alter1 alter2.
apply (buildeq EqSt1 H).
apply eqalters_body.
Qed.

End Alter_I.

Section Alter_II.
(* The same proof but using the new co-inductive types  *)

Require Import Streams.

CoFixpoint gen1  : bool -> Stream bool :=
  fun b : bool => Cons b (gen1 (negb b)).

CoFixpoint gen2  : bool -> Stream bool :=
  fun b : bool => Cons (negb b) (gen2 (negb b)).

Let alter1 := gen1 false.
Let alter2 := gen2 true.

Theorem eqalters_III : EqSt alter1 alter2.
cofix u.
apply eqst.
trivial.
apply eqst.
trivial.
assumption.
Qed.

End Alter_II.