Section SortsOfECC.
Inductive srt_ecc : Set :=
| Sprop : srt_ecc
| Stype : nat -> srt_ecc.
Inductive axiom_ecc : srt_ecc -> srt_ecc -> Prop :=
| ax_prop : forall (n : nat), axiom_ecc Sprop (Stype n)
| ax_type : forall (n m : nat), n < m -> axiom_ecc (Stype n) (Stype m).
Inductive rules_ecc : srt_ecc -> srt_ecc -> srt_ecc -> Prop :=
| rule_prop_l : forall (s : srt_ecc), rules_ecc Sprop s s
| rule_prop_r : forall (s : srt_ecc), rules_ecc s Sprop Sprop
| rule_type :
forall (n m p : nat),
n <= p -> m <= p -> rules_ecc (Stype n) (Stype m) (Stype p).
Inductive univ_ecc : srt_ecc -> srt_ecc -> Prop :=
univ_type :
forall (n m : nat),
n <= m -> univ_ecc (Stype n) (Stype m).
Definition univ : relation srt_ecc := clos_refl_trans _ univ_ecc.
Hint Resolve ax_prop ax_type rule_prop_l rule_prop_r rule_type univ_type:
pts.
Hint Unfold univ: pts.
(* Inversion et Decidabilite de l'inclusion entre sortes *)
Let univ_trans : forall x y z : srt_ecc, univ x y -> univ y z -> univ x z.
Proof rt_trans srt_ecc univ_ecc.
Inductive inv_univ : srt_ecc -> srt_ecc -> Prop :=
| iu_prop : inv_univ Sprop Sprop
| iu_type :
forall (n m : nat),
n <= m -> inv_univ (Stype n) (Stype m).
Hint Resolve iu_prop iu_type: pts.
simple induction 1; intros; auto with arith pts.
inversion_clear H1.
apply iu_type.
apply le_trans with m; auto with arith pts.
Qed.
simple induction 1.
simple induction 1; auto with arith pts.
simple destruct x; auto with arith pts.
intros.
apply H4.
apply inv_univ_trans with y.
apply H1; auto with arith pts.
apply H3; auto with arith pts.
Qed.
simple destruct s; simple destruct s'; intros; try (right; discriminate).
left; auto with arith pts.
elim eq_nat_dec with n n0; intros.
left; elim a; auto with arith pts.
right; red in |- *; intros H; apply b; injection H; auto with arith pts.
Qed.
refine
(fun s s' : srt_ecc =>
match s, s' return (decide (univ s s')) with
| Sprop, Sprop => _
| Stype n, Stype n' => _
| _, _ => right _ _
end).
left; auto with arith pts.
red in |- *; intros.
apply univ_inv with Sprop (Stype n); intros; auto with arith pts.
inversion_clear H0.
red in |- *; intros.
apply univ_inv with (Stype n) Sprop; intros; auto with arith pts.
inversion_clear H0.
case (le_gt_dec n n'); [ left | right ].
auto with pts.
red in |- *; intros.
apply univ_inv with (Stype n) (Stype n'); intros; auto with arith pts.
inversion_clear H0.
absurd (n <= n'); auto with arith pts.
Qed.
(* Inference des axiomes et regles *)
refine
(fun s : srt_ecc =>
match s return {sp : srt_ecc | ppal (axiom_ecc s) univ sp} with
| Sprop => exist _ (Stype 0) _
| Stype n => exist _ (Stype (S n)) _
end).
split; intros; auto with arith pts.
inversion_clear H; auto with arith pts.
split; intros; auto with arith pts.
inversion_clear H; auto with arith pts.
Qed.
refine
(fun x1 x2 : srt_ecc =>
match
x1, x2
return
{x3 : srt_ecc | rules_ecc x1 x2 x3 &
forall s1 s2 s3 : srt_ecc,
rules_ecc s1 s2 s3 -> univ x1 s1 -> univ x2 s2 -> univ x3 s3}
with
| Sprop, _ => exist2 _ _ x2 _ _
| Stype n, Sprop => exist2 _ _ Sprop _ _
| Stype n, Stype n' => exist2 _ _ (Stype (max_nat n n')) _ _
end).
auto with pts.
simple induction 1; intros; auto with arith pts.
apply univ_trans with (Stype m); auto with arith pts.
auto with pts.
intros.
apply univ_inv with Sprop s2; intros.
auto with arith pts.
generalize H.
inversion_clear H2; intros.
inversion_clear H2; auto with arith pts.
unfold max_nat in |- *.
elim (le_gt_dec n n'); auto with arith pts.
intros.
apply univ_inv with (Stype n) s1; intros; auto with arith pts.
apply univ_inv with (Stype n') s2; intros; auto with arith pts.
generalize H.
inversion_clear H2.
inversion_clear H3; intros.
inversion_clear H3.
cut (max_nat n n' <= p); auto with arith pts.
apply least_upper_bound_max_nat.
apply le_trans with m; auto with arith pts.
apply le_trans with m0; auto with arith pts.
Qed.
End SortsOfECC.
Definition term := term srt_ecc.
Definition env := env srt_ecc.
(* Construction du CTS *)
Definition ecc : CTS_spec srt_ecc :=
Build_CTS_spec _ axiom_ecc rules_ecc univ_ecc (beta_delta_rule _).
(* Construction du PTS issu du CTS *)
Definition ecc_pts : PTS_sub_spec srt_ecc := cts_pts_functor _ ecc.
Definition le_type : red_rule srt_ecc :=
Rule _ (Le_type _ (pts_le_type _ ecc_pts)).
Definition typ : env -> term -> term -> Prop := typ _ ecc_pts.
Definition typ_ppal : env -> term -> term -> Prop := typ_ppal _ ecc_pts.
Definition wft : env -> term -> Prop := wf_type _ ecc_pts.
Definition wf : env -> Prop := wf _ ecc_pts.
Definition sn := sn srt_ecc (ctxt _ (Rule _ (head_reduct _ ecc))).
Definition red := red _ (Rule _ (beta_delta_rule srt_ecc)).
Definition conv := conv _ (Rule _ (beta_delta_rule srt_ecc)).
Hint Unfold le_type typ wft wf sn: pts.
(* Algorithme de mise en forme normale de tete Decidabilite du sous-typage pour les types bien formes *)

Lemma whnf :
forall (e : env) (t : term),
sn e t ->
{u : term | red _ (beta_delta _) e t u &
head_normal _ (beta_delta _) e u}.