Require Import MGraph.
Require Import Packages.
Require Import FunInd.

Parameter R: PackageSet.t.
Parameter C: ConflictSet.t.
Parameter Dependencies: Package.t -> list PackageSet.t.

Declare Module PkgGraph: DiGraph PackageSet.
Import PkgGraph.

Module PkgFacts := MGraphFacts PackageSet PkgGraph.
Import PkgFacts.
Module PkgAux := Aux PackageSet.

Parameter sdg: PkgGraph.t.

Axiom sdg_edge: forall p p', IsEdge p p' sdg <-> strong_dep Dependencies R C p p'.

Definition is_lift (S: PackageSet.t) (l: list Package.t) :=
  forall s, In s S <-> List.In s l.

Lemma sdg_transitive: forall p q, connected sdg p q -> IsEdge p q sdg.
Proof.
  intros. unfold connected in H. destruct H as [l Hl].
  functional induction (is_path_from_to sdg l p q).
    apply Hl.
    apply <- sdg_edge. apply strong_dep_trans with h. split.
      apply -> sdg_edge. apply (proj1 Hl).
      apply -> sdg_edge. apply (IHP (proj2 Hl)).
Qed.

(* lemma 3.12 *)
Lemma cycle_is_clique: forall l, is_cycle sdg l -> is_clique sdg (PkgAux.equiv_set l).
Proof.
  intros. unfold is_clique. unfold For_all. intros x Hx x' Hx' Hneq.
  elim (path_stuff sdg l x x' (cycle_is_path _ _ H) (PkgAux.equiv_set_2 Hx) (PkgAux.equiv_set_2 Hx')).
    intros. absurd (Package.eq x x'). apply Hneq. apply H0.
    intros. destruct H0 as [p [Hinc [Hf | Hf]]].
      apply sdg_transitive. exists p. apply Hf.
      apply sdg_transitive. destruct (cycle_is_cyclic sdg l x' x H (PkgAux.equiv_set_2 Hx') (PkgAux.equiv_set_2 Hx)).
        absurd (Package.eq x x'). apply Hneq. apply (Package.eq_sym H0).
        destruct H0. exists x0. apply (proj2 H0).
Qed.

(* the collapse graph is the detransed decycled version of sdg with start *)
Inductive clp_node: Type :=
  start: clp_node
| collapse: Package.t -> PackageSet.t -> clp_node. (* at least one node *)

Declare Module Clp: OrderedType with Definition t := clp_node.
Declare Module CollapseSet: MSetInterface.S with Module E := Clp.
Declare Module FlowGraph: DiGraph CollapseSet.
Module FGFacts := MGraphFacts CollapseSet FlowGraph.

Parameter fg: FlowGraph.t.

Axiom collapse_start: FlowGraph.IsVertex start fg.
(* Axiom collapse_vertex_1a: forall p ps,
  FlowGraph.IsVertex (collapse p ps) fg -> For_all (fun x => IsVertex x sdg) (add p ps).
Axiom collapse_vertex_1b: forall p,
  IsVertex p sdg -> exists ps, In p ps /\ FlowGraph.IsVertex (collapse ps) fg.
Axiom collapse_vertex_2: forall ps,
  FlowGraph.IsVertex (collapse ps) fg <-> is_maximal_clique sdg ps. *)
Axiom collapse_edge_start: forall p ps,
  For_all (fun v => Empty (pred sdg v)) (add p ps) ->
  FlowGraph.IsEdge start (collapse p ps) fg.
(* Axiom collapse_edge_1a: forall ps ps', FlowGraph.IsEdge (collapse ps) (collapse ps') fg ->
  exists p, In p ps /\ exists p', In p' ps /\ connected sdg p p'. *)
Axiom collapse_edge_1b: forall p ps p' ps',
  Exists (fun v => Exists (fun v' => IsEdge v v' sdg) (add p' ps')) (add p ps) ->
  FlowGraph.IsEdge (collapse p ps) (collapse p' ps') fg.
Axiom collapse_detrans: forall p q r,
  FlowGraph.IsEdge p q fg -> FlowGraph.IsEdge q r fg -> ~FlowGraph.IsEdge p r fg.

(* lemma 3.16 *)
Lemma reachable_from_start: forall p ps, FlowGraph.IsVertex (collapse p ps) fg ->
  FGFacts.connected fg start (collapse p ps).
Proof.
  intros. case_eq (for_all (fun v => PackageSet.is_empty (pred sdg v)) (add p ps)).
    (* if all predecessors of p/ps are empty, we're done *)
    intros. exists nil. apply collapse_edge_start. unfold For_all. intros.
    apply is_empty_spec. apply (for_all_2 (cpt_pred_empty sdg) H0 H1).
    (* but if not, then we must do something more complicated *)


Require Import Relation_Operators.
Require Import PFun.

Global Set Implicit Arguments.

Record Actions :=
  { action: Type;
    (* I'm going to regret this so much *)
    action_ret : action -> Type; }.

Record ActionSem (act:Actions) :=
  { state : Type;
    act_step: state -> forall a, (action_ret act a * state) -> Prop;
    act_error : state -> action act -> Prop; }.

Section Prog.

  Variable act:Actions.

  Inductive prog : Type -> Type :=
  | Io : forall a, prog (action_ret act a)
  | Yield : prog unit
  | Ret : forall T, T -> prog T
  | Bind : forall T T', prog T' -> (T' -> prog T) -> prog T.

  Variable sem:ActionSem act.

  Definition TID := nat.
  Opaque TID.

  Inductive outcome T :=
  | Finished : (state sem)*(state sem) -> T -> outcome T
  | Error.
  Arguments Error {T}.

  Inductive act_sem :
    forall a, state sem * state sem -> outcome (action_ret act a) -> Prop :=
  | StepIo : forall a s_i s r s',
      act_step sem s a (r, s') ->
      act_sem a (s_i, s) (Finished (s_i, s') r)
  | StepIoError : forall a s_i s,
      act_error sem s a ->
      act_sem a (s_i, s) Error.

  Definition Protocol := TID -> state sem -> state sem -> Prop.
  Variable G : Protocol.
  Definition Rely : Protocol :=
    fun tid => clos_refl_trans _ (fun s s' =>
                                 exists tid', tid <> tid' /\
                                         G tid' s s').

  Inductive exec (tid:TID) : forall T, (state sem)*(state sem) -> prog T -> outcome T -> Prop :=
  | ExecIo : forall a st out,
      act_sem a st out ->
      exec tid st (Io a) out
  | ExecRet : forall T (v:T) st,
      exec tid st (Ret v) (Finished st v)
  | ExecBindFinished : forall T T'
                         (p1: prog T') (p2: T' -> prog T)
                         st st' r out,
      exec tid st p1 (Finished st' r) ->
      exec tid st' (p2 r) out ->
      exec tid st (Bind p1 p2) out
  | ExecBindError : forall T T'
                      (p1: prog T') (p2: T' -> prog T)
                      st,
      exec tid st p1 Error ->
      exec tid st (Bind p1 p2) Error
  | ExecYield : forall s_i s s',
      G tid s_i s ->
      Rely tid s s' ->
      exec tid (s_i, s) Yield (Finished (s', s') tt)
  | ExecYieldError : forall s_i s,
      ~G tid s_i s ->
      exec tid (s_i, s) Yield Error.

  Record SpecParams T :=
    { precondition : Prop;
      postcondition : forall (st': state sem * state sem) (r:T), Prop }.

  Definition Spec T := state sem * state sem -> SpecParams T.

  Definition prog_ok tid T (spec: Spec T) (p: prog T) :=
    forall st out,
      precondition (spec st) ->
      exec tid st p out ->
      match out with
      | Finished st' r => postcondition (spec st) st' r
      | Error => False
      end.

End Prog.

Instance tid_EqDec : EqDec TID.
Proof.
  unfold EqDec.
  decide equality.
Defined.


(* 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)                    *)
(* Notation management revised in December 2002 *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*  leZ.v                                                                   *)
(*                                                                          *)
(*  Definition of ``less or equal'' on integers                             *)
(*                                                                          *)
(*                                                                          *)
(*  Samuel Boutin                                                           *)
(*  Coq V5.10                                                               *)
(*  June  1995                                                              *)
(*                                                                          *)
(*                                                                          *)
(****************************************************************************)
(*                               leZ.v                                      *)
(****************************************************************************)

Require Import nat.
Require Import quotient.
Require Import integer_defs.

Section LEZ.

Open Scope nat_scope.

Definition leZ_XX (y x : Z_typ) : Prop := x .1 + y .2 <= y .1 + x .2.

Require Import Le.

Lemma le_with_plus1 : forall p n m : nat, n <= m -> p + n <= p + m.
auto with arith.
Qed.

Lemma le_with_plus2 : forall p n m : nat, p + n <= p + m -> n <= m.
exact (fun p n m : nat => plus_le_reg_l n m p).
Qed.

Lemma tech1 :
 forall a1 a2 b1 b2 c1 c2 : nat,
 a1 + b2 = a2 + b1 -> c1 + a2 <= c2 + a1 -> c1 + b2 <= c2 + b1.

intros.
apply (le_with_plus2 a1).
elim (plus_permute c1).
rewrite H.
repeat elim (plus_comm b1).
repeat elim (plus_permute b1).
apply (le_with_plus1 b1).
elim (plus_comm c2).
auto with arith.
Qed.

Lemma Compat_leZ_XX : forall x : Z_typ, Compat_prop Z_typ Z_rel (leZ_XX x).

simple induction x; intros c2 c1.
red in |- *.
simple induction x0; intros a2 a1.
simple induction y; intros b2 b1.
unfold leZ_XX in |- *; simpl in |- *.
unfold Z_rel in |- *; simpl in |- *.
elim (plus_comm a1).
elim (plus_comm c1).
split.
intro.
elim (plus_comm c1).
apply (tech1 a1 a2 b1 b2 c1 c2).
elim H; auto with arith.
auto with arith.
elim (plus_comm c1).
intro.
apply (tech1 b1 b2 a1 a2 c1 c2).
elim (plus_comm a1).
elim H.
elim (plus_comm a2).
auto with arith.
auto with arith.
Qed.

Definition leZ_X (z : Z) (x : Z_typ) : Prop :=
  lift_prop Z_typ Z_rel (leZ_XX x) (Compat_leZ_XX x) z.

Lemma Compat_leZ_X : forall z : Z, Compat_prop Z_typ Z_rel (leZ_X z).

red in |- *.
simple induction x; intros a1 a2.
simple induction y; intros b1 b2.
unfold Z_rel in |- *; simpl in |- *.
apply (Closure_prop Z_typ Z_rel z).
unfold leZ_X in |- *.
simple induction x0; intros c1 c2.
repeat rewrite (Reduce_prop Z_typ Z_rel).
unfold leZ_XX in |- *; simpl in |- *.
intro.
repeat elim (plus_comm c2).
split.
intro.
apply (tech1 a1 a2 b1 b2 c1 c2).
elim (plus_comm b1).
elim H.
auto with arith.
auto with arith.
intro.
apply (tech1 b1 b2 a1 a2 c1 c2).
elim H.
elim (plus_comm b2).
auto with arith.
auto with arith.
Qed.

Definition leZ (z : Z) : Z -> Prop :=
  lift_prop Z_typ Z_rel (leZ_X z) (Compat_leZ_X z).

Infix "<=" := leZ (at level 70, no associativity) : INT_scope.

Open Scope INT_scope.

Definition ltZ (z1 z2 : Z) : Prop := z1 <= z2 /\ z1 <> z2.

End LEZ.

(* Export Infix notations *)

Arguments Scope leZ [INT_scope INT_scope].
Arguments Scope ltZ [INT_scope INT_scope].

Infix "<=" := leZ (at level 70, no associativity) : INT_scope.
Infix "<" := ltZ (at level 70, no associativity) : INT_scope.


Require Import AggregateType.demo2.expr.
Require Import AggregateType.demo2.computable_theorems.
Open Scope nat.

Inductive ListType: list Type -> Type :=
  | Nil: ListType nil
  | Cons: forall {A B} (a: A) (b: ListType B), ListType (A :: B).

Fixpoint ListTypeGen {A} (F: A -> Type) (f: forall A, F A) (l: list A) : ListType (map F l) :=
  match l with
  | nil => Nil
  | cons h t => Cons (f h) (ListTypeGen F f t)
  end.

Lemma ListTypeGen_preserve: forall A F f1 f2 (l: list A),
  (forall a, In a l -> f1 a = f2 a) ->
  ListTypeGen F f1 l = ListTypeGen F f2 l.
Proof.
  intros.
  induction l.
  + reflexivity.
  + simpl.
    rewrite H, IHl.
    - reflexivity.
    - intros; apply H; simpl; tauto.
    - simpl; left; auto.
Defined.

Definition decay' {X} {F: Type} {l: list X} (v: ListType (map (fun _ => F) l)): list F.
  remember (map (fun _ : X => F) l) eqn:E.
  revert l E.
  induction v; intros.
  + exact nil.
  + destruct l; inversion E.
    specialize (IHv l H1).
    rewrite H0 in a.
    exact (a :: IHv).
Defined.

Fixpoint decay'' {X} {F: Type} (l0 : list Type) (v: ListType l0) :
  forall (l: list X), l0 = map (fun _ => F) l -> list F :=
  match v in ListType l1
    return forall l2, l1 = map (fun _ => F) l2 -> list F
  with
  | Nil => fun _ _ => nil
  | Cons A B a b =>
    fun (l1 : list X) (E0 : A :: B = map (fun _ : X => F) l1) =>
    match l1 as l2 return (A :: B = map (fun _ : X => F) l2 -> list F) with
    | nil => fun _ => nil (* impossible case *)
    | x :: l2 =>
       fun E1 : A :: B = map (fun _ : X => F) (x :: l2) =>
       (fun
          X0 : map (fun _ : X => F) (x :: l2) =
               map (fun _ : X => F) (x :: l2) -> list F =>
        X0 eq_refl)
         match
           E1 in (_ = y)
           return (y = map (fun _ : X => F) (x :: l2) -> list F)
         with
         | eq_refl =>
             fun H0 : A :: B = map (fun _ : X => F) (x :: l2) =>
              (fun (H3 : A = F) (H4 : B = map (fun _ : X => F) l2) =>
                  (eq_rect A (fun A0 : Type => A0) a F H3) :: (decay'' B b l2 H4))
                 (f_equal
                    (fun e : list Type =>
                     match e with
                     | nil => A
                     | T :: _ => T
                     end) H0)
                (f_equal
                   (fun e : list Type =>
                    match e with
                    | nil => B
                    | _ :: l3 => l3
                    end) H0)
         end
    end E0
  end.

Definition decay {X} {F: Type} {l: list X} (v: ListType (map (fun _ => F) l)): list F :=
  let l0 := map (fun _ => F) l in
  let E := @eq_refl _ (map (fun _ => F) l) : l0 = map (fun _ => F) l in
  decay'' l0 v l E.

Lemma decay_spec: forall A F f l,
  decay (ListTypeGen (fun _: A => F) f l) = map f l.
Proof.
  intros.
  unfold decay.
  induction l.
  + simpl.
    reflexivity.
  + simpl.
    f_equal.
    auto.
Defined.

Section COMPOSITE_ENV.

Context {cs: compspecs}.

Lemma type_ind: forall P : type -> Prop,
  (forall t,
  match t with
  | Tstruct id => let m := co_members (get_co id) in Forall (fun it => P (field_type (fst it) m)) m
  | _ => True
  end -> P t) ->
  forall t, P t.
Proof.
  intros P IH_TYPE.
  intros.
  remember (rank_type cenv_cs t) as n eqn: RANK'.
  assert (rank_type cenv_cs t <= n)%nat as RANK.
  subst. apply le_n.
  clear RANK'.
  revert t RANK.
  induction n;
  intros;
  specialize (IH_TYPE t); destruct t;
  try solve [specialize (IH_TYPE I); auto].
  + (* Tstruct level 0 *)
    simpl in RANK.
    unfold get_co in IH_TYPE.
    destruct (Maps.PTree.get id cenv_cs); [inv RANK | apply IH_TYPE; simpl; constructor].
  + (* Tstruct level positive *)
    simpl in RANK.
    pose proof I. (*get_co_members_no_replicate i.*)
    unfold get_co in *.
    destruct (Maps.PTree.get id cenv_cs) as [co |] eqn:CO; [| apply IH_TYPE; simpl; constructor].
    apply IH_TYPE; clear IH_TYPE.
    apply Forall_forall.
    intros [i0 t0] ?; simpl.
    apply IHn.
    pose proof rank_type_field_type _ _ _ _ H0.
    eapply le_trans; [eassumption |].
    apply le_S_n; auto.
    rewrite <- co_consistent_rank; auto.
    exact (cenv_consistent id co CO).
Defined.

Ltac type_induction t :=
  pattern t;
  match goal with
  | |- ?P t =>
    apply type_ind; clear t;
    let t := fresh "t" in
    intros t IH;
    let id := fresh "id" in
    destruct t as [ | id]
  end.

Variable A: type -> Type.

Definition FT_aux id :=
    let m := co_members (get_co id) in
    ListType (map (fun it => A (field_type (fst it) m)) m).

Variable F_Tint: forall t: type, A t.
Variable F_Tstruct: forall id, FT_aux id -> A (Tstruct id).

Fixpoint type_func_rec (n: nat) (t: type): A t :=
  match n with
  | 0 =>
    match t as t0 return A t0 with
    | Tstruct id =>
       match (Maps.PTree.get id cenv_cs)with
       | None => let m := co_members (get_co id) in
                       F_Tstruct id (ListTypeGen (fun it => A (field_type (fst it) m)) (fun it => F_Tint (field_type (fst it) m)) m)
       | _ => F_Tint (Tstruct id)
       end
    | t' => F_Tint t'
    end
  | S n' =>
    match t as t0 return A t0 with
    | Tstruct id =>  let m := co_members (get_co id) in
                            F_Tstruct id (ListTypeGen (fun it => A (field_type (fst it) m)) (fun it => type_func_rec n' (field_type (fst it) m)) m)
    | t' => F_Tint t'
    end
  end.

Definition type_func t := type_func_rec (rank_type cenv_cs t) t.

Lemma rank_type_Tstruct: forall id co, (Maps.PTree.get id cenv_cs) = Some co ->
  rank_type cenv_cs (Tstruct id) = S (co_rank (get_co id)).
Proof.
  intros.
  unfold get_co; simpl.
  destruct (Maps.PTree.get id cenv_cs); auto; congruence.
Defined.

Lemma type_func_rec_rank_irrelevent: forall t n n0,
  n >= rank_type cenv_cs t ->
  n0 >= rank_type cenv_cs t ->
  type_func_rec n t = type_func_rec n0 t.
Proof.
 (* DON'T USE omega IN THIS PROOF!
   We want the proof to compute reasonably efficiently.
*)
  intros t.
  type_induction t;
  intros;
  try solve [destruct n; simpl; auto; destruct n0; simpl; auto].
  + (* Tstruct *)
    unfold get_co in IH.
    destruct (Maps.PTree.get id cenv_cs) as [co |] eqn: CO.
    - erewrite rank_type_Tstruct in H by eauto.
      erewrite rank_type_Tstruct in H0 by eauto.
      destruct n; simpl in H; try solve [inv H].
      destruct n0; simpl in H; try solve [inv H0].
      simpl.
      f_equal.
      apply ListTypeGen_preserve.
      intros [i t] Hin.
      unfold get_co in H, H0, Hin |- *; rewrite CO in H, H0, Hin |- *.
      simpl in IH.
      generalize (Forall_forall1 _ _ IH); clear IH; intro IH.
      specialize (IH (i, t) Hin n n0).
      apply le_S_n in H; apply le_S_n in H0.
      assert (H3 := rank_type_members cenv_cs i t _ Hin).
      apply IH.
      * simpl.
        eapply le_trans; [ | eassumption].
        erewrite co_consistent_rank; [eapply rank_type_field_type; eassumption |].
        exact (cenv_consistent id co CO).
      * simpl.
        eapply le_trans; [ | eassumption].
        erewrite co_consistent_rank; [eapply rank_type_field_type; eassumption |].
        exact (cenv_consistent id co CO).
    - destruct n, n0; simpl;  unfold FT_aux in *;
      generalize (F_Tstruct id) as FF; unfold get_co;
      rewrite CO; intros; auto.
Defined.

Definition FTI_aux id :=
    let m := co_members (get_co id) in
    (ListTypeGen (fun it => A (field_type (fst it) m)) (fun it => type_func (field_type (fst it) m)) m).

Lemma type_func_ind: forall t,
  type_func t =
  match t as t0 return A t0 with
  | Tstruct id => F_Tstruct id (FTI_aux id)
  | t' => F_Tint t'
  end.
Proof.
  intros.
  type_induction t; try reflexivity.
  + (* Tstruct *)
    unfold type_func in *.
    simpl type_func_rec.
    destruct (Maps.PTree.get id cenv_cs) as [co |] eqn:CO; simpl.
    - f_equal.
      apply ListTypeGen_preserve; intros [i t].
      unfold get_co; rewrite CO.
      intro Hin.
      generalize (Forall_forall1 _ _ IH); clear IH; intro IH.
      apply type_func_rec_rank_irrelevent.
      * simpl.
        erewrite co_consistent_rank; [eapply rank_type_field_type; eassumption |].
        exact (cenv_consistent id co CO).
      * apply le_n.
    - rewrite CO.
      f_equal.
      unfold FTI_aux, get_co; rewrite CO.
      reflexivity.
Defined.

End COMPOSITE_ENV.

Arguments type_func {cs} A F_Tint F_Tstruct t / .

Ltac type_induction t :=
  pattern t;
  match goal with
  | |- ?P t =>
    apply type_ind; clear t;
    let t := fresh "t" in
    intros t IH;
    let id := fresh "id" in
    destruct t as [ | id]
  end.


(**

 Ahrens, Lumsdaine, Voevodsky, 2015

Contents:

  - Construction of a type-category from a category with Families
  - Proof that the constructed type-category is split

*)

Require Import UniMath.CategoryTheory.limits.pullbacks.

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import TypeTheory.Auxiliary.CategoryTheoryImports.
Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.
Require Import TypeTheory.Auxiliary.Pullbacks.

Require Import TypeTheory.TypeCat.TypeCat.
Require Import TypeTheory.OtherDefs.CwF_Pitts.

(* Locally override the notation [ γ ♯ a ], at a higher level,
  to get more informative bracketing when pairing meets composition. *)
Local Notation "γ ## a" := (pairing γ a) (at level 75).

(** * Type-cat from cat with Families *)

(**
Every CwF gives rise to a type-category.

Since the components of the type-cat structure are highly successively dependent, we construct most of them individually, before putting them together in [type_cat_of_cwf].
*)

Section TypeCat_of_CwF.

Context (CC : category) (C : cwf_struct CC).

Definition type_cat1_of_cwf : typecat_structure1 CC.
Proof.
  unfold typecat_structure1.
  exists (type C).
  exists (comp_obj ).
  exact (fun Γ a Γ' f => a{{f}}).
Defined.

(** We can now assemble the components into a type-category: *)

Definition type_cat_of_cwf : typecat_structure CC.
Proof.
  exists type_cat1_of_cwf.
  unfold typecat_structure2.
  exists (@proj_mor CC C).
  exists (@q_cwf CC C).
  exists (@dpr_q_cwf CC C).
  intros; apply @is_symmetric_isPullback.
  apply is_pullback_reindx_cwf.
Defined.

(** * Splitness of the constructed TypeCat *)

(** Moreover, the type-cat of a CwF is always split. *)

Definition issplit_type_cat_of_cwf
  : is_split_typecat type_cat_of_cwf.
Proof.
  unfold is_split_typecat.
  repeat split.
  - (* Types over each object form a set *)
    apply cwf_types_isaset.
  - (* Reindexing along identities *)
    exists (reindx_type_id C).
    intros Γ A.
    unfold q_typecat; simpl. unfold q_cwf.
    eapply pathscomp0. 2: { apply id_left. }
    eapply pathscomp0. 2: apply maponpaths_2.
    eapply pathscomp0. 2: { symmetry. apply pairing_transport. }
    2: { apply cwf_law_4. }
    eapply pathscomp0. { apply (pairing_mapeq _ _ (id_right _ )). }
    apply maponpaths.
    eapply pathscomp0. { apply transport_f_f. }
    eapply pathscomp0.
    { eapply term_typeeq_transport_lemma.
      eapply term_typeeq_transport_lemma_2.
      reflexivity. }
    apply pathsinv0, (functtransportf (fun D => D{{_}})).
  - (* Reindexing along composites *)
    exists (fun Γ A Γ' f Γ'' g => reindx_type_comp C f g A).
    intros Γ A Γ' f Γ'' g.
    unfold q_typecat. simpl.
    eapply pathscomp0. 2: { apply id_left. }
    rewrite 2 assoc.
    unfold ext_typecat. simpl.
    rewrite <- cwf_law_4.
    rewrite pairing_transport.
    unfold q_cwf.
    rewrite cwf_law_3.
    match goal with [|- pairing ?b _ = pairing ?e _ ] =>
              set (X := b); set (X' := e)  end.
    etrans.
    + refine (pairing_mapeq _ X' _ _ ).
      subst X X'.
      etrans. 2: { apply pathsinv0, maponpaths_2, cwf_law_3. }
      etrans. 2: { apply pathsinv0, assoc. }
      etrans. { apply assoc. }
      apply maponpaths_2.
      etrans. 2: { apply pathsinv0, cwf_law_1. }
      etrans. 2: { apply pathsinv0, assoc. }
      apply maponpaths_2. sym. apply cwf_law_1.
    + apply maponpaths.
      match goal with |[ |- transportf _ ?e _ = transportf _ ?e' _  ] =>
                       generalize e, e' end.
      intros p p'.
      rew_trans_@.
      apply term_typeeq_transport_lemma.
      etrans. 2:{ apply rterm_typeeq. }
      match goal with |[ |- transportf _ ?e _ = transportf _ ?e' _  ] =>
                       generalize e, e' end.
      clear p p' X X'; intros p p'.
      rewrite (reindx_term_comp C).
      rewrite transport_f_f.
      match goal with |[ |- transportf _ ?e _ = transportf _ ?e' _  ] =>
                       generalize e, e' end.
      clear p p'; intros p p'.
      rewrite cwf_law_2'.
      unfold transportb.
      rewrite 2 transport_f_f.
      apply term_typeeq_transport_lemma.
      match goal with |[ |- _ = transportf _ ?e _ ⟦ _ ⟧ ] => generalize e end.
      intro q.
      etrans. 2: { apply rterm_typeeq. }
      rewrite cwf_law_2'.
      unfold transportb.
      rewrite 2 transport_f_f.
      match goal with |[ |- transportf _ ?e _ = transportf _ ?e' _  ] =>
                       generalize e, e' end.
      clear p q p'; intros p p'.
      match goal with |[ |- _ = transportf _ _  (transportf _ ?e' _ ) ] =>
                       set (p'':=e') end.
      apply term_typeeq_transport_lemma.
      match goal with |[ |- transportf _ ?e _ = transportf _ ?e' _  ] =>
                       generalize e end.
      clear p p'; intro p. clearbody p''.
      eapply pathscomp0. 2: { apply pathsinv0, retype_term_pi. }
      apply maponpaths_2, cwf_types_isaset.
Qed.

End TypeCat_of_CwF.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl 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 General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export type_sys_useful.

Lemma term_equality_symmetric_eq_term_equals {p} :
  forall eq eq' : per(p),
    term_equality_symmetric eq
    -> eq_term_equals eq eq'
    -> term_equality_symmetric eq'.
Proof.
  introv tes eqt.
  unfold term_equality_symmetric; introv.
  allrw <- eqt; sp.
Qed.

Lemma term_equality_transitive_eq_term_equals {p} :
  forall eq eq' : per(p),
    term_equality_transitive eq
    -> eq_term_equals eq eq'
    -> term_equality_transitive eq'.
Proof.
  introv tet eqt.
  unfold term_equality_transitive; introv.
  allrw <- eqt; sp.
  apply tet with (t2 := t2); sp.
Qed.

Lemma term_equality_respecting_eq_term_equals {p} :
  forall lib (eq eq' : per(p)),
    term_equality_respecting lib eq
    -> eq_term_equals eq eq'
    -> term_equality_respecting lib eq'.
Proof.
  introv ter eqt.
  unfold term_equality_respecting; introv.
  allrw <- eqt; sp.
Qed.

Lemma type_sys_props_uv {p} :
  forall lib (ts : cts(p)) A B eq eq',
    type_sys_props lib ts A B eq
    -> eq_term_equals eq eq'
    -> type_sys_props lib ts A B eq'.
Proof.
  introv tsp eqt.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
  prove_type_sys_props Case.

  - Case "uniquely_valued".
    introv e.
    apply uv in e.
    apply eq_term_equals_trans with (eq2 := eq); sp.
    apply eq_term_equals_sym; sp.

  - Case "type_symmetric".
    introv e1 e2 e3.
    generalize (tys T T3 eq'0); introv k.
    repeat (dest_imp k hyp).
    generalize (tyt A eq); introv j; repeat (dest_imp j hyp); repnd.
    apply tygs; sp.
    generalize (tyst B eq); introv u; repeat (dest_imp u hyp); repnd.
    repdors; subst.
    generalize (tymt A A T3 eq eq'); sp.
    generalize (tymt B B T3 eq eq'); sp.
    apply eq_term_equals_trans with (eq2 := eq'); sp.

  - Case "type_transitive".
    introv e1.
    generalize (tyt T3 eq'0); introv k; dest_imp k hyp.

  - Case "type_stransitive".
    introv e.
    generalize (tyst T3 eq'0); introv k; dest_imp k hyp.

  - Case "type_value_respecting".
    introv e c.
    generalize (tyvr T T3); introv k; dest_imp k hyp.

  - Case "term_symmetric".
    apply @term_equality_symmetric_eq_term_equals with (eq := eq); sp.

  - Case "term_transitive".
    apply @term_equality_transitive_eq_term_equals with (eq := eq); sp.

  - Case "term_value_respecting".
    apply @term_equality_respecting_eq_term_equals with (eq := eq); sp.

  - Case "type_gsymmetric".
    introv e.
    generalize (tygs T T3 eq'0); sp.

  - Case "type_gtransitive".
    sp.

  - Case "type_mtransitive".
    introv e1 e2 e3.
    generalize (tymt T T3 T4 eq1 eq2); sp.
Qed.

Lemma type_sys_props_implies_term_eq_sym {p} :
  forall lib (ts : cts(p)) P P' eqp,
    type_sys_props lib ts P P' eqp
    -> term_equality_symmetric eqp.
Proof.
  intros; onedtsp uv1 tys1 tyt1 tyst1 tyvr1 tes1 tet1 tevr1 tygs1 tygt1 dum1; sp.
Qed.

Lemma type_sys_props_implies_term_eq_trans {p} :
  forall lib (ts : cts(p)) P P' eqp,
    type_sys_props lib ts P P' eqp
    -> term_equality_transitive eqp.
Proof.
  intros; onedtsp uv1 tys1 tyt1 tyst1 tyvr1 tes1 tet1 tevr1 tygs1 tygt1 dum1; sp.
Qed.


Require Import CakeSem.Utils.
Require Import CakeSem.Namespace.

(* Literal constants *)
Inductive lit : Type :=
| IntLit : int -> lit
| CharLit : char -> lit
| StrLit : string -> lit
| Word8Lit : word8 -> lit
| Word64Lit : word64 -> lit.

Inductive opn : Type :=
  | Plus : opn
  | Minus : opn
  | Times : opn
  | Divide : opn
  | Modulo : opn.
Scheme Equality for opn.

Inductive opb : Type :=
  | Lt : opb
  | Gt : opb
  | Leq : opb
  | Geq : opb.
Scheme Equality for opb.

Inductive opw : Type :=
  | Andw : opw
  | Orw : opw
  | Xorw : opw
  | Addw : opw
  | Subw : opw.
Scheme Equality for opw.

Inductive shift : Type :=
  | Lsl : shift
  | Lsr : shift
  | Asr : shift
  | Ror : shift.
Scheme Equality for shift.

Notation modN := string.
Notation varN := string.
Notation conN := string.
Notation typeN := string.
Notation tvarN := string.

Inductive word_size : Type :=
  | W8 : word_size
  | W64 : word_size.
Scheme Equality for word_size.

Inductive fpcmp : Type :=
| FP_Less | FP_LessEqual | FP_Greater | FP_GreaterEqual | FP_Equal.
Scheme Equality for fpcmp.

Inductive fpuop : Type :=
| FP_Abs | FP_Neg | FP_Sqrt.
Scheme Equality for fpuop.

Inductive fpbop : Type :=
| FP_Add | FP_Sub | FP_Mul | FP_Div.
Scheme Equality for fpbop.

Inductive fptop : Set :=
| FP_Fma.
Scheme Equality for fptop.

Inductive op : Type :=
  | Opn : opn -> op
  | Opb : opb -> op
  | Opw : word_size -> opw -> op
  | Shift : word_size -> shift -> nat -> op
  | Equality : op
  | OpFpCmp : fpcmp -> op
  | OpFpUop : fpuop -> op
  | OpFpBop : fpbop -> op
  | OpFpTop : fptop -> op
(* Function application *)
  | Opapp : op
  (* Reference operations *)
  | Opassign : op
  | Opref : op
  | Opderef : op
  (* Word8Array operations *)
  | Aw8alloc : op
  | Aw8sub : op
  | Aw8length : op
  | Aw8update : op
  (* Word/integer conversions *)
  | WordFromInt : word_size -> op
  | WordToInt : word_size -> op
  (* string/bytearray conversions *)
  | CopyStrStr : op
  | CopyStrAw8 : op
  | CopyAw8Str : op
  | CopyAw8Aw8 : op
  (* Char operations *)
  | Ord : op
  | Chr : op
  | Chopb : opb -> op
  (* String operations *)
  | Implode : op
  | Explode : op
  | Strsub : op
  | Strlen : op
  | Strcat : op
  (* Vector operations *)
  | VfromList : op
  | Vsub : op
  | Vlength : op
  (* Array operations *)
  | Aalloc : op
  | AallocEmpty : op
  | Asub : op
  | Alength : op
  | Aupdate : op
  (* Unsafe array accesses *)
  | Asub_unsafe : op
  | Aupdate_unsafe : op
  | Aw8sub_unsafe : op
  | Aw8update_unsafe : op
  (* List operations *)
  | ListAppend : op
  (* Configure the GC *)
  | ConfigGC : op
  (* Call a given foreign function *)
  | FFI : string -> op.
Scheme Equality for op.

Inductive lop : Type :=
  | And : lop
  | Or : lop.
Scheme Equality for lop.

(* Helper relation for lists *)
Inductive Forall'' (A : Type) (P'' : A -> Type) : list A -> Type :=
| Forall_nil'' : Forall'' A P'' []
| Forall_cons'' : forall (x : A) (l : list A), P'' x -> Forall'' A P'' l -> Forall'' A P'' (x :: l).

Arguments Forall'' {A } _.

(* We need to build our own inductive principles for a bit *)
Unset Elimination Schemes.

(* Set Elimination Schemes. *)
(** BACKPORT this definition to Cakeml Lem semantics *)
Definition constr_id : Type :=
  option (ident modN conN).

Inductive ast_t : Type :=
| Atvar : tvarN -> ast_t
| Atfun : ast_t -> ast_t -> ast_t
| Attup : list ast_t -> ast_t
| Atapp : list ast_t -> ident modN typeN -> ast_t.

Inductive pat : Type :=
| Pany : pat
| Pvar : varN -> pat
| Plit : lit -> pat
| Pcon : constr_id -> list pat -> pat
| Pref : pat -> pat
| Pas : pat -> varN -> pat
| Ptannot : pat -> ast_t -> pat.

(* locs Defined elsewhere in the Lem spec *)
Definition locs : Type := list nat.

(* Expressions *)
Inductive exp : Type :=
  | ERaise : exp -> exp
  | EHandle : exp -> list (pat * exp) -> exp
  | ELit : lit -> exp
  | ECon : constr_id -> list exp -> exp
  | EVar : ident modN varN -> exp
  | EFun : varN -> exp -> exp
  | EApp : op -> list exp -> exp
  | ELog : lop -> exp -> exp -> exp
  | EIf  : exp -> exp -> exp -> exp
  | EMat : exp -> list (pat * exp) -> exp
  | ELet : option varN -> exp -> exp -> exp
  | ELetrec : list (varN * varN * exp) -> exp -> exp
  | ETannot : exp -> ast_t -> exp
  | ELannot : exp -> locs -> exp.

Definition typeDef : Type :=
  list (list tvarN * typeN * list (conN * list ast_t)).

(* Declarations *)
Inductive dec : Type :=
  | Dlet : locs -> pat -> exp -> dec
  | Dletrec : locs -> list (varN * varN * exp) -> dec
  | Dtype : locs -> typeDef -> dec
  | Dtabbrev : locs -> list tvarN -> typeN -> ast_t -> dec
  | Dexn : locs -> conN -> list ast_t -> dec
  | Dmod : modN -> list dec -> dec
  | Dlocal : list dec -> list dec -> dec.

Fixpoint pat_bindings (p : pat) (already_bound : list varN) : list varN :=
  match p with
  | Pany => already_bound
  | Pvar n => n :: already_bound
  | Plit _ => already_bound
  | Pcon _ ps => List.fold_right (fun p acc => acc ++ pat_bindings p already_bound) [] ps
  | Pref p' => pat_bindings p' already_bound ++ already_bound
  | Pas p' n => pat_bindings p' (n :: already_bound)
  | Ptannot p' _ => pat_bindings p' already_bound
  end.

(*-------------------------------------------------------------------*)
(** Begin induction principle *)

(** AST *)
Fixpoint ast_t_rect' (P : ast_t -> Type)
         (H1 : forall (s : tvarN), P (Atvar s))
         (H2 : forall (a1 a2 : ast_t), P a1 -> P a2 -> P (Atfun a1 a2))
         (H3 : forall (l : list ast_t), Forall'' P l -> P (Attup l))
         (H4 : forall (l : list ast_t) (i : ident modN typeN), Forall'' P l -> P (Atapp l i))
         (a : ast_t) : P a :=
  let fix loop (ls : list ast_t) :=
      match ls with
      | [] => Forall_nil'' ast_t P
      | h::t => Forall_cons'' ast_t P h t (ast_t_rect' P H1 H2 H3 H4 h) (loop t)
      end
  in
  match a with
  | Atvar s => H1 s
  | Atfun a1 a2 => H2 a1 a2 (ast_t_rect' P H1 H2 H3 H4 a1) (ast_t_rect' P H1 H2 H3 H4 a2)
  | Attup l => H3 l (loop l)
  | Atapp l i =>  H4 l i (loop l)
  end.

Definition ast_t_ind' (P : ast_t -> Prop) := ast_t_rect' P.
Definition ast_t_rec' (P : ast_t -> Set) := ast_t_rect' P.

(** PAT *)

Fixpoint pat_rect' (P : pat -> Type)
  (H0 : P Pany)
  (H1 : forall (v : varN), P (Pvar v))
  (H2 : forall (l : lit), P (Plit l))
  (H3 : forall (o : constr_id) (l : list pat), Forall'' P l -> P (Pcon o l))
  (H4 : forall (p : pat), P p -> P (Pref p))
  (H5 : forall (p : pat) (n : varN), P p -> P (Pas p n))
  (H6 : forall (p : pat) (a : ast_t), P p -> P (Ptannot p a))
  (p : pat) : P p :=
  let pat_rect'' := pat_rect' P H0 H1 H2 H3 H4 H5 H6 in
  match p return (P p) with
  | Pany => H0
  | Pvar v => H1 v
  | Plit l => H2 l
  | Pcon o l => let fix loop (l : list pat) :=
                   match l with
                   | [] => Forall_nil'' pat P
                   | h::t => Forall_cons'' pat P h t (pat_rect'' h) (loop t)
                   end
               in
               H3 o l (loop l)
  | Pref p' => H4 p' (pat_rect'' p')
  | Pas p' n => H5 p' n (pat_rect'' p')
  | Ptannot p' a => H6 p' a (pat_rect'' p')
  end.

Definition pat_rec' (P : pat -> Set) := pat_rect' P.
Definition pat_ind' (P : pat -> Prop) := pat_rect' P.

(** Exp *)

Definition exp_rect_helper (P : exp -> Type) (p : pat * exp) : Type :=
  match p with
  | (x, y) => P y
  end.

Definition exp_rect_helper' (P : exp -> Type) (p : varN * varN * exp) : Type :=
  match p with
  | (x, y, z) => P z
  end.

Fixpoint exp_rect' (P : exp -> Type)
         (H  : forall (e' : exp), P e' -> P (ERaise e'))
         (H0 : forall (e' : exp) (l : list (pat * exp)), P e' ->
                                                    Forall'' (exp_rect_helper P) l ->
                                                    P (EHandle e' l))
         (H1 : forall (l : lit), P (ELit l))
         (H2 : forall (o : constr_id) (l : list exp), Forall'' P l ->
                                                 P (ECon o l))
         (H3 : forall (i : ident modN varN), P (EVar i))
         (H4 : forall (v : varN) (e : exp), P e -> P (EFun v e))
         (H5 : forall (o : op) (l : list exp), Forall'' P l -> P (EApp o l))
         (H6 : forall (lo : lop) (e1 e2 : exp), P e1 -> P e2 -> P (ELog lo e1 e2))
         (H7 : forall (c t e : exp), P c -> P t -> P e -> P (EIf c t e))
         (H8 : forall (e : exp), P e -> forall (l : list (pat * exp)), Forall'' (exp_rect_helper P) l ->
                                                            P (EMat e l))
         (H9 : forall (o : option varN) (e1 e2 : exp), P e1 -> P e2 -> P (ELet o e1 e2))
         (H10 : forall (vve : list (varN * varN * exp)) (e : exp), Forall'' (exp_rect_helper' P) vve ->
                                                   P e -> P (ELetrec vve e))
         (H11 : forall (e : exp) (a : ast_t), P e -> P (ETannot e a))
         (H12 : forall (e : exp) (l : locs), P e -> P (ELannot e l))
         (e : exp) : P e :=
  let exp_rect' := fun e' => exp_rect' P H H0 H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 H12 e' in
  let fix loop (l : list exp) :=
      match l with
      | [] => Forall_nil'' exp P
      | h::t => Forall_cons'' exp P h t (exp_rect' h) (loop t)
      end
  in
  let fix pair_loop (l : list (pat * exp)) :=
      match l with
      | [] => Forall_nil'' (pat * exp) (exp_rect_helper P)
      | (x,y)::t => Forall_cons'' (pat * exp) (exp_rect_helper P) (x,y) t (exp_rect' y) (pair_loop t)
      end
  in
  let fix trip_loop (l : list (varN * varN * exp)) :=
      match l with
      | [] => Forall_nil'' (varN * varN * exp) (exp_rect_helper' P)
      | (x,y,z)::t => Forall_cons'' (varN * varN * exp) (exp_rect_helper' P) (x,y,z) t (exp_rect' z) (trip_loop t)
      end
  in
  match e with
  | ERaise e' => H e' (exp_rect' e')
  | EHandle e' l => H0 e' l (exp_rect' e') (pair_loop l)
  | ELit l => H1 l
  | ECon o l  => H2 o l (loop l)
  | EVar i    => H3 i
  | EFun v e' => H4 v e' (exp_rect' e')
  | EApp o l  => H5 o l (loop l)
  | ELog lo e1 e2 => H6 lo e1 e2 (exp_rect' e1) (exp_rect' e2)
  | EIf c t e => H7 c t e (exp_rect' c) (exp_rect' t) (exp_rect' e)
  | EMat e' l     => H8 e' (exp_rect' e') l (pair_loop l)
  | ELet o e1 e2  => H9 o e1 e2 (exp_rect' e1) (exp_rect' e2)
  | ELetrec vve e => H10 vve e (trip_loop vve) (exp_rect' e)
  | ETannot e' a  => H11 e' a (exp_rect' e')
  | ELannot e' l  => H12 e' l (exp_rect' e')
  end.

Definition exp_rec' (P : exp -> Set) := exp_rect' P.
Definition exp_ind' (P : exp -> Prop) := exp_rect' P.

Definition list_exp_rect_helper (P : list exp -> Type) (p : pat * exp) : Type :=
  match p with
  | (x, y) => P [y]
  end.

Definition list_exp_rect_helper' (P : list exp -> Type) (p : varN * varN * exp) : Type :=
  match p with
  | (x, y, z) => P [z]
  end.

(** DEC *)
Fixpoint dec_rect' (P : dec -> Type)
         (H1 : forall (l : locs) (p : pat) (e : exp), P (Dlet l p e))
         (H2 : forall (l : locs) (lv : list (varN * varN * exp)), P (Dletrec l lv))
         (H3 : forall (l : locs) (t : typeDef), P (Dtype l t))
         (H4 : forall (l : locs) (tvs : list tvarN) (tn : typeN) (a : ast_t), P (Dtabbrev l tvs tn a))
         (H5 : forall (l : locs) (cn : conN) (ls : list ast_t), P (Dexn l cn ls))
         (H6 : forall (mn : modN) (ds : list dec), Forall'' P ds -> P (Dmod mn ds))
         (H7 : forall (ds1 ds2 : list dec), Forall'' P ds1 -> Forall'' P ds2 -> P (Dlocal ds1 ds2))
         (d : dec) : P d :=
  let fix loop (l : list dec) : Forall'' P l :=
      match l with
      | [] => Forall_nil'' _ _
      | d'::l' => Forall_cons'' _ P d' l' (dec_rect' P H1 H2 H3 H4 H5 H6 H7 d') (loop l')
      end
  in
  match d with
  | Dlet l p e => H1 l p e
  | Dletrec l lv => H2 l lv
  | Dtype l t => H3 l t
  | Dtabbrev l tvs tn a => H4 l tvs tn a
  | Dexn l cn ls => H5 l cn ls
  | Dmod mn ds => H6 mn ds (loop ds)
  | Dlocal ds1 ds2 => H7 ds1 ds2 (loop ds1) (loop ds2)
  end.

Definition dec_rec' (P : dec -> Set) := dec_rect' P.
Definition dec_ind' (P : dec -> Prop) := dec_rect' P.

Definition ast_t_rect := ast_t_rect'.
Definition exp_rect := exp_rect'.
Definition pat_rect := pat_rect'.
Definition dec_rect := dec_rect'.

Definition ast_t_rec := ast_t_rec'.
Definition exp_rec := exp_rec'.
Definition pat_rec := pat_rec'.
Definition dec_rec := dec_rec'.

Definition ast_t_ind := ast_t_ind'.
Definition exp_ind := exp_ind'.
Definition pat_ind := pat_ind'.
Definition dec_ind := dec_ind'.

(** End induction principle *)
(*-------------------------------------------------------------------*)

(** Begin boolean equality *)
(*-------------------------------------------------------------------*)

Scheme Equality for list.
Scheme Equality for ident.
Scheme Equality for option.
Scheme Equality for prod.

Definition lit_beq (lit1 lit2 : lit) : bool :=
  match lit1, lit2 with
  | IntLit i1, IntLit i2 => Z.eqb i1 i2
  | CharLit c1, CharLit c2 => Ascii.eqb c1 c2
  | StrLit s1, StrLit s2 => String.eqb s1 s2
  | Word8Lit w1, Word8Lit w2 => word_equality 8 w1 w2
  | Word64Lit w1, Word64Lit w2 => word_equality 64 w1 w2
  | _, _ => false
  end.

Fixpoint ast_t_beq (a1 a2 : ast_t) : bool :=
  match a1, a2 with
  | Atvar v1, Atvar v2 => String.eqb v1 v2
  | Atfun a3 a4, Atfun a5 a6 => andb (ast_t_beq a3 a5) (ast_t_beq a4 a6)
  | Attup l1, Attup l2 => list_beq _ ast_t_beq l1 l2
  | Atapp l1 i1, Atapp l2 i2 => andb (list_beq _ ast_t_beq l1 l2)
                                    (ident_beq _ _ String.eqb String.eqb i1 i2)
  | _, _ => false
  end.

Definition constr_id_beq := option_beq _ (ident_beq _ _ String.eqb String.eqb).

Fixpoint pat_beq (p1 p2 : pat) :=
  match p1, p2 with
  | Pvar s1, Pvar s2 => String.eqb s1 s2
  | Pcon cid1 l1, Pcon cid2 l2 => andb (constr_id_beq cid1 cid2) (list_beq _ pat_beq l1 l2)
  | _, _ => false
  end.

Arguments list_beq {_}.
Arguments prod_beq {_} {_}.

Fixpoint exp_beq (exp1 exp2 : exp) :=
  match exp1, exp2 with
  | ERaise e1, ERaise e2 => exp_beq e1 e2
  | EHandle e1 l1, EHandle e2 l2 => andb (exp_beq e1 e2) (list_beq (prod_beq pat_beq exp_beq) l1 l2)
  | ELit lit1, ELit lit2 => lit_beq lit1 lit2
  | ECon c1 l1, ECon c2 l2 => andb (constr_id_beq c1 c2) (list_beq exp_beq l1 l2)
  | EVar i1, EVar i2 => ident_beq _ _ String.eqb String.eqb i1 i2
  | EFun v1 e1, EFun v2 e2 => andb (String.eqb v1 v2) (exp_beq e1 e2)
  | EApp o1 l1, EApp o2 l2 => andb (op_beq o1 o2) (list_beq exp_beq l1 l2)
  | ELog lo1 e1 e2, ELog lo2 e3 e4 => andb (andb (lop_beq lo1 lo2) (exp_beq e1 e3)) (exp_beq e2 e4)
  | EIf c1 t1 e1, EIf c2 t2 e2 => andb (andb (exp_beq c1 c2) (exp_beq t1 t2)) (exp_beq e1 e2)
  | EMat e1 l1, EMat e2 l2 => andb (exp_beq e1 e2) (list_beq (prod_beq pat_beq exp_beq) l1 l2)
  | ELet o1 e1 e2, ELet o2 e3 e4 => andb (andb (option_beq _ String.eqb o1 o2) (exp_beq e1 e3))
                                        (exp_beq e2 e4)
  | ELetrec l1 e1, ELetrec l2 e2 => andb (list_beq (prod_beq
                                                            (prod_beq String.eqb String.eqb)
                                                            exp_beq) l1 l2)
                                        (exp_beq e1 e2)
  | ELannot e1 lc1, ELannot e2 lc2 => andb (exp_beq e1 e2) (list_beq  Nat.eqb lc1 lc2)
  | _, _ => false
  end.

Definition typeDef_beq := list_beq (prod_beq (prod_beq (list_beq String.eqb) String.eqb) (list_beq (prod_beq String.eqb (list_beq ast_t_beq)))).

Open Scope bool_scope.

Fixpoint dec_beq (dec1 dec2 : dec) :=
  match dec1, dec2 with
  | Dlet l1 p1 e1, Dlet l2 p2 e2 => list_beq Nat.eqb l1 l2 && pat_beq p1 p2 && exp_beq e1 e2
  | Dletrec l1 lvve1 , Dletrec l2 lvve2 => list_beq Nat.eqb l1 l2 &&
                                            list_beq (prod_beq (prod_beq String.eqb String.eqb) exp_beq) lvve1 lvve2
  | Dtype l1 t1, Dtype l2 t2 => list_beq Nat.eqb l1 l2 && typeDef_beq t1 t2
  | Dtabbrev l1 lts1 tn1 ast1 , Dtabbrev l2 lts2 tn2 ast2 => list_beq Nat.eqb l1 l2 &&
                                                              list_beq String.eqb lts1 lts2 &&
                                                              String.eqb tn1 tn2 &&
                                                              ast_t_beq ast1 ast2
  | Dexn l1 cn1 last1, Dexn l2 cn2 last2 => list_beq Nat.eqb l1 l2 &&
                                             String.eqb cn1 cn2 &&
                                             list_beq ast_t_beq last1 last2
  | Dmod mn1 ld1, Dmod mn2 ld2 => String.eqb mn1 mn2 &&
                                   list_beq dec_beq ld1 ld2

  | Dlocal ld11 ld12, Dlocal ld21 ld22 => list_beq dec_beq ld11 ld21 &&
                                           list_beq dec_beq ld12 ld22
  | _, _ => false
  end.

(** End boolean equality *)
(*-------------------------------------------------------------------*)

(** Decidable Equality for terms, patterns, and expressions *)
(*-------------------------------------------------------------------*)

Theorem lit_eq_dec (l l' : lit) : {l = l'} + {l <> l'}.
  decide equality; auto with DecidableEquality. apply (word_eq_dec 8). apply (word_eq_dec 64). Defined.
#[export] Hint Resolve lit_eq_dec : DecidableEquality.

(* Theorem opn_eq_dec (o o' : opn) : {o = o'} + {o <> o'}. *)
(*  decide equality. Defined. *)
#[export] Hint Resolve opn_eq_dec : DecidableEquality.

(* Theorem opb_eq_dec (o o' : opn) : {o = o'} + {o <> o'}. *)
(*   decide equality. *)
(* Defined. *)
#[export] Hint Resolve opb_eq_dec : DecidableEquality.

(* Theorem opw_eq_dec (o o' : opn) : {o = o'} + {o <> o'}. *)
(*   decide equality. *)
(* Defined. *)
#[export] Hint Resolve opw_eq_dec : DecidableEquality.

(* Theorem shift_eq_dec (o o' : opn) : {o = o'} + {o <> o'}. *)
(*   decide equality. *)
(* Defined. *)
#[export] Hint Resolve shift_eq_dec : DecidableEquality.

(* Theorem op_eq_dec : forall (o0 o1 : op), {o0 = o1} + {o0 <> o1}. *)
(* Proof. *)
(*   decide equality; try (apply string_dec); decide equality. *)
(* Defined. *)
#[export] Hint Resolve op_eq_dec : DecidableEquality.

(* Theorem lop_eq_dec : forall (l0 l1 : lop), {l0 = l1} + {l0 <> l1}. *)
(* Proof. decide equality.  Defined. *)
#[export] Hint Resolve lop_eq_dec : DecidableEquality.

Theorem ast_t_eq_dec : forall (a1 a2 : ast_t), {a1 = a2} + {a1 <> a2}.
Proof.
  decide equality;
    auto with DecidableEquality.
  - generalize dependent l0; induction H; destruct l0.
    left; reflexivity.
    right; congruence.
    right; congruence.
    destruct (IHForall'' l0). destruct (p a). subst.
    left; reflexivity.
    right; congruence.
    right; congruence.
  - generalize dependent l0. induction H; destruct l0.
    left; reflexivity.
    right; congruence.
    right; congruence.
    destruct (IHForall'' l0).
    destruct (p a). subst.
    left; reflexivity.
    right; congruence.
    right. congruence.
Defined.
#[export] Hint Resolve ast_t_eq_dec : DecidableEquality.

Theorem constr_id_eq_dec : forall (c0 c1 : constr_id), {c0 = c1} + {c0 <> c1}.
Proof.
  decide equality. auto with DecidableEquality.  Defined.
#[export] Hint Resolve constr_id_eq_dec : DecidableEquality.

Theorem pat_eq_dec : forall (p0 p1 : pat), {p0 = p1} + {p0 <> p1}.
Proof.
  decide equality; auto with DecidableEquality.
  generalize dependent l0;
  induction X; destruct l0; try (right; congruence); try (left; reflexivity).
  destruct (IHX l0); destruct (p p2); subst; try (left; reflexivity); try (right; congruence).
Defined.
#[export] Hint Resolve pat_eq_dec : DecidableEquality.

Theorem typeDef_eq_dec : forall (t0 t1 : typeDef), {t0 = t1} + {t0 <> t1}.
Proof. decide equality; auto with DecidableEquality.  Defined.
#[export] Hint Resolve typeDef_eq_dec : DecidableEquality.

Theorem locs_eq_dec : forall (l0 l1 : locs), {l0 = l1} + {l0 <> l1}.
Proof.
  decide equality; auto with DecidableEquality.
Defined.
#[export] Hint Resolve locs_eq_dec : DecidableEquality.


Set Primitive Projections.
Set Universe Polymorphism.
Set Polymorphic Inductive Cumulativity.

Inductive True : SProp := I.
Inductive False : SProp :=.
Inductive and (A : SProp) (B : SProp) : SProp := conj : A -> B -> and A B.

Axiom F : False.
Ltac admit := case F.

Set Definitional UIP.

Inductive eqn (A : Type) (x : A) : A -> SProp := refl : eqn A x x.

Unset Definitional UIP.

Arguments eqn {_}.
Arguments eqn_rect {_ _} _ _ {_}.

Definition rew {A} (P : A -> SProp) {x y : A} (e : eqn x y) (p : P x) : P y :=
  match e in eqn _ z return P z with refl _ _ => p end.

Definition transp {A} (P : A -> Type) {x y : A} (e : eqn x y) (p : P x) : P y.
Proof.
refine (match e in eqn _ z return P z with refl _ _ => p end).
Defined.

Record sig (A : Type) (B : A -> Type) := pair { fst : A; snd : B fst }.

Arguments fst {_ _}.
Arguments snd {_ _}.

Record exist (A : Type) (B : A -> SProp) := pack { val : A; spc : B val }.

Arguments val {_ _}.
Arguments spc {_ _}.

Axiom ℙ : Set.
Axiom le0 : ℙ -> ℙ -> Set.

Definition le (p q : ℙ) := forall r, le0 q r -> le0 p r.

Notation "p ≤ q" := (le p q) (at level 70).
Notation "α ∘ β" := (fun (r : ℙ) (γ : le0 _ r) => α r (β r γ)) (at level 50).
Notation "!" := (fun (r : ℙ) (γ : le0 _ r) => γ).
Notation "α · t" := (fun (q : ℙ) (β : q ≤ _) => t q (β ∘ α)) (at level 50).

Record Ctx := {
  ctx_typ : forall p, Type;
  ctx_rel : forall (p : ℙ), (forall q (α : q ≤ p), ctx_typ q) -> SProp;
}.

Coercion ctx_typ : Ctx >-> Funclass.
Arguments ctx_rel _ {_}.

Record Sub (Γ Δ : Ctx) := {
  sub_fun : forall p
    (γ : forall q (α : q ≤ p), Γ q)
    (γε : forall q (α : q ≤ p), ctx_rel Γ (α · γ)),
    Δ p;
  sub_rel : forall p
    (γ : forall q (α : q ≤ p), Γ q)
    (γε : forall q (α : q ≤ p), ctx_rel Γ (α · γ)),
    ctx_rel Δ (fun q α => sub_fun q (α · γ) (α · γε));
}.

Coercion sub_fun : Sub >-> Funclass.

Arguments sub_fun {_ _}.
Arguments sub_rel {_ _}.

Definition Idn {Γ : Ctx} : Sub Γ Γ.
Proof.
unshelve econstructor.
+ unshelve refine (fun p γ γε => γ p !).
+ unshelve refine (fun p γ γε => γε p !).
Defined.

Definition Cmp {Γ Δ Ξ : Ctx} (σ : Sub Γ Δ) (ρ : Sub Δ Ξ) : Sub Γ Ξ.
Proof.
unshelve econstructor.
+ unshelve refine (fun p γ γε => ρ _ _ _).
  unshelve refine (fun q α => σ _ (α · γ) (fun r β => γε _ (β ∘ α))).
  unshelve refine (fun q α => σ.(sub_rel) _ (α · γ) (α · γε)).
+ unshelve refine (fun p γ γε =>
  ρ.(sub_rel) _
    (fun q α => σ _ (α · γ) (fun r β => γε _ (β ∘ α)))
    (fun q α => σ.(sub_rel) _ (α · γ) (α · γε))
).
Defined.

Lemma Idn_Cmp : forall {Γ Δ} (σ : Sub Γ Δ), Cmp Idn σ = σ.
Proof.
reflexivity.
Qed.

Lemma Cmp_Idn : forall {Γ Δ} (σ : Sub Γ Δ), Cmp σ Idn = σ.
Proof.
reflexivity.
Qed.

Lemma Cmp_Cmp : forall {Γ Δ Ξ Ω} (σ : Sub Γ Δ) (ρ : Sub Δ Ξ) (θ : Sub Ξ Ω),
  Cmp (Cmp σ ρ) θ = Cmp σ (Cmp ρ θ).
Proof.
reflexivity.
Qed.

Record Typ (Γ : Ctx) := {
  typ_typ : forall p
    (γ : forall q (α : q ≤ p), Γ q)
    (γε : forall q (α : q ≤ p), ctx_rel Γ (α · γ)),
    Type;
  typ_rel : forall p
    (γ : forall q (α : q ≤ p), Γ q)
    (γε : forall q (α : q ≤ p), ctx_rel Γ (α · γ))
    (x : forall q (α : q ≤ p), typ_typ q (α · γ) (α · γε)), SProp;
}.

Coercion typ_typ : Typ >-> Funclass.
Arguments typ_rel {_} _ {_ _ _}.

Definition Typ_subs {Γ Δ : Ctx} (σ : Sub Δ Γ) (A : Typ Γ) : Typ Δ.
Proof.
unshelve econstructor.
+ unshelve refine (fun p δ δε => A p (fun q α => σ q (α · δ) (α · δε)) _).
  unshelve refine (fun q α => σ.(sub_rel) q (α · δ) (α · δε)).
+ unshelve refine (
  fun p δ δε x => @typ_rel _ A _
    (fun q α => σ q (α · δ) (α · δε))
    (fun q α => σ.(sub_rel) q (α · δ) (α · δε)) x).
Defined.

Record Trm (Γ : Ctx) (A : Typ Γ) := {
  trm_elt : forall p
    (γ : forall q (α : q ≤ p), Γ q)
    (γε : forall q (α : q ≤ p), ctx_rel Γ (α · γ)),
    A p γ γε;
  trm_rel : forall p
    (γ : forall q (α : q ≤ p), Γ q)
    (γε : forall q (α : q ≤ p), ctx_rel Γ (α · γ)),
    @typ_rel Γ A p γ γε (fun q (α : q ≤ p) => trm_elt q (α · γ) (α · γε))
}.

Arguments trm_elt {_ _}.
Arguments trm_rel {_ _}.

Definition Trm_subs {Γ Δ : Ctx} (σ : Sub Δ Γ) {A : Typ Γ}
  (t : Trm Γ A) : Trm Δ (Typ_subs σ A).
Proof.
unshelve econstructor.
+ simpl; refine (fun p γ γε => _).
  refine (t.(trm_elt) _ _ (fun q α => sub_rel σ q (α · γ) (α · γε))).
+ simpl; refine (fun p γ γε => _).
  refine (t.(trm_rel) _ _ (fun q α => sub_rel σ q (α · γ) (α · γε))).
Defined.

Definition Nil : Ctx.
Proof.
unshelve econstructor.
+ refine (fun _ => unit).
+ refine (fun _ _ => True).
Defined.

Record Ext_typ (Γ : Ctx) (A : Typ Γ) (p : ℙ) := {
  ext_typ_ctx : forall q (α : q ≤ p), Γ q;
  ext_typ_rel : forall q (α : q ≤ p), ctx_rel Γ (α · ext_typ_ctx);
  ext_typ_ext : A p ext_typ_ctx ext_typ_rel;
}.

Arguments ext_typ_ctx {_ _ _}.
Arguments ext_typ_rel {_ _ _}.
Arguments ext_typ_ext {_ _ _}.

Definition Build_Ext_typ₀ {Γ : Ctx} {A : Typ Γ} {p : ℙ}
  (γ : forall (q : ℙ) (α : q ≤ p), Γ q)
  (γε : forall (q : ℙ) (α : q ≤ p), ctx_rel Γ (α · γ))
  (x : forall (q : ℙ) (α : q ≤ p), A q (α · γ) (α · γε))
  (xε : forall (q : ℙ) (α : q ≤ p), @typ_rel Γ A q (α · γ) (α · γε) (α · x)) :
  forall q (α : q ≤ p), Ext_typ Γ A q :=
  fun q α => Build_Ext_typ _ _ _ (fun r β => γ r (β ∘ α)) (α · γε) (x q α).

Definition run {A : ℙ -> Type} {p : ℙ}
  (x : forall (q : ℙ) (α : q ≤ p) r (β : r ≤ q), A r) :
  forall (q : ℙ) (α : q ≤ p), A q := fun q (α : q ≤ p) => x q α q !.

Definition ret {A : ℙ -> Type} {p : ℙ}
  (x : forall (q : ℙ) (α : q ≤ p), A q) :
  forall (q : ℙ) (α : q ≤ p) r (β : r ≤ q), A r :=
    fun q (α : q ≤ p) r (β : r ≤ q) => x r (β ∘ α).

Definition evl {A} {p} x := @ret A p (@run A p x).

Definition Fε {A : ℙ -> Type} {p : ℙ}
  (x : forall (q : ℙ) (α : q ≤ p) r (β : r ≤ q), A r) :=
  eqn x (evl x).

Definition ΘF {A} {p : ℙ}
  (x : forall (q : ℙ) (α : q ≤ p) r (β : r ≤ q), A r)
  (xε : @Fε A p x) {q} (α : q ≤ p) : @Fε A q (α · x).
Proof.
refine (match xε in eqn _ z return Fε (α · z) -> Fε (α · x) with refl _ _ => fun e => e end _).
reflexivity.
Defined.

Notation "α • xε" := (ΘF _ xε α)  (at level 50).

Definition Θ {Γ : Ctx} {p : ℙ}
  (γ : forall (q : ℙ) (α : q ≤ p) r (β : r ≤ q), Γ r)
  (γε : forall (q : ℙ) (α : q ≤ p) r (β : r ≤ q), ctx_rel Γ (β · (γ q α)))
  (γe : Fε γ) :
  forall (q : ℙ) (α : q ≤ p),
    ctx_rel Γ (fun  (r : ℙ) (β : r ≤ q) => γ r (β ∘ α) r !) :=
  rew (fun γ₀ => forall q (α : q ≤ p), ctx_rel Γ (α · (γ₀ p !))) γe (γε p !).

Definition F_rect {A : ℙ -> Type} {p : ℙ}
  (P : forall
    (x : forall (q : ℙ) (α : q ≤ p) r (β : r ≤ q), A r)
    (xε : Fε x),
    Type
  )
  (u : forall
    (x : forall (q : ℙ) (α : q ≤ p), A q),
    P (ret x) (refl _ _)
  )
  (x : forall (q : ℙ) (α : q ≤ p) r (β : r ≤ q), A r)
  (xε : Fε x) :
  P x xε.
Proof.
unshelve refine (
  eqn_rect (fun x₀ (e₀ : eqn (evl x) x₀) => P x₀ (rew Fε e₀ (refl _ _))) (u (run x))
  (rew (fun z => eqn z _) xε (refl _ _))
).
Defined.

Definition F_sind {A : ℙ -> Type} {p : ℙ}
  (P : forall
    (x : forall (q : ℙ) (α : q ≤ p) r (β : r ≤ q), A r)
    (xε : Fε x),
    SProp
  )
  (u : forall
    (x : forall (q : ℙ) (α : q ≤ p), A q),
    P (ret x) (refl _ _)
  )
  (x : forall (q : ℙ) (α : q ≤ p) r (β : r ≤ q), A r)
  (xε : Fε x) :
  P x xε.
Proof.
unshelve refine (
  eqn_sind _ _ (fun x₀ (e₀ : eqn (evl x) x₀) => P x₀ (rew Fε e₀ (refl _ _))) (u (run x))
  _ (rew (fun z => eqn z _) xε (refl _ _))
).
Defined.

Definition letΘ {Γ : Ctx} {A : Typ Γ} {p : ℙ}
  (γ : forall (q : ℙ) (α : q ≤ p) r (β : r ≤ q), Γ r)
  (γε : forall (q : ℙ) (α : q ≤ p) r (β : r ≤ q), ctx_rel Γ (β · (γ q α)))
  (γe : Fε γ)
  (x : forall q (α : q ≤ p), A q (γ q α) (γε q α)) :
  (forall (q : ℙ) (α : q ≤ p), A q (evl γ q α) (α · Θ _ γε γe)).
Proof.
refine (fun q (α : q ≤ p) =>
  eqn_rect
    (fun
      (γ₀ : forall r : ℙ, r ≤ q -> Γ r)
      (e₀ : eqn (γ q α) γ₀) =>
        A q γ₀ (rew (fun γ₀ => forall (r : ℙ) (β : r ≤ q), ctx_rel Γ (β · γ₀)) e₀ (γε q α))
  )
  (x q α)
  (rew (fun γ₀ => eqn _ (γ₀ q α)) γe (refl _ _))
).
(*
refine (fun q (α : q ≤ p) =>
  F_rect (fun γ₀ e₀ => forall γε, A q (γ₀ q α) (γε q α) -> A q (evl γ₀ q α) (α · Θ γ₀ γε e₀)) (fun γ γε x => x) γ γe γε (x q α)
).
*)
Defined.

Lemma letΘ_mono : forall Γ A p γ γε γe x q (α : q ≤ p),
  α · (@letΘ Γ A p γ γε γe x) = @letΘ Γ A q (α · γ) (α · γε) (α • γe) (α · x).
Proof.
reflexivity.
Qed.

Definition eqn_sym {A} {x y : A} (e : eqn x y) : eqn y x.
Proof.
destruct e; reflexivity.
Qed.

Definition eqn_trs {A} {x y z : A} (p : eqn x y) (q : eqn y z) : eqn x z.
Proof.
destruct p, q; reflexivity.
Qed.

Definition eqn_app {A B} (f : A -> B) {x y : A} (e : eqn x y) : eqn (f x) (f y).
Proof.
destruct e; reflexivity.
Qed.

Record Ext_rel (Γ : Ctx) (A : Typ Γ) (p : ℙ)
  (γ : forall q (β : q ≤ p) r (β : r ≤ q), Γ r)
  (γε : forall q (α : q ≤ p) r (β : r ≤ q), ctx_rel Γ (β · (γ q α)))
  (x : forall q (α : q ≤ p), A q (γ q α) (γε q α)) : SProp := {

  ext_rel_ctx : Fε γ;

  ext_rel_ext :
    forall q (α : q ≤ p),
    @typ_rel _ A q
      (fun r (β : r ≤ q) => (γ r (β ∘ α)) r !)
      (Θ _ (fun r β => (γε r (β ∘ α))) (α • ext_rel_ctx))
      (letΘ _ _ (α • ext_rel_ctx) (α · x))
}.

Arguments ext_rel_ctx {_ _ _ _ _ _}.
Arguments ext_rel_ext {_ _ _ _ _ _}.

Definition Ext (Γ : Ctx) (A : Typ Γ) : Ctx.
Proof.
unshelve econstructor.
+ refine (Ext_typ Γ A).
+ refine (fun p γ =>
  Ext_rel Γ A p
    (fun q α => (γ q α).(ext_typ_ctx))
    (fun q α => (γ q α).(ext_typ_rel))
    (fun q α => (γ q α).(ext_typ_ext))
).
Defined.

Definition Cns (Γ : Ctx) (A : Typ Γ) (t : Trm Γ A) : Sub Γ (Ext Γ A).
Proof.
unshelve econstructor; simpl.
+ refine (fun p γ γε => _).
  unshelve econstructor.
  - refine γ.
  - refine γε.
  - refine (t.(trm_elt) _ γ γε).
+ simpl; refine (fun p γ γε => _).
  unshelve econstructor; simpl; [reflexivity|].
  simpl. refine (fun q α => t.(trm_rel) _ _ _).
Defined.

Definition Wkn (Γ : Ctx) (A : Typ Γ) : Sub (Ext Γ A) Γ.
Proof.
unshelve econstructor; simpl.
+ refine (fun p γ γε => (γ p !).(ext_typ_ctx) p !).
+ simpl.
  intros p γ γε.
  refine (Θ _ _ ((γε p !).(ext_rel_ctx)) p !).
  refine (fun q α => (γ q α).(ext_typ_rel)).
Defined.

Definition Lft {Γ Δ : Ctx} (σ : Sub Γ Δ) (A : Typ Δ) :
  Sub (Ext Γ (Typ_subs σ A)) (Ext Δ A).
Proof.
unshelve econstructor.
+ unshelve refine (fun p γ γε => Build_Ext_typ _ _ _ _ _ _); simpl in *.
  - unshelve refine (fun q α => σ q (fun r (β : r ≤ q) => (γ r (β ∘ α)).(ext_typ_ctx) r !) _).
    refine (Θ _ (fun r β => (γ r (β ∘ α)).(ext_typ_rel)) ((γε q α).(ext_rel_ctx))).

  - refine (fun q α => σ.(sub_rel) q
      (fun r (β : r ≤ q) => (γ r (β ∘ α)).(ext_typ_ctx) r !)
      (rew (fun γ₀ => forall r (β : r ≤ q), ctx_rel Γ (β · (γ₀ q α))) ((γε p !).(ext_rel_ctx)) (γ q α).(ext_typ_rel))
    ).
  - refine (

      eqn_rect (fun γ₀ e₀ =>
      let e₁ := rew (fun γ₁ => forall (q : ℙ) (α : q ≤ p), ctx_rel Γ (α · γ₁)) e₀ (γ p !).(ext_typ_rel) in
      A p
        (fun (q : ℙ) (α : q ≤ p) =>
         σ q (α · γ₀)
           (α · e₁))
        (fun (q : ℙ) (α : q ≤ p) =>
         sub_rel σ q (α · γ₀)
           (α · e₁))
      ) ((γ p !).(ext_typ_ext)) (rew (fun γ₀ => eqn _ (γ₀ p !)) (ext_rel_ctx (γε p !)) (refl _ _))
    ).
+ simpl.
  refine (fun p γ γε => _).
  unshelve econstructor.
  - reflexivity.
  - refine (fun q α => _).
    refine ((γε q α).(ext_rel_ext) q !).
Defined.

Definition Var {Γ : Ctx} {A : Typ Γ} : Trm (Ext Γ A) (Typ_subs (Wkn Γ A) A).
Proof.
unshelve econstructor; simpl.
+ refine (fun p γ γε => _).
  refine (letΘ _ (fun q α => (γ q α).(ext_typ_rel)) ((γε p !).(ext_rel_ctx)) _ p !).
  refine (fun q α => (γ q α).(ext_typ_ext)).
+ simpl.
  refine (fun p γ γε => _).
  refine (@ext_rel_ext _ _ _ _ _ _ (γε p !) p !).
Defined.

Definition Prd {Γ : Ctx} (A : Typ Γ) (B : Typ (Ext Γ A)) : Typ Γ.
Proof.
unshelve econstructor; simpl.
+ refine (fun p γ γε => _).
  refine (forall
    (x : forall q (α : q ≤ p), A q (α · γ) (α · γε))
    (xε : forall q (α : q ≤ p), @typ_rel Γ A _ (α · γ) (α · γε) (α · x)), _).
  unshelve refine (B.(typ_typ _) p _ _).
  - refine (Build_Ext_typ₀ γ γε x xε).
  - simpl; unshelve econstructor; simpl.
    { reflexivity. }
    { refine (α · xε). }
+ simpl.
  refine (fun p γ γε f => _).
  unshelve refine (
    forall
      q (α : q ≤ p)
      (x : forall r (β : r ≤ q), A r ((β ∘ α) · γ) ((β ∘ α) · γε))
      (xε : forall r (β : r ≤ q), @typ_rel _ A r ((β ∘ α) · γ) ((β ∘ α) · γε) (β · x)),
      @typ_rel _ B q _ _ _
  ).
  - refine (Build_Ext_typ₀ (α · γ) (α · γε) x xε).
  - simpl; intros r β; unshelve econstructor; simpl.
    { reflexivity. }
    { refine (β · xε). }
  - simpl.
    refine (fun r β => f r (β ∘ α) (β · x) (β · xε)).
Defined.

Definition Lam {Γ : Ctx} (A : Typ Γ) {B : Typ (Ext Γ A)}
  (t : Trm (Ext Γ A) B) : Trm Γ (Prd A B).
Proof.
unshelve econstructor.
+ refine (fun p γ γε x xε => _); simpl.
  unshelve refine (t.(trm_elt) p _ _).
+ simpl.
  refine (fun p γ γε q α x xε => _).
  unshelve refine (t.(trm_rel) _ _ _).
Defined.

Definition App {Γ : Ctx} {A : Typ Γ} {B : Typ (Ext Γ A)}
  (t : Trm Γ (Prd A B)) (u : Trm Γ A) : Trm Γ (Typ_subs (Cns _ _ u) B).
Proof.
unshelve econstructor.
+ refine (fun p γ γε => _); simpl.
  unshelve refine (t.(trm_elt) p γ γε _ (fun q α => u.(trm_rel) q (α · γ) (α · γε))).
+ simpl. refine (fun p γ γε => _).
  unshelve refine (t.(trm_rel) p _ _ _ _ _  (fun q α => u.(trm_rel) q (α · γ) (α · γε))).
Defined.

Lemma Lam_App_eqn :
  forall (Γ : Ctx) (A : Typ Γ) (B : Typ (Ext Γ A)) (t : Trm (Ext Γ A) B) (u : Trm Γ A),
  App (Lam A t) u = Trm_subs (Cns _ _ u) t.
Proof.
reflexivity.
Qed.

Lemma App_Lam_eqn :
  forall (Γ : Ctx) (A : Typ Γ) (B : Typ (Ext Γ A))
  (t : Trm Γ (Prd A B)),
  Lam A (@App (Ext Γ A) (Typ_subs (Wkn Γ A) A) (Typ_subs (Lft (Wkn Γ A) A) B) (Trm_subs (Wkn Γ A) t) Var) = t.
Proof.
reflexivity.
Qed.

(** Universes *)

Record TYPE@{i} (p : ℙ) : Type@{i+1} := {
  elt : forall q (α : q ≤ p), Type@{i};
  rel : (forall q (α : q ≤ p), elt q α) -> SProp;
}.

Arguments elt {_}.
Arguments rel {_}.

Definition Unv {Γ : Ctx} : Typ Γ.
Proof.
unshelve econstructor.
+ refine (fun p γ γε => TYPE p).
+ simpl; refine (fun p γ γε A => _).
  refine (eqn (fun q (α : q ≤ p) => ((A q α).(elt) q !)) ((A p !).(elt))).
Defined.

Definition Elt {Γ : Ctx} (A : Trm Γ Unv) : Typ Γ.
Proof.
unshelve econstructor.
+ refine (fun p γ γε => (A.(trm_elt) p γ γε).(elt) p !).
+ simpl; unshelve refine (fun p γ γε x => _).
  refine ((A.(trm_elt) p γ γε).(rel) _).
  refine (eqn_rect (fun A₀ _ => forall q (α : q ≤ p), A₀ q α) x (A.(trm_rel) p γ γε)).
Defined.

Definition Rfl {Γ : Ctx} (A : Typ Γ) : Trm Γ Unv.
Proof.
unshelve econstructor; simpl.
+ refine (fun p γ γε => _).
  unshelve econstructor.
  - refine (fun q α => A.(typ_typ _) q (α · γ) (α · γε)).
  - refine (A.(typ_rel)).
+ reflexivity.
Defined.

Lemma Rfl_Elt : forall (Γ : Ctx) (A : Typ Γ), Elt (Rfl A) = A.
Proof.
reflexivity.
Qed.

(** Helper *)

Definition Build_trm_aux {Γ : Ctx} (A : Typ Γ)
  (x : forall (p : ℙ)
    (γ : forall q (α : q ≤ p), Γ q)
    (γε : forall q (α : q ≤ p), (ctx_rel Γ) (α · γ)),
    exist
    (forall q (α : q ≤ p), A q (α · γ) (α · γε))
    (fun x => forall q (α : q ≤ p), @typ_rel _ A q (α · γ) (α · γε) (α · x)))
  (xε : forall p
    (γ : forall q (α : q ≤ p), Γ q)
    (γε : forall q (α : q ≤ p), (ctx_rel Γ) (α · γ)),
(*     typ_rel A (val (x p γ γε)) -> *)
(*     typ_rel A (fun (q : ℙ) (α : q ≤ p) => val (x q (α · γ) (α · γε)) q !)) *)
    eqn ((x p γ γε).(val)) (fun q (α : q ≤ p) => (x q (α · γ) (α · γε)).(val) q !))
  : Trm Γ A.
Proof.
unshelve econstructor.
+ intros p γ γε.
  refine ((x p γ γε).(val) p !).
+ simpl; intros p γ γε.
(*   refine (xε p γ γε ((x p γ γε).(spc) p !)). *)
  refine (rew (fun x₀ => typ_rel A x₀) (xε p γ γε) _).
  refine ((x p γ γε).(spc) p !).
Defined.

Definition Ext_elim₀  {Γ : Ctx} (A : Typ Γ) (p : ℙ)
  (P : forall
    (γ : forall q : ℙ, q ≤ p -> Ext Γ A q)
    (γε : forall (q : ℙ) (α : q ≤ p), ctx_rel (Ext Γ A) (α · γ)), Type)
  (u : forall
    (γ : forall q (α : q ≤ p) r (β : r ≤ q), Γ r)
    (γε : forall q (α : q ≤ p) r (β : r ≤ q), ctx_rel Γ (β · (γ q α)))
    (x : forall q (α : q ≤ p), A q (γ q α) (γε q α))
    (γe : Fε γ)
    (xε : forall q (α : q ≤ p), @typ_rel Γ A q (evl (α · γ) q !) (α · Θ γ γε γe) (letΘ (α · γ) (α · γε) (α • γe) (α · x))),
    P
    (fun q α => Build_Ext_typ Γ A q (γ q α) (γε q α) (x q α))
    (fun q α => Build_Ext_rel Γ A q (α · γ) (α · γε) (α · x) (α • γe) (α · xε))

  )
  (γ : forall q (α : q ≤ p), Ext Γ A q)
  (γε : forall q (α : q ≤ p), ctx_rel (Ext Γ A) (α · γ)) :
  P γ γε.
Proof.
refine (u
  (fun q α r β => (γ q α).(ext_typ_ctx) r β)
  (fun q α r β => (γ q α).(ext_typ_rel) r β)
  (fun q α => (γ q α).(ext_typ_ext))
  ((γε p !).(ext_rel_ctx))
  (fun q α => (γε q α).(ext_rel_ext) q !)
).
Defined.

Definition Ext_elim₀_s  {Γ : Ctx} (A : Typ Γ) (p : ℙ)
  (P : forall
    (γ : forall q : ℙ, q ≤ p -> Ext Γ A q)
    (γε : forall (q : ℙ) (α : q ≤ p), ctx_rel (Ext Γ A) (α · γ)), SProp)
  (u : forall
    (γ : forall q (α : q ≤ p) r (β : r ≤ q), Γ r)
    (γε : forall q (α : q ≤ p) r (β : r ≤ q), ctx_rel Γ (β · (γ q α)))
    (x : forall q (α : q ≤ p), A q (γ q α) (γε q α))
    (γe : Fε γ)
    (xε : forall q (α : q ≤ p), @typ_rel Γ A q (evl (α · γ) q !) (α · Θ γ γε γe) (letΘ (α · γ) (α · γε) (α • γe) (α · x))),
    P
    (fun q α => Build_Ext_typ Γ A q (γ q α) (γε q α) (x q α))
    (fun q α => Build_Ext_rel Γ A q (α · γ) (α · γε) (α · x) (α • γe) (α · xε))

  )
  (γ : forall q (α : q ≤ p), Ext Γ A q)
  (γε : forall q (α : q ≤ p), ctx_rel (Ext Γ A) (α · γ)) :
  P γ γε.
Proof.
refine (u
  (fun q α r β => (γ q α).(ext_typ_ctx) r β)
  (fun q α r β => (γ q α).(ext_typ_rel) r β)
  (fun q α => (γ q α).(ext_typ_ext))
  ((γε p !).(ext_rel_ctx))
  (fun q α => (γε q α).(ext_rel_ext) q !)
).
Defined.

Definition Build_Ext_rel₀ {Γ : Ctx} {A : Typ Γ} {p : ℙ}
  (γ : forall q (α : q ≤ p), Γ q)
  (γε : forall q (α : q ≤ p), ctx_rel Γ (α · γ))
  (x : forall q (α : q ≤ p), A q (α · γ) (α · γε))
  (xε : forall q (α : q ≤ p), @typ_rel _ A q (α · γ) (α · γε) (α · x))
  : forall (q : ℙ) (α : q ≤ p),
     ctx_rel (Ext Γ A) (α · Build_Ext_typ₀ γ γε x xε).
Proof.
refine (fun q α =>
  Build_Ext_rel Γ A q (α · ret γ)
    (fun r β s ζ => γε s (ζ ∘ β ∘ α)) (α · x) (refl _ _) (α · xε)
).
Defined.

Definition Build_lam_aux {Γ : Ctx} (A : Typ Γ) (B : Typ (Ext Γ A))
  (f : forall (p : ℙ)
    (γ : forall q : ℙ, q ≤ p -> Γ q)
    (γε : forall (q : ℙ) (α : q ≤ p), ctx_rel Γ (α · γ))
    (x : forall (q : ℙ) (α : q ≤ p), A q (α · γ) (α · γε))
    (xε : forall (q : ℙ) (α : q ≤ p), @typ_rel _ A _ (α · γ) (α · γε) (α · x)),
    exist
    (forall q (α : q ≤ p), B q (Build_Ext_typ₀ (α · γ) (α · γε) (α · x) (α · xε))
      (Build_Ext_rel₀ (α · γ) (α · γε) (α · x) (α · xε)))
    (fun y => forall (q : ℙ) (α : q ≤ p),
      @typ_rel (Ext Γ A) B _
        (Build_Ext_typ₀ (α · γ) (α · γε) (α · x) (α · xε))
        (Build_Ext_rel₀ (α · γ) (α · γε) (α · x) (α · xε))
        (α · y)
    )
  )
  (fε :
    forall (p : ℙ)
      (γ : forall q : ℙ, q ≤ p -> Γ q)
      (γε : forall (q : ℙ) (α : q ≤ p), ctx_rel Γ (α · γ))
      (x : forall (q : ℙ) (α : q ≤ p), A q (α · γ) (α · γε))
      (xε : forall (q : ℙ) (α : q ≤ p), @typ_rel _ A q (α · γ) (α · γε) (α · x)),
    eqn
      (@val _ _ (f p γ γε x xε))
      (fun (q : ℙ) (α : q ≤ p) => @val _ _ (f q (α · γ) (α · γε) (α · x) (α · xε)) q !)
  )
  : Trm Γ (Prd A B).
Proof.
unshelve refine (Lam _ _).
unshelve refine (Build_trm_aux _ (fun p => _) _).
+ refine (@Ext_elim₀ Γ A p _ _).
  intros γ γε x γe; revert γ γe γε x.
  refine (F_rect _ _).
  intros γ γε x xε.
  unshelve econstructor.
  refine ((f p γ (γε p !) x xε).(val)).
  refine ((f p γ (γε p !) x xε).(spc)).
+ intros; simpl.
  unfold Ext_elim₀; simpl.
  revert γ γε.
  unshelve refine (Ext_elim₀_s _ _ _ _).
  intros γ γε x γe; revert γ γe γε x.
  refine (F_sind _ _); intros γ γε x xε; simpl in *.
  refine (fε p γ (γε _ _) x xε).
Defined.

Lemma Build_lam_aux_App : forall Γ A B f fε (u : Trm Γ A),
  @trm_elt _ _ (@App Γ A B (@Build_lam_aux Γ A B f fε) u) =
  (fun p γ γε => (f p γ γε (fun q α => u.(trm_elt) q (α · γ) (α · γε)) (fun q α => u.(trm_rel) q (α · γ) (α · γε))).(val) p !).
Proof.
reflexivity.
Qed.

(** Sum type *)

Inductive Sum₀ {p : ℙ} (A B : forall q (α : q ≤ p), Type) :=
| Inl₀ : forall (x : forall q (α : q ≤ p), A q α), Sum₀ A B
| Inr₀ : forall (y : forall q (α : q ≤ p), B q α), Sum₀ A B.

Inductive Sumε {p : ℙ}
  (A : forall q (α : q ≤ p), Type)
  (Aε : forall q (α : q ≤ p), (forall r (β : r ≤ q), A r (β ∘ α)) -> SProp)
  (B : forall q (α : q ≤ p), Type)
  (Bε : forall q (α : q ≤ p), (forall r (β : r ≤ q), B r (β ∘ α)) -> SProp)
  : (forall q (α : q ≤ p), Sum₀ (α · A) (α · B)) -> SProp :=
| Inlε : forall
  (x : forall q (α : q ≤ p), A q α)
  (xε : forall q (α : q ≤ p), Aε q α (α · x)), Sumε A Aε B Bε (fun q α => Inl₀ _ _ (α · x))
| Inrε : forall
  (y : forall q (α : q ≤ p), B q α)
  (yε : forall q (α : q ≤ p), Bε q α (α · y)), Sumε A Aε B Bε (fun q α => Inr₀ _ _ (α · y))
.

Definition Sum {Γ : Ctx} (A B : Typ Γ) : Typ Γ.
Proof.
unshelve econstructor.
+ refine (fun p γ γε => @Sum₀ p (fun q α => A q (α · γ) (α · γε)) (fun q α => B q (α · γ) (α · γε))).
+ refine (fun p γ γε s => _).
  refine (@Sumε p
    (fun q α => A q (α · γ) (α · γε)) (fun q α => @typ_rel Γ A q (α · γ) (α · γε))
    (fun q α => B q (α · γ) (α · γε)) (fun q α => @typ_rel Γ B q (α · γ) (α · γε))
    s
  ).
Defined.

Definition Inl {Γ : Ctx} {A B : Typ Γ} : Trm Γ (Prd A (Typ_subs (Wkn Γ A) (Sum A B))).
Proof.
unshelve econstructor; simpl.
+ refine (fun p γ γε x xε => Inl₀ _ _ x).
+ refine (fun p γ γε q α x xε => Inlε _ _ _ _ x xε).
Defined.

Definition Inr {Γ : Ctx} {A B : Typ Γ} : Trm Γ (Prd B (Typ_subs (Wkn Γ B) (Sum A B))).
Proof.
unshelve econstructor; simpl.
+ refine (fun p γ γε y yε => Inr₀ _ _ y).
+ refine (fun p γ γε q α y yε => Inrε _ _ _ _ y yε).
Defined.

(* Definition Sum_Inl_inv (p : ℙ)
    (s : forall q : ℙ, q ≤ p -> Inl₀ q)
    (sε : forall (q : ℙ) (α : q ≤ p), Natε (α · n))
    (e : eqn (Inl₀ p) (n p !)) :
    eqn (fun q _ => O₀ q) n.
Proof.
 *)

Definition Sum_rect {Γ : Ctx} (A B : Typ Γ)
  (P : Trm Γ (Prd (Sum A B) Unv))
  (pL : Trm Γ
    (Prd A
      (Elt (@App (Ext Γ A) (Typ_subs (Wkn _ _) (Sum A B)) Unv (Trm_subs (Wkn _ _) P)
      (@App (Ext Γ A) (Typ_subs (Wkn Γ A) A) (Typ_subs (Cmp (Wkn _ _) (Wkn _ _)) (Sum A B)) (@Inl _ _ (Typ_subs (Wkn Γ A) B)) (@Var Γ A))))
    )
  )
  (pR : Trm Γ
    (Prd B
      (Elt (@App (Ext Γ B) (Typ_subs (Wkn _ _) (Sum A B)) Unv (Trm_subs (Wkn _ _) P)
      (@App (Ext Γ B) (Typ_subs (Wkn Γ B) B) (Typ_subs (Cmp (Wkn _ _) (Wkn _ _)) (Sum A B)) (@Inr _ (Typ_subs (Wkn Γ B) A) _) (@Var Γ B))))
    )
  )
  :
  Trm Γ (Prd (Sum A B) (Elt ((@App _ (Typ_subs (Wkn _ _) (Sum A B)) Unv (Trm_subs (Wkn _ _) P)) (@Var _ (Sum A B))))).
Proof.
unshelve econstructor; simpl.
+ refine (fun p γ γε s sε => _).
  generalize (refl _ (s p !)).
  generalize (s p !) at 1 as s₀.
  destruct s₀ as [x₀|y₀]; intros e₀.
  - assert (e₁ : eqn (fun q (α : q ≤ p) => Inl₀ _ _ (α · x₀)) s).
    { refine (
        match sε p ! in Sumε _ _ _ _ s₁ return
          eqn _ (s₁ p !) -> eqn _ s₁
        with
        | Inlε _ _ _ _ x xε => _
        | Inrε _ _ _ _ y yε => _
      end e₀); clear e₀; intros e₀.
      + assert (e₁: eqn x₀ x).
        { refine (match e₀ in eqn _ s₁ return match s₁ return SProp with Inl₀ _ _ x => eqn x₀ x | Inr₀ _ _ _ => True end with refl _ _ => refl _ _ end). }
        destruct e₁; reflexivity.
      + elimtype False.
        refine (match e₀ in eqn _ s₁ return match s₁ return SProp with Inl₀ _ _ x => True | Inr₀ _ _ _ => False end with refl _ _ => I end).
    }
    destruct e₁.
    refine (pL.(trm_elt) p γ γε x₀ _).
    { refine (
        match sε p ! in Sumε _ _ _ _ s₁ return
          match s₁ p ! return SProp with Inl₀ _ _ x₀ => forall q α, typ_rel A (α · x₀) | Inr₀ _ _ _ => True end
        with
        | Inlε _ _ _ _ x xε => xε
        | Inrε _ _ _ _ y yε => I
      end). }
  - assert (e₁ : eqn (fun q (α : q ≤ p) => Inr₀ _ _ (α · y₀)) s).
    { refine (
        match sε p ! in Sumε _ _ _ _ s₁ return
          eqn _ (s₁ p !) -> eqn _ s₁
        with
        | Inlε _ _ _ _ x xε => _
        | Inrε _ _ _ _ y yε => _
      end e₀); clear e₀; intros e₀.
      + elimtype False.
        refine (match e₀ in eqn _ s₁ return match s₁ return SProp with Inl₀ _ _ x => False | Inr₀ _ _ _ => True end with refl _ _ => I end).
      + assert (e₁: eqn y₀ y).
        { refine (match e₀ in eqn _ s₁ return match s₁ return SProp with Inl₀ _ _ x => True | Inr₀ _ _ y => eqn y₀ y end with refl _ _ => refl _ _ end). }
        destruct e₁; reflexivity.
    }
    destruct e₁.
    refine (pR.(trm_elt) p γ γε y₀ _).
    { refine (
        match sε p ! in Sumε _ _ _ _ s₁ return
          match s₁ p ! return SProp with Inr₀ _ _ y₀ => forall q α, typ_rel B (α · y₀) | Inl₀ _ _ _ => True end
        with
        | Inlε _ _ _ _ x xε => I
        | Inrε _ _ _ _ y yε => yε
      end). }
+ intros p γ γε q α s sε. simpl.
  assert (sε₀ := sε q !).
  match type of sε₀ with Sumε _ _ _ _ ?s₀ => change s₀ with s in sε₀ end.
  destruct sε₀ as [x xε|y yε]; simpl.
  - refine (pL.(trm_rel) q (α · γ) (α · γε) q ! x xε).
  - refine (pR.(trm_rel) q (α · γ) (α · γε) q ! y yε).
Defined.

Lemma Sum_rect_Inl : forall
  (Γ : Ctx) (A B : Typ Γ)
  (P : Trm Γ (Prd (Sum A B) Unv))
  (P : Trm Γ (Prd (Sum A B) Unv))
  (pL : Trm Γ
    (Prd A
      (Elt (@App (Ext Γ A) (Typ_subs (Wkn _ _) (Sum A B)) Unv (Trm_subs (Wkn _ _) P)
      (@App (Ext Γ A) (Typ_subs (Wkn Γ A) A) (Typ_subs (Cmp (Wkn _ _) (Wkn _ _)) (Sum A B)) (@Inl _ _ (Typ_subs (Wkn Γ A) B)) (@Var Γ A))))
    )
  )
  (pR : Trm Γ
    (Prd B
      (Elt (@App (Ext Γ B) (Typ_subs (Wkn _ _) (Sum A B)) Unv (Trm_subs (Wkn _ _) P)
      (@App (Ext Γ B) (Typ_subs (Wkn Γ B) B) (Typ_subs (Cmp (Wkn _ _) (Wkn _ _)) (Sum A B)) (@Inr _ (Typ_subs (Wkn Γ B) A) _) (@Var Γ B))))
    )
  )
  (x : Trm Γ A),
  (App (Sum_rect A B P pL pR) (App Inl x)) = App pL x.
Proof.
reflexivity.
Qed.

Lemma Sum_rect_Inr : forall
  (Γ : Ctx) (A B : Typ Γ)
  (P : Trm Γ (Prd (Sum A B) Unv))
  (P : Trm Γ (Prd (Sum A B) Unv))
  (pL : Trm Γ
    (Prd A
      (Elt (@App (Ext Γ A) (Typ_subs (Wkn _ _) (Sum A B)) Unv (Trm_subs (Wkn _ _) P)
      (@App (Ext Γ A) (Typ_subs (Wkn Γ A) A) (Typ_subs (Cmp (Wkn _ _) (Wkn _ _)) (Sum A B)) (@Inl _ _ (Typ_subs (Wkn Γ A) B)) (@Var Γ A))))
    )
  )
  (pR : Trm Γ
    (Prd B
      (Elt (@App (Ext Γ B) (Typ_subs (Wkn _ _) (Sum A B)) Unv (Trm_subs (Wkn _ _) P)
      (@App (Ext Γ B) (Typ_subs (Wkn Γ B) B) (Typ_subs (Cmp (Wkn _ _) (Wkn _ _)) (Sum A B)) (@Inr _ (Typ_subs (Wkn Γ B) A) _) (@Var Γ B))))
    )
  )
  (y : Trm Γ B),
  (App (Sum_rect A B P pL pR) (App Inr y)) = App pR y.
Proof.
reflexivity.
Qed.

(** Natural numbers *)

Inductive Nat₀ (p : ℙ) :=
| O₀ : Nat₀ p
| S₀ : forall (n : forall q (α : q ≤ p), Nat₀ q), Nat₀ p.

Inductive Natε {p : ℙ} : (forall q (α : q ≤ p), Nat₀ q) -> SProp :=
| Oε : Natε (fun q _ => O₀ q)
| Sε : forall (n : forall q (α : q ≤ p), Nat₀ q) (nε : forall q (α : q ≤ p), Natε (α · n)),
      Natε (fun q α => S₀ q (α · n)).

Definition Nat {Γ : Ctx} : Typ Γ.
Proof.
unshelve econstructor.
+ refine (fun p γ γε => _).
  exact (Nat₀ p).
+ refine (fun p γ γε n => _).
  exact (Natε n).
Defined.

Definition O {Γ : Ctx} : Trm Γ Nat.
Proof.
unshelve econstructor.
+ refine (fun p γ γε => O₀ p).
+ simpl; refine (fun p γ γε => Oε).
Defined.

Definition S {Γ : Ctx} : Trm Γ (Prd Nat Nat).
Proof.
unshelve econstructor.
+ simpl; refine (fun p γ γε n nε => S₀ p n).
+ simpl; refine (fun p γ γε q α n nε => Sε n nε).
Defined.

Definition Nat_O_inv (p : ℙ)
    (n : forall q : ℙ, q ≤ p -> Nat₀ q)
    (nε : forall (q : ℙ) (α : q ≤ p), Natε (α · n))
    (e : eqn (O₀ p) (n p !)) :
    eqn (fun q _ => O₀ q) n.
Proof.
specialize (nε p !).
change (Natε n) in nε.
destruct nε.
+ reflexivity.
+ let t := match type of e with eqn _ ?t => t end in
  elimtype False;
  change (match t with O₀ _ => True | S₀ _ n => False end).
  destruct e; constructor.
Qed.

Set Printing Relevance.

Definition Nat_S_inv (p : ℙ)
    (n : forall q : ℙ, q ≤ p -> Nat₀ q)
    (nε : forall (q : ℙ) (α : q ≤ p), Natε (α · n))
    (m : forall q : ℙ, q ≤ p -> Nat₀ q)
    (e : eqn (S₀ p m) (n p !)) :
    eqn (fun q α => S₀ q (α · m)) n.
Proof.
specialize (nε p !).
change (Natε n) in nε.
destruct nε.
+ let t := match type of e with eqn _ ?t => t end in
  elimtype False;
  change (match t with S₀ _ _ => True | O₀ _ => False end).
  destruct e; constructor.
+ refine (
    match e in eqn _ z return
      match z return SProp with
      | O₀ _ => True
      | S₀ _ n₀ => eqn (fun q α => S₀ q (α · m)) (fun q α => S₀ q (α · n₀))
      end
    with refl _ _ => refl _ _ end
  ).
Defined.

Definition Natε_S_inv (p : ℙ)
  (n : forall q : ℙ, q ≤ p -> Nat₀ q)
  (nε : forall (q : ℙ) (α : q ≤ p), Natε (fun r β => S₀ r ((β ∘ α) · n))) :
  forall q (α : q ≤ p), Natε (α · n).
Proof.
specialize (nε p !).
refine (
match nε in Natε n₀ return
  match n₀ p ! return SProp with
  | O₀ _ => True
  | S₀ _ m₀ => forall q α, Natε (α · m₀)
  end
with
| Oε => I
| Sε _ mε => mε
end
).
Defined.

Definition Nat_rect {Γ : Ctx}
  (P : Trm Γ (Prd Nat Unv))
  (pO : Trm Γ (Elt (App P O)))
  (pS : Trm Γ
    (Prd Nat
    (Prd (Elt (@App _ Nat Unv (Trm_subs (Wkn _ _) P) (@Var _ Nat)))
      (Elt (@App _ Nat Unv ((Trm_subs (Wkn (Ext Γ Nat) _)
      (Trm_subs (Wkn Γ Nat) P))) (App S (Trm_subs (Wkn (Ext Γ Nat) _) Var)))))))
  :
  Trm Γ (Prd Nat (Elt ((@App _ Nat Unv (Trm_subs (Wkn _ _) P)) (@Var _ Nat)))).
Proof.
unshelve refine (Build_lam_aux _ _ _ _).
+ intros p γ γε n nε. simpl in n, nε.
(*   unfold letΘ in *; simpl in *. *)
  generalize (refl _ (n p !)).
  generalize (n p !) at 1 as n₀.
  intros n₀; revert n₀ n nε.
  fix F 1; intros n₀.
  destruct n₀ as [|n₀]; intros n nε e₀.
(*   induction n₀ as [|p n₀ IHn₀]; intros e₀. *)
  - simpl. unshelve econstructor.

    * refine (fun q α => _).

      pose (e₁ := Nat_O_inv _ n nε e₀).

      destruct e₁.

      refine (pO.(trm_elt) q (α · γ) (α · γε)).

    * pose (e₁ := Nat_O_inv _ n nε e₀).
      destruct e₁; simpl.
      refine (fun q α => pO.(trm_rel) q (α · γ) (α · γε)).

  - unshelve econstructor.

    * refine (fun q α => _).

      pose (e₁ := Nat_S_inv _ n nε n₀ e₀).
      induction e₁.
      unshelve refine (pS.(trm_elt) q (α · γ) (α · γε) (α · n₀) (Natε_S_inv _ (α · n₀) (α · nε)) _ _).
      { unshelve refine (α · (F (n₀ p !) _ (Natε_S_inv _ n₀ nε) (refl _ _)).(val)). }
      { unshelve refine (α · (F (n₀ p !) _ (Natε_S_inv _ n₀ nε) (refl _ _)).(spc)). }

    * set (e₁ := Nat_S_inv _ n nε n₀ e₀).
      induction e₁.
      unshelve refine (fun q α =>
        pS.(trm_rel) q (α · γ) (α · γε) q !
          (α · n₀) (Natε_S_inv _ (α · n₀) (α · nε)) q !
          (α · (F _ _ (Natε_S_inv _ n₀ nε) (refl _ _)).(val))
          (α · (F _ _ (Natε_S_inv _ n₀ nε) (refl _ _)).(spc))
      ).

+ intros p.
  intros γ γε n nε.
  simpl in n, nε.
  assert (nε₀ := nε p !).
  change (Natε n) in nε₀.
  induction nε₀.
  - reflexivity.
  - admit. (* FIXME *)
Defined.

Lemma Nat_rect_O : forall
  (Γ : Ctx)
  (P : Trm Γ (Prd Nat Unv))
  (pO : Trm Γ (Elt (App P O)))
  (pS : Trm Γ
    (Prd Nat
    (Prd (Elt (@App _ Nat Unv (Trm_subs (Wkn _ _) P) (@Var _ Nat)))
      (Elt (@App _ Nat Unv ((Trm_subs (Wkn (Ext Γ Nat) _)
      (Trm_subs (Wkn Γ Nat) P))) (App S (Trm_subs (Wkn (Ext Γ Nat) _) Var))))))),
  (App (Nat_rect P pO pS) O) = pO.
Proof.
reflexivity.
Qed.

Axiom funext : forall A (B : A -> Type) (f g : forall x : A, B x),
  (forall x, f x = g x) -> f = g.
Axiom funext_s : forall {A : SProp} (B : A -> Type) (f g : forall x : A, B x),
  (forall x, f x = g x) -> f = g.

Axiom Trm_ext : forall Γ A x xε y yε, x = y -> @Build_Trm Γ A x xε = @Build_Trm Γ A y yε.

(* Set Fast Name Printing. *)

Definition hide {A} {x : A} := x.

Lemma Nat_rect_S : forall
  (Γ : Ctx)
  (P : Trm Γ (Prd Nat Unv))
  (pO : Trm Γ (Elt (App P O)))
  (pS : Trm Γ
    (Prd Nat
    (Prd (Elt (@App _ Nat Unv (Trm_subs (Wkn _ _) P) (@Var _ Nat)))
      (Elt (@App _ Nat Unv ((Trm_subs (Wkn (Ext Γ Nat) _)
      (Trm_subs (Wkn Γ Nat) P))) (App S (Trm_subs (Wkn (Ext Γ Nat) _) Var)))))))
  (n : Trm Γ Nat),
  App (Nat_rect P pO pS) (App S n) =
  @App _ (Elt (App P n)) (Typ_subs (Wkn _ _) (Elt (App P (App S n)))) (App pS n) (App (Nat_rect P pO pS) n).
Proof.
intros.
simpl.
apply Trm_ext.
apply funext; intros p; apply funext; intros γ; apply funext_s; intros γε.
simpl.
match goal with [ |- @eq _ (trm_elt pS p ?γl ?γεl _ _ _ _) _ ] => change γl with γ end.
match goal with [ |- @eq _ (trm_elt pS p ?γl ?γεl _ _ _ _) _ ] => change γεl with γε end;
match goal with [ |- @eq _ (trm_elt pS p _ _ ?n _ _ _) _ ] => set (n₀ := n) end.
match goal with [ |- @eq _ (trm_elt pS p _ _ _ ?nεl _ _) _ ] => set (nε := nεl); clearbody nε end.
match goal with [ |- @eq _ _ (trm_elt pS p _ _ _ ?nε₀ _ _) ] => set (nε' := nε₀); clearbody nε' end.
let T := type of nε in let T' := type of nε' in unify T T'.
match goal with [ |- @eq _ (trm_elt pS p _ _ _ _ _ ?pεl) _ ] => set (pε := pεl); clearbody pε end.
let T := type of pε in change (@hide SProp T) in pε.
match goal with [ |- @eq _ (trm_elt pS p _ _ _ _ ?ul _) _ ] =>
  set (u := ul); change ul with (@hide _ ul) in u
end.
match goal with [ |- @eq _ _ (trm_elt pS p _ _ _ _ ?ul _) ] =>
  set (u' := ul); change ul with (@hide _ ul) in u'
end.
match goal with [ |- @eq _ _ (trm_elt pS p _ _ _ _ _ ?pεl) ] => set (pε' := pεl); clearbody pε' end.
let T := type of pε' in change (@hide SProp T) in pε'.
simpl in nε'.

let T := type of nε in change (T : SProp) in nε'.
unfold letΘ in *; simpl in *.

change (

eq (trm_elt pS p γ γε n₀ nε u pε)
  (trm_elt pS p γ γε n₀ nε u' pε')

).

assert (u = u').
{ unfold u, u', hide.
clear u u'.

apply funext; intros q; apply funext; intros α.

clear pε pε'.
clear nε'.

match goal with [ |-
  @eq _ (val _ _ _)
  (val _ _ _)
] =>
(*   set (P₀ := P); change Q with P₀; *)
(*   set (pO₀ := pO); change qO with pO₀; *)
(*   set (pS₀ := pS); change qS with pS₀; *)
  idtac
end.
match goal with [ |- @eq ?A ?t ?u ] => idtac t end.

match goal with [ |-
  @eq _ (val (Nat₀_rect ?P ?pO ?pS _ _ _ _ _ _ _) _ _)
  (val (Nat₀_rect ?Q ?qO ?qS _ _ _ _ _ _ _) _ _)
] =>
  set (P₀ := P); change Q with P₀;
  set (pO₀ := pO); change qO with pO₀;
  set (pS₀ := pS); change qS with pS₀;
  idtac
end.

match goal with [ |- @eq ?A ?t ?u ] => idtac u end.
match goal with [ |- @eq ?A ?t ?u ] => idtac t end.

refine (eq_refl).
reflexivity.
(* match goal with [ |- @eq ?A (eqn_rect _ _ ?e₀ _ _) _ ] => set (e := e₀); clearbody e end. *)
(* let t := match type of e with @eqn ?A ?t ?u => t end in *)
(* change e with (refl (forall q (α : q ≤ p), Nat₀ q) t). *)
reflexivity.

rewrite H.
change e with (refl _ _).

match goal with [ |- @eq ?A _ _ ] => pose A end.

reflexivity. (* fails *)
Abort.