diff --git a/common/theories/Environment.v b/common/theories/Environment.v index d85274f96..bd47913f8 100644 --- a/common/theories/Environment.v +++ b/common/theories/Environment.v @@ -9,7 +9,7 @@ Module Type Term. Parameter Inline term : Type. Parameter Inline tRel : nat -> term. - Parameter Inline tSort : Universe.t -> term. + Parameter Inline tSort : Sort.t -> term. Parameter Inline tProd : aname -> term -> term -> term. Parameter Inline tLambda : aname -> term -> term -> term. Parameter Inline tLetIn : aname -> term -> term -> term -> term. @@ -129,7 +129,7 @@ Module Environment (T : Term). Import T. #[global] Existing Instance subst_instance_constr. - Definition judgment := judgment_ Universe.t term. + Definition judgment := judgment_ Sort.t term. (** ** Declarations *) Notation context_decl := (context_decl term). @@ -344,7 +344,7 @@ Module Environment (T : Term). Record one_inductive_body := { ind_name : ident; ind_indices : context; (* Indices of the inductive types, under params *) - ind_sort : Universe.t; (* Sort of the inductive. *) + ind_sort : Sort.t; (* Sort of the inductive. *) ind_type : term; (* Closed arity = forall mind_params, ind_indices, tSort ind_sort *) ind_kelim : allowed_eliminations; (* Allowed eliminations *) ind_ctors : list constructor_body; @@ -856,10 +856,10 @@ Module Environment (T : Term). Definition primitive_invariants (p : prim_tag) (cdecl : constant_body) := match p with | primInt | primFloat => - [/\ cdecl.(cst_type) = tSort Universe.type0, cdecl.(cst_body) = None & + [/\ cdecl.(cst_type) = tSort Sort.type0, cdecl.(cst_body) = None & cdecl.(cst_universes) = Monomorphic_ctx] | primArray => - let s := Universe.make (Level.lvar 0) in + let s := sType (Universe.make' (Level.lvar 0)) in [/\ cdecl.(cst_type) = tImpl (tSort s) (tSort s), cdecl.(cst_body) = None & cdecl.(cst_universes) = Polymorphic_ctx array_uctx] end. @@ -1239,7 +1239,7 @@ End EnvironmentDecideReflectInstances. Module Type TermUtils (T: Term) (E: EnvironmentSig T). Import T E. - Parameter Inline destArity : context -> term -> option (context × Universe.t). + Parameter Inline destArity : context -> term -> option (context × Sort.t). Parameter Inline inds : kername -> Instance.t -> list one_inductive_body -> list term. End TermUtils. diff --git a/common/theories/EnvironmentTyping.v b/common/theories/EnvironmentTyping.v index 76fdc2308..8e7f8757b 100644 --- a/common/theories/EnvironmentTyping.v +++ b/common/theories/EnvironmentTyping.v @@ -280,16 +280,16 @@ Module Lookup (T : Term) (E : EnvironmentSig T). now rewrite H; cbn; autorewrite with len. Qed. - Definition wf_universe Σ s : Prop := - Universe.on_sort - (fun u => forall l, LevelExprSet.In l u -> LevelSet.In (LevelExpr.get_level l) (global_ext_levels Σ)) - True s. + Definition wf_universe Σ (u : Universe.t) : Prop := + forall l, LevelExprSet.In l u -> LevelSet.In (LevelExpr.get_level l) (global_ext_levels Σ). - Definition wf_universe_dec Σ s : {@wf_universe Σ s} + {~@wf_universe Σ s}. + Definition wf_sort Σ (s : sort) : Prop := + Sort.on_sort (wf_universe Σ) True s. + + Definition wf_universe_dec Σ u : {wf_universe Σ u} + {~wf_universe Σ u}. Proof. - destruct s; try (left; exact I). - cbv [wf_universe Universe.on_sort LevelExprSet.In LevelExprSet.this t_set]. - destruct t as [[t _] _]. + cbv [wf_universe LevelExprSet.In LevelExprSet.this t_set]. + destruct u as [[t _] _]. induction t as [|t ts [IHt|IHt]]; [ left | | right ]. { inversion 1. } { destruct (LevelSetProp.In_dec (LevelExpr.get_level t) (global_ext_levels Σ)) as [H|H]; [ left | right ]. @@ -298,6 +298,12 @@ Module Lookup (T : Term) (E : EnvironmentSig T). { intro H; apply IHt; intros; apply H; now constructor. } Defined. + Definition wf_sort_dec Σ s : {@wf_sort Σ s} + {~@wf_sort Σ s}. + Proof. + destruct s; try (left; exact I). + apply wf_universe_dec. + Defined. + Lemma declared_ind_declared_constructors `{cf : checker_flags} {Σ ind mib oib} : declared_inductive Σ ind mib oib -> Alli (fun i => declared_constructor Σ (ind, i) mib oib) 0 (ind_ctors oib). @@ -837,13 +843,13 @@ Module EnvTyping (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E). Section TypeLocalOver. Context (checking : context -> term -> term -> Type). - Context (sorting : context -> term -> Universe.t -> Type). + Context (sorting : context -> term -> sort -> Type). Context (cproperty : forall (Γ : context), All_local_env (lift_sorting1 checking sorting) Γ -> forall (t T : term), checking Γ t T -> Type). Context (sproperty : forall (Γ : context), All_local_env (lift_sorting1 checking sorting) Γ -> - forall (t : term) (u : Universe.t), sorting Γ t u -> Type). + forall (t : term) (u : sort), sorting Γ t u -> Type). Inductive All_local_env_over_sorting : forall (Γ : context), All_local_env (lift_sorting1 checking sorting) Γ -> Type := @@ -971,9 +977,9 @@ Module EnvTyping (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E). Section lift_sorting_size_gen. Context {checking : term -> term -> Type}. - Context {sorting : term -> Universe.t -> Type}. + Context {sorting : term -> sort -> Type}. Context (csize : forall (t T : term), checking t T -> size). - Context (ssize : forall (t : term) (u : Universe.t), sorting t u -> size). + Context (ssize : forall (t : term) (u : sort), sorting t u -> size). Definition lift_sorting_size_gen base j (w : lift_sorting checking sorting j) : size := base + option_default_size (fun tm => csize tm _) (j_term j) w.1 + ssize _ _ w.2.π2.1. @@ -1039,7 +1045,7 @@ Module EnvTyping (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E). Section All_local_env_size. Context {checking : forall (Γ : context), term -> term -> Type}. - Context {sorting : forall (Γ : context), term -> Universe.t -> Type}. + Context {sorting : forall (Γ : context), term -> sort -> Type}. Context (csize : forall Γ t T, checking Γ t T -> size). Context (ssize : forall Γ t u, sorting Γ t u -> size). @@ -1089,7 +1095,7 @@ Module EnvTyping (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E). End Regular. Section Bidirectional. - Context {checking : context -> term -> term -> Type} {sorting : context -> term -> Universe.t -> Type}. + Context {checking : context -> term -> term -> Type} {sorting : context -> term -> sort -> Type}. Context (checking_size : forall Γ t T, checking Γ t T -> size). Context (sorting_size : forall Γ t s, sorting Γ t s -> size). @@ -1172,16 +1178,16 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT (** For well-formedness of inductive declarations we need a way to check that a assumptions of a given context is typable in a sort [u]. We also force well-typing of the let-ins in any universe to imply wf_local. *) - Fixpoint type_local_ctx Σ (Γ Δ : context) (u : Universe.t) : Type := + Fixpoint type_local_ctx Σ (Γ Δ : context) (u : sort) : Type := match Δ with - | [] => wf_universe Σ u + | [] => wf_sort Σ u | {| decl_name := na; decl_body := None; decl_type := t |} :: Δ => type_local_ctx Σ Γ Δ u × P Σ (Γ ,,, Δ) (TypUniv t u (* na.(binder_relevance) *)) | {| decl_body := Some _; |} as d :: Δ => type_local_ctx Σ Γ Δ u × P Σ (Γ ,,, Δ) (j_decl d) end. - Fixpoint sorts_local_ctx Σ (Γ Δ : context) (us : list Universe.t) : Type := + Fixpoint sorts_local_ctx Σ (Γ Δ : context) (us : list sort) : Type := match Δ, us with | [], [] => unit | {| decl_name := na; decl_body := None; decl_type := t |} :: Δ, u :: us => @@ -1516,20 +1522,20 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT Definition check_constructors_smaller φ cunivss ind_sort := Forall (fun cunivs => - Forall (fun argsort => leq_universe φ argsort ind_sort) cunivs) cunivss. + Forall (fun argsort => leq_sort φ argsort ind_sort) cunivs) cunivss. (** This ensures that all sorts in kelim are lower or equal to the top elimination sort, if set. For inductives in Type we do not check [kelim] currently. *) - Definition constructor_univs := list Universe.t. + Definition constructor_univs := list sort. (* The sorts of the arguments context (without lets) *) Definition elim_sort_prop_ind (ind_ctors_sort : list constructor_univs) := match ind_ctors_sort with | [] => (* Empty inductive proposition: *) IntoAny | [ s ] => - if forallb Universes.is_propositional s then + if forallb Sort.is_propositional s then IntoAny (* Singleton elimination *) else IntoPropSProp (* Squashed: some arguments are higher than Prop, restrict to Prop *) @@ -1544,23 +1550,25 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT Definition check_ind_sorts (Σ : global_env_ext) params kelim ind_indices cdecls ind_sort : Type := - if Universe.is_prop ind_sort then + match Sort.to_family ind_sort with + | Sort.fProp => (** The inductive is declared in the impredicative sort Prop *) (** No universe-checking to do: any size of constructor argument is allowed, however elimination restrictions apply. *) (allowed_eliminations_subset kelim (elim_sort_prop_ind cdecls) : Type) - else if Universe.is_sprop ind_sort then + | Sort.fSProp => (** The inductive is declared in the impredicative sort SProp *) (** No universe-checking to do: any size of constructor argument is allowed, however elimination restrictions apply. *) (allowed_eliminations_subset kelim (elim_sort_sprop_ind cdecls) : Type) - else + | _ => (** The inductive is predicative: check that all constructors arguments are smaller than the declared universe. *) check_constructors_smaller Σ cdecls ind_sort × if indices_matter then type_local_ctx Σ params ind_indices ind_sort - else True. + else True + end. Record on_ind_body Σ mind mdecl i idecl := { (** The type of the inductive must be an arity, sharing the same params @@ -1776,7 +1784,7 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT Lemma type_local_ctx_impl (P Q : global_env_ext -> context -> judgment -> Type) Σ Σ' Γ Δ u : type_local_ctx P Σ Γ Δ u -> - (forall u, wf_universe Σ u -> wf_universe Σ' u) -> + (forall u, wf_sort Σ u -> wf_sort Σ' u) -> (forall Γ j, P Σ Γ j -> Q Σ' Γ j) -> type_local_ctx Q Σ' Γ Δ u. Proof. @@ -1993,14 +2001,14 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT unfold check_constructors_smaller. intro H; apply Forall_impl with (1 := H). intros l Hl; apply Forall_impl with (1 := Hl). - intro u. now apply leq_universe_config_impl. + intro u. now apply leq_sort_config_impl. Qed. Lemma on_global_decl_impl_full {cf1 cf2 : checker_flags} Pcmp1 Pcmp2 P1 P2 Σ Σ' kn d : config.impl cf1 cf2 -> (forall Γ j, P1 Σ Γ j -> P2 Σ' Γ j) -> (forall u Γ pb t t', Pcmp1 (Σ.1, u) Γ pb t t' -> Pcmp2 (Σ'.1, u) Γ pb t t') -> - (forall u, wf_universe Σ u -> wf_universe Σ' u) -> + (forall u, wf_sort Σ u -> wf_sort Σ' u) -> (forall l s, @check_constructors_smaller cf1 (global_ext_constraints Σ) l s -> @check_constructors_smaller cf2 (global_ext_constraints Σ') l s) -> (forall u l, @on_variance cf1 Σ.1 u l -> @on_variance cf2 Σ'.1 u l) -> @@ -2037,8 +2045,7 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT all: rewrite ?andb_false_r //=. + exact (onProjections X). + pose proof (ind_sorts X) as X1. unfold check_ind_sorts in *. - destruct Universe.is_prop; auto. - destruct Universe.is_sprop; auto. + destruct Sort.to_family; auto. destruct X1 as [constr_smaller type_local_ctx]. split. * apply Xc, constr_smaller. diff --git a/common/theories/Reflect.v b/common/theories/Reflect.v index 431c56c98..923b0e564 100644 --- a/common/theories/Reflect.v +++ b/common/theories/Reflect.v @@ -397,7 +397,7 @@ Ltac finish_reflect := end); constructor; trivial; congruence. -Definition eqb_universes_decl x y := +Definition eqb_sorts_decl x y := match x, y with | Monomorphic_ctx, Monomorphic_ctx => true | Polymorphic_ctx cx, Polymorphic_ctx cy => eqb cx cy @@ -405,9 +405,9 @@ Definition eqb_universes_decl x y := end. #[global,program] Instance reflect_universes_decl : ReflectEq universes_decl := - {| eqb := eqb_universes_decl |}. + {| eqb := eqb_sorts_decl |}. Next Obligation. - unfold eqb_universes_decl. + unfold eqb_sorts_decl. intros [] []; finish_reflect. Qed. diff --git a/common/theories/Universes.v b/common/theories/Universes.v index c7a79d607..615cb5e05 100644 --- a/common/theories/Universes.v +++ b/common/theories/Universes.v @@ -26,7 +26,7 @@ Hint Extern 10 => absurd : core. (** A valuation is a universe level (nat) given for each universe lvariable (Level.t). - It is >= for polymorphic concreteUniverses and > 0 for monomorphic concreteUniverses. *) + It is >= for polymorphic concrete_sort and > 0 for monomorphic concrete_sort. *) Record valuation := { valuation_mono : string -> positive ; valuation_poly : nat -> nat }. @@ -247,7 +247,6 @@ Module PropLevel. End PropLevel. Module LevelExpr. - (* npe = no prop expression *) Definition t := (Level.t * nat)%type. Global Instance Evaluable : Evaluable t @@ -270,15 +269,6 @@ Module LevelExpr. Definition set : t := (Level.lzero, 0%nat). Definition type1 : t := (Level.lzero, 1%nat). - (* Used for (un)quoting. *) - Definition from_kernel_repr (e : Level.t * bool) : t - := (e.1, if e.2 then 1%nat else 0%nat). - - Definition to_kernel_repr (e : t) : Level.t * bool - := match e with - | (l, b) => (l, match b with 0%nat => false | _ => true end) - end. - Definition eq : t -> t -> Prop := eq. Definition eq_equiv : Equivalence eq := _. @@ -349,7 +339,7 @@ Module LevelExprSetDecide := LevelExprSetProp.Dec. Module LevelExprSetExtraOrdProp := MSets.ExtraOrdProperties LevelExprSet LevelExprSetOrdProp. (* We have decidable equality w.r.t leibniz equality for sets of levels. - This means concreteUniverses also have a decidable equality. *) + This means concrete_sort also has a decidable equality. *) #[global, program] Instance levelexprset_reflect : ReflectEq LevelExprSet.t := { eqb := LevelExprSet.equal }. Next Obligation. @@ -596,7 +586,7 @@ End NonEmptySetFacts. Import NonEmptySetFacts. -Module LevelAlgExpr. +Module Universe. (** A universe / an algebraic expression is a list of universe expressions which is: - sorted - without duplicate @@ -618,15 +608,20 @@ Module LevelAlgExpr. #[global] Instance eq_dec_univ0 : EqDec t := eq_dec. Definition make (e: LevelExpr.t) : t := singleton e. - Definition make' (l: Level.t) := singleton (LevelExpr.make l). + Definition make' (l: Level.t) : t := singleton (LevelExpr.make l). + + Lemma make'_inj l l' : make' l = make' l' -> l = l'. + Proof. + destruct l, l' => //=; now inversion 1. + Qed. (** The non empty / sorted / without dup list of univ expressions, the components of the pair are the head and the tail of the (non empty) list *) Definition exprs : t -> LevelExpr.t * list LevelExpr.t := to_nonempty_list. - Global Instance Evaluable : Evaluable LevelAlgExpr.t + Global Instance Evaluable : Evaluable Universe.t := fun v u => - let '(e, u) := LevelAlgExpr.exprs u in + let '(e, u) := Universe.exprs u in List.fold_left (fun n e => Nat.max (val v e) n) u (val v e). (** Test if the universe is a lub of levels or contains +n's. *) @@ -637,6 +632,9 @@ Module LevelAlgExpr. Definition is_level (u : t) : bool := (LevelExprSet.cardinal u =? 1)%nat && is_levels u. + (* Used for quoting. *) + Definition from_kernel_repr (e : Level.t * nat) (es : list (Level.t * nat)) : t + := add_list es (Universe.make e). Definition succ : t -> t := map LevelExpr.succ. @@ -665,7 +663,7 @@ Module LevelAlgExpr. { intros ? H. apply irreflexivity in H; assumption. } { intros ??? H1 H2; etransitivity; tea. } Qed. -End LevelAlgExpr. +End Universe. Ltac u := change LevelSet.elt with Level.t in *; @@ -673,21 +671,21 @@ Ltac u := (* change ConstraintSet.elt with UnivConstraint.t in *. *) -Lemma val_fold_right (u : LevelAlgExpr.t) v : - val v u = fold_right (fun e x => Nat.max (val v e) x) (val v (LevelAlgExpr.exprs u).1) - (List.rev (LevelAlgExpr.exprs u).2). +Lemma val_fold_right (u : Universe.t) v : + val v u = fold_right (fun e x => Nat.max (val v e) x) (val v (Universe.exprs u).1) + (List.rev (Universe.exprs u).2). Proof. - unfold val at 1, LevelAlgExpr.Evaluable. - destruct (LevelAlgExpr.exprs u). + unfold val at 1, Universe.Evaluable. + destruct (Universe.exprs u). now rewrite fold_left_rev_right. Qed. -Lemma val_In_le (u : LevelAlgExpr.t) v e : +Lemma val_In_le (u : Universe.t) v e : LevelExprSet.In e u -> val v e <= val v u. Proof. intro H. rewrite val_fold_right. apply In_to_nonempty_list_rev in H. - fold LevelAlgExpr.exprs in H; destruct (LevelAlgExpr.exprs u); cbn in *. + fold Universe.exprs in H; destruct (Universe.exprs u); cbn in *. destruct H as [H|H]. - subst. induction (List.rev l); cbnr. lia. - induction (List.rev l); cbn; invs H. @@ -695,12 +693,12 @@ Proof. + specialize (IHl0 H0). lia. Qed. -Lemma val_In_max (u : LevelAlgExpr.t) v : +Lemma val_In_max (u : Universe.t) v : exists e, LevelExprSet.In e u /\ val v e = val v u. Proof. eapply iff_ex. { intro. eapply and_iff_compat_r. apply In_to_nonempty_list_rev. } - rewrite val_fold_right. fold LevelAlgExpr.exprs; destruct (LevelAlgExpr.exprs u) as [e l]; cbn in *. + rewrite val_fold_right. fold Universe.exprs; destruct (Universe.exprs u) as [e l]; cbn in *. clear. induction (List.rev l); cbn. - exists e. split; cbnr. left; reflexivity. - destruct IHl0 as [e' [H1 H2]]. @@ -712,7 +710,7 @@ Proof. destruct H1 as [H1|H1]; [now left|right]. now constructor 2. Qed. -Lemma val_ge_caract (u : LevelAlgExpr.t) v k : +Lemma val_ge_caract (u : Universe.t) v k : (forall e, LevelExprSet.In e u -> val v e <= k) <-> val v u <= k. Proof. split. @@ -720,7 +718,7 @@ Proof. eapply iff_forall; intro. eapply imp_iff_compat_r. apply In_to_nonempty_list_rev. } rewrite val_fold_right. - fold LevelAlgExpr.exprs; destruct (LevelAlgExpr.exprs u) as [e l]; cbn; clear. + fold Universe.exprs; destruct (Universe.exprs u) as [e l]; cbn; clear. induction (List.rev l); cbn. + intros H. apply H. left; reflexivity. + intros H. @@ -733,14 +731,14 @@ Proof. - intros H e He. eapply val_In_le in He. etransitivity; eassumption. Qed. -Lemma val_le_caract (u : LevelAlgExpr.t) v k : +Lemma val_le_caract (u : Universe.t) v k : (exists e, LevelExprSet.In e u /\ k <= val v e) <-> k <= val v u. Proof. split. - eapply imp_iff_compat_r. { eapply iff_ex; intro. eapply and_iff_compat_r. apply In_to_nonempty_list_rev. } rewrite val_fold_right. - fold LevelAlgExpr.exprs; destruct (LevelAlgExpr.exprs u) as [e l]; cbn; clear. + fold Universe.exprs; destruct (Universe.exprs u) as [e l]; cbn; clear. induction (List.rev l); cbn. + intros H. destruct H as [e' [[H1|H1] H2]]. * now subst. @@ -756,7 +754,7 @@ Qed. -Lemma val_caract (u : LevelAlgExpr.t) v k : +Lemma val_caract (u : Universe.t) v k : val v u = k <-> (forall e, LevelExprSet.In e u -> val v e <= k) /\ exists e, LevelExprSet.In e u /\ val v e = k. @@ -772,7 +770,7 @@ Proof. exists e. split; tas. lia. Qed. -Lemma val_add v e (s: LevelAlgExpr.t) +Lemma val_add v e (s: Universe.t) : val v (add e s) = Nat.max (val v e) (val v s). Proof. apply val_caract. split. @@ -786,7 +784,7 @@ Proof. Qed. Lemma val_sup v s1 s2 : - val v (LevelAlgExpr.sup s1 s2) = Nat.max (val v s1) (val v s2). + val v (Universe.sup s1 s2) = Nat.max (val v s1) (val v s2). Proof. eapply val_caract. cbn. split. - intros e' H. eapply LevelExprSet.union_spec in H. destruct H as [H|H]. @@ -808,11 +806,11 @@ Proof. Qed. -Lemma levelalg_get_is_level_correct u l : - LevelAlgExpr.get_is_level u = Some l -> u = LevelAlgExpr.make' l. +Lemma universe_get_is_level_correct u l : + Universe.get_is_level u = Some l -> u = Universe.make' l. Proof. intro H. - unfold LevelAlgExpr.get_is_level in *. + unfold Universe.get_is_level in *. destruct (LevelExprSet.elements u) as [|l0 L] eqn:Hu1; [discriminate |]. destruct l0, L; try discriminate. * destruct n; inversion H; subst. @@ -822,1315 +820,1279 @@ Qed. Lemma sup0_comm x1 x2 : - LevelAlgExpr.sup x1 x2 = LevelAlgExpr.sup x2 x1. + Universe.sup x1 x2 = Universe.sup x2 x1. Proof. apply eq_univ'; simpl. unfold LevelExprSet.Equal. intros H. rewrite !LevelExprSet.union_spec. intuition. Qed. +(* +Lemma val_zero_exprs v (l : Universe.t) : 0 <= val v l. +Proof. + rewrite val_fold_right. + destruct (Universe.exprs l) as [e u']; clear l; cbn. + induction (List.rev u'); simpl. + - destruct e as [npl_expr]. + destruct npl_expr as [t b]. + cbn. + assert (0 <= val v t) by apply Level.val_zero. + destruct b;lia. + - pose proof (LevelExpr.val_zero a v); lia. +Qed. *) -Declare Scope univ_scope. -Delimit Scope univ_scope with u. - -(** Universes with linear hierarchy *) -Section ConcreteUniverses. - Context {cf}. - Inductive concreteUniverses := - | UProp - | USProp - | UType (i : nat). - Derive NoConfusion EqDec for concreteUniverses. +Module ConstraintType. + Inductive t_ : Set := Le (z : Z) | Eq. + Derive NoConfusion EqDec for t_. - (** u + n <= u' *) - Definition leq_cuniverse_n n u u' := - match u, u' with - | UProp, UProp - | USProp, USProp => (n = 0)%Z - | UType u, UType u' => (Z.of_nat u <= Z.of_nat u' - n)%Z - | UProp, UType u => - if prop_sub_type then True else False - | _, _ => False - end. + Definition t := t_. + Definition eq : t -> t -> Prop := eq. + Definition eq_equiv : Equivalence eq := _. - Definition leq_cuniverse := leq_cuniverse_n 0. - Definition lt_cuniverse := leq_cuniverse_n 1. + Definition Le0 := Le 0. + Definition Lt := Le 1. - Notation "x <_ n y" := (leq_cuniverse_n n x y) (at level 10, n name) : univ_scope. - Notation "x < y" := (lt_cuniverse x y) : univ_scope. - Notation "x <= y" := (leq_cuniverse x y) : univ_scope. + Inductive lt_ : t -> t -> Prop := + | LeLe n m : (n < m)%Z -> lt_ (Le n) (Le m) + | LeEq n : lt_ (Le n) Eq. + Derive Signature for lt_. + Definition lt := lt_. - Definition cuniv_sup u1 u2 := - match u1, u2 with - | UProp, UProp => UProp - | USProp, USProp => USProp - | UType v, UType v' => UType (Nat.max v v') - | _, UType _ => u2 - | UType _, _ => u1 - | UProp, USProp => UProp - | USProp, UProp => UProp - end. + Global Instance lt_strorder : StrictOrder lt. + Proof. + constructor. + - intros []; intro X; inversion X. lia. + - intros ? ? ? X Y; invs X; invs Y; constructor. lia. + Qed. - Definition is_uprop u := match u with UProp => True | _ => False end. - Definition is_usprop u := match u with USProp => True | _ => False end. - Definition is_uproplevel u := match u with USProp | UProp => True | _ => False end. - Definition is_uproplevel_or_set u := match u with USProp | UProp | UType 0 => True | _ => False end. - Definition is_utype u := match u with UType _ => True | _ => False end. + Global Instance lt_compat : Proper (eq ==> eq ==> iff) lt. + Proof. + intros ? ? X ? ? Y; invs X; invs Y. reflexivity. + Qed. - (** Type of a product *) - Definition cuniv_of_product domsort rangsort := - match rangsort with - (* Prop and SProp impredicativity *) - | UProp | USProp => rangsort - | _ => cuniv_sup domsort rangsort + Definition compare (x y : t) : comparison := + match x, y with + | Le n, Le m => Z.compare n m + | Le _, Eq => Datatypes.Lt + | Eq, Eq => Datatypes.Eq + | Eq, _ => Datatypes.Gt end. - Lemma cuniv_sup_comm u u' : cuniv_sup u u' = cuniv_sup u' u. - Proof using Type. destruct u, u'; cbn; try congruence. f_equal; lia. Qed. - - Lemma cuniv_sup_not_uproplevel u u' : - ~ is_uproplevel u -> ∑ n, cuniv_sup u u' = UType n. - Proof using Type. - destruct u, u'; cbn; intros Hp; try absurd; - now eexists. + Lemma compare_spec x y : CompareSpec (eq x y) (lt x y) (lt y x) (compare x y). + Proof. + destruct x, y; repeat constructor. simpl. + destruct (Z.compare_spec z z0); simpl; constructor. + subst; constructor. now constructor. now constructor. Qed. - Lemma cuniv_le_uprop_inv u : (u <= UProp)%u -> u = UProp. - Proof using Type. destruct u; simpl; intros Hle; try absurd; now reflexivity. Qed. - - Lemma cuniv_le_usprop_inv u : (u <= USProp)%u -> u = USProp. - Proof using Type. destruct u; simpl; intros Hle; try absurd; now reflexivity. Qed. - - Lemma cuniv_uprop_le_inv u : (UProp <= u)%u -> - (u = UProp \/ (prop_sub_type /\ exists n, u = UType n)). - Proof using Type. - destruct u; simpl; intros Hle; [ left; reflexivity | absurd | right ]. - destruct prop_sub_type; [| absurd]. - split; [ trivial | now eexists ]. + Lemma eq_dec x y : {eq x y} + {~ eq x y}. + Proof. + unfold eq. decide equality. apply Z.eq_dec. Qed. +End ConstraintType. - Lemma cuniv_sup_mon u u' v v' : (u <= u')%u -> (UType v <= UType v')%u -> - (cuniv_sup u (UType v) <= cuniv_sup u' (UType v'))%u. - Proof using Type. - destruct u, u'; simpl; intros Hle Hle'; try absurd; - lia. - Qed. +Module UnivConstraint. + Definition t : Set := Level.t * ConstraintType.t * Level.t. - Lemma leq_cuniv_of_product_mon u u' v v' : - (u <= u')%u -> - (v <= v')%u -> - (cuniv_of_product u v <= cuniv_of_product u' v')%u. - Proof using Type. - intros Hle1 Hle2. - destruct v, v'; cbn in Hle2 |- *; auto. - - destruct u'; cbn; assumption. - - apply cuniv_sup_mon; assumption. - Qed. + Definition eq : t -> t -> Prop := eq. + Definition eq_equiv : Equivalence eq := _. - Lemma impredicative_cuniv_product {l u} : - is_uproplevel u -> - (cuniv_of_product l u <= u)%u. - Proof using Type. now destruct u. Qed. + Definition make l1 ct l2 : t := (l1, ct, l2). + Inductive lt_ : t -> t -> Prop := + | lt_Level2 l1 t l2 l2' : Level.lt l2 l2' -> lt_ (l1, t, l2) (l1, t, l2') + | lt_Cstr l1 t t' l2 l2' : ConstraintType.lt t t' -> lt_ (l1, t, l2) (l1, t', l2') + | lt_Level1 l1 l1' t t' l2 l2' : Level.lt l1 l1' -> lt_ (l1, t, l2) (l1', t', l2'). + Definition lt := lt_. - Global Instance leq_cuniverse_refl : Reflexive leq_cuniverse. - Proof using Type. - intros []; cbnr; lia. + Lemma lt_strorder : StrictOrder lt. + Proof. + constructor. + - intros []; intro X; inversion X; subst; + try (eapply Level.lt_strorder; eassumption). + eapply ConstraintType.lt_strorder; eassumption. + - intros ? ? ? X Y; invs X; invs Y; constructor; tea. + etransitivity; eassumption. + 2: etransitivity; eassumption. + eapply ConstraintType.lt_strorder; eassumption. Qed. - Global Instance leq_cuniverse_n_trans n : Transitive (leq_cuniverse_n (Z.of_nat n)). - Proof using Type. - intros [] [] []; cbnr; trivial; try absurd; lia. + Lemma lt_compat : Proper (eq ==> eq ==> iff) lt. + Proof. + intros ? ? X ? ? Y; invs X; invs Y. reflexivity. Qed. - Global Instance leq_cuniverse_trans : Transitive leq_cuniverse. - Proof using Type. apply (leq_cuniverse_n_trans 0). Qed. - - Global Instance lt_cuniverse_trans : Transitive lt_cuniverse. - Proof using Type. apply (leq_cuniverse_n_trans 1). Qed. - - Global Instance leq_cuniverse_preorder : PreOrder leq_cuniverse := - Build_PreOrder _ _ _. + Definition compare : t -> t -> comparison := + fun '(l1, t, l2) '(l1', t', l2') => + compare_cont (Level.compare l1 l1') + (compare_cont (ConstraintType.compare t t') + (Level.compare l2 l2')). - Global Instance lt_cuniverse_str_order : StrictOrder lt_cuniverse. - Proof using Type. - split. - - intros []; unfold complement; cbnr; lia. - - exact _. + Lemma compare_spec x y + : CompareSpec (eq x y) (lt x y) (lt y x) (compare x y). + Proof. + destruct x as [[l1 t] l2], y as [[l1' t'] l2']; cbn. + destruct (Level.compare_spec l1 l1'); cbn; repeat constructor; tas. + invs H. + destruct (ConstraintType.compare_spec t t'); cbn; repeat constructor; tas. + invs H. + destruct (Level.compare_spec l2 l2'); cbn; repeat constructor; tas. + invs H. reflexivity. Qed. - Global Instance leq_cuniverse_antisym : Antisymmetric _ eq leq_cuniverse. - Proof using Type. - intros [] []; cbnr; try absurd. - intros. f_equal; lia. - Qed. + Lemma eq_dec x y : {eq x y} + {~ eq x y}. + Proof. + unfold eq. decide equality; apply eq_dec. + Defined. -End ConcreteUniverses. + Definition eq_leibniz (x y : t) : eq x y -> x = y := id. +End UnivConstraint. +Module ConstraintSet := MSetAVL.Make UnivConstraint. +Module ConstraintSetFact := WFactsOn UnivConstraint ConstraintSet. +Module ConstraintSetOrdProp := MSetProperties.OrdProperties ConstraintSet. +Module ConstraintSetProp := ConstraintSetOrdProp.P. +Module CS := ConstraintSet. +Module ConstraintSetDecide := ConstraintSetProp.Dec. +Module ConstraintSetExtraOrdProp := MSets.ExtraOrdProperties ConstraintSet ConstraintSetOrdProp. +Module ConstraintSetExtraDecide := MSetAVL.Decide UnivConstraint ConstraintSet. +Ltac csets := ConstraintSetDecide.fsetdec. -(** This inductive classifies which eliminations are allowed for inductive types - in lvarious sorts. *) -Inductive allowed_eliminations : Set := - | IntoSProp - | IntoPropSProp - | IntoSetPropSProp - | IntoAny. -Derive NoConfusion EqDec for allowed_eliminations. +Notation "(=_cset)" := ConstraintSet.Equal (at level 0). +Infix "=_cset" := ConstraintSet.Equal (at level 30). +Notation "(==_cset)" := ConstraintSet.equal (at level 0). +Infix "==_cset" := ConstraintSet.equal (at level 30). +Definition declared_cstr_levels levels (cstr : UnivConstraint.t) := + let '(l1,_,l2) := cstr in + LevelSet.In l1 levels /\ LevelSet.In l2 levels. -Definition is_allowed_elimination_cuniv (allowed : allowed_eliminations) : concreteUniverses -> Prop := - match allowed with - | IntoSProp => is_usprop - | IntoPropSProp => is_uproplevel - | IntoSetPropSProp => is_uproplevel_or_set - | IntoAny => fun _ => True - end. +Definition is_declared_cstr_levels levels (cstr : UnivConstraint.t) : bool := + let '(l1,_,l2) := cstr in + LevelSet.mem l1 levels && LevelSet.mem l2 levels. -Inductive sort_family : Set := - | fSProp - | fProp - | fType. -Derive NoConfusion EqDec for sort_family. +Lemma CS_union_empty s : ConstraintSet.union ConstraintSet.empty s =_cset s. +Proof. + intros x; rewrite ConstraintSet.union_spec. lsets. +Qed. -Definition family_of_cuniv u := - match u with - | USProp => fSProp - | UProp => fProp - | UType _ => fType - end. +Lemma CS_For_all_union f cst cst' : ConstraintSet.For_all f (ConstraintSet.union cst cst') -> + ConstraintSet.For_all f cst. +Proof. + unfold CS.For_all. + intros IH x inx. apply (IH x). + now eapply CS.union_spec; left. +Qed. -Module Universe. - Inductive t_ := - lProp | lSProp | lType (_ : LevelAlgExpr.t). - Derive NoConfusion for t_. +Lemma CS_For_all_add P x s : CS.For_all P (CS.add x s) -> P x /\ CS.For_all P s. +Proof. + intros. + split. + * apply (H x), CS.add_spec; left => //. + * intros y iny. apply (H y), CS.add_spec; right => //. +Qed. - Definition t := t_. +#[global] Instance CS_For_all_proper P : Morphisms.Proper ((=_cset) ==> iff)%signature (ConstraintSet.For_all P). +Proof. + intros s s' eqs. + unfold CS.For_all. split; intros IH x inxs; apply (IH x); + now apply eqs. +Qed. - Definition eqb (u1 u2 : t) : bool := - match u1, u2 with - | lSProp, lSProp => true - | lProp, lProp => true - | lType e1, lType e2 => eqb e1 e2 - | _, _ => false - end. +(** {6 Sort instances} *) - #[global, program] Instance reflect_eq_universe : ReflectEq t := - { eqb := eqb }. - Next Obligation. - destruct x, y; cbn; try constructor; auto; try congruence. - destruct (eqb_spec t0 t1); constructor. now f_equal. - congruence. - Qed. +Module Instance. - #[global] Instance eq_dec_univ : EqDec t := eq_dec. + (** A universe instance represents a vector of argument concrete_sort + to a polymorphic definition (constant, inductive or constructor). *) + Definition t : Set := list Level.t. - Definition on_sort (P: LevelAlgExpr.t -> Prop) (def: Prop) (s : t) := - match s with - | lProp | lSProp => def - | lType l => P l + Definition empty : t := []. + Definition is_empty (i : t) : bool := + match i with + | [] => true + | _ => false end. - (** Create a universe representing the given level. *) - Definition make (l : Level.t) : t := - lType (LevelAlgExpr.make (LevelExpr.make l)). - - Definition of_expr e := (lType (LevelAlgExpr.make e)). - - Definition add_to_exprs (e : LevelExpr.t) (u : t) : t := - match u with - | lSProp | lProp => u - | lType l => lType (add e l) - end. + Definition eqb (i j : t) := + forallb2 Level.eqb i j. - Definition add_list_to_exprs (es : list LevelExpr.t) (u : t) : t := - match u with - | lSProp | lProp => u - | lType l => lType (add_list es l) - end. + Definition equal_upto (f : Level.t -> Level.t -> bool) (i j : t) := + forallb2 f i j. +End Instance. - (** Test if the universe is a lub of levels or contains +n's. *) - Definition is_levels (u : t) : bool := - match u with - | lSProp | lProp => true - | lType l => LevelAlgExpr.is_levels l - end. +Module UContext. + Definition t := list name × (Instance.t × ConstraintSet.t). - (** Test if the universe is a level or an algebraic universe. *) - Definition is_level (u : t) : bool := - match u with - | lSProp | lProp => true - | lType l => LevelAlgExpr.is_level l - end. + Definition make' : Instance.t -> ConstraintSet.t -> Instance.t × ConstraintSet.t := pair. + Definition make (ids : list name) (inst_ctrs : Instance.t × ConstraintSet.t) : t := (ids, inst_ctrs). - Definition is_sprop (u : t) : bool := - match u with - | lSProp => true - | _ => false - end. + Definition empty : t := ([], (Instance.empty, ConstraintSet.empty)). - Definition is_prop (u : t) : bool := - match u with - | lProp => true - | _ => false - end. + Definition instance : t -> Instance.t := fun x => fst (snd x). + Definition constraints : t -> ConstraintSet.t := fun x => snd (snd x). - Definition is_type_sort (u : t) : bool := - match u with - | lType _ => true - | _ => false - end. + Definition dest : t -> list name * (Instance.t * ConstraintSet.t) := fun x => x. +End UContext. - Definition type0 : t := make Level.lzero. - Definition type1 : t := lType (LevelAlgExpr.make LevelExpr.type1). +Module AUContext. + Definition t := list name × ConstraintSet.t. - Definition of_levels (l : PropLevel.t + Level.t) : t := - match l with - | inl PropLevel.lSProp => lSProp - | inl PropLevel.lProp => lProp - | inr l => lType (LevelAlgExpr.make' l) - end. + Definition make (ids : list name) (ctrs : ConstraintSet.t) : t := (ids, ctrs). + Definition repr (x : t) : UContext.t := + let (u, cst) := x in + (u, (mapi (fun i _ => Level.lvar i) u, cst)). - (* Used for quoting. *) - Definition from_kernel_repr (e : Level.t * bool) (es : list (Level.t * bool)) : t - := lType (add_list (List.map LevelExpr.from_kernel_repr es) - (LevelAlgExpr.make (LevelExpr.from_kernel_repr e))). - - (* Definition uex_to_kernel_repr (e : LevelExpr.t) : Level.t * bool := *) - (* match e with *) - (* | LevelExpr.npe (l, b) => (NoPropLevel.to_level l, b) *) - (* end. *) - - (* Definition to_kernel_repr (u : t) : list (Level.t * bool) *) - (* := map (LevelExpr.to_kernel_repr) (LevelExprSet.elements u). *) - (* match u with *) - (* | lProp => [(Level.lProp, false)] *) - (* | lSProp => [(Level.lSProp, false)] *) - (* | lType l => map uex_to_kernel_repr (LevelExprSet.elements l) *) - (* end. *) + Definition levels (uctx : t) : LevelSet.t := + LevelSetProp.of_list (fst (snd (repr uctx))). - (** The universe strictly above FOR TYPING (not cumulativity) *) + #[local] + Existing Instance EqDec_ReflectEq. + Definition inter (au av : AUContext.t) : AUContext.t := + let prefix := (split_prefix au.1 av.1).1.1 in + let lvls := fold_left_i (fun s i _ => LevelSet.add (Level.lvar i) s) prefix LevelSet.empty in + let filter := ConstraintSet.filter (is_declared_cstr_levels lvls) in + make prefix (ConstraintSet.union (filter au.2) (filter av.2)). +End AUContext. - Definition super (l : t) : t := - match l with - | lSProp => type1 - | lProp => type1 - | lType l => lType (LevelAlgExpr.succ l) - end. +Module ContextSet. + Definition t := LevelSet.t × ConstraintSet.t. - Definition sup (u v : t) : t := - match u,v with - | lSProp, lProp => lProp - | lProp, lSProp => lProp - | (lSProp | lProp), u' => u' - | u', (lSProp | lProp) => u' - | lType l1, lType l2 => lType (LevelAlgExpr.sup l1 l2) - end. + Definition levels : t -> LevelSet.t := fst. + Definition constraints : t -> ConstraintSet.t := snd. - Definition get_univ_exprs (u : t) (H1 : is_prop u = false) (H2 : is_sprop u = false) : LevelAlgExpr.t. - destruct u; try discriminate; easy. Defined. + Definition empty : t := (LevelSet.empty, ConstraintSet.empty). - (** Type of a product *) - Definition sort_of_product (domsort rangsort : t) := - (* Prop and SProp impredicativity *) - if Universe.is_prop rangsort || Universe.is_sprop rangsort then rangsort - else Universe.sup domsort rangsort. + Definition is_empty (uctx : t) + := LevelSet.is_empty (fst uctx) && ConstraintSet.is_empty (snd uctx). - Lemma eqb_refl u : eqb u u. - Proof. - destruct u; auto. - now apply LevelExprSet.equal_spec. - Qed. + Definition Equal (x y : t) : Prop := + x.1 =_lset y.1 /\ x.2 =_cset y.2. - Definition get_is_level (u : t) : option Level.t := - match u with - | lSProp => None - | lProp => None - | lType l => LevelAlgExpr.get_is_level l - end. + Definition equal (x y : t) : bool := + x.1 ==_lset y.1 && x.2 ==_cset y.2. - Definition to_family u := - match u with - | lSProp => fSProp - | lProp => fProp - | lType _ => fType - end. + Definition Subset (x y : t) : Prop := + LevelSet.Subset (levels x) (levels y) /\ + ConstraintSet.Subset (constraints x) (constraints y). - Definition to_cuniv v u := - match u with - | lSProp => USProp - | lProp => UProp - | lType l => UType (val v l) - end. + Definition subset (x y : t) : bool := + LevelSet.subset (levels x) (levels y) && + ConstraintSet.subset (constraints x) (constraints y). + + Definition inter (x y : t) : t := + (LevelSet.inter (levels x) (levels y), + ConstraintSet.inter (constraints x) (constraints y)). - Lemma to_family_to_cuniv u v : - family_of_cuniv (to_cuniv v u) = to_family u. + Definition inter_spec (x y : t) : + Subset (inter x y) x /\ + Subset (inter x y) y /\ + forall z, Subset z x -> Subset z y -> Subset z (inter x y). Proof. - destruct u; cbnr. + split; last split. + 1,2: split=> ?; [move=> /LevelSet.inter_spec [//]|move=> /ConstraintSet.inter_spec [//]]. + move=> ? [??] [??]; split=> ??; + [apply/LevelSet.inter_spec|apply/ConstraintSet.inter_spec]; split; auto. Qed. - Lemma val_make v l - : to_cuniv v (make l) = UType (val v l). + Definition union (x y : t) : t := + (LevelSet.union (levels x) (levels y), ConstraintSet.union (constraints x) (constraints y)). + + Definition union_spec (x y : t) : + Subset x (union x y) /\ + Subset y (union x y) /\ + forall z, Subset x z -> Subset y z -> Subset (union x y) z. Proof. - destruct l; cbnr. + split; last split. + 1,2: split=> ??; [apply/LevelSet.union_spec|apply/ConstraintSet.union_spec ]; by constructor. + move=> ? [??] [??]; split=> ?; + [move=>/LevelSet.union_spec|move=>/ConstraintSet.union_spec]=>-[]; auto. Qed. - Lemma make_inj x y : - make x = make y -> x = y. + Lemma equal_spec s s' : equal s s' <-> Equal s s'. Proof. - destruct x, y; try now inversion 1. + rewrite /equal/Equal/is_true Bool.andb_true_iff LevelSet.equal_spec ConstraintSet.equal_spec. + reflexivity. Qed. - Inductive lt_ : t -> t -> Prop := - | ltPropSProp : lt_ lProp lSProp - | ltPropType s : lt_ lProp (lType s) - | ltSPropType s : lt_ lSProp (lType s) - | ltTypeType s1 s2 : LevelAlgExpr.lt s1 s2 -> lt_ (lType s1) (lType s2). - Derive Signature for lt_. - - Definition lt := lt_. - - Module OT <: OrderedType. - Definition t := t. - #[local] Definition eq : t -> t -> Prop := eq. - #[local] Definition eq_equiv : Equivalence eq := _. - Definition lt := lt. - #[local] Instance lt_strorder : StrictOrder lt. - Proof. - constructor. - - intros [| |] X; inversion X. - now eapply irreflexivity in H1. - - intros [| |] [| |] [| |] X1 X2; - inversion X1; inversion X2; constructor. - subst. - etransitivity; tea. - Qed. - - Definition lt_compat : Proper (eq ==> eq ==> iff) lt. - Proof. - intros x y e z t e'. hnf in * |- ; subst. reflexivity. - Qed. - Definition compare (x y : t) : comparison - := match x, y with - | lProp, lProp => Eq - | lProp, _ => Lt - | _, lProp => Gt - | lSProp, lSProp => Eq - | lSProp, _ => Lt - | _, lSProp => Gt - | lType x, lType y => LevelExprSet.compare x y - end. - Lemma compare_spec x y : CompareSpec (eq x y) (lt x y) (lt y x) (compare x y). - Proof. - cbv [compare eq]. - destruct x, y. - all: lazymatch goal with - | [ |- context[LevelExprSet.compare ?x ?y] ] - => destruct (LevelExprSet.compare_spec x y) - | _ => idtac - end. - all: lazymatch goal with - | [ H : LevelExprSet.eq (?f ?x) (?f ?y) |- _ ] - => apply LevelExprSet.eq_leibniz in H; - is_var x; is_var y; destruct x, y; cbn in H; subst - | _ => idtac - end. - all: repeat constructor; try apply f_equal; try assumption. - f_equal; apply Eqdep_dec.UIP_dec; decide equality. - Qed. - Definition eq_dec (x y : t) : {x = y} + {x <> y}. - Proof. repeat decide equality. apply LevelAlgExpr.eq_dec_univ0. Defined. - End OT. - Module OTOrig <: OrderedTypeOrig := Backport_OT OT. -End Universe. - -Module UniverseMap := FMapAVL.Make Universe.OTOrig. -Module UniverseMapFact := FMapFacts.WProperties UniverseMap. -Module UniverseMapExtraFact := FSets.WFactsExtra_fun Universe.OTOrig UniverseMap UniverseMapFact.F. -Module UniverseMapDecide := FMapAVL.Decide Universe.OTOrig UniverseMap. + Lemma subset_spec s s' : subset s s' <-> Subset s s'. + Proof. + rewrite /subset/Subset/is_true Bool.andb_true_iff LevelSet.subset_spec ConstraintSet.subset_spec. + reflexivity. + Qed. -Definition is_propositional u := - Universe.is_prop u || Universe.is_sprop u. + Lemma subsetP s s' : reflect (Subset s s') (subset s s'). + Proof. + generalize (subset_spec s s'). + destruct subset; case; constructor; intuition. + Qed. +End ContextSet. -Notation "⟦ u ⟧_ v" := (Universe.to_cuniv v u) (at level 0, format "⟦ u ⟧_ v", v name) : univ_scope. +Export (hints) ContextSet. +Notation "(=_cs)" := ContextSet.Equal (at level 0). +Notation "(⊂_cs)" := ContextSet.Subset (at level 0). +Infix "=_cs" := ContextSet.Equal (at level 30). +Infix "⊂_cs" := ContextSet.Subset (at level 30). +Notation "(==_cs)" := ContextSet.equal (at level 0). +Notation "(⊂?_cs)" := ContextSet.subset (at level 0). +Infix "==_cs" := ContextSet.equal (at level 30). +Infix "⊂?_cs" := ContextSet.subset (at level 30). -Lemma val_universe_sup v u1 u2 : - Universe.to_cuniv v (Universe.sup u1 u2) = cuniv_sup (Universe.to_cuniv v u1) (Universe.to_cuniv v u2). +Lemma incl_cs_refl cs : cs ⊂_cs cs. Proof. - destruct u1 as [ | | l1]; destruct u2 as [ | | l2];cbn;try lia; auto. - f_equal. apply val_sup. + split; [lsets|csets]. Qed. -Lemma is_prop_val u : - Universe.is_prop u -> forall v, Universe.to_cuniv v u = UProp. +Lemma incl_cs_trans cs1 cs2 cs3 : cs1 ⊂_cs cs2 -> cs2 ⊂_cs cs3 -> cs1 ⊂_cs cs3. Proof. - destruct u as [| | u];try discriminate;auto. + intros [? ?] [? ?]; split; [lsets|csets]. Qed. -Lemma is_sprop_val u : - Universe.is_sprop u -> forall v, Universe.to_cuniv v u = USProp. +Lemma empty_contextset_subset u : ContextSet.empty ⊂_cs u. Proof. - destruct u as [| | u];try discriminate;auto. + red. split; cbn; [lsets|csets]. Qed. -(* -Lemma val_zero_exprs v (l : LevelAlgExpr.t) : 0 <= val v l. -Proof. - rewrite val_fold_right. - destruct (LevelAlgExpr.exprs l) as [e u']; clear l; cbn. - induction (List.rev u'); simpl. - - destruct e as [npl_expr]. - destruct npl_expr as [t b]. - cbn. - assert (0 <= val v t) by apply Level.val_zero. - destruct b;lia. - - pose proof (LevelExpr.val_zero a v); lia. -Qed. *) +(* Variance info is needed to do full universe polymorphism *) +Module Variance. + (** A universe position in the instance given to a cumulative + inductive can be the following. Note there is no Contralvariant + case because [forall x : A, B <= forall x : A', B'] requires [A = + A'] as opposed to [A' <= A]. *) + Inductive t := + | Irrelevant : t + | Covariant : t + | Invariant : t. + Derive NoConfusion EqDec for t. + (* val check_subtype : t -> t -> bool *) + (* val sup : t -> t -> t *) +End Variance. -Lemma val_is_prop u v : - Universe.to_cuniv v u = UProp <-> Universe.is_prop u. -Proof. - destruct u; auto;cbn in *; intuition congruence. -Qed. +(** What to check of two instances *) +Variant opt_variance := + AllEqual | AllIrrelevant | Variance of list Variance.t. -Lemma val_is_sprop u v : - Universe.to_cuniv v u = USProp <-> Universe.is_sprop u. -Proof. - destruct u;auto;cbn in *; intuition congruence. -Qed. +Inductive universes_decl : Type := +| Monomorphic_ctx +| Polymorphic_ctx (cst : AUContext.t). -Lemma is_prop_and_is_sprop_val_false u : - Universe.is_prop u = false -> Universe.is_sprop u = false -> - forall v, ∑ n, Universe.to_cuniv v u = UType n. -Proof. - intros Hp Hsp v. - destruct u; try discriminate. simpl. eexists; eauto. -Qed. +Derive NoConfusion for universes_decl. -Lemma val_is_prop_false u v n : - Universe.to_cuniv v u = UType n -> Universe.is_prop u = false. -Proof. - pose proof (is_prop_val u) as H. destruct (Universe.is_prop u); cbnr. - rewrite (H eq_refl v). discriminate. -Qed. +Definition levels_of_udecl u := + match u with + | Monomorphic_ctx => LevelSet.empty + | Polymorphic_ctx ctx => AUContext.levels ctx + end. -Lemma get_is_level_correct u l : - Universe.get_is_level u = Some l -> u = Universe.lType (LevelAlgExpr.make' l). -Proof. - intro H; destruct u; cbnr; try discriminate. - f_equal; now apply levelalg_get_is_level_correct. +Definition constraints_of_udecl u := + match u with + | Monomorphic_ctx => ConstraintSet.empty + | Polymorphic_ctx ctx => snd (snd (AUContext.repr ctx)) + end. + +Declare Scope univ_scope. +Delimit Scope univ_scope with u. + +Inductive satisfies0 (v : valuation) : UnivConstraint.t -> Prop := +| satisfies0_Lt (l l' : Level.t) (z : Z) : (Z.of_nat (val v l) <= Z.of_nat (val v l') - z)%Z + -> satisfies0 v (l, ConstraintType.Le z, l') +| satisfies0_Eq (l l' : Level.t) : val v l = val v l' + -> satisfies0 v (l, ConstraintType.Eq, l'). + +Definition satisfies v : ConstraintSet.t -> Prop := + ConstraintSet.For_all (satisfies0 v). + +Lemma satisfies_union v φ1 φ2 : + satisfies v (CS.union φ1 φ2) + <-> (satisfies v φ1 /\ satisfies v φ2). +Proof using Type. + unfold satisfies. split. + - intros H; split; intros c Hc; apply H; now apply CS.union_spec. + - intros [H1 H2] c Hc; apply CS.union_spec in Hc; destruct Hc; auto. Qed. -Lemma eqb_true_iff u v : - Universe.eqb u v <-> u = v. -Proof. - split. 2: intros ->; apply Universe.eqb_refl. - intro H. - destruct u, v;auto;try discriminate. - apply f_equal. now apply univ_expr_eqb_true_iff. +Lemma satisfies_subset φ φ' val : + ConstraintSet.Subset φ φ' -> + satisfies val φ' -> + satisfies val φ. +Proof using Type. + intros sub sat ? isin. + apply sat, sub; auto. Qed. -Lemma sup_comm x1 x2 : - Universe.sup x1 x2 = Universe.sup x2 x1. -Proof. - destruct x1,x2;auto. - cbn;apply f_equal;apply sup0_comm. +Definition consistent ctrs := exists v, satisfies v ctrs. + +Definition consistent_extension_on cs cstr := + forall v, satisfies v (ContextSet.constraints cs) -> exists v', + satisfies v' cstr /\ + LevelSet.For_all (fun l => val v l = val v' l) (ContextSet.levels cs). + +Lemma consistent_extension_on_empty Σ : + consistent_extension_on Σ CS.empty. +Proof using Type. + move=> v hv; exists v; split; [move=> ? /CS.empty_spec[]| move=> ??//]. Qed. -Lemma is_not_prop_and_is_not_sprop u : - Universe.is_prop u = false -> Universe.is_sprop u = false -> - ∑ u', u = Universe.lType u'. -Proof. - intros Hp Hsp. - destruct u; try discriminate. now eexists. +Lemma consistent_extension_on_union X cstrs + (wfX : forall c, CS.In c X.2 -> LS.In c.1.1 X.1 /\ LS.In c.2 X.1) : + consistent_extension_on X cstrs <-> + consistent_extension_on X (CS.union cstrs X.2). +Proof using Type. + split. + 2: move=> h v /h [v' [/satisfies_union [??] eqv']]; exists v'; split=> //. + move=> hext v /[dup] vsat /hext [v' [v'sat v'eq]]. + exists v'; split=> //. + apply/satisfies_union; split=> //. + move=> c hc. destruct (wfX c hc). + destruct (vsat c hc); constructor; rewrite -!v'eq //. Qed. -Lemma is_prop_sort_sup x1 x2 : - Universe.is_prop (Universe.sup x1 x2) - -> Universe.is_prop x2 \/ Universe.is_sprop x2 . -Proof. destruct x1,x2;auto. Qed. -Lemma is_prop_sort_sup' x1 x2 : - Universe.is_prop (Universe.sup x1 x2) - -> Universe.is_prop x1 \/ Universe.is_sprop x1 . -Proof. destruct x1,x2;auto. Qed. +Definition leq0_universe_n n φ (u u' : Universe.t) := + forall v, satisfies v φ -> (Z.of_nat (val v u) <= Z.of_nat (val v u') - n)%Z. -Lemma is_prop_or_sprop_sort_sup x1 x2 : - Universe.is_sprop (Universe.sup x1 x2) -> Universe.is_sprop x2. -Proof. destruct x1,x2;auto. Qed. +Definition leq_universe_n {cf} n φ (u u' : Universe.t) := + if check_univs then leq0_universe_n n φ u u' else True. -Lemma is_prop_sort_sup_prop x1 x2 : - Universe.is_prop x1 && Universe.is_prop x2 -> - Universe.is_prop (Universe.sup x1 x2). -Proof. destruct x1,x2;auto. Qed. +Definition lt_universe {cf} := leq_universe_n 1. +Definition leq_universe {cf} := leq_universe_n 0. -Lemma is_prop_or_sprop_sort_sup_prop x1 x2 : - Universe.is_sprop x1 && Universe.is_sprop x2 -> - Universe.is_sprop (Universe.sup x1 x2). -Proof. destruct x1,x2;auto. Qed. +Definition eq0_universe φ (u u' : Universe.t) := + forall v, satisfies v φ -> val v u = val v u'. -Lemma is_prop_sup u s : - Universe.is_prop (Universe.sup u s) -> - (Universe.is_prop u \/ Universe.is_sprop u) /\ - (Universe.is_prop s \/ Universe.is_sprop s). -Proof. destruct u,s;auto. Qed. +Definition eq_universe {cf} φ (u u' : Universe.t) := + if check_univs then eq0_universe φ u u' else True. -Lemma is_sprop_sup_iff u s : - Universe.is_sprop (Universe.sup u s) <-> - (Universe.is_sprop u /\ Universe.is_sprop s). -Proof. split;destruct u,s;intuition. Qed. +(* ctrs are "enforced" by φ *) -Lemma is_type_sup_r s1 s2 : - Universe.is_type_sort s2 -> - Universe.is_type_sort (Universe.sup s1 s2). -Proof. destruct s2; try absurd; destruct s1; cbnr; intros; absurd. Qed. +Definition valid_constraints0 φ ctrs + := forall v, satisfies v φ -> satisfies v ctrs. -Lemma is_prop_sort_prod x2 x3 : - Universe.is_prop (Universe.sort_of_product x2 x3) - -> Universe.is_prop x3. -Proof. - unfold Universe.sort_of_product. - destruct x3;cbn;auto. - intros;simpl in *;destruct x2;auto. -Qed. +Definition valid_constraints {cf} φ ctrs + := if check_univs then valid_constraints0 φ ctrs else True. -Lemma is_sprop_sort_prod x2 x3 : - Universe.is_sprop (Universe.sort_of_product x2 x3) - -> Universe.is_sprop x3. -Proof. - unfold Universe.sort_of_product. - destruct x3;cbn;auto. - intros;simpl in *;destruct x2;auto. -Qed. +Definition compare_universe {cf} φ (pb : conv_pb) := + match pb with + | Conv => eq_universe φ + | Cumul => leq_universe φ + end. -Module ConstraintType. - Inductive t_ : Set := Le (z : Z) | Eq. - Derive NoConfusion EqDec for t_. - Definition t := t_. - Definition eq : t -> t -> Prop := eq. - Definition eq_equiv : Equivalence eq := _. +Ltac unfold_univ_rel0 := + unfold eq0_universe, leq0_universe_n, valid_constraints0 in *; + try ( + match goal with |- forall v : valuation, _ -> _ => idtac end; + intros v Hv; + repeat match goal with H : forall v : valuation, _ -> _ |- _ => specialize (H v Hv) end; + cbnr + ). - Definition Le0 := Le 0. - Definition Lt := Le 1. +Ltac unfold_univ_rel := + unfold eq_universe, leq_universe, lt_universe, leq_universe_n, valid_constraints in *; + destruct check_univs; [unfold_univ_rel0 | trivial]. - Inductive lt_ : t -> t -> Prop := - | LeLe n m : (n < m)%Z -> lt_ (Le n) (Le m) - | LeEq n : lt_ (Le n) Eq. - Derive Signature for lt_. - Definition lt := lt_. +Section Univ. + Context {cf}. - Global Instance lt_strorder : StrictOrder lt. - Proof. - constructor. - - intros []; intro X; inversion X. lia. - - intros ? ? ? X Y; invs X; invs Y; constructor. lia. + Lemma valid_subset φ φ' ctrs + : ConstraintSet.Subset φ φ' -> valid_constraints φ ctrs + -> valid_constraints φ' ctrs. + Proof using Type. + unfold_univ_rel. + intros Hφ H v Hv. apply H. + intros ctr Hc. apply Hv. now apply Hφ. Qed. - Global Instance lt_compat : Proper (eq ==> eq ==> iff) lt. - Proof. - intros ? ? X ? ? Y; invs X; invs Y. reflexivity. + Lemma switch_minus (x y z : Z) : (x <= y - z <-> x + z <= y)%Z. + Proof using Type. split; lia. Qed. + + (** **** Lemmas about eq and leq **** *) + + Global Instance eq_universe_refl φ : Reflexive (eq_universe φ). + Proof using Type. + intros u; unfold_univ_rel. Qed. - Definition compare (x y : t) : comparison := - match x, y with - | Le n, Le m => Z.compare n m - | Le _, Eq => Datatypes.Lt - | Eq, Eq => Datatypes.Eq - | Eq, _ => Datatypes.Gt - end. + Global Instance leq_universe_refl φ : Reflexive (leq_universe φ). + Proof using Type. + intros u; unfold_univ_rel. lia. + Qed. - Lemma compare_spec x y : CompareSpec (eq x y) (lt x y) (lt y x) (compare x y). - Proof. - destruct x, y; repeat constructor. simpl. - destruct (Z.compare_spec z z0); simpl; constructor. - subst; constructor. now constructor. now constructor. + Global Instance eq_universe_sym φ : Symmetric (eq_universe φ). + Proof using Type. + intros u u' H; unfold_univ_rel. + lia. Qed. - Lemma eq_dec x y : {eq x y} + {~ eq x y}. - Proof. - unfold eq. decide equality. apply Z.eq_dec. + Global Instance eq_universe_trans φ : Transitive (eq_universe φ). + Proof using Type. + intros u u' u'' H1 H2; unfold_univ_rel. + lia. Qed. -End ConstraintType. -Module UnivConstraint. - Definition t : Set := Level.t * ConstraintType.t * Level.t. + Global Instance leq_universe_n_trans n φ : Transitive (leq_universe_n (Z.of_nat n) φ). + Proof using Type. + intros u u' u'' H1 H2; unfold_univ_rel. + lia. + Qed. - Definition eq : t -> t -> Prop := eq. - Definition eq_equiv : Equivalence eq := _. + Global Instance leq_universe_trans φ : Transitive (leq_universe φ). + Proof using Type. apply (leq_universe_n_trans 0). Qed. - Definition make l1 ct l2 : t := (l1, ct, l2). + Global Instance lt_universe_trans φ : Transitive (lt_universe φ). + Proof using Type. apply (leq_universe_n_trans 1). Qed. - Inductive lt_ : t -> t -> Prop := - | lt_Level2 l1 t l2 l2' : Level.lt l2 l2' -> lt_ (l1, t, l2) (l1, t, l2') - | lt_Cstr l1 t t' l2 l2' : ConstraintType.lt t t' -> lt_ (l1, t, l2) (l1, t', l2') - | lt_Level1 l1 l1' t t' l2 l2' : Level.lt l1 l1' -> lt_ (l1, t, l2) (l1', t', l2'). - Definition lt := lt_. + Lemma eq0_leq0_universe φ u u' : + eq0_universe φ u u' <-> leq0_universe_n 0 φ u u' /\ leq0_universe_n 0 φ u' u. + Proof using Type. + split. + - intros H. split; unfold_univ_rel0; lia. + - intros [H1 H2]. unfold_univ_rel0; lia. + Qed. - Lemma lt_strorder : StrictOrder lt. - Proof. - constructor. - - intros []; intro X; inversion X; subst; - try (eapply Level.lt_strorder; eassumption). - eapply ConstraintType.lt_strorder; eassumption. - - intros ? ? ? X Y; invs X; invs Y; constructor; tea. - etransitivity; eassumption. - 2: etransitivity; eassumption. - eapply ConstraintType.lt_strorder; eassumption. + Lemma eq_universe_leq_universe φ u u' : + eq_universe φ u u' <-> leq_universe φ u u' /\ leq_universe φ u' u. + Proof using Type. + unfold_univ_rel => //. + apply eq0_leq0_universe. Qed. - Lemma lt_compat : Proper (eq ==> eq ==> iff) lt. - Proof. - intros ? ? X ? ? Y; invs X; invs Y. reflexivity. + Lemma leq_universe_sup_l φ u1 u2 : leq_universe φ u1 (Universe.sup u1 u2). + Proof using Type. unfold_univ_rel. rewrite val_sup; lia. Qed. + + Lemma leq_universe_sup_r φ u1 u2 : leq_universe φ u2 (Universe.sup u1 u2). + Proof using Type. unfold_univ_rel. rewrite val_sup; lia. Qed. + + Lemma leq_universe_sup_mon φ u1 u1' u2 u2' : leq_universe φ u1 u1' -> leq_universe φ u2 u2' -> + leq_universe φ (Universe.sup u1 u2) (Universe.sup u1' u2'). + Proof using Type. + intros H1 H2; unfold_univ_rel. + rewrite !val_sup. lia. Qed. - Definition compare : t -> t -> comparison := - fun '(l1, t, l2) '(l1', t', l2') => - compare_cont (Level.compare l1 l1') - (compare_cont (ConstraintType.compare t t') - (Level.compare l2 l2')). + Global Instance eq_leq_universe φ : subrelation (eq_universe φ) (leq_universe φ). + Proof using Type. + intros u u'. apply eq_universe_leq_universe. + Qed. - Lemma compare_spec x y - : CompareSpec (eq x y) (lt x y) (lt y x) (compare x y). + Global Instance eq_universe_equivalence φ : Equivalence (eq_universe φ) := Build_Equivalence _ _ _ _. + + Global Instance leq_universe_preorder φ : PreOrder (leq_universe φ) := Build_PreOrder _ _ _. + + Global Instance lt_universe_irrefl {c: check_univs} φ (H: consistent φ) : Irreflexive (lt_universe φ). + Proof using Type. + intro u. unfold complement. + unfold_univ_rel => //. + destruct H as [v Hv]; intros nH; specialize (nH v Hv); lia. + Qed. + + Global Instance lt_universe_str_order {c: check_univs} φ (H: consistent φ) : StrictOrder (lt_universe φ). Proof. - destruct x as [[l1 t] l2], y as [[l1' t'] l2']; cbn. - destruct (Level.compare_spec l1 l1'); cbn; repeat constructor; tas. - invs H. - destruct (ConstraintType.compare_spec t t'); cbn; repeat constructor; tas. - invs H. - destruct (Level.compare_spec l2 l2'); cbn; repeat constructor; tas. - invs H. reflexivity. + refine (Build_StrictOrder _ _ _). + now unshelve eapply lt_universe_irrefl. Qed. - Lemma eq_dec x y : {eq x y} + {~ eq x y}. + Global Instance leq_universe_antisym φ : Antisymmetric _ (eq_universe φ) (leq_universe φ). + Proof using Type. intros t u tu ut. now apply eq_universe_leq_universe. Qed. + + Global Instance leq_universe_partial_order φ + : PartialOrder (eq_universe φ) (leq_universe φ). Proof. - unfold eq. decide equality; apply eq_dec. + intros x y; split; apply eq_universe_leq_universe. Defined. - Definition eq_leibniz (x y : t) : eq x y -> x = y := id. -End UnivConstraint. -Module ConstraintSet := MSetAVL.Make UnivConstraint. -Module ConstraintSetFact := WFactsOn UnivConstraint ConstraintSet. -Module ConstraintSetOrdProp := MSetProperties.OrdProperties ConstraintSet. -Module ConstraintSetProp := ConstraintSetOrdProp.P. -Module CS := ConstraintSet. -Module ConstraintSetDecide := ConstraintSetProp.Dec. -Module ConstraintSetExtraOrdProp := MSets.ExtraOrdProperties ConstraintSet ConstraintSetOrdProp. -Module ConstraintSetExtraDecide := MSetAVL.Decide UnivConstraint ConstraintSet. -Ltac csets := ConstraintSetDecide.fsetdec. + Global Instance compare_universe_subrel φ pb : subrelation (eq_universe φ) (compare_universe φ pb). + Proof using Type. + destruct pb; tc. + Qed. -Notation "(=_cset)" := ConstraintSet.Equal (at level 0). -Infix "=_cset" := ConstraintSet.Equal (at level 30). -Notation "(==_cset)" := ConstraintSet.equal (at level 0). -Infix "==_cset" := ConstraintSet.equal (at level 30). + Global Instance compare_universe_refl φ pb : Reflexive (compare_universe φ pb). + Proof using Type. + destruct pb; tc. + Qed. -Definition declared_cstr_levels levels (cstr : UnivConstraint.t) := - let '(l1,_,l2) := cstr in - LevelSet.In l1 levels /\ LevelSet.In l2 levels. + Global Instance compare_universe_trans φ pb : Transitive (compare_universe φ pb). + Proof using Type. + destruct pb; tc. + Qed. -Definition is_declared_cstr_levels levels (cstr : UnivConstraint.t) : bool := - let '(l1,_,l2) := cstr in - LevelSet.mem l1 levels && LevelSet.mem l2 levels. + Global Instance compare_universe_preorder φ pb : PreOrder (compare_universe φ pb). + Proof using Type. + destruct pb; tc. + Qed. -Lemma CS_union_empty s : ConstraintSet.union ConstraintSet.empty s =_cset s. -Proof. - intros x; rewrite ConstraintSet.union_spec. lsets. -Qed. + Definition eq_leq_universe' φ u u' + := @eq_leq_universe φ u u'. + Definition leq_universe_refl' φ u + := @leq_universe_refl φ u. -Lemma CS_For_all_union f cst cst' : ConstraintSet.For_all f (ConstraintSet.union cst cst') -> - ConstraintSet.For_all f cst. -Proof. - unfold CS.For_all. - intros IH x inx. apply (IH x). - now eapply CS.union_spec; left. -Qed. + Hint Resolve eq_leq_universe' leq_universe_refl' : core. -Lemma CS_For_all_add P x s : CS.For_all P (CS.add x s) -> P x /\ CS.For_all P s. -Proof. - intros. - split. - * apply (H x), CS.add_spec; left => //. - * intros y iny. apply (H y), CS.add_spec; right => //. -Qed. -#[global] Instance CS_For_all_proper P : Morphisms.Proper ((=_cset) ==> iff)%signature (ConstraintSet.For_all P). -Proof. - intros s s' eqs. - unfold CS.For_all. split; intros IH x inxs; apply (IH x); - now apply eqs. -Qed. + Lemma cmp_universe_subset φ φ' pb t u : + ConstraintSet.Subset φ φ' -> compare_universe φ pb t u -> compare_universe φ' pb t u. + Proof using Type. + intros Hctrs. + destruct pb, t, u; cbnr; trivial. + all: intros H; unfold_univ_rel; + apply H. + all: eapply satisfies_subset; eauto. + Qed. -(** {6 Universe instances} *) + Lemma eq_universe_subset φ φ' t u + : ConstraintSet.Subset φ φ' + -> eq_universe φ t u -> eq_universe φ' t u. + Proof using Type. apply cmp_universe_subset with (pb := Conv). Qed. -Module Instance. + Lemma leq_universe_subset φ φ' t u + : ConstraintSet.Subset φ φ' + -> leq_universe φ t u -> leq_universe φ' t u. + Proof using Type. apply cmp_universe_subset with (pb := Cumul). Qed. - (** A universe instance represents a vector of argument concreteUniverses - to a polymorphic definition (constant, inductive or constructor). *) - Definition t : Set := list Level.t. +End Univ. - Definition empty : t := []. - Definition is_empty (i : t) : bool := - match i with - | [] => true - | _ => false - end. +Module Sort. + Inductive t_ {univ} := + sProp | sSProp | sType (_ : univ). + Derive NoConfusion for t_. + Arguments t_ : clear implicits. - Definition eqb (i j : t) := - forallb2 Level.eqb i j. + Definition t := t_ Universe.t. - Definition equal_upto (f : Level.t -> Level.t -> bool) (i j : t) := - forallb2 f i j. -End Instance. + Inductive family : Set := + | fSProp + | fProp + | fType. + Derive NoConfusion EqDec for family. -Module UContext. - Definition t := list name × (Instance.t × ConstraintSet.t). + Definition eqb {univ} `{ReflectEq univ} (u1 u2 : t_ univ) : bool := + match u1, u2 with + | sSProp, sSProp => true + | sProp, sProp => true + | sType e1, sType e2 => eqb e1 e2 + | _, _ => false + end. - Definition make' : Instance.t -> ConstraintSet.t -> Instance.t × ConstraintSet.t := pair. - Definition make (ids : list name) (inst_ctrs : Instance.t × ConstraintSet.t) : t := (ids, inst_ctrs). + #[global, program] Instance reflect_eq_sort {univ} `{ReflectEq univ} : ReflectEq (t_ univ) := + { eqb := eqb }. + Next Obligation. + destruct x, y; cbn; try constructor; auto; try congruence. + destruct (eqb_spec u u0); constructor. now f_equal. + congruence. + Qed. - Definition empty : t := ([], (Instance.empty, ConstraintSet.empty)). + #[global] Instance eq_dec_sort {univ} `{EqDec univ} : EqDec (t_ univ) := ltac:(intros s s'; decide equality). - Definition instance : t -> Instance.t := fun x => fst (snd x). - Definition constraints : t -> ConstraintSet.t := fun x => snd (snd x). + Definition on_sort {univ} {T} (P: univ -> T) (def: T) (s : t_ univ) := + match s with + | sProp | sSProp => def + | sType l => P l + end. - Definition dest : t -> list name * (Instance.t * ConstraintSet.t) := fun x => x. -End UContext. + (** Test if the universe is a lub of levels or contains +n's. *) + Definition is_levels (s : t) : bool := + match s with + | sSProp | sProp => true + | sType l => Universe.is_levels l + end. -Module AUContext. - Definition t := list name × ConstraintSet.t. + (** Test if the universe is a level or an algebraic universe. *) + Definition is_level (s : t) : bool := + match s with + | sSProp | sProp => true + | sType l => Universe.is_level l + end. - Definition make (ids : list name) (ctrs : ConstraintSet.t) : t := (ids, ctrs). - Definition repr (x : t) : UContext.t := - let (u, cst) := x in - (u, (mapi (fun i _ => Level.lvar i) u, cst)). + Definition is_sprop {univ} (s : t_ univ) : bool := + match s with + | sSProp => true + | _ => false + end. - Definition levels (uctx : t) : LevelSet.t := - LevelSetProp.of_list (fst (snd (repr uctx))). + Definition is_prop {univ} (s : t_ univ) : bool := + match s with + | sProp => true + | _ => false + end. - #[local] - Existing Instance EqDec_ReflectEq. - Definition inter (au av : AUContext.t) : AUContext.t := - let prefix := (split_prefix au.1 av.1).1.1 in - let lvls := fold_left_i (fun s i _ => LevelSet.add (Level.lvar i) s) prefix LevelSet.empty in - let filter := ConstraintSet.filter (is_declared_cstr_levels lvls) in - make prefix (ConstraintSet.union (filter au.2) (filter av.2)). -End AUContext. + Definition is_propositional {univ} (s : t_ univ) : bool := + match s with + | sProp | sSProp => true + | _ => false + end. -Module ContextSet. - Definition t := LevelSet.t × ConstraintSet.t. + Lemma is_prop_propositional {univ} (s : t_ univ) : + is_prop s -> is_propositional s. + Proof. now destruct s. Qed. + Lemma is_sprop_propositional {univ} (s : t_ univ) : + is_sprop s -> is_propositional s. + Proof. now destruct s. Qed. - Definition levels : t -> LevelSet.t := fst. - Definition constraints : t -> ConstraintSet.t := snd. + Definition is_type_sort {univ} (s : t_ univ) : bool := + match s with + | sType _ => true + | _ => false + end. - Definition empty : t := (LevelSet.empty, ConstraintSet.empty). + Definition type0 : t := sType (Universe.make LevelExpr.set). + Definition type1 : t := sType (Universe.make LevelExpr.type1). - Definition is_empty (uctx : t) - := LevelSet.is_empty (fst uctx) && ConstraintSet.is_empty (snd uctx). + Definition of_levels (l : PropLevel.t + Level.t) : t := + match l with + | inl PropLevel.lSProp => sSProp + | inl PropLevel.lProp => sProp + | inr l => sType (Universe.make' l) + end. - Definition Equal (x y : t) : Prop := - x.1 =_lset y.1 /\ x.2 =_cset y.2. + (** The universe strictly above FOR TYPING (not cumulativity) *) - Definition equal (x y : t) : bool := - x.1 ==_lset y.1 && x.2 ==_cset y.2. + Definition super_ {univ} type1 univ_succ (s : t_ univ) : t_ univ := + match s with + | sSProp | sProp => sType type1 + | sType l => sType (univ_succ l) + end. + Definition super : t -> t := super_ (Universe.make LevelExpr.type1) Universe.succ. + Definition csuper := super_ 1 S. - Definition Subset (x y : t) : Prop := - LevelSet.Subset (levels x) (levels y) /\ - ConstraintSet.Subset (constraints x) (constraints y). + Definition sup_ {univ} univ_sup (s s' : t_ univ) : t_ univ := + match s, s' with + | sSProp, s' => s' + | sProp, sSProp => sProp + | sProp, s' => s' + | sType u1, sType u2 => sType (univ_sup u1 u2) + | sType _ as s, _ => s + end. + Definition sup : t -> t -> t := sup_ Universe.sup. + Definition csup := sup_ Nat.max. - Definition subset (x y : t) : bool := - LevelSet.subset (levels x) (levels y) && - ConstraintSet.subset (constraints x) (constraints y). + (** Type of a product *) + Definition sort_of_product_ {univ} univ_sup (domsort rangsort : t_ univ) : t_ univ := + match rangsort with + | sSProp | sProp => rangsort + (* Prop and SProp impredicativity *) + | _ => Sort.sup_ univ_sup domsort rangsort + end. + Definition sort_of_product : t -> t -> t := sort_of_product_ Universe.sup. + Definition csort_of_product := sort_of_product_ Nat.max. - Definition inter (x y : t) : t := - (LevelSet.inter (levels x) (levels y), - ConstraintSet.inter (constraints x) (constraints y)). + Definition get_is_level (s : t) : option Level.t := + match s with + | sSProp => None + | sProp => None + | sType l => Universe.get_is_level l + end. - Definition inter_spec (x y : t) : - Subset (inter x y) x /\ - Subset (inter x y) y /\ - forall z, Subset z x -> Subset z y -> Subset z (inter x y). - Proof. - split; last split. - 1,2: split=> ?; [move=> /LevelSet.inter_spec [//]|move=> /ConstraintSet.inter_spec [//]]. - move=> ? [??] [??]; split=> ??; - [apply/LevelSet.inter_spec|apply/ConstraintSet.inter_spec]; split; auto. - Qed. + Definition to_family {univ} (s : t_ univ) := + match s with + | sSProp => fSProp + | sProp => fProp + | sType _ => fType + end. - Definition union (x y : t) : t := - (LevelSet.union (levels x) (levels y), ConstraintSet.union (constraints x) (constraints y)). + Definition to_csort v s := + match s with + | sSProp => sSProp + | sProp => sProp + | sType u => sType (val v u) + end. - Definition union_spec (x y : t) : - Subset x (union x y) /\ - Subset y (union x y) /\ - forall z, Subset x z -> Subset y z -> Subset (union x y) z. + Lemma to_family_to_csort s v : + to_family (to_csort v s) = to_family s. Proof. - split; last split. - 1,2: split=> ??; [apply/LevelSet.union_spec|apply/ConstraintSet.union_spec ]; by constructor. - move=> ? [??] [??]; split=> ?; - [move=>/LevelSet.union_spec|move=>/ConstraintSet.union_spec]=>-[]; auto. + destruct s; cbnr. Qed. - Lemma equal_spec s s' : equal s s' <-> Equal s s'. - Proof. - rewrite /equal/Equal/is_true Bool.andb_true_iff LevelSet.equal_spec ConstraintSet.equal_spec. - reflexivity. - Qed. + Lemma sType_super_ {univ type1 univ_succ} (s : t_ univ) : + to_family (super_ type1 univ_succ s) = fType. + Proof. now destruct s. Qed. - Lemma subset_spec s s' : subset s s' <-> Subset s s'. - Proof. - rewrite /subset/Subset/is_true Bool.andb_true_iff LevelSet.subset_spec ConstraintSet.subset_spec. - reflexivity. - Qed. + Lemma sType_super (s : t) : + to_family (super s) = fType. + Proof. apply sType_super_. Qed. - Lemma subsetP s s' : reflect (Subset s s') (subset s s'). - Proof. - generalize (subset_spec s s'). - destruct subset; case; constructor; intuition. - Qed. -End ContextSet. + Inductive lt_ {univ univ_lt} : t_ univ -> t_ univ -> Prop := + | ltPropSProp : lt_ sProp sSProp + | ltPropType s : lt_ sProp (sType s) + | ltSPropType s : lt_ sSProp (sType s) + | ltTypeType s1 s2 : univ_lt s1 s2 -> lt_ (sType s1) (sType s2). + Derive Signature for lt_. + Arguments lt_ {univ} univ_lt. -Export (hints) ContextSet. + Definition lt := lt_ Universe.lt. + Definition clt := lt_ Nat.lt. -Notation "(=_cs)" := ContextSet.Equal (at level 0). -Notation "(⊂_cs)" := ContextSet.Subset (at level 0). -Infix "=_cs" := ContextSet.Equal (at level 30). -Infix "⊂_cs" := ContextSet.Subset (at level 30). -Notation "(==_cs)" := ContextSet.equal (at level 0). -Notation "(⊂?_cs)" := ContextSet.subset (at level 0). -Infix "==_cs" := ContextSet.equal (at level 30). -Infix "⊂?_cs" := ContextSet.subset (at level 30). + Module OT <: OrderedType. + Definition t := t. + #[local] Definition eq : t -> t -> Prop := eq. + #[local] Definition eq_equiv : Equivalence eq := _. + Definition lt := lt. + #[local] Instance lt_strorder : StrictOrder lt. + Proof. + constructor. + - intros [| |] X; inversion X. + now eapply irreflexivity in H1. + - intros [| |] [| |] [| |] X1 X2; + inversion X1; inversion X2; constructor. + subst. + etransitivity; tea. + Qed. -Lemma incl_cs_refl cs : cs ⊂_cs cs. + Definition lt_compat : Proper (eq ==> eq ==> iff) lt. + Proof. + intros x y e z t e'. hnf in * |- ; subst. reflexivity. + Qed. + Definition compare (x y : t) : comparison + := match x, y with + | sProp, sProp => Eq + | sProp, _ => Lt + | _, sProp => Gt + | sSProp, sSProp => Eq + | sSProp, _ => Lt + | _, sSProp => Gt + | sType x, sType y => LevelExprSet.compare x y + end. + Lemma compare_spec x y : CompareSpec (eq x y) (lt x y) (lt y x) (compare x y). + Proof. + cbv [compare eq]. + destruct x, y. + all: lazymatch goal with + | [ |- context[LevelExprSet.compare ?x ?y] ] + => destruct (LevelExprSet.compare_spec x y) + | _ => idtac + end. + all: lazymatch goal with + | [ H : LevelExprSet.eq (?f ?x) (?f ?y) |- _ ] + => apply LevelExprSet.eq_leibniz in H; + is_var x; is_var y; destruct x, y; cbn in H; subst + | _ => idtac + end. + all: repeat constructor; try apply f_equal; try assumption. + f_equal; apply Eqdep_dec.UIP_dec; decide equality. + Qed. + Definition eq_dec (x y : t) : {x = y} + {x <> y}. + Proof. repeat decide equality. apply Universe.eq_dec_univ0. Defined. + End OT. + Module OTOrig <: OrderedTypeOrig := Backport_OT OT. +End Sort. + + +Module SortMap := FMapAVL.Make Sort.OTOrig. +Module SortMapFact := FMapFacts.WProperties SortMap. +Module SortMapExtraFact := FSets.WFactsExtra_fun Sort.OTOrig SortMap SortMapFact.F. +Module SortMapDecide := FMapAVL.Decide Sort.OTOrig SortMap. + +Notation sProp := Sort.sProp. +Notation sSProp := Sort.sSProp. +Notation sType := Sort.sType. +Notation sort := Sort.t. + +Notation "⟦ u ⟧_ v" := (Sort.to_csort v u) (at level 0, format "⟦ u ⟧_ v", v name) : univ_scope. + + +Lemma val_sort_sup v s1 s2 : + Sort.to_csort v (Sort.sup s1 s2) = Sort.csup (Sort.to_csort v s1) (Sort.to_csort v s2). Proof. - split; [lsets|csets]. + destruct s1 as [ | | u1]; destruct s2 as [ | | u2]; cbnr. + f_equal. apply val_sup. Qed. -Lemma incl_cs_trans cs1 cs2 cs3 : cs1 ⊂_cs cs2 -> cs2 ⊂_cs cs3 -> cs1 ⊂_cs cs3. +Lemma is_prop_val s : + Sort.is_prop s -> forall v, Sort.to_csort v s = Sort.sProp. Proof. - intros [? ?] [? ?]; split; [lsets|csets]. + destruct s => //. Qed. -Lemma empty_contextset_subset u : ContextSet.empty ⊂_cs u. +Lemma is_sprop_val s : + Sort.is_sprop s -> forall v, Sort.to_csort v s = Sort.sSProp. Proof. - red. split; cbn; [lsets|csets]. + destruct s => //. Qed. -(* Variance info is needed to do full universe polymorphism *) -Module Variance. - (** A universe position in the instance given to a cumulative - inductive can be the following. Note there is no Contralvariant - case because [forall x : A, B <= forall x : A', B'] requires [A = - A'] as opposed to [A' <= A]. *) - Inductive t := - | Irrelevant : t - | Covariant : t - | Invariant : t. - Derive NoConfusion EqDec for t. - (* val check_subtype : t -> t -> bool *) - (* val sup : t -> t -> t *) -End Variance. +Lemma val_is_prop s v : + Sort.to_csort v s = sProp <-> Sort.is_prop s. +Proof. + destruct s => //. +Qed. + +Lemma val_is_sprop s v : + Sort.to_csort v s = sSProp <-> Sort.is_sprop s. +Proof. + destruct s => //. +Qed. + +Lemma is_prop_and_is_sprop_val_false s : + Sort.is_prop s = false -> Sort.is_sprop s = false -> + forall v, ∑ n, Sort.to_csort v s = sType n. +Proof. + intros Hp Hsp v. + destruct s => //. simpl. eexists; eauto. +Qed. + +Lemma val_is_prop_false s v n : + Sort.to_csort v s = sType n -> Sort.is_prop s = false. +Proof. + destruct s => //. +Qed. + +Lemma get_is_level_correct s l : + Sort.get_is_level s = Some l -> s = sType (Universe.make' l). +Proof. + intro H; destruct s => //=. + f_equal; now apply universe_get_is_level_correct. +Qed. -Inductive universes_decl : Type := -| Monomorphic_ctx -| Polymorphic_ctx (cst : AUContext.t). +Lemma eqb_true_iff (s s' : sort) : + eqb s s' <-> s = s'. +Proof. + split. apply /eqb_spec. eapply introP. apply /eqb_spec. +Qed. -Derive NoConfusion for universes_decl. +Lemma sup_comm x1 x2 : + Sort.sup x1 x2 = Sort.sup x2 x1. +Proof. + destruct x1,x2;auto. + cbn;apply f_equal;apply sup0_comm. +Qed. -Definition levels_of_udecl u := - match u with - | Monomorphic_ctx => LevelSet.empty - | Polymorphic_ctx ctx => AUContext.levels ctx - end. +Lemma is_not_prop_and_is_not_sprop {univ} (s : Sort.t_ univ) : + Sort.is_prop s = false -> Sort.is_sprop s = false -> + ∑ s', s = sType s'. +Proof. + intros Hp Hsp. + destruct s => //. now eexists. +Qed. -Definition constraints_of_udecl u := - match u with - | Monomorphic_ctx => ConstraintSet.empty - | Polymorphic_ctx ctx => snd (snd (AUContext.repr ctx)) - end. +Lemma is_prop_sort_sup x1 x2 : + Sort.is_prop (Sort.sup x1 x2) + -> Sort.is_prop x2 \/ Sort.is_sprop x2 . +Proof. destruct x1,x2;auto. Qed. -Section Univ. - Context {cf: checker_flags}. +Lemma is_prop_sort_sup' x1 x2 : + Sort.is_prop (Sort.sup x1 x2) + -> Sort.is_prop x1 \/ Sort.is_sprop x1 . +Proof. destruct x1,x2;auto. Qed. - Inductive satisfies0 (v : valuation) : UnivConstraint.t -> Prop := - | satisfies0_Lt (l l' : Level.t) (z : Z) : (Z.of_nat (val v l) <= Z.of_nat (val v l') - z)%Z - -> satisfies0 v (l, ConstraintType.Le z, l') - | satisfies0_Eq (l l' : Level.t) : val v l = val v l' - -> satisfies0 v (l, ConstraintType.Eq, l'). +Lemma is_prop_or_sprop_sort_sup x1 x2 : + Sort.is_sprop (Sort.sup x1 x2) -> Sort.is_sprop x2. +Proof. destruct x1,x2;auto. Qed. - Definition satisfies v : ConstraintSet.t -> Prop := - ConstraintSet.For_all (satisfies0 v). +Lemma is_prop_sort_sup_prop x1 x2 : + Sort.is_prop x1 && Sort.is_prop x2 -> + Sort.is_prop (Sort.sup x1 x2). +Proof. destruct x1,x2;auto. Qed. - Lemma satisfies_union v φ1 φ2 : - satisfies v (CS.union φ1 φ2) - <-> (satisfies v φ1 /\ satisfies v φ2). - Proof using Type. - unfold satisfies. split. - - intros H; split; intros c Hc; apply H; now apply CS.union_spec. - - intros [H1 H2] c Hc; apply CS.union_spec in Hc; destruct Hc; auto. - Qed. +Lemma is_prop_or_sprop_sort_sup_prop x1 x2 : + Sort.is_sprop x1 && Sort.is_sprop x2 -> + Sort.is_sprop (Sort.sup x1 x2). +Proof. destruct x1,x2;auto. Qed. - Lemma satisfies_subset φ φ' val : - ConstraintSet.Subset φ φ' -> - satisfies val φ' -> - satisfies val φ. - Proof using Type. - intros sub sat ? isin. - apply sat, sub; auto. - Qed. +Lemma is_prop_sup s s' : + Sort.is_prop (Sort.sup s s') -> + Sort.is_propositional s /\ Sort.is_propositional s'. +Proof. destruct s, s'; auto. Qed. - Definition consistent ctrs := exists v, satisfies v ctrs. +Lemma is_sprop_sup_iff s s' : + Sort.is_sprop (Sort.sup s s') <-> + (Sort.is_sprop s /\ Sort.is_sprop s'). +Proof. split; destruct s, s' => //=; intuition. Qed. - Definition consistent_extension_on cs cstr := - forall v, satisfies v (ContextSet.constraints cs) -> exists v', - satisfies v' cstr /\ - LevelSet.For_all (fun l => val v l = val v' l) (ContextSet.levels cs). +Lemma is_type_sup_r s1 s2 : + Sort.is_type_sort s2 -> + Sort.is_type_sort (Sort.sup s1 s2). +Proof. destruct s2; try absurd; destruct s1; cbnr; intros; absurd. Qed. - Lemma consistent_extension_on_empty Σ : - consistent_extension_on Σ CS.empty. - Proof using Type. - move=> v hv; exists v; split; [move=> ? /CS.empty_spec[]| move=> ??//]. - Qed. +Lemma is_prop_sort_prod x2 x3 : + Sort.is_prop (Sort.sort_of_product x2 x3) + -> Sort.is_prop x3. +Proof. + unfold Sort.sort_of_product. + destruct x3;cbn;auto. + intros;simpl in *;destruct x2;auto. +Qed. - Lemma consistent_extension_on_union X cstrs - (wfX : forall c, CS.In c X.2 -> LS.In c.1.1 X.1 /\ LS.In c.2 X.1) : - consistent_extension_on X cstrs <-> - consistent_extension_on X (CS.union cstrs X.2). - Proof using Type. - split. - 2: move=> h v /h [v' [/satisfies_union [??] eqv']]; exists v'; split=> //. - move=> hext v /[dup] vsat /hext [v' [v'sat v'eq]]. - exists v'; split=> //. - apply/satisfies_union; split=> //. - move=> c hc. destruct (wfX c hc). - destruct (vsat c hc); constructor; rewrite -!v'eq //. - Qed. +Lemma is_sprop_sort_prod x2 x3 : + Sort.is_sprop (Sort.sort_of_product x2 x3) + -> Sort.is_sprop x3. +Proof. + unfold Sort.sort_of_product. + destruct x3;cbn;auto. + intros;simpl in *;destruct x2;auto. +Qed. - Definition leq0_levelalg_n n φ (u u' : LevelAlgExpr.t) := - forall v, satisfies v φ -> (Z.of_nat (val v u) <= Z.of_nat (val v u') - n)%Z. - Definition leq_levelalg_n n φ (u u' : LevelAlgExpr.t) := - if check_univs then leq0_levelalg_n n φ u u' else True. - Definition leq_universe_n_ {CS} leq_levelalg_n n (φ: CS) s s' := +Section SortCompare. + Context {cf}. + Definition leq_sort_n_ {univ} (leq_universe_n : Z -> univ -> univ -> Prop) n s s' : Prop := match s, s' with - | Universe.lProp, Universe.lProp - | Universe.lSProp, Universe.lSProp => (n = 0)%Z - | Universe.lType u, Universe.lType u' => leq_levelalg_n n φ u u' - | Universe.lProp, Universe.lType u => prop_sub_type + | sProp, sProp + | sSProp, sSProp => (n = 0)%Z + | sType u, sType u' => leq_universe_n n u u' + | sProp, sType u => prop_sub_type | _, _ => False end. - Definition leq_universe_n := leq_universe_n_ leq_levelalg_n. + Definition leq_sort_n n φ := leq_sort_n_ (fun n => leq_universe_n n φ) n. + Definition lt_sort := leq_sort_n 1. + Definition leq_sort := leq_sort_n 0. - Definition leqb_universe_n_ leqb_levelalg_n b s s' := + Definition leqb_sort_n_ {univ} (leqb_universe_n : bool -> univ -> univ -> bool) b s s' : bool := match s, s' with - | Universe.lProp, Universe.lProp - | Universe.lSProp, Universe.lSProp => negb b - | Universe.lType u, Universe.lType u' => leqb_levelalg_n b u u' - | Universe.lProp, Universe.lType u => prop_sub_type + | sProp, sProp + | sSProp, sSProp => negb b + | sType u, sType u' => leqb_universe_n b u u' + | sProp, sType u => prop_sub_type | _, _ => false end. - Definition eq0_levelalg φ (u u' : LevelAlgExpr.t) := - forall v, satisfies v φ -> val v u = val v u'. - - Definition eq_levelalg φ (u u' : LevelAlgExpr.t) := - if check_univs then eq0_levelalg φ u u' else True. - - Definition eq_universe_ {CS} (prop_conv_type : bool) eq_levelalg (φ: CS) s s' := + Definition eq_sort_ {univ} (eq_universe : univ -> univ -> Prop) s s' : Prop := match s, s' with - | Universe.lProp, Universe.lProp - | Universe.lSProp, Universe.lSProp => True - | Universe.lType u, Universe.lType u' => eq_levelalg φ u u' - | Universe.lType _, Universe.lProp - | Universe.lProp, Universe.lType _ => prop_conv_type + | sProp, sProp + | sSProp, sSProp => True + | sType u, sType u' => eq_universe u u' | _, _ => False end. - Definition eq_universe := eq_universe_ false eq_levelalg. + Definition eq_sort φ := eq_sort_ (eq_universe φ). - Definition lt_levelalg := leq_levelalg_n 1. - Definition leq_levelalg := leq_levelalg_n 0. - Definition lt_universe := leq_universe_n 1. - Definition leq_universe := leq_universe_n 0. + Definition eqb_sort_ {univ} (eqb_universe : univ -> univ -> bool) s s' : bool := + match s, s' with + | sProp, sProp + | sSProp, sSProp => true + | sType u, sType u' => eqb_universe u u' + | _, _ => false + end. - Definition compare_universe (pb : conv_pb) := + Definition compare_sort φ (pb : conv_pb) := match pb with - | Conv => eq_universe - | Cumul => leq_universe + | Conv => eq_sort φ + | Cumul => leq_sort φ end. - Lemma leq_levelalg_leq_levelalg_n (φ : ConstraintSet.t) u u' : - leq_levelalg φ u u' <-> leq_levelalg_n 0 φ u u'. + Lemma leq_sort_leq_sort_n (φ : ConstraintSet.t) s s' : + leq_sort φ s s' <-> leq_sort_n 0 φ s s'. Proof using Type. intros. reflexivity. Qed. - Lemma leq_universe_leq_universe_n (φ : ConstraintSet.t) u u' : - leq_universe φ u u' <-> leq_universe_n 0 φ u u'. - Proof using Type. intros. reflexivity. Qed. + Lemma compare_sort_type φ pb u u' : + compare_sort φ pb (sType u) (sType u') = compare_universe φ pb u u'. + Proof. now destruct pb. Qed. - (* ctrs are "enforced" by φ *) + Section GeneralLemmas. + Context {univ} {leq_universe_n : Z -> univ -> univ -> Prop} {eq_universe : univ -> univ -> Prop}. - Definition valid_constraints0 φ ctrs - := forall v, satisfies v φ -> satisfies v ctrs. + Let leq_sort_n := leq_sort_n_ leq_universe_n. + Let lt_sort := leq_sort_n_ leq_universe_n 1. + Let leq_sort := leq_sort_n_ leq_universe_n 0. + Let eq_sort := eq_sort_ eq_universe. + Notation "x <_ n y" := (leq_sort_n n x y) (at level 10, n name). + Notation "x < y" := (lt_sort x y). + Notation "x <= y" := (leq_sort x y). - Definition valid_constraints φ ctrs - := if check_univs then valid_constraints0 φ ctrs else True. - Lemma valid_subset φ φ' ctrs - : ConstraintSet.Subset φ φ' -> valid_constraints φ ctrs - -> valid_constraints φ' ctrs. - Proof using Type. - unfold valid_constraints. - destruct check_univs; [|trivial]. - intros Hφ H v Hv. apply H. - intros ctr Hc. apply Hv. now apply Hφ. - Qed. + Lemma sort_le_prop_inv s : s <= sProp -> s = sProp. + Proof using Type. destruct s => //. Qed. - Lemma switch_minus (x y z : Z) : (x <= y - z <-> x + z <= y)%Z. - Proof using Type. split; lia. Qed. + Lemma sort_le_sprop_inv s : s <= sSProp -> s = sSProp. + Proof using Type. destruct s => //. Qed. - (* Lemma llt_lt n m : (n < m)%u -> (n < m)%Z. - Proof. lled; lia. Qed. + Lemma sort_prop_le_inv s : sProp <= s -> + (s = sProp \/ (prop_sub_type /\ exists n, s = sType n)). + Proof using Type. + destruct s => //= Hle. + - now left. + - right; split => //; now eexists. + Qed. - Lemma lle_le n m : (n <= m)%u -> (n <= m)%Z. - Proof. lled; lia. Qed. + Lemma sort_sprop_le_inv s : sSProp <= s -> s = sSProp. + Proof using Type. destruct s => //. Qed. - Lemma lt_llt n m : prop_sub_type -> (n < m)%Z -> (n < m)%u. - Proof. unfold llt. now intros ->. Qed. + Global Instance leq_sort_refl `{Reflexive univ (leq_universe_n 0)} : Reflexive leq_sort. + Proof using Type. intros []; cbnr. Qed. - Lemma le_lle n m : prop_sub_type -> (n <= m)%Z -> (n <= m)%u. - Proof. lled; [lia|discriminate]. Qed. + Global Instance eq_sort_refl `{Reflexive univ eq_universe} : Reflexive eq_sort. + Proof using Type. intros []; cbnr. Qed. - Lemma lt_llt' n m : (0 <= n)%Z -> (n < m)%Z -> (n < m)%u. - Proof. lled; lia. Qed. + Global Instance eq_sort_sym `{Symmetric univ eq_universe} : Symmetric eq_sort. + Proof using Type. intros [] [] => //=. apply H. Qed. - Lemma le_lle' n m : (0 <= n)%Z -> (n <= m)%Z -> (n <= m)%u. - Proof. lled; lia. Qed. *) + Global Instance leq_sort_n_trans n `{Transitive univ (leq_universe_n n)} : Transitive (leq_sort_n n). + Proof using Type. + intros [] [] [] => //=. apply H. + Qed. + Global Instance leq_sort_trans `{Transitive univ (leq_universe_n 0)} : Transitive leq_sort. + Proof using Type. apply (leq_sort_n_trans 0). Qed. - (** **** Lemmas about eq and leq **** *) + Global Instance lt_sort_trans `{Transitive univ (leq_universe_n 1)} : Transitive lt_sort. + Proof using Type. apply (leq_sort_n_trans 1). Qed. - Ltac unfold_univ_rel0 := - unfold eq0_levelalg, leq0_levelalg_n in *; - intros v Hv; cbnr. + Global Instance eq_sort_trans `{Transitive univ eq_universe} : Transitive eq_sort. + Proof using Type. + intros [] [] [] => //=. apply H. + Qed. - Ltac unfold_univ_rel := - unfold eq_levelalg, leq_levelalg, lt_levelalg, leq_levelalg_n in *; - destruct check_univs; [unfold_univ_rel0 | trivial]. + Global Instance leq_sort_preorder `{PreOrder univ (leq_universe_n 0)} : PreOrder leq_sort := + Build_PreOrder _ _ _. + (* Can't be a global instance since it can lead to infinite search *) + Lemma lt_sort_irrefl : Irreflexive (leq_universe_n 1) -> Irreflexive lt_sort. + Proof using Type. + intros H []; unfold complement; cbnr. 1,2: lia. apply H. + Qed. - Global Instance eq_levelalg_refl φ : Reflexive (eq_levelalg φ). - Proof using Type. - intros u; unfold_univ_rel. - Qed. + Global Instance lt_sort_str_order `{StrictOrder univ (leq_universe_n 1)} : StrictOrder lt_sort := + Build_StrictOrder _ (lt_sort_irrefl _) _. - Global Instance eq_universe_refl φ : Reflexive (eq_universe φ). - Proof using Type. - intros []; cbnr. - Qed. + Global Instance eq_leq_sort `{subrelation univ eq_universe (leq_universe_n 0)}: subrelation eq_sort leq_sort. + Proof using Type. + intros [] [] => //=. apply H. + Qed. - Global Instance leq_levelalg_n_refl φ : Reflexive (leq_levelalg φ). - Proof using Type. - intros u; unfold_univ_rel. lia. - Qed. + Global Instance eq_sort_equivalence `{Equivalence univ eq_universe} : Equivalence eq_sort := Build_Equivalence _ _ _ _. - Global Instance leq_universe_refl φ : Reflexive (leq_universe φ). - Proof using Type. - intros []; cbnr. - Qed. + Global Instance leq_sort_antisym `{Antisymmetric _ eq_universe (leq_universe_n 0)} : Antisymmetric _ eq_sort leq_sort. + Proof using Type. + intros [] [] => //=. apply H. + Qed. - Global Instance eq_levelalg_sym φ : Symmetric (eq_levelalg φ). - Proof using Type. - intros u u' H; unfold_univ_rel. - specialize (H v Hv); lia. - Qed. + Global Instance leq_sort_partial_order `{PartialOrder _ eq_universe (leq_universe_n 0)}: PartialOrder eq_sort leq_sort. + Proof. + assert (subrelation eq_universe (leq_universe_n 0)). + { intros u u' Hu. specialize (H u u'); cbn in H. apply H in Hu. apply Hu. } + assert (subrelation eq_universe (flip (leq_universe_n 0))). + { intros u u' Hu. specialize (H u u'); cbn in H. apply H in Hu. apply Hu. } + intros s s'. split. + - intro Heq. split. + + now eapply eq_leq_sort. + + now eapply eq_leq_sort. + - intros [Hle Hge]. now eapply leq_sort_antisym. + Qed. - Global Instance eq_universe_sym φ : Symmetric (eq_universe φ). - Proof using Type. - intros [] []; cbnr; auto. - now symmetry. - Qed. + End GeneralLemmas. - Global Instance eq_levelalg_trans φ : Transitive (eq_levelalg φ). - Proof using Type. - intros u u' u'' H1 H2; unfold_univ_rel. - specialize (H1 v Hv); specialize (H2 v Hv); lia. - Qed. - Global Instance eq_universe_trans φ : Transitive (eq_universe φ). - Proof using Type. - intros [] [] []; cbnr; trivial; try absurd. - etransitivity; eauto. - Qed. + (** Universes with linear hierarchy *) + Definition concrete_sort := Sort.t_ nat. - Global Instance leq_levelalg_n_trans n φ : Transitive (leq_levelalg_n (Z.of_nat n) φ). - Proof using Type. - intros u u' u'' H1 H2; unfold_univ_rel. - specialize (H1 v Hv); specialize (H2 v Hv); lia. - Qed. + (** u + n <= u' *) + Definition leq_csort_n : Z -> concrete_sort -> concrete_sort -> Prop := + leq_sort_n_ (fun n u u' => (Z.of_nat u <= Z.of_nat u' - n)%Z). - Global Instance leq_universe_n_trans n φ : Transitive (leq_universe_n (Z.of_nat n) φ). - Proof using Type. - intros [] [] []; cbnr; trivial; try absurd. - now etransitivity. - Qed. + Definition leq_csort := leq_csort_n 0. + Definition lt_csort := leq_csort_n 1. - Global Instance leq_universe_trans φ : Transitive (leq_universe φ). - Proof using Type. apply (leq_universe_n_trans 0). Qed. + Notation "x <_ n y" := (leq_csort_n n x y) (at level 10, n name) : univ_scope. + Notation "x < y" := (lt_csort x y) : univ_scope. + Notation "x <= y" := (leq_csort x y) : univ_scope. - Global Instance lt_universe_trans φ : Transitive (lt_universe φ). - Proof using Type. apply (leq_universe_n_trans 1). Qed. + Definition is_propositional_or_set s := match s with sSProp | sProp | sType 0 => true | _ => false end. - Lemma eq0_leq0_levelalg φ u u' : - eq0_levelalg φ u u' <-> leq0_levelalg_n 0 φ u u' /\ leq0_levelalg_n 0 φ u' u. - Proof using Type. - split. - - intros H. split; unfold eq0_levelalg, leq_levelalg_n in *; - intros v Hv; specialize (H v Hv); lia. - - intros [H1 H2]. unfold eq0_levelalg, leq_levelalg_n in *. - intros v Hv. specialize (H1 v Hv); specialize (H2 v Hv); lia. - Qed. + Lemma csort_sup_comm s s' : Sort.csup s s' = Sort.csup s' s. + Proof using Type. destruct s, s' => //=. f_equal; lia. Qed. - Lemma eq_leq_levelalg φ u u' : - eq_levelalg φ u u' <-> leq_levelalg φ u u' /\ leq_levelalg φ u' u. + Lemma csort_sup_not_uproplevel s s' : + ~ Sort.is_propositional s -> ∑ n, Sort.csup s s' = sType n. Proof using Type. - split. - - intros H. split; unfold_univ_rel; specialize (H v Hv); lia. - - intros [H1 H2]. unfold_univ_rel. specialize (H1 v Hv); specialize (H2 v Hv); lia. + destruct s => //=. + destruct s'; now eexists. Qed. - Lemma eq_leq_universe φ u u' : - eq_universe φ u u' <-> leq_universe φ u u' /\ leq_universe φ u' u. + Lemma csort_sup_mon s s' v v' : (s <= s')%u -> (sType v <= sType v')%u -> + (Sort.csup s (sType v) <= Sort.csup s' (sType v'))%u. Proof using Type. - destruct u, u'; cbnr; intuition auto. - all: now apply eq_leq_levelalg. + destruct s, s' => //=; intros Hle Hle'; + lia. Qed. - Lemma leq_levelalg_sup0_l φ u1 u2 : leq_levelalg φ u1 (LevelAlgExpr.sup u1 u2). - Proof using Type. unfold_univ_rel. rewrite val_sup; lia. Qed. - - Lemma leq_levelalg_sup0_r φ u1 u2 : leq_levelalg φ u2 (LevelAlgExpr.sup u1 u2). - Proof using Type. unfold_univ_rel. rewrite val_sup; lia. Qed. - - Lemma leq_levelalg_sup0_mon φ u1 u1' u2 u2' : leq_levelalg φ u1 u1' -> leq_levelalg φ u2 u2' -> - leq_levelalg φ (LevelAlgExpr.sup u1 u2) (LevelAlgExpr.sup u1' u2'). + Lemma leq_csort_of_product_mon u u' v v' : + (u <= u')%u -> + (v <= v')%u -> + (Sort.csort_of_product u v <= Sort.csort_of_product u' v')%u. Proof using Type. - intros H1 H2; unfold_univ_rel. - specialize (H1 v Hv); specialize (H2 v Hv). - rewrite !val_sup. lia. + intros Hle1 Hle2. + destruct v, v'; cbn in Hle2 |- *; auto. + - destruct u'; cbn; assumption. + - apply csort_sup_mon; assumption. Qed. - Lemma leq_universe_sup_l φ u1 s2 : - let s1 := Universe.lType u1 in - leq_universe φ s1 (Universe.sup s1 s2). + Lemma impredicative_csort_product {univ} {univ_sup} {l u} : + Sort.is_propositional u -> + Sort.sort_of_product_ (univ := univ) univ_sup l u = u. + Proof using Type. now destruct u. Qed. + + Lemma leq_sort_sup_l φ u1 s2 : + let s1 := sType u1 in + leq_sort φ s1 (Sort.sup s1 s2). Proof using Type. destruct s2 as [| | u2]; cbnr. - apply leq_levelalg_sup0_l. + apply leq_universe_sup_l. Qed. - Lemma leq_universe_sup_r φ s1 u2 : - let s2 := Universe.lType u2 in - leq_universe φ s2 (Universe.sup s1 s2). + Lemma leq_sort_sup_r φ s1 u2 : + let s2 := sType u2 in + leq_sort φ s2 (Sort.sup s1 s2). Proof using Type. destruct s1 as [| | u1]; cbnr. - apply leq_levelalg_sup0_r. + apply leq_universe_sup_r. Qed. - Lemma leq_universe_product φ (s1 s2 : Universe.t) - : leq_universe φ s2 (Universe.sort_of_product s1 s2). + Lemma leq_sort_product φ (s1 s2 : Sort.t) + : leq_sort φ s2 (Sort.sort_of_product s1 s2). Proof using Type. - destruct s2 as [| | u2]. - - apply leq_universe_refl. - - apply leq_universe_refl. - - apply leq_universe_sup_r. + destruct s2 as [| | u2] => //. + apply leq_sort_sup_r. Qed. (* Rk: [leq_universe φ s1 (sort_of_product s1 s2)] does not hold due to - impredicativity. *) - - Global Instance eq_universe_leq_universe φ : subrelation (eq_universe φ) (leq_universe φ). - Proof using Type. - intros u u'. apply eq_leq_universe. - Qed. - - Global Instance eq_levelalg_equivalence φ : Equivalence (eq_levelalg φ) := Build_Equivalence _ _ _ _. - - Global Instance leq_levelalg_preorder φ : PreOrder (leq_levelalg φ) := - {| PreOrder_Transitive := leq_levelalg_n_trans 0 _ |}. - - Global Instance lt_levelalg_str_order {c: check_univs} φ (H: consistent φ) : StrictOrder (lt_levelalg φ). - Proof using Type. - split. - - intros u; unfold complement, lt_levelalg, leq_levelalg_n; cbn. - rewrite c; destruct H as [v Hv]; intros nH; specialize (nH v Hv); lia. - - apply (leq_levelalg_n_trans 1). - Qed. + impredicativity. *) - Global Instance leq_levelalg_antisym φ - : Antisymmetric _ (eq_levelalg φ) (leq_levelalg φ). - Proof using Type. intros t u tu ut. now apply eq_leq_levelalg. Qed. - Global Instance leq_levelalg_partial_order φ - : PartialOrder (eq_levelalg φ) (leq_levelalg φ). + Global Instance lt_sort_irrefl' {c: check_univs} φ (H: consistent φ) : Irreflexive (lt_sort φ). Proof. - intros x y; split; apply eq_leq_levelalg. - Defined. - - - Global Instance eq_universe_equivalence φ : Equivalence (eq_universe φ) := Build_Equivalence _ _ _ _. - - Global Instance leq_universe_preorder φ : PreOrder (leq_universe φ) := Build_PreOrder _ _ _. + unshelve eapply lt_sort_irrefl. + now unshelve eapply lt_universe_irrefl. + Qed. - Global Instance lt_universe_str_order {c: check_univs} φ (H: consistent φ) : StrictOrder (lt_universe φ). + Global Instance lt_sort_str_order' {c: check_univs} φ (H: consistent φ) : StrictOrder (lt_sort φ). Proof using Type. - split. - - intros []; unfold complement; cbn; [lia|lia|]. - apply @StrictOrder_Irreflexive; apply @lt_levelalg_str_order; assumption. - - exact _. + unshelve eapply lt_sort_str_order. + now unshelve eapply lt_universe_str_order. Qed. - Global Instance leq_universe_antisym φ - : Antisymmetric _ (eq_universe φ) (leq_universe φ). - Proof using Type. intros t u tu ut. now apply eq_leq_universe. Qed. - - Global Instance leq_universe_partial_order φ - : PartialOrder (eq_universe φ) (leq_universe φ). - Proof. - intros x y; split; apply eq_leq_universe. - Defined. - - Global Instance compare_universe_subrel pb Σ : subrelation (eq_universe Σ) (compare_universe pb Σ). + Global Instance compare_sort_subrel φ pb : subrelation (eq_sort φ) (compare_sort φ pb). Proof using Type. destruct pb; tc. Qed. - Global Instance compare_universe_refl pb Σ : Reflexive (compare_universe pb Σ). + Global Instance compare_sort_refl φ pb : Reflexive (compare_sort φ pb). Proof using Type. destruct pb; tc. Qed. - Global Instance compare_universe_trans pb Σ : Transitive (compare_universe pb Σ). + Global Instance compare_sort_trans φ pb : Transitive (compare_sort φ pb). Proof using Type. destruct pb; tc. Qed. - Global Instance compare_universe_preorder pb Σ : PreOrder (compare_universe pb Σ). + Global Instance compare_sort_preorder φ pb : PreOrder (compare_sort φ pb). Proof using Type. destruct pb; tc. Qed. - Definition eq_universe_leq_universe' φ u u' - := @eq_universe_leq_universe φ u u'. - Definition leq_universe_refl' φ u - := @leq_universe_refl φ u. + Definition eq_leq_sort' φ leq_universe eq_universe Hsub u u' + := @eq_leq_sort φ leq_universe eq_universe Hsub u u'. + Definition leq_sort_refl' φ leq_universe leq_refl u + := @leq_sort_refl φ leq_universe leq_refl u. - Hint Resolve eq_universe_leq_universe' leq_universe_refl' : core. + Hint Resolve eq_leq_universe' leq_universe_refl' : core. - Lemma cmp_universe_subset ctrs ctrs' pb t u - : ConstraintSet.Subset ctrs ctrs' - -> compare_universe pb ctrs t u -> compare_universe pb ctrs' t u. + + Lemma cmp_sort_subset φ φ' pb t u + : ConstraintSet.Subset φ φ' + -> compare_sort φ pb t u -> compare_sort φ' pb t u. Proof using Type. intros Hctrs. destruct pb, t, u; cbnr; trivial. @@ -2139,54 +2101,82 @@ Section Univ. all: eapply satisfies_subset; eauto. Qed. - Lemma eq_universe_subset ctrs ctrs' t u + Lemma eq_sort_subset ctrs ctrs' t u : ConstraintSet.Subset ctrs ctrs' - -> eq_universe ctrs t u -> eq_universe ctrs' t u. - Proof using Type. apply cmp_universe_subset with (pb := Conv). Qed. + -> eq_sort ctrs t u -> eq_sort ctrs' t u. + Proof using Type. apply cmp_sort_subset with (pb := Conv). Qed. - Lemma leq_universe_subset ctrs ctrs' t u + Lemma leq_sort_subset ctrs ctrs' t u : ConstraintSet.Subset ctrs ctrs' - -> leq_universe ctrs t u -> leq_universe ctrs' t u. - Proof using Type. apply cmp_universe_subset with (pb := Cumul). Qed. + -> leq_sort ctrs t u -> leq_sort ctrs' t u. + Proof using Type. apply cmp_sort_subset with (pb := Cumul). Qed. +End SortCompare. - (** Elimination restriction *) +(** Elimination restriction *) - Definition is_lSet φ s := eq_universe φ s Universe.type0. - (* Unfolded definition : - match s with - | Universe.lType u => - if check_univs then forall v, satisfies v φ -> val v u = 0 else True - | _ => False - end. *) - - Definition is_allowed_elimination φ allowed : Universe.t -> Prop := - match allowed with - | IntoSProp => Universe.is_sprop - | IntoPropSProp => is_propositional - | IntoSetPropSProp => fun s => is_propositional s \/ is_lSet φ s - | IntoAny => fun s => True - end. - (* Is [a] a subset of [a']? *) - Definition allowed_eliminations_subset (a a' : allowed_eliminations) : bool := - match a, a' with - | IntoSProp, _ - | IntoPropSProp, (IntoPropSProp | IntoSetPropSProp | IntoAny) - | IntoSetPropSProp, (IntoSetPropSProp | IntoAny) - | IntoAny, IntoAny => true - | _, _ => false - end. +(** This inductive classifies which eliminations are allowed for inductive types + in various sorts. *) +Inductive allowed_eliminations : Set := + | IntoSProp + | IntoPropSProp + | IntoSetPropSProp + | IntoAny. +Derive NoConfusion EqDec for allowed_eliminations. - Lemma allowed_eliminations_subset_impl φ a a' s - : allowed_eliminations_subset a a' -> - is_allowed_elimination φ a s -> is_allowed_elimination φ a' s. - Proof using Type. - destruct a, a'; cbnr; trivial; - destruct s; cbnr; trivial; - intros H1 H2; try absurd; constructor; trivial. - Qed. -End Univ. +Definition is_allowed_elimination_cuniv (allowed : allowed_eliminations) : concrete_sort -> bool := + match allowed with + | IntoSProp => Sort.is_sprop + | IntoPropSProp => Sort.is_propositional + | IntoSetPropSProp => is_propositional_or_set + | IntoAny => fun _ => true + end. + +Definition is_lSet {cf} φ s := eq_sort φ s Sort.type0. + (* Unfolded definition : + match s with + | Sort.sType u => + if check_univs then forall v, satisfies v φ -> val v u = 0 else true + | _ => false + end. *) + +Definition is_allowed_elimination {cf} φ allowed : Sort.t -> Prop := + match allowed with + | IntoSProp => Sort.is_sprop + | IntoPropSProp => Sort.is_propositional + | IntoSetPropSProp => fun s => Sort.is_propositional s \/ is_lSet φ s + | IntoAny => fun s => true + end. + +(* Is [a] a subset of [a']? *) +Definition allowed_eliminations_subset (a a' : allowed_eliminations) : bool := + match a, a' with + | IntoSProp, _ + | IntoPropSProp, (IntoPropSProp | IntoSetPropSProp | IntoAny) + | IntoSetPropSProp, (IntoSetPropSProp | IntoAny) + | IntoAny, IntoAny => true + | _, _ => false + end. + +Lemma allowed_eliminations_subset_impl {cf} φ a a' s + : allowed_eliminations_subset a a' -> + is_allowed_elimination φ a s -> is_allowed_elimination φ a' s. +Proof using Type. + destruct a, a'; cbnr; trivial; + destruct s; cbnr; trivial; + intros H1 H2; try absurd; constructor; trivial. +Qed. + +Lemma is_allowed_elimination_monotone `{cf : checker_flags} Σ s1 s2 a : + leq_sort Σ s1 s2 -> is_allowed_elimination Σ a s2 -> is_allowed_elimination Σ a s1. +Proof. + destruct a, s2 as [| |u2], s1 as [| |u1] => //=. 1: now left. + intros Hle [H|]; right => //. + unfold_univ_rel. + cbn in H. + lia. +Qed. Section UnivCF2. Context {cf1 cf2 : checker_flags}. @@ -2201,11 +2191,10 @@ Section UnivCF2. Lemma cmp_universe_config_impl ctrs pb t u : config.impl cf1 cf2 - -> @compare_universe cf1 pb ctrs t u -> @compare_universe cf2 pb ctrs t u. + -> @compare_universe cf1 ctrs pb t u -> @compare_universe cf2 ctrs pb t u. Proof using Type. - destruct pb, t, u; cbnr; trivial. - all: unfold config.impl, eq_levelalg, leq_levelalg_n, is_true. - all: do 2 destruct check_univs, prop_sub_type; cbn => //. + unfold config.impl, compare_universe, leq_universe, eq_universe, leq_universe_n, is_true. + destruct pb; do 2 destruct check_univs => //=. Qed. Lemma eq_universe_config_impl ctrs t u @@ -2218,6 +2207,27 @@ Section UnivCF2. -> @leq_universe cf1 ctrs t u -> @leq_universe cf2 ctrs t u. Proof using Type. apply cmp_universe_config_impl with (pb := Cumul). Qed. + Lemma cmp_sort_config_impl ctrs pb t u + : config.impl cf1 cf2 + -> @compare_sort cf1 ctrs pb t u -> @compare_sort cf2 ctrs pb t u. + Proof using Type. + unfold compare_sort, leq_sort, eq_sort, eq_sort_, leq_sort_n, leq_sort_n_, is_true. + destruct pb, t, u => //=. + - apply eq_universe_config_impl. + - unfold config.impl. do 2 destruct check_univs, prop_sub_type; cbn => //=. + - apply leq_universe_config_impl. + Qed. + + Lemma eq_sort_config_impl ctrs t u + : config.impl cf1 cf2 + -> @eq_sort cf1 ctrs t u -> @eq_sort cf2 ctrs t u. + Proof using Type. apply cmp_sort_config_impl with (pb := Conv). Qed. + + Lemma leq_sort_config_impl ctrs t u + : config.impl cf1 cf2 + -> @leq_sort cf1 ctrs t u -> @leq_sort cf2 ctrs t u. + Proof using Type. apply cmp_sort_config_impl with (pb := Cumul). Qed. + (** Elimination restriction *) Lemma allowed_eliminations_config_impl φ a s @@ -2225,109 +2235,103 @@ Section UnivCF2. @is_allowed_elimination cf1 φ a s -> @is_allowed_elimination cf2 φ a s. Proof using Type. destruct a, s; cbnr; trivial. - unfold eq_levelalg, config.impl, is_true. + unfold eq_universe, config.impl, is_true. do 2 destruct check_univs; cbnr; auto => //. Qed. End UnivCF2. -Ltac unfold_univ_rel0 := - unfold eq0_levelalg, leq0_levelalg_n in *; - intros v Hv; cbnr. -Ltac unfold_univ_rel := - unfold is_allowed_elimination, is_lSet, - leq_universe, eq_universe, leq_universe_n, leq_universe_n_, eq_universe_, - eq_levelalg, leq_levelalg, lt_levelalg, leq_levelalg_n in *; +Ltac unfold_univ_rel ::= + unfold is_allowed_elimination, is_lSet, valid_constraints, + compare_sort, eq_sort, leq_sort, lt_sort, leq_sort_n, leq_sort_n_, eq_sort_, leqb_sort_n_, eqb_sort_, + compare_universe, leq_universe, eq_universe, leq_universe_n in *; destruct check_univs; [unfold_univ_rel0 | trivial]. Tactic Notation "unfold_univ_rel" "eqn" ":"ident(H) := - unfold is_allowed_elimination, is_lSet, - leq_universe, eq_universe, leq_universe_n, leq_universe_n_, eq_universe_, - eq_levelalg, leq_levelalg, lt_levelalg, leq_levelalg_n in *; + unfold is_allowed_elimination, is_lSet, valid_constraints, + compare_sort, eq_sort, leq_sort, lt_sort, leq_sort_n, leq_sort_n_, eq_sort_, leqb_sort_n_, eqb_sort_, + compare_universe, leq_universe, eq_universe, leq_universe_n in *; destruct check_univs eqn:H; [unfold_univ_rel0 | trivial]. (* Ltac prop_non_prop := match goal with - | |- context[ Universe.is_prop ?u || Universe.is_sprop ?u] => - destruct (Universe.is_prop u || Universe.is_sprop u) - | H : context[ Universe.is_prop ?u || Universe.is_sprop ?u] |- _ => - destruct (Universe.is_prop u || Universe.is_sprop u) + | |- context[ Sort.is_prop ?u || Sort.is_sprop ?u] => + destruct (Sort.is_prop u || Sort.is_sprop u) + | H : context[ Sort.is_prop ?u || Sort.is_sprop ?u] |- _ => + destruct (Sort.is_prop u || Sort.is_sprop u) end. *) Ltac cong := intuition congruence. - -Lemma leq_universe_product_mon {cf} ϕ s1 s1' s2 s2' : - leq_universe ϕ s1 s1' -> - leq_universe ϕ s2 s2' -> - leq_universe ϕ (Universe.sort_of_product s1 s2) (Universe.sort_of_product s1' s2'). +Lemma leq_sort_product_mon {cf} ϕ s1 s1' s2 s2' : + leq_sort ϕ s1 s1' -> + leq_sort ϕ s2 s2' -> + leq_sort ϕ (Sort.sort_of_product s1 s2) (Sort.sort_of_product s1' s2'). Proof. destruct s2 as [| | u2], s2' as [| | u2']; cbnr; try absurd; destruct s1 as [| | u1], s1' as [| | u1']; cbnr; try absurd; trivial. - - intros _ H2; etransitivity; [apply H2 | apply leq_levelalg_sup0_r]. - - apply leq_levelalg_sup0_mon. + - intros _ H2; etransitivity; [apply H2 | apply leq_universe_sup_r]. + - apply leq_universe_sup_mon. Qed. Lemma impredicative_product {cf} {ϕ l u} : - Universe.is_prop u -> - leq_universe ϕ (Universe.sort_of_product l u) u. + Sort.is_propositional u -> + leq_sort ϕ (Sort.sort_of_product l u) u. Proof. - unfold Universe.sort_of_product. - intros ->. reflexivity. + destruct u => //; reflexivity. Qed. Section UniverseLemmas. Context {cf: checker_flags}. - Lemma sup0_idem s : LevelAlgExpr.sup s s = s. + Lemma univ_sup_idem s : Universe.sup s s = s. Proof using Type. apply eq_univ'; cbn. intro; rewrite !LevelExprSet.union_spec. intuition. Qed. - Lemma sup_idem s : Universe.sup s s = s. + Lemma sup_idem s : Sort.sup s s = s. Proof using Type. destruct s; cbn; auto. apply f_equal. - apply sup0_idem. + apply univ_sup_idem. Qed. Lemma sort_of_product_idem s - : Universe.sort_of_product s s = s. + : Sort.sort_of_product s s = s. Proof using Type. - unfold Universe.sort_of_product; destruct s; try reflexivity. + unfold Sort.sort_of_product; destruct s; try reflexivity. apply sup_idem. Qed. - Lemma sup0_assoc s1 s2 s3 : - LevelAlgExpr.sup s1 (LevelAlgExpr.sup s2 s3) = LevelAlgExpr.sup (LevelAlgExpr.sup s1 s2) s3. + Lemma univ_sup_assoc s1 s2 s3 : + Universe.sup s1 (Universe.sup s2 s3) = Universe.sup (Universe.sup s1 s2) s3. Proof using Type. apply eq_univ'; cbn. symmetry; apply LevelExprSetProp.union_assoc. Qed. - Instance proper_sup0_eq_levelalg φ : - Proper (eq_levelalg φ ==> eq_levelalg φ ==> eq_levelalg φ) LevelAlgExpr.sup. + Instance proper_univ_sup_eq_univ φ : + Proper (eq_universe φ ==> eq_universe φ ==> eq_universe φ) Universe.sup. Proof using Type. intros u1 u1' H1 u2 u2' H2. unfold_univ_rel. - specialize (H1 v Hv); specialize (H2 v Hv). rewrite !val_sup. lia. Qed. - Instance universe_sup_eq_universe φ : - Proper (eq_universe φ ==> eq_universe φ ==> eq_universe φ) Universe.sup. + Instance proper_sort_sup_eq_sort φ : + Proper (eq_sort φ ==> eq_sort φ ==> eq_sort φ) Sort.sup. Proof using Type. intros [| | u1] [| |u1'] H1 [| |u2] [| |u2'] H2; cbn in *; try absurd; auto. - now apply proper_sup0_eq_levelalg. + now apply proper_univ_sup_eq_univ. Qed. Lemma sort_of_product_twice u s : - Universe.sort_of_product u (Universe.sort_of_product u s) - = Universe.sort_of_product u s. + Sort.sort_of_product u (Sort.sort_of_product u s) + = Sort.sort_of_product u s. Proof using Type. destruct u,s; cbnr. - now rewrite sup0_assoc sup0_idem. + now rewrite univ_sup_assoc univ_sup_idem. Qed. End UniverseLemmas. @@ -2343,7 +2347,7 @@ Section no_prop_leq_type. Qed. Lemma spec_map_succ l x : - LevelExprSet.In x (LevelAlgExpr.succ l) <-> + LevelExprSet.In x (Universe.succ l) <-> exists x', LevelExprSet.In x' l /\ x = LevelExpr.succ x'. Proof using Type. rewrite map_spec. reflexivity. @@ -2354,10 +2358,10 @@ Section no_prop_leq_type. destruct l as []; simpl. cbn. lia. Qed. - Lemma val_map_succ v l : val v (LevelAlgExpr.succ l) = val v l + 1. + Lemma val_map_succ v l : val v (Universe.succ l) = val v l + 1. Proof using Type. pose proof (spec_map_succ l). - set (n := LevelAlgExpr.succ l) in *. + set (n := Universe.succ l) in *. destruct (val_In_max l v) as [max [inmax eqv]]. rewrite <-eqv. rewrite val_caract. split. intros. @@ -2369,52 +2373,19 @@ Section no_prop_leq_type. now rewrite val_succ. Qed. - Lemma leq_universe_super s s' : - leq_universe ϕ s s' -> - leq_universe ϕ (Universe.super s) (Universe.super s'). + Lemma leq_sort_super s s' : + leq_sort ϕ s s' -> + leq_sort ϕ (Sort.super s) (Sort.super s'). Proof using Type. destruct s as [| | u1], s' as [| | u1']; cbnr; try absurd; intros H; unfold_univ_rel; - rewrite !val_map_succ. lia. - specialize (H v Hv). lia. - Qed. - - Lemma leq_universe_props s1 s2 : - leq_universe ϕ s1 s2 -> - match s1, s2 with - | Universe.lProp, Universe.lProp => True - | Universe.lSProp, Universe.lSProp => True - | Universe.lProp, Universe.lSProp => False - | Universe.lSProp, Universe.lProp => False - | Universe.lProp, Universe.lType _ => prop_sub_type - | Universe.lSProp, Universe.lType _ => False - | Universe.lType l, Universe.lType l' => True - | Universe.lType _, _ => False - end. - Proof using Type. - destruct s1, s2; cbnr; trivial. - Qed. - - Lemma leq_universe_prop_r s1 s2 : - leq_universe ϕ s1 s2 -> - Universe.is_prop s2 -> Universe.is_prop s1. - Proof using Type. - destruct s2; cbn; [ | absurd | absurd]. - destruct s1; cbn; [ auto | absurd | absurd]. - Qed. - - Lemma leq_universe_sprop_r s1 s2 : - leq_universe ϕ s1 s2 -> - Universe.is_sprop s2 -> Universe.is_sprop s1. - Proof using Type. - destruct s2; cbn; [ absurd | | absurd]. - destruct s1; cbn; [ absurd | auto | absurd]. + rewrite !val_map_succ; lia. Qed. - Lemma leq_universe_prop_no_prop_sub_type s1 s2 : + Lemma leq_sort_prop_no_prop_sub_type s1 s2 : prop_sub_type = false -> - leq_universe ϕ s1 s2 -> - Universe.is_prop s1 -> Universe.is_prop s2. + leq_sort ϕ s1 s2 -> + Sort.is_prop s1 -> Sort.is_prop s2. Proof using Type. intros ps. destruct s1; cbn; [ | absurd | absurd]. @@ -2422,88 +2393,25 @@ Section no_prop_leq_type. destruct s2; cbn; [ auto | absurd | absurd]. Qed. - Lemma leq_universe_sprop_l s1 s2 : - leq_universe ϕ s1 s2 -> - Universe.is_sprop s1 -> Universe.is_sprop s2. - Proof using Type. - destruct s1; cbn; [ absurd | | absurd]. - destruct s2; cbn; [ absurd | auto | absurd]. - Qed. - - Hint Resolve leq_universe_sprop_l leq_universe_sprop_r - leq_universe_prop_r - leq_universe_prop_no_prop_sub_type - : univ_lemmas. - - Lemma leq_prop_prop {l l'} : - Universe.is_prop l -> Universe.is_prop l' -> - leq_universe ϕ l l'. - Proof using Type. - destruct l, l'; cbnr; absurd. - Qed. - - Lemma leq_sprop_sprop {l l'} : - Universe.is_sprop l -> Universe.is_sprop l' -> - leq_universe ϕ l l'. - Proof using Type. - destruct l, l'; cbnr; absurd. - Qed. + Hint Resolve leq_sort_prop_no_prop_sub_type : univ_lemmas. - Lemma leq_prop_is_prop_sprop {s1 s2} : + Lemma leq_prop_is_propositonal {s1 s2} : prop_sub_type = false -> - leq_universe ϕ s1 s2 -> - is_propositional s1 <-> is_propositional s2. + leq_sort ϕ s1 s2 -> + Sort.is_propositional s1 <-> Sort.is_propositional s2. Proof using Type. intros ps. destruct s1, s2; cbn; try absurd; intros H; split; trivial. now rewrite ps in H. Qed. - Lemma is_prop_gt s1 s2 : - leq_universe ϕ (Universe.super s1) s2 -> Universe.is_prop s2 -> False. - Proof using Type. - intros Hleq Hprop. - apply leq_universe_prop_r in Hleq; tas. - now destruct s1. - Qed. - - Lemma is_sprop_gt s1 s2 : - leq_universe ϕ (Universe.super s1) s2 -> Universe.is_sprop s2 -> False. - Proof using Type. - intros Hleq Hprop. - apply leq_universe_sprop_r in Hleq; tas. - now destruct s1. - Qed. - - Lemma is_prop_superE s : Universe.is_prop (Universe.super s) -> False. - Proof using Type. - destruct s => //. - Qed. - - Lemma is_sprop_superE s : Universe.is_sprop (Universe.super s) -> False. - Proof using Type. - destruct s => //. - Qed. - - Lemma is_prop_prod {s s'} : Universe.is_prop s' -> Universe.is_prop (Universe.sort_of_product s s'). - Proof using Type. - intros isp. - unfold Universe.sort_of_product. rewrite isp. auto. - Qed. - - Lemma is_sprop_prod {s s'} : Universe.is_sprop s' -> Universe.is_sprop (Universe.sort_of_product s s'). - Proof using Type. - intros isp. - unfold Universe.sort_of_product. rewrite isp orb_true_r. auto. - Qed. - End no_prop_leq_type. (* This level is a hack used in plugings to generate fresh levels *) Definition fresh_level : Level.t := Level.level "__metacoq_fresh_level__". -(* This universe is a hack used in plugins to generate fresh concreteUniverses *) -Definition fresh_universe : Universe.t := Universe.make fresh_level. +(* This universe is a hack used in plugins to generate fresh universes *) +Definition fresh_universe : Universe.t := Universe.make' fresh_level. (** * Universe substitution @@ -2542,15 +2450,21 @@ Notation "x @[ u ]" := (subst_instance u x) (at level 3, end end. -#[global] Instance subst_instance_univ0 : UnivSubst LevelAlgExpr.t := +#[global] Instance subst_instance_universe : UnivSubst Universe.t := fun u => map (subst_instance_level_expr u). -#[global] Instance subst_instance_univ : UnivSubst Universe.t := +#[global] Instance subst_instance_sort : UnivSubst Sort.t := fun u e => match e with - | Universe.lProp | Universe.lSProp => e - | Universe.lType l => Universe.lType (subst_instance u l) + | sProp | sSProp => e + | sType u' => sType (subst_instance u u') end. +Lemma subst_instance_to_family s u : + Sort.to_family s@[u] = Sort.to_family s. +Proof. + destruct s => //. +Qed. + #[global] Instance subst_instance_instance : UnivSubst Instance.t := fun u u' => List.map (subst_instance_level u) u'. @@ -2567,13 +2481,13 @@ Section Closedu. Definition closedu_level_expr (s : LevelExpr.t) := closedu_level (LevelExpr.get_level s). - Definition closedu_universe_levels (u : LevelAlgExpr.t) := + Definition closedu_universe (u : Universe.t) := LevelExprSet.for_all closedu_level_expr u. - Definition closedu_universe (u : Universe.t) := + Definition closedu_sort (u : Sort.t) := match u with - | Universe.lSProp | Universe.lProp => true - | Universe.lType l => closedu_universe_levels l + | sSProp | sProp => true + | sType l => closedu_universe l end. Definition closedu_instance (u : Instance.t) := @@ -2596,13 +2510,13 @@ Section UniverseClosedSubst. Qed. Lemma closedu_subst_instance_univ u s - : closedu_universe 0 s -> subst_instance_univ u s = s. + : closedu_sort 0 s -> subst_instance_sort u s = s. Proof. intro H. destruct s as [| | t]; cbnr. apply f_equal. apply eq_univ'. destruct t as [ts H1]. - unfold closedu_universe_levels in *;cbn in *. + unfold closedu_universe in *;cbn in *. intro e; split; intro He. - apply map_spec in He. destruct He as [e' [He' X]]. rewrite closedu_subst_instance_level_expr in X. @@ -2655,7 +2569,7 @@ Section SubstInstanceClosed. Qed. Lemma subst_instance_univ_closedu s - : closedu_universe #|u| s -> closedu_universe 0 (subst_instance_univ u s). + : closedu_sort #|u| s -> closedu_sort 0 (subst_instance_sort u s). Proof using Hcl. intro H. destruct s as [| |t]; cbnr. @@ -2692,11 +2606,11 @@ Definition string_of_level (l : Level.t) : string := Definition string_of_level_expr (e : LevelExpr.t) : string := let '(l, n) := e in string_of_level l ^ (if n is 0 then "" else "+" ^ string_of_nat n). -Definition string_of_sort (u : Universe.t) := +Definition string_of_sort (u : Sort.t) := match u with - | Universe.lSProp => "SProp" - | Universe.lProp => "Prop" - | Universe.lType l => "Type(" ^ string_of_list string_of_level_expr (LevelExprSet.elements l) ^ ")" + | sSProp => "SProp" + | sProp => "Prop" + | sType l => "Type(" ^ string_of_list string_of_level_expr (LevelExprSet.elements l) ^ ")" end. Definition string_of_universe_instance u := diff --git a/common/theories/UniversesDec.v b/common/theories/UniversesDec.v index 7b3712d98..f73f495c7 100644 --- a/common/theories/UniversesDec.v +++ b/common/theories/UniversesDec.v @@ -77,7 +77,7 @@ Proof. split; apply global_uctx_invariants_union_or; constructor; apply levels_of_cs2_spec. Qed. -Definition levels_of_algexpr (u : LevelAlgExpr.t) : VSet.t +Definition levels_of_universe (u : Universe.t) : VSet.t := LevelExprSet.fold (fun gc acc => match LevelExpr.get_noprop gc with | Some l => VSet.add l acc @@ -85,10 +85,10 @@ Definition levels_of_algexpr (u : LevelAlgExpr.t) : VSet.t end) u VSet.empty. -Lemma levels_of_algexpr_spec u cstr (lvls := levels_of_algexpr u) +Lemma levels_of_universe_spec u cstr (lvls := levels_of_universe u) : gc_levels_declared (lvls, cstr) u. Proof. - subst lvls; cbv [levels_of_algexpr gc_levels_declared gc_expr_declared on_Some_or_None LevelExpr.get_noprop]; cbn [fst snd]. + subst lvls; cbv [levels_of_universe gc_levels_declared gc_expr_declared on_Some_or_None LevelExpr.get_noprop]; cbn [fst snd]. cbv [LevelExprSet.For_all]; cbn [fst snd]. repeat first [ apply conj | progress intros @@ -751,14 +751,14 @@ Proof. destruct b; [ left; apply H; reflexivity | right; intro H'; apply H in H'; auto ]. Defined. -Definition leq0_levelalg_n_dec n ϕ u u' : {@leq0_levelalg_n (uGraph.Z_of_bool n) ϕ u u'} + {~@leq0_levelalg_n (uGraph.Z_of_bool n) ϕ u u'}. +Definition leq0_universe_n_dec n ϕ u u' : {@leq0_universe_n (uGraph.Z_of_bool n) ϕ u u'} + {~@leq0_universe_n (uGraph.Z_of_bool n) ϕ u u'}. Proof. - pose proof (@uGraph.gc_leq0_levelalg_n_iff config.default_checker_flags (uGraph.Z_of_bool n) ϕ u u') as H. + pose proof (@uGraph.gc_leq0_universe_n_iff config.default_checker_flags (uGraph.Z_of_bool n) ϕ u u') as H. pose proof (@uGraph.gc_consistent_iff config.default_checker_flags ϕ). cbv [on_Some on_Some_or_None] in *. destruct gc_of_constraints eqn:?. all: try solve [ left; cbv [consistent] in *; hnf; intros; exfalso; intuition eauto ]. - pose proof (fun G cstr => @uGraph.leqb_levelalg_n_spec G (LevelSet.union (levels_of_cs ϕ) (LevelSet.union (levels_of_algexpr u) (levels_of_algexpr u')), cstr)). + pose proof (fun G cstr => @uGraph.leqb_universe_n_spec G (LevelSet.union (levels_of_cs ϕ) (LevelSet.union (levels_of_universe u) (levels_of_universe u')), cstr)). pose proof (fun x y => @gc_of_constraints_of_uctx config.default_checker_flags (x, y)) as H'. pose proof (@is_consistent_spec config.default_checker_flags (levels_of_cs ϕ, ϕ)). specialize_under_binders_by eapply gc_levels_declared_union_or. @@ -770,40 +770,40 @@ Proof. specialize_under_binders_by eapply levels_of_cs_spec. specialize_under_binders_by reflexivity. destruct is_consistent; - [ | left; now cbv [leq0_levelalg_n consistent] in *; intros; exfalso; intuition eauto ]. + [ | left; now cbv [leq0_universe_n consistent] in *; intros; exfalso; intuition eauto ]. specialize_by intuition eauto. let H := match goal with H : forall (b : bool), _ |- _ => H end in specialize (H n u u'). - specialize_under_binders_by (constructor; eapply gc_levels_declared_union_or; constructor; eapply levels_of_algexpr_spec). + specialize_under_binders_by (constructor; eapply gc_levels_declared_union_or; constructor; eapply levels_of_universe_spec). match goal with H : is_true ?b <-> ?x, H' : ?y <-> ?x |- {?y} + {_} => destruct b eqn:?; [ left | right ] end. all: intuition. Defined. -Definition leq_levelalg_n_dec cf n ϕ u u' : {@leq_levelalg_n cf (uGraph.Z_of_bool n) ϕ u u'} + {~@leq_levelalg_n cf (uGraph.Z_of_bool n) ϕ u u'}. +Definition leq_universe_n_dec cf n ϕ u u' : {@leq_universe_n cf (uGraph.Z_of_bool n) ϕ u u'} + {~@leq_universe_n cf (uGraph.Z_of_bool n) ϕ u u'}. Proof. - cbv [leq_levelalg_n]; destruct (@leq0_levelalg_n_dec n ϕ u u'); destruct ?; auto. + cbv [leq_universe_n]; destruct (@leq0_universe_n_dec n ϕ u u'); destruct ?; auto. Defined. -Definition eq0_levelalg_dec ϕ u u' : {@eq0_levelalg ϕ u u'} + {~@eq0_levelalg ϕ u u'}. +Definition eq0_universe_dec ϕ u u' : {@eq0_universe ϕ u u'} + {~@eq0_universe ϕ u u'}. Proof. - pose proof (@eq0_leq0_levelalg ϕ u u') as H. - destruct (@leq0_levelalg_n_dec false ϕ u u'), (@leq0_levelalg_n_dec false ϕ u' u); constructor; destruct H; split_and; now auto. + pose proof (@eq0_leq0_universe ϕ u u') as H. + destruct (@leq0_universe_n_dec false ϕ u u'), (@leq0_universe_n_dec false ϕ u' u); constructor; destruct H; split_and; now auto. Defined. -Definition eq_levelalg_dec {cf ϕ} u u' : {@eq_levelalg cf ϕ u u'} + {~@eq_levelalg cf ϕ u u'}. +Definition eq_universe_dec {cf ϕ} u u' : {@eq_universe cf ϕ u u'} + {~@eq_universe cf ϕ u u'}. Proof. - cbv [eq_levelalg]; destruct ?; auto using eq0_levelalg_dec. + cbv [eq_universe]; destruct ?; auto using eq0_universe_dec. Defined. -Definition eq_universe__dec {CS pst eq_levelalg ϕ} - (eq_levelalg_dec : forall u u', {@eq_levelalg ϕ u u'} + {~@eq_levelalg ϕ u u'}) +Definition eq_sort__dec {univ eq_universe} + (eq_universe_dec : forall u u', {@eq_universe u u'} + {~@eq_universe u u'}) s s' - : {@eq_universe_ CS pst eq_levelalg ϕ s s'} + {~@eq_universe_ CS pst eq_levelalg ϕ s s'}. + : {@eq_sort_ univ eq_universe s s'} + {~@eq_sort_ univ eq_universe s s'}. Proof. - cbv [eq_universe_]; repeat destruct ?; auto. all: destruct pst; auto. + cbv [eq_sort_]; repeat destruct ?; auto. all: destruct pst; auto. Defined. -Definition eq_universe_dec {cf ϕ} s s' : {@eq_universe cf ϕ s s'} + {~@eq_universe cf ϕ s s'} := eq_universe__dec eq_levelalg_dec _ _. +Definition eq_sort_dec {cf ϕ} s s' : {@eq_sort cf ϕ s s'} + {~@eq_sort cf ϕ s s'} := eq_sort__dec eq_universe_dec _ _. Definition valid_constraints_dec cf ϕ cstrs : {@valid_constraints cf ϕ cstrs} + {~@valid_constraints cf ϕ cstrs}. Proof. @@ -830,12 +830,12 @@ Definition valid_constraints0_dec ϕ ctrs : {@valid_constraints0 ϕ ctrs} + {~@v Definition is_lSet_dec cf ϕ s : {@is_lSet cf ϕ s} + {~@is_lSet cf ϕ s}. Proof. - apply eq_universe_dec. + apply eq_sort_dec. Defined. Definition is_allowed_elimination_dec cf ϕ allowed u : {@is_allowed_elimination cf ϕ allowed u} + {~@is_allowed_elimination cf ϕ allowed u}. Proof. cbv [is_allowed_elimination is_true]; destruct ?; auto; try solve [ repeat decide equality ]. - destruct (@is_lSet_dec cf ϕ u), is_propositional; intuition auto. + destruct (@is_lSet_dec cf ϕ u), Sort.is_propositional; intuition auto. Defined. diff --git a/common/theories/uGraph.v b/common/theories/uGraph.v index 339be5f40..3f0fdc162 100644 --- a/common/theories/uGraph.v +++ b/common/theories/uGraph.v @@ -544,36 +544,36 @@ Qed. Local Open Scope univ_scope. -Definition gc_leq0_levelalg_n n ctrs (u u' : LevelAlgExpr.t) := +Definition gc_leq0_universe_n n ctrs (u u' : Universe.t) := forall v, gc_satisfies v ctrs -> (Z.of_nat (val v u) <= Z.of_nat (val v u') - n)%Z. -Definition gc_leq_levelalg_n n ctrs (u u' : LevelAlgExpr.t) := - if check_univs then gc_leq0_levelalg_n n ctrs u u' else True. +Definition gc_leq_universe_n n ctrs (u u' : Universe.t) := + if check_univs then gc_leq0_universe_n n ctrs u u' else True. -Definition gc_eq0_levelalg φ (u u' : LevelAlgExpr.t) := +Definition gc_eq0_universe φ (u u' : Universe.t) := forall v, gc_satisfies v φ -> val v u = val v u'. -Definition gc_eq_levelalg φ (u u' : LevelAlgExpr.t) := - if check_univs then gc_eq0_levelalg φ u u' else True. +Definition gc_eq_universe φ (u u' : Universe.t) := + if check_univs then gc_eq0_universe φ u u' else True. -Definition gc_leq0_levelalg := gc_leq0_levelalg_n 0. -Definition gc_lt0_levelalg := gc_leq0_levelalg_n 1. -Definition gc_leq_levelalg := gc_leq_levelalg_n 0. -Definition gc_lt_levelalg := gc_leq_levelalg_n 1. +Definition gc_leq0_universe := gc_leq0_universe_n 0. +Definition gc_lt0_universe := gc_leq0_universe_n 1. +Definition gc_leq_universe := gc_leq_universe_n 0. +Definition gc_lt_universe := gc_leq_universe_n 1. Ltac unfold_univ_rel0 := - unfold eq0_levelalg, leq0_levelalg_n, - gc_eq0_levelalg, gc_leq0_levelalg, gc_lt0_levelalg, gc_leq0_levelalg_n in *; + unfold eq0_universe, leq0_universe_n, + gc_eq0_universe, gc_leq0_universe, gc_lt0_universe, gc_leq0_universe_n in *; intros v Hv; cbnr. Ltac unfold_univ_rel := - unfold eq_levelalg, leq_levelalg, lt_levelalg, leq_levelalg_n, - gc_eq_levelalg, gc_leq_levelalg, gc_lt_levelalg, gc_leq_levelalg_n in *; + unfold eq_universe, leq_universe, lt_universe, leq_universe_n, + gc_eq_universe, gc_leq_universe, gc_lt_universe, gc_leq_universe_n in *; destruct check_univs; [| trivial]. -Lemma gc_leq0_levelalg_n_iff (n: Z) ctrs u u' : - leq0_levelalg_n n ctrs u u' - <-> on_Some_or_None (fun ctrs => gc_leq0_levelalg_n n ctrs u u') +Lemma gc_leq0_universe_n_iff (n: Z) ctrs u u' : + leq0_universe_n n ctrs u u' + <-> on_Some_or_None (fun ctrs => gc_leq0_universe_n n ctrs u u') (gc_of_constraints ctrs). Proof. split. @@ -593,18 +593,18 @@ Proof. rewrite e in Hv; contradiction. Defined. -Lemma gc_leq0_levelalg_iff ctrs u u': - leq0_levelalg_n 0 ctrs u u' - <-> on_Some_or_None (fun ctrs => gc_leq0_levelalg_n 0 ctrs u u') +Lemma gc_leq0_universe_iff ctrs u u': + leq0_universe_n 0 ctrs u u' + <-> on_Some_or_None (fun ctrs => gc_leq0_universe_n 0 ctrs u u') (gc_of_constraints ctrs). Proof using Type. - apply gc_leq0_levelalg_n_iff. + apply gc_leq0_universe_n_iff. Qed. -Lemma gc_eq0_levelalg_iff ctrs u u' : - eq0_levelalg ctrs u u' - <-> on_Some_or_None (fun ctrs => gc_eq0_levelalg ctrs u u') +Lemma gc_eq0_universe_iff ctrs u u' : + eq0_universe ctrs u u' + <-> on_Some_or_None (fun ctrs => gc_eq0_universe ctrs u u') (gc_of_constraints ctrs). Proof. split. @@ -623,33 +623,33 @@ Proof. rewrite e in Hv; contradiction. Defined. -Lemma gc_leq_levelalg_n_iff n ctrs u u' : - leq_levelalg_n n ctrs u u' - <-> on_Some_or_None (fun ctrs => gc_leq_levelalg_n n ctrs u u') +Lemma gc_leq_universe_n_iff n ctrs u u' : + leq_universe_n n ctrs u u' + <-> on_Some_or_None (fun ctrs => gc_leq_universe_n n ctrs u u') (gc_of_constraints ctrs). Proof using Type. unfold_univ_rel. - apply gc_leq0_levelalg_n_iff. + apply gc_leq0_universe_n_iff. destruct (gc_of_constraints ctrs); reflexivity. Qed. -Lemma gc_leq_levelalg_iff ctrs u u' : - leq_levelalg ctrs u u' - <-> on_Some_or_None (fun ctrs => gc_leq_levelalg ctrs u u') +Lemma gc_leq_universe_iff ctrs u u' : + leq_universe ctrs u u' + <-> on_Some_or_None (fun ctrs => gc_leq_universe ctrs u u') (gc_of_constraints ctrs). Proof using Type. unfold_univ_rel. - apply gc_leq0_levelalg_iff. + apply gc_leq0_universe_iff. destruct (gc_of_constraints ctrs); reflexivity. Qed. -Lemma gc_eq_levelalg_iff ctrs u u' : - eq_levelalg ctrs u u' - <-> on_Some_or_None (fun ctrs => gc_eq_levelalg ctrs u u') +Lemma gc_eq_universe_iff ctrs u u' : + eq_universe ctrs u u' + <-> on_Some_or_None (fun ctrs => gc_eq_universe ctrs u u') (gc_of_constraints ctrs). Proof using Type. unfold_univ_rel. - apply gc_eq0_levelalg_iff. + apply gc_eq0_universe_iff. destruct (gc_of_constraints ctrs); reflexivity. Qed. @@ -855,7 +855,7 @@ Proof. rewrite EdgeSet.add_spec. split. * intros [[c [eq inl]]|?]. - subst e. firstorder auto. + subst e. left. repeat eexists; tea. now right. destruct H as [->|ing]; [left|right]; auto. exists a; firstorder auto. * intros [[c [eq [->|inl]]]|?]; auto. @@ -1206,30 +1206,30 @@ Section CheckLeqProcedure. end. (* this is function [exists_bigger] of kernel/uGraph.ml *) - Definition leqb_expr_univ_n_gen lt (e1 : LevelExpr.t) (u : LevelAlgExpr.t) := + Definition leqb_expr_univ_n_gen lt (e1 : LevelExpr.t) (u : Universe.t) := (* CHECKME:SPROP: should we use [prop_sub_type] here somehow? *) (* if LevelExpr.is_prop e1 && (n =? 0) then *) - (* prop_sub_type || Universe.is_prop u *) + (* prop_sub_type || Sort.is_prop u *) (* else *) - let '(e2, u) := LevelAlgExpr.exprs u in + let '(e2, u) := Universe.exprs u in List.fold_left (fun b e2 => leqb_expr_n_gen lt e1 e2 || b) u (leqb_expr_n_gen lt e1 e2). (* this is function [real_check_leq] of kernel/uGraph.ml *) - Definition leqb_levelalg_n_gen lt (l1 l2 : LevelAlgExpr.t) := - let '(e1, u1) := LevelAlgExpr.exprs l1 in + Definition leqb_universe_n_gen lt (l1 l2 : Universe.t) := + let '(e1, u1) := Universe.exprs l1 in List.fold_left (fun b e1 => leqb_expr_univ_n_gen ⎩ lt ⎭ e1 l2 && b) u1 (leqb_expr_univ_n_gen ⎩ lt ⎭ e1 l2). - Definition check_leqb_levelalg_gen (u1 u2 : LevelAlgExpr.t) := + Definition check_leqb_universe_gen (u1 u2 : Universe.t) := ~~ check_univs || (u1 == u2) - || leqb_levelalg_n_gen false u1 u2. + || leqb_universe_n_gen false u1 u2. - Definition check_eqb_levelalg_gen (u1 u2 : LevelAlgExpr.t) := + Definition check_eqb_universe_gen (u1 u2 : Universe.t) := ~~ check_univs || (u1 == u2) - || (leqb_levelalg_n_gen false u1 u2 && leqb_levelalg_n_gen false u2 u1). + || (leqb_universe_n_gen false u1 u2 && leqb_universe_n_gen false u2 u1). Definition check_gc_constraint_gen (gc : GoodConstraint.t) := ~~ check_univs || @@ -1251,19 +1251,19 @@ Section CheckLeqProcedure. end. Definition eqb_univ_instance_gen (u1 u2 : Instance.t) : bool := - forallb2 (fun l1 l2 => check_eqb_levelalg_gen - (LevelAlgExpr.make' l1) (LevelAlgExpr.make' l2)) u1 u2. + forallb2 (fun l1 l2 => check_eqb_universe_gen + (Universe.make' l1) (Universe.make' l2)) u1 u2. - Definition leqb_universe_gen (s1 s2 : Universe.t) := - leqb_universe_n_ (fun _ => check_leqb_levelalg_gen) false s1 s2. + Definition leqb_sort_gen (s1 s2 : Sort.t) := + leqb_sort_n_ (fun _ => check_leqb_universe_gen) false s1 s2. - Definition check_leqb_universe_gen (u1 u2 : Universe.t) := - Universe.eqb u1 u2 - || leqb_universe_gen u1 u2. + Definition check_leqb_sort_gen (s1 s2 : Sort.t) := + (s1 == s2) + || leqb_sort_gen s1 s2. - Definition check_eqb_universe_gen (u1 u2 : Universe.t) := - Universe.eqb u1 u2 - || (leqb_universe_gen u1 u2 && leqb_universe_gen u2 u1). + Definition check_eqb_sort_gen (s1 s2 : Sort.t) := + (s1 == s2) + || (leqb_sort_gen s1 s2 && leqb_sort_gen s2 s1). End CheckLeqProcedure. @@ -1294,14 +1294,11 @@ Section CheckLeq. Definition gc_expr_declared e := on_Some_or_None (fun l => VSet.In l uctx.1) (LevelExpr.get_noprop e). - Definition gc_levels_declared (u : LevelAlgExpr.t) + Definition gc_levels_declared (u : Universe.t) := LevelExprSet.For_all gc_expr_declared u. - Definition gc_levels_declared_univ (u : Universe.t) - := match u with - | Universe.lSProp | Universe.lProp => True - | Universe.lType l => gc_levels_declared l - end. + Definition gc_levels_declared_sort (s : Sort.t) + := Sort.on_sort gc_levels_declared True s. Lemma val_level_of_variable_level v (l : VariableLevel.t) : val v (l : Level.t) = val v l. @@ -1318,7 +1315,7 @@ Section CheckLeq. Qed. Lemma val_labelling_of_valuation' v (l : Level.t) n : - val v (LevelAlgExpr.make (l, n)) + val v (Universe.make (l, n)) = n + labelling_of_valuation v l. Proof using Type. reflexivity. @@ -1361,13 +1358,13 @@ Section CheckLeq. (** ** Check of leq ** *) Ltac unfold_univ_rel0 := - unfold eq0_levelalg, leq0_levelalg_n, leq_vertices, - gc_eq0_levelalg, gc_leq0_levelalg, gc_lt0_levelalg, gc_leq0_levelalg_n in *; + unfold eq0_universe, leq0_universe_n, leq_vertices, + gc_eq0_universe, gc_leq0_universe, gc_lt0_universe, gc_leq0_universe_n in *; intros v Hv; cbnr. - Lemma leq_levelalg_vertices0 n (l l' : Level.t) + Lemma leq_universe_vertices0 n (l l' : Level.t) : leq_vertices G n l l' - -> gc_leq0_levelalg_n n uctx.2 (LevelAlgExpr.make' l) (LevelAlgExpr.make' l'). + -> gc_leq0_universe_n n uctx.2 (Universe.make' l) (Universe.make' l'). Proof using HG. intros H. unfold_univ_rel0. apply make_graph_spec in Hv; tas. @@ -1377,16 +1374,16 @@ Section CheckLeq. rewrite !val_labelling_of_valuation; lia. Qed. - Lemma leq_levelalg_vertices1 n (l l' : Level.t) + Lemma leq_universe_vertices1 n (l l' : Level.t) (Hl : VSet.In l (wGraph.V G)) (Hl' : VSet.In l' (wGraph.V G)) - : gc_leq0_levelalg_n n uctx.2 (LevelAlgExpr.make' l) (LevelAlgExpr.make' l') + : gc_leq0_universe_n n uctx.2 (Universe.make' l) (Universe.make' l') -> leq_vertices G n l l'. Proof using HG Huctx. intros H. unfold_univ_rel0. eapply correct_labelling_proper in Hv. 2:symmetry; tea. 2:reflexivity. specialize (H _ (make_graph_spec' _ Huctx _ Hv)) as HH. eapply HG in Hl, Hl'. - rewrite !LevelAlgExpr.val_make' in HH. + rewrite !Universe.val_make' in HH. rewrite <- (valuation_labelling_eq _ _ Hv l Hl). rewrite <- (valuation_labelling_eq _ _ Hv l' Hl'). pose proof (val_labelling_of_valuation (valuation_of_labelling v) l). @@ -1394,14 +1391,14 @@ Section CheckLeq. rewrite H0 H1 in HH. lia. Qed. - Lemma leq_levelalg_vertices n (l l' : Level.t) + Lemma leq_universe_vertices n (l l' : Level.t) (Hl : VSet.In l (wGraph.V G)) (Hl' : VSet.In l' (wGraph.V G)) - : gc_leq0_levelalg_n n uctx.2 (LevelAlgExpr.make' l) (LevelAlgExpr.make' l') + : gc_leq0_universe_n n uctx.2 (Universe.make' l) (Universe.make' l') <-> leq_vertices G n l l'. Proof using HG Huctx. split. - - intros H. unfold_univ_rel0. apply leq_levelalg_vertices1; tas. - - apply leq_levelalg_vertices0. + - intros H. unfold_univ_rel0. apply leq_universe_vertices1; tas. + - apply leq_universe_vertices0. Qed. Definition leqb_level_n n (l l' : Level.t) @@ -1410,12 +1407,12 @@ Section CheckLeq. Definition leqb_level_n_spec_gen (leqb_level_n : Z -> Level.t -> Level.t -> bool) := forall n (l l' : Level.t) (Hl : VSet.In l uctx.1) (Hl' : VSet.In l' uctx.1), leqb_level_n n l l' - <-> gc_leq0_levelalg_n n uctx.2 (LevelAlgExpr.make' l) (LevelAlgExpr.make' l'). + <-> gc_leq0_universe_n n uctx.2 (Universe.make' l) (Universe.make' l'). Lemma leqb_level_n_spec : leqb_level_n_spec_gen leqb_level_n. Proof using HC HG Huctx. unfold leqb_level_n_spec_gen; intros; - symmetry. etransitivity. apply leq_levelalg_vertices; now apply HG. + symmetry. etransitivity. apply leq_universe_vertices; now apply HG. etransitivity. apply leqb_vertices_correct; try exact _. 1-2:now rewrite HG; exact _. now unfold leqb_level_n. Qed. @@ -1428,7 +1425,7 @@ Section CheckLeq. : gc_expr_declared e -> gc_expr_declared e' -> leqb_expr_n_gen leqb_level_n_gen lt e e' -> - gc_leq0_levelalg_n lt uctx.2 (LevelAlgExpr.make e) (LevelAlgExpr.make e'). + gc_leq0_universe_n lt uctx.2 (Universe.make e) (Universe.make e'). Proof using Type. unfold leqb_expr_n. destruct e as [l k], e' as [l' k']; @@ -1448,7 +1445,7 @@ Section CheckLeq. (HHl : gc_expr_declared e) (HHl' : gc_expr_declared e') : leqb_expr_n_gen leqb_level_n_gen ⎩ n ⎭ e e' - <-> gc_leq0_levelalg_n ⎩ n ⎭ uctx.2 (LevelAlgExpr.make e) (LevelAlgExpr.make e'). + <-> gc_leq0_universe_n ⎩ n ⎭ uctx.2 (Universe.make e) (Universe.make e'). Proof using HC. split; [apply (leqb_expr_n_spec0_gen _ leqb_correct)|]; try assumption. destruct e as [l k] eqn:eqe, e' as [l' k'] eqn:eqe'; cbn; intro H; @@ -1470,18 +1467,18 @@ Section CheckLeq. (leqb_correct : leqb_level_n_spec_gen leqb_level_n_gen) n e1 u : gc_expr_declared e1 -> gc_levels_declared u -> leqb_expr_univ_n_gen leqb_level_n_gen n e1 u - -> gc_leq0_levelalg_n n uctx.2 (LevelAlgExpr.make e1) u. + -> gc_leq0_universe_n n uctx.2 (Universe.make e1) u. Proof using Type. unfold leqb_expr_univ_n_gen; intros He1 Hu H. unfold_univ_rel0. rewrite val_fold_right. - destruct (LevelAlgExpr.exprs u) as [e u'] eqn:ee;cbn in *. + destruct (Universe.exprs u) as [e u'] eqn:ee;cbn in *. rewrite <- !fold_left_rev_right in H; cbn in *. red in Hu. assert (Hu': gc_expr_declared e /\ Forall gc_expr_declared u'). { - split. apply Hu. apply In_to_nonempty_list. fold LevelAlgExpr.exprs. left. now rewrite ee. + split. apply Hu. apply In_to_nonempty_list. fold Universe.exprs. left. now rewrite ee. apply Forall_forall. intros e' He'. apply Hu. - apply In_to_nonempty_list. fold LevelAlgExpr.exprs. right. now rewrite ee. } + apply In_to_nonempty_list. fold Universe.exprs. right. now rewrite ee. } destruct Hu' as [He Hu']. apply Forall_rev in Hu'. revert Hu'. induction (List.rev u'); cbn in *; intros. @@ -1496,7 +1493,7 @@ Section CheckLeq. Import Nbar Datatypes. - Lemma val_le_caract' (u : LevelAlgExpr.t) v k : + Lemma val_le_caract' (u : Universe.t) v k : (exists e, LevelExprSet.In e u /\ Z.of_nat k <= Z.of_nat (val v e))%Z <-> (Z.of_nat k <= Z.of_nat (val v u))%Z. Proof using Type. epose proof (val_le_caract u v k). @@ -1509,7 +1506,7 @@ Section CheckLeq. lia. Qed. - Lemma val_ge_caract' (u : LevelAlgExpr.t) v k : + Lemma val_ge_caract' (u : Universe.t) v k : (forall e, LevelExprSet.In e u -> (Z.of_nat (val v e) <= Z.of_nat k)%Z) <-> (Z.of_nat (val v u) <= Z.of_nat k)%Z. Proof using Type. epose proof (val_ge_caract u v k). @@ -1558,13 +1555,13 @@ Section CheckLeq. (* Non trivial lemma *) (* l + n <= max (l1, ... ln) -> exists i, l+n <= li *) - Lemma gc_leq0_levelalg_n_sup lt (l : Level.t) b (u : LevelAlgExpr.t) + Lemma gc_leq0_universe_n_sup lt (l : Level.t) b (u : Universe.t) (e := (l, b)) : gc_level_declared l -> gc_levels_declared u -> - gc_leq0_levelalg_n ⎩ lt ⎭ uctx.2 (LevelAlgExpr.make e) u -> + gc_leq0_universe_n ⎩ lt ⎭ uctx.2 (Universe.make e) u -> exists (e' : LevelExpr.t), LevelExprSet.In e' u - /\ gc_leq0_levelalg_n ⎩ lt ⎭ uctx.2 (LevelAlgExpr.make e) (LevelAlgExpr.make e'). + /\ gc_leq0_universe_n ⎩ lt ⎭ uctx.2 (Universe.make e) (Universe.make e'). Proof using HC HG Huctx. intros Hl Hu H. assert (HG1 : invariants G) by (rewrite HG; exact _). @@ -1612,7 +1609,7 @@ Section CheckLeq. forward Hv; [now rewrite <- HG|]. specialize (H _ Hv). specialize (Hl' _ Hv). specialize (Hl'' _ Hv). - rewrite LevelAlgExpr.val_make in H. + rewrite Universe.val_make in H. rewrite (val_valuation_of_labelling' _ l b) in H; tas. apply switch_minus in H. subst e. @@ -1768,7 +1765,7 @@ Section CheckLeq. pose proof (make_graph_spec' _ Huctx lab) as Hv. forward Hv; [now rewrite <- HG|]. specialize (H _ Hv); clear Hv. - rewrite LevelAlgExpr.val_make in H. + rewrite Universe.val_make in H. rewrite val_valuation_of_labelling' in H; tas. apply switch_minus in H. @@ -1850,23 +1847,23 @@ Section CheckLeq. Lemma leqb_expr_univ_n_spec_gen leqb_level_n_gen (leqb_correct : leqb_level_n_spec_gen leqb_level_n_gen) - lt e1 (u : LevelAlgExpr.t) + lt e1 (u : Universe.t) (He1 : gc_expr_declared e1) (Hu : gc_levels_declared u) : leqb_expr_univ_n_gen leqb_level_n_gen ⎩ lt ⎭ e1 u - <-> gc_leq0_levelalg_n ⎩ lt ⎭ uctx.2 (LevelAlgExpr.make e1) u. + <-> gc_leq0_universe_n ⎩ lt ⎭ uctx.2 (Universe.make e1) u. Proof using HC HG Huctx. split; [eapply leqb_expr_univ_n_spec0_gen; eauto|]. unfold leqb_expr_univ_n_gen; intro HH. - case_eq (LevelAlgExpr.exprs u). intros e u' ee. + case_eq (Universe.exprs u). intros e u' ee. assert (Hu': gc_expr_declared e /\ Forall gc_expr_declared u'). { - split. apply Hu. apply In_to_nonempty_list. fold LevelAlgExpr.exprs. left. now rewrite ee. + split. apply Hu. apply In_to_nonempty_list. fold Universe.exprs. left. now rewrite ee. apply Forall_forall. intros e' He'. apply Hu. - apply In_to_nonempty_list. fold LevelAlgExpr.exprs. right. now rewrite ee. } + apply In_to_nonempty_list. fold Universe.exprs. right. now rewrite ee. } destruct e1 as [l1 b1]. - apply gc_leq0_levelalg_n_sup in HH; tas. + apply gc_leq0_universe_n_sup in HH; tas. destruct HH as [e' [He' HH]]. eapply leqb_expr_n_spec_gen in HH; eauto; tas. - apply In_to_nonempty_list in He'. fold LevelAlgExpr.exprs in He'; rewrite ee in He'; cbn in He'. + apply In_to_nonempty_list in He'. fold Universe.exprs in He'; rewrite ee in He'; cbn in He'. rewrite <- !fold_left_rev_right. clear -He' HH. destruct He' as [H|H]; [subst|]. * induction (List.rev u'); tas;cbn -[leqb_expr_n]. @@ -1878,27 +1875,27 @@ Section CheckLeq. Definition leqb_expr_univ_n_spec := leqb_expr_univ_n_spec_gen _ leqb_level_n_spec. - Definition leqb_levelalg_n := (leqb_levelalg_n_gen leqb_level_n). + Definition leqb_universe_n := (leqb_universe_n_gen leqb_level_n). Lemma fold_right_xpred0 {A} (l : list A) : fold_right (fun _ => xpred0) false l = false. Proof using Type. induction l; simpl; auto. Qed. - Lemma leqb_levelalg_n_spec0_gen leqb_level_n_gen + Lemma leqb_universe_n_spec0_gen leqb_level_n_gen (leqb_correct : leqb_level_n_spec_gen leqb_level_n_gen) - lt (u1 u2 : LevelAlgExpr.t) + lt (u1 u2 : Universe.t) (Hu1 : gc_levels_declared u1) (Hu2 : gc_levels_declared u2) -: leqb_levelalg_n_gen leqb_level_n_gen lt u1 u2 -> gc_leq0_levelalg_n ⎩ lt ⎭ uctx.2 u1 u2. +: leqb_universe_n_gen leqb_level_n_gen lt u1 u2 -> gc_leq0_universe_n ⎩ lt ⎭ uctx.2 u1 u2. Proof using Type. - unfold leqb_levelalg_n_gen. intros H. + unfold leqb_universe_n_gen. intros H. unfold_univ_rel0. - unfold val, LevelAlgExpr.Evaluable. - destruct (LevelAlgExpr.exprs u1) as [e1 u1'] eqn:Hu1'. + unfold val, Universe.Evaluable. + destruct (Universe.exprs u1) as [e1 u1'] eqn:Hu1'. rewrite <- fold_left_rev_right in *; cbn in *. assert (Hu': gc_expr_declared e1 /\ Forall gc_expr_declared u1'). { - split. apply Hu1. apply In_to_nonempty_list. fold LevelAlgExpr.exprs. left. now rewrite Hu1'. + split. apply Hu1. apply In_to_nonempty_list. fold Universe.exprs. left. now rewrite Hu1'. apply Forall_forall. intros e' He'. apply Hu1. - apply In_to_nonempty_list. fold LevelAlgExpr.exprs. right. now rewrite Hu1'. } + apply In_to_nonempty_list. fold Universe.exprs. right. now rewrite Hu1'. } destruct Hu' as [? Hu']. apply Forall_rev in Hu'. revert Hu'. induction (List.rev u1'); cbn in *; intros. + eapply leqb_expr_univ_n_spec0_gen in H; eauto. @@ -1912,19 +1909,19 @@ Section CheckLeq. * now inversion Hu'. Qed. - Definition leqb_levelalg_n_spec0 := leqb_levelalg_n_spec0_gen _ leqb_level_n_spec. + Definition leqb_universe_n_spec0 := leqb_universe_n_spec0_gen _ leqb_level_n_spec. - Lemma leqb_levelalg_n_spec_gen leqb_level_n_gen + Lemma leqb_universe_n_spec_gen leqb_level_n_gen (leqb_correct : leqb_level_n_spec_gen leqb_level_n_gen) - lt (l1 l2 : LevelAlgExpr.t) + lt (l1 l2 : Universe.t) (Hu1 : gc_levels_declared l1) (Hu2 : gc_levels_declared l2) - : leqb_levelalg_n_gen leqb_level_n_gen lt l1 l2 - <-> gc_leq0_levelalg_n ⎩ lt ⎭ uctx.2 l1 l2. + : leqb_universe_n_gen leqb_level_n_gen lt l1 l2 + <-> gc_leq0_universe_n ⎩ lt ⎭ uctx.2 l1 l2. Proof using HC HG Huctx. - split; [eapply leqb_levelalg_n_spec0_gen; eauto |]. - unfold leqb_levelalg_n_gen; intro HH. - unfold LevelAlgExpr.exprs. + split; [eapply leqb_universe_n_spec0_gen; eauto |]. + unfold leqb_universe_n_gen; intro HH. + unfold Universe.exprs. case_eq (to_nonempty_list l1); intros e1 uu1 Huu1. rewrite (fold_left_andb_forallb (fun e => _)). pose proof (to_nonempty_list_spec' l1) as X; rewrite Huu1 in X; cbn in X. @@ -1939,59 +1936,59 @@ Section CheckLeq. eapply (val_ge_caract' l1 v (val v l1)).p2. lia. auto. Qed. - Definition leqb_levelalg_n_spec := leqb_levelalg_n_spec_gen _ leqb_level_n_spec. + Definition leqb_universe_n_spec := leqb_universe_n_spec_gen _ leqb_level_n_spec. - Definition check_leqb_levelalg := (check_leqb_levelalg_gen leqb_level_n). + Definition check_leqb_universe := (check_leqb_universe_gen leqb_level_n). - Lemma check_leqb_levelalg_spec_gen leqb_level_n_gen + Lemma check_leqb_universe_spec_gen leqb_level_n_gen (leqb_correct : leqb_level_n_spec_gen leqb_level_n_gen) - (u1 u2 : LevelAlgExpr.t) + (u1 u2 : Universe.t) (Hu1 : gc_levels_declared u1) (Hu2 : gc_levels_declared u2) - : check_leqb_levelalg_gen leqb_level_n_gen u1 u2 <-> gc_leq_levelalg uctx.2 u1 u2. + : check_leqb_universe_gen leqb_level_n_gen u1 u2 <-> gc_leq_universe uctx.2 u1 u2. Proof using HC HG Huctx. - unfold check_leqb_levelalg_gen, - gc_leq_levelalg, gc_leq_levelalg_n, - leqb_levelalg_n_gen, gc_leq0_levelalg_n. + unfold check_leqb_universe_gen, + gc_leq_universe, gc_leq_universe_n, + leqb_universe_n_gen, gc_leq0_universe_n. destruct check_univs; [|split; trivial]. split; cbn. - move/orP => [|]. + rewrite univ_expr_eqb_true_iff. intros <- v Hv. lia. - + now eapply (leqb_levelalg_n_spec0_gen _ _ false). - - intros H; eapply (leqb_levelalg_n_spec_gen _ _ false) in H; tas. - unfold leqb_levelalg_n_gen in H. rewrite H. + + now eapply (leqb_universe_n_spec0_gen _ _ false). + - intros H; eapply (leqb_universe_n_spec_gen _ _ false) in H; tas. + unfold leqb_universe_n_gen in H. rewrite H. now rewrite orb_true_r. Unshelve. all:eauto. Qed. - Definition check_leqb_levelalg_spec := check_leqb_levelalg_spec_gen _ leqb_level_n_spec. + Definition check_leqb_universe_spec := check_leqb_universe_spec_gen _ leqb_level_n_spec. - Definition check_eqb_levelalg := (check_eqb_levelalg_gen leqb_level_n). + Definition check_eqb_universe := (check_eqb_universe_gen leqb_level_n). - Lemma check_eqb_levelalg_spec_gen leqb_level_n_gen + Lemma check_eqb_universe_spec_gen leqb_level_n_gen (leqb_correct : leqb_level_n_spec_gen leqb_level_n_gen) - (l1 l2 : LevelAlgExpr.t) + (l1 l2 : Universe.t) (Hu1 : gc_levels_declared l1) (Hu2 : gc_levels_declared l2) - : check_eqb_levelalg_gen leqb_level_n_gen l1 l2 <-> gc_eq_levelalg uctx.2 l1 l2. + : check_eqb_universe_gen leqb_level_n_gen l1 l2 <-> gc_eq_universe uctx.2 l1 l2. Proof using HC HG Huctx. - unfold check_eqb_levelalg_gen, gc_eq_levelalg. + unfold check_eqb_universe_gen, gc_eq_universe. destruct check_univs; [|split; trivial]. split; cbn. - move/orP => [ | /andP [Hle Hge]]. + rewrite univ_expr_eqb_true_iff. now intros <- v Hv. - + eapply leqb_levelalg_n_spec0_gen in Hle, Hge; eauto. + + eapply leqb_universe_n_spec0_gen in Hle, Hge; eauto. unfold_univ_rel0. specialize (Hle v Hv); specialize (Hge v Hv). simpl in *. lia. - intros H. toProp; right. - toProp; eapply leqb_levelalg_n_spec_gen; tas; intros v Hv; specialize (H v Hv). + toProp; eapply leqb_universe_n_spec_gen; tas; intros v Hv; specialize (H v Hv). rewrite H. cbn; lia. rewrite H. cbn; lia. Qed. - Definition check_eqb_levelalg_spec := check_eqb_levelalg_spec_gen _ leqb_level_n_spec. + Definition check_eqb_universe_spec := check_eqb_universe_spec_gen _ leqb_level_n_spec. Lemma fold_left_false {A} l : fold_left (B:=A) (fun _ : bool => xpred0) l false = false. Proof using Type. @@ -2070,56 +2067,54 @@ Section CheckLeq. Definition eqb_univ_instance := (eqb_univ_instance_gen leqb_level_n). - Definition leqb_universe := (leqb_universe_gen leqb_level_n). + Definition leqb_sort := (leqb_sort_gen leqb_level_n). - Definition check_leqb_universe := (check_leqb_universe_gen leqb_level_n). + Definition check_leqb_sort := (check_leqb_sort_gen leqb_level_n). - Definition check_eqb_universe := (check_eqb_universe_gen leqb_level_n). + Definition check_eqb_sort := (check_eqb_sort_gen leqb_level_n). - Lemma check_eqb_universe_refl_gen leqb_level_n_gen + Lemma check_eqb_sort_refl_gen leqb_level_n_gen (leqb_correct : leqb_level_n_spec_gen leqb_level_n_gen) u : - check_eqb_universe_gen leqb_level_n_gen u u. + check_eqb_sort_gen leqb_level_n_gen u u. Proof using Type. - unfold check_eqb_universe_gen; toProp; left. - apply Universe.eqb_refl. + unfold check_eqb_sort_gen; toProp; left. + apply eqb_refl. Qed. - Definition check_eqb_universe_refl := check_eqb_universe_refl_gen _ leqb_level_n_spec. + Definition check_eqb_sort_refl := check_eqb_sort_refl_gen _ leqb_level_n_spec. - Definition gc_leq_universe := - leq_universe_n_ (fun n φ u u' => if check_univs then gc_leq0_levelalg_n n φ u u' else True) 0. + Definition gc_leq_sort φ := + leq_sort_n_ (fun n u u' => if check_univs then gc_leq0_universe_n n φ u u' else True) 0. - Definition gc_eq_universe := - eq_universe_ false (fun φ u u' => if check_univs then gc_eq0_levelalg φ u u' else True). + Definition gc_eq_sort φ := + eq_sort_ (fun u u' => if check_univs then gc_eq0_universe φ u u' else True). - Let levels_declared_univ (u : Universe.t) := - match u with - | Universe.lSProp | Universe.lProp => True - | Universe.lType l => gc_levels_declared l - end. + Let levels_declared_sort (s : Sort.t) := + Sort.on_sort gc_levels_declared True s. - Lemma check_eqb_universe_spec_gen leqb_level_n_gen + Lemma check_eqb_sort_spec_gen leqb_level_n_gen (leqb_correct : leqb_level_n_spec_gen leqb_level_n_gen) - (u1 u2 : Universe.t) - (Hu1 : levels_declared_univ u1) - (Hu2 : levels_declared_univ u2) - : check_eqb_universe_gen leqb_level_n_gen u1 u2 <-> gc_eq_universe uctx.2 u1 u2. + (u1 u2 : Sort.t) + (Hu1 : levels_declared_sort u1) + (Hu2 : levels_declared_sort u2) + : check_eqb_sort_gen leqb_level_n_gen u1 u2 <-> gc_eq_sort uctx.2 u1 u2. Proof. - unfold check_eqb_universe_gen, gc_eq_universe. + unfold check_eqb_sort_gen, gc_eq_sort. destruct u1, u2; cbnr; split; intuition auto. - now destruct prop_sub_type. - - eapply check_eqb_levelalg_spec_gen; eauto; tas. - unfold check_eqb_universe_gen, check_eqb_levelalg_gen in *; cbn in *. - unfold check_leqb_levelalg_gen in *. + - eapply check_eqb_universe_spec_gen; eauto; tas. + unfold check_eqb_sort_gen, check_eqb_universe_gen in *; cbn in *. + unfold check_leqb_universe_gen in *. destruct check_univs; cbnr. - move/orP: H => [-> | /andP [/orP [/orP [Hf | ->] | H1] /orP [/orP [Hf' | e] | H2]]] //. + unfold eqb at 1, Sort.reflect_eq_sort, Sort.eqb in H. cbn in H. + move/orP : H => /= [-> //|] /andP[] /orP[-> //|] H1 /orP[e | H2]. 1: apply NonEmptySetFacts.univ_expr_eqb_true_iff in e as ->. 1: toProp; left; now apply NonEmptySetFacts.univ_expr_eqb_true_iff. toProp; right; now toProp. - toProp; right. - eapply check_eqb_levelalg_spec_gen in H; eauto; tas. - unfold check_eqb_levelalg_gen in *; cbn in *. - unfold check_leqb_levelalg_gen in *. + eapply check_eqb_universe_spec_gen in H; eauto; tas. + unfold check_eqb_universe_gen in *; cbn in *. + unfold check_leqb_universe_gen in *. destruct check_univs; [cbn in * | trivial]. move/orP : H => [H | /andP [H1 H2]]. + apply NonEmptySetFacts.univ_expr_eqb_true_iff in H as ->. @@ -2127,7 +2122,7 @@ Section CheckLeq. + toProp; toProp; right; assumption. Defined. - Definition check_eqb_universe_spec := check_eqb_universe_spec_gen _ leqb_level_n_spec. + Definition check_eqb_sort_spec := check_eqb_sort_spec_gen _ leqb_level_n_spec. End CheckLeq. @@ -2178,7 +2173,7 @@ Section CheckLeq2. := on_Some_or_None (fun l : Level.t => level_declared l) (LevelExpr.get_noprop e). - Let levels_declared (u : LevelAlgExpr.t) := + Let levels_declared (u : Universe.t) := LevelExprSet.For_all expr_declared u. Lemma level_gc_declared_declared l @@ -2198,7 +2193,7 @@ Section CheckLeq2. intro; now apply (level_gc_declared_declared l) in H. Qed. - Lemma levels_gc_declared_declared (u : LevelAlgExpr.t) + Lemma levels_gc_declared_declared (u : Universe.t) : levels_declared u -> gc_levels_declared uctx' u. Proof using HG expr_declared. unfold levels_declared, gc_levels_declared. @@ -2212,13 +2207,13 @@ Section CheckLeq2. (He1 : expr_declared e1) (Hu : levels_declared u) : leqb_expr_univ_n_gen leqb_level_n_gen ⎩ lt ⎭ e1 u - <-> leq0_levelalg_n ⎩ lt ⎭ uctx.2 (LevelAlgExpr.make e1) u. + <-> leq0_universe_n ⎩ lt ⎭ uctx.2 (Universe.make e1) u. Proof using HG' Huctx'. etransitivity. eapply (leqb_expr_univ_n_spec_gen G uctx' Huctx' HC' HG'); eauto; tas. - apply expr_gc_declared_declared; tas. - apply levels_gc_declared_declared; tas. - - symmetry. etransitivity. apply gc_leq0_levelalg_n_iff. + - symmetry. etransitivity. apply gc_leq0_universe_n_iff. unfold uctx'; cbn; clear -HG. unfold is_graph_of_uctx, gc_of_uctx in *. destruct (gc_of_constraints uctx.2) as [ctrs|]. @@ -2228,19 +2223,19 @@ Section CheckLeq2. Definition leqb_univ_expr_n_spec' := leqb_univ_expr_n_spec_gen' _ (leqb_level_n_spec _ _ Huctx' HC' HG'). - Lemma check_leqb_levelalg_spec_gen' leqb_level_n_gen + Lemma check_leqb_universe_spec_gen' leqb_level_n_gen (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) u1 u2 : levels_declared u1 -> levels_declared u2 -> - check_leqb_levelalg_gen leqb_level_n_gen u1 u2 -> leq_levelalg uctx.2 u1 u2. + check_leqb_universe_gen leqb_level_n_gen u1 u2 -> leq_universe uctx.2 u1 u2. Proof using HG' Huctx'. - unfold check_leqb_levelalg_gen; intros Hu1 Hu2 H. + unfold check_leqb_universe_gen; intros Hu1 Hu2 H. unfold_univ_rel. cbn in H; toProp H; destruct H as [e | ]. { apply NonEmptySetFacts.univ_expr_eqb_true_iff in e. destruct e; lia. } - eapply leqb_levelalg_n_spec0_gen in H; eauto. - eapply gc_leq0_levelalg_iff; tea. + eapply leqb_universe_n_spec0_gen in H; eauto. + eapply gc_leq0_universe_iff; tea. unfold uctx' in *. unfold is_graph_of_uctx, gc_of_uctx in HG. destruct (gc_of_constraints uctx.2). cbn in *. exact H. @@ -2248,80 +2243,80 @@ Section CheckLeq2. Unshelve. all: try eapply levels_gc_declared_declared; eauto. Qed. - Definition check_leqb_levelalg_spec' := - check_leqb_levelalg_spec_gen' _ (leqb_level_n_spec _ _ Huctx' HC' HG'). + Definition check_leqb_universe_spec' := + check_leqb_universe_spec_gen' _ (leqb_level_n_spec _ _ Huctx' HC' HG'). - Lemma check_leqb_levelalg_complete_gen leqb_level_n_gen + Lemma check_leqb_universe_complete_gen leqb_level_n_gen (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) u1 u2 : levels_declared u1 -> levels_declared u2 -> - leq_levelalg uctx.2 u1 u2 -> - check_leqb_levelalg_gen leqb_level_n_gen u1 u2. + leq_universe uctx.2 u1 u2 -> + check_leqb_universe_gen leqb_level_n_gen u1 u2. Proof using HG' Huctx'. intros decl1 decl2. apply levels_gc_declared_declared in decl1. apply levels_gc_declared_declared in decl2. - rewrite gc_leq_levelalg_iff. + rewrite gc_leq_universe_iff. unfold is_graph_of_uctx, gc_of_uctx in HG. unfold uctx' in *. destruct gc_of_constraints; [cbn in *|contradiction HG]. intros eq. - apply <- check_leqb_levelalg_spec_gen; eauto. + apply <- check_leqb_universe_spec_gen; eauto. exact eq. Qed. - Definition check_leqb_levelalg_complete := - check_leqb_levelalg_complete_gen _ (leqb_level_n_spec _ _ Huctx' HC' HG'). + Definition check_leqb_universe_complete := + check_leqb_universe_complete_gen _ (leqb_level_n_spec _ _ Huctx' HC' HG'). - Lemma check_eqb_levelalg_spec_gen' leqb_level_n_gen + Lemma check_eqb_universe_spec_gen' leqb_level_n_gen (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) u1 u2 : levels_declared u1 -> levels_declared u2 -> - check_eqb_levelalg_gen leqb_level_n_gen u1 u2 -> eq_levelalg uctx.2 u1 u2. + check_eqb_universe_gen leqb_level_n_gen u1 u2 -> eq_universe uctx.2 u1 u2. Proof using HG' Huctx'. - unfold check_eqb_levelalg_gen; intros Hu1 Hu2 H. + unfold check_eqb_universe_gen; intros Hu1 Hu2 H. unfold_univ_rel. cbn in H; toProp H; destruct H as [e | ]. { apply NonEmptySetFacts.univ_expr_eqb_true_iff in e. destruct e; lia. } apply andb_prop in H. destruct H as [H1 H2]. - unshelve eapply leqb_levelalg_n_spec0_gen in H1; eauto. - unshelve eapply leqb_levelalg_n_spec0_gen in H2; eauto. + unshelve eapply leqb_universe_n_spec0_gen in H1; eauto. + unshelve eapply leqb_universe_n_spec0_gen in H2; eauto. unfold uctx' in *. unfold is_graph_of_uctx, gc_of_uctx in HG. - apply <- eq0_leq0_levelalg; tea. - split; eapply gc_leq0_levelalg_iff; + apply <- eq0_leq0_universe; tea. + split; eapply gc_leq0_universe_iff; (destruct (gc_of_constraints uctx.2); [cbn in *|contradiction HG]); tas. all: now eapply levels_gc_declared_declared. Qed. - Definition check_eqb_levelalg_spec' := - check_eqb_levelalg_spec_gen' _ (leqb_level_n_spec _ _ Huctx' HC' HG'). + Definition check_eqb_universe_spec' := + check_eqb_universe_spec_gen' _ (leqb_level_n_spec _ _ Huctx' HC' HG'). - Lemma check_eqb_levelalg_complete_gen leqb_level_n_gen + Lemma check_eqb_universe_complete_gen leqb_level_n_gen (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) u1 u2 : levels_declared u1 -> levels_declared u2 -> - eq_levelalg uctx.2 u1 u2 -> - check_eqb_levelalg_gen leqb_level_n_gen u1 u2. + eq_universe uctx.2 u1 u2 -> + check_eqb_universe_gen leqb_level_n_gen u1 u2. Proof using HG' Huctx'. intros decl1 decl2. apply levels_gc_declared_declared in decl1. apply levels_gc_declared_declared in decl2. - rewrite gc_eq_levelalg_iff. + rewrite gc_eq_universe_iff. unfold is_graph_of_uctx, gc_of_uctx in HG. unfold uctx' in *. destruct gc_of_constraints; [cbn in *|contradiction HG]. intros eq. - apply <- check_eqb_levelalg_spec_gen; eauto. + apply <- check_eqb_universe_spec_gen; eauto. exact eq. Qed. - Definition check_eqb_levelalg_complete := - check_eqb_levelalg_complete_gen _ (leqb_level_n_spec _ _ Huctx' HC' HG'). + Definition check_eqb_universe_complete := + check_eqb_universe_complete_gen _ (leqb_level_n_spec _ _ Huctx' HC' HG'). Definition leq0_level_n z l l' := - leq0_levelalg_n z uctx.2 (LevelAlgExpr.make' l) (LevelAlgExpr.make' l'). + leq0_universe_n z uctx.2 (Universe.make' l) (Universe.make' l'). Definition valid_gc_constraint (gc : GoodConstraint.t) := match gc with @@ -2344,7 +2339,7 @@ Section CheckLeq2. Proof using HG' Huctx'. intros decll decll'. unfold leq0_level_n. - intros le; eapply gc_leq0_levelalg_n_iff in le. + intros le; eapply gc_leq0_universe_n_iff in le. unfold is_graph_of_uctx, gc_of_uctx in HG. unfold uctx' in *. destruct gc_of_constraints; [cbn in *|contradiction HG]. @@ -2482,65 +2477,62 @@ Section CheckLeq2. Definition check_constraints_complete := check_constraints_complete_gen _ (leqb_level_n_spec _ _ Huctx' HC' HG'). - Let levels_declared_univ (u : Universe.t) - := match u with - | Universe.lSProp | Universe.lProp => True - | Universe.lType l => levels_declared l - end. + Let levels_declared_sort (s : Sort.t) + := Sort.on_sort levels_declared True s. - Lemma levels_univ_gc_declared_declared (u : Universe.t) - : levels_declared_univ u -> gc_levels_declared_univ uctx' u. + Lemma levels_univ_gc_declared_declared (s : Sort.t) + : levels_declared_sort s -> gc_levels_declared_sort uctx' s. Proof using HG levels_declared. - destruct u; cbnr. + destruct s; cbnr. apply levels_gc_declared_declared. Qed. - Lemma check_leqb_universe_spec_gen' leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) u1 u2 - : levels_declared_univ u1 -> - levels_declared_univ u2 -> - check_leqb_universe_gen leqb_level_n_gen u1 u2 -> leq_universe uctx.2 u1 u2. + Lemma check_leqb_sort_spec_gen' leqb_level_n_gen + (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) s1 s2 + : levels_declared_sort s1 -> + levels_declared_sort s2 -> + check_leqb_sort_gen leqb_level_n_gen s1 s2 -> leq_sort uctx.2 s1 s2. Proof using HG' Huctx'. intros Hu1 Hu2. move => /orP [H | H]. - apply eqb_true_iff in H as ->. reflexivity. - - destruct u1, u2; cbn in *; trivial; try discriminate H. - now eapply check_leqb_levelalg_spec_gen'. + - destruct s1, s2; cbn in *; trivial; try discriminate H. + now eapply check_leqb_universe_spec_gen'. Qed. - Definition check_leqb_universe_spec' := - check_leqb_universe_spec_gen' _ (leqb_level_n_spec _ _ Huctx' HC' HG'). + Definition check_leqb_sort_spec' := + check_leqb_sort_spec_gen' _ (leqb_level_n_spec _ _ Huctx' HC' HG'). - Lemma check_leqb_universe_complete_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) u1 u2 : - levels_declared_univ u1 -> - levels_declared_univ u2 -> - leq_universe uctx.2 u1 u2 -> - check_leqb_universe_gen leqb_level_n_gen u1 u2. + Lemma check_leqb_sort_complete_gen leqb_level_n_gen + (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) s1 s2 : + levels_declared_sort s1 -> + levels_declared_sort s2 -> + leq_sort uctx.2 s1 s2 -> + check_leqb_sort_gen leqb_level_n_gen s1 s2. Proof using HG' Huctx'. - move : u1 u2 => [| | u1] [| | u2] //. cbn. + move : s1 s2 => [| | u1] [| | u2] //. cbn. intros decl1 decl2 Hle. - unfold check_leqb_universe_gen. + unfold check_leqb_sort_gen. toProp; right. - apply check_leqb_levelalg_complete_gen => //. + apply check_leqb_universe_complete_gen => //. Qed. - Definition check_leqb_universe_complete := - check_leqb_universe_complete_gen _ (leqb_level_n_spec _ _ Huctx' HC' HG'). + Definition check_leqb_sort_complete := + check_leqb_sort_complete_gen _ (leqb_level_n_spec _ _ Huctx' HC' HG'). - Lemma check_eqb_universe_spec_gen' leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) u1 u2 - : levels_declared_univ u1 -> - levels_declared_univ u2 -> - check_eqb_universe_gen leqb_level_n_gen u1 u2 -> eq_universe uctx.2 u1 u2. + Lemma check_eqb_sort_spec_gen' leqb_level_n_gen + (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) s1 s2 + : levels_declared_sort s1 -> + levels_declared_sort s2 -> + check_eqb_sort_gen leqb_level_n_gen s1 s2 -> eq_sort uctx.2 s1 s2. Proof using HG' Huctx'. - move : u1 u2 => [| | u1] [| | u2] //; intros Hu1 Hu2. + move : s1 s2 => [| | u1] [| | u2] //; intros Hu1 Hu2. { move/andP => [H HH] //. } move/orP => [H | H]. - apply eqb_true_iff in H as ->. reflexivity. - - eapply check_eqb_levelalg_spec_gen'; eauto. - cbn in H. unfold check_eqb_levelalg_gen in *. + - eapply check_eqb_universe_spec_gen'; eauto. + cbn in H. unfold check_eqb_universe_gen in *. move/andP: H => [/orP [/orP [-> | ->] | ->] /orP [/orP [He | HH] | ->]] //. all: try now rewrite orb_true_r. now rewrite He. @@ -2548,28 +2540,29 @@ Section CheckLeq2. toProp; left; toProp; right; now apply NonEmptySetFacts.univ_expr_eqb_true_iff. Qed. - Definition check_eqb_universe_spec' := - check_eqb_universe_spec_gen' _ (leqb_level_n_spec _ _ Huctx' HC' HG'). + Definition check_eqb_sort_spec' := + check_eqb_sort_spec_gen' _ (leqb_level_n_spec _ _ Huctx' HC' HG'). - Lemma check_eqb_universe_complete_gen leqb_level_n_gen + Lemma check_eqb_sort_complete_gen leqb_level_n_gen (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) u1 u2 : - levels_declared_univ u1 -> - levels_declared_univ u2 -> - eq_universe uctx.2 u1 u2 -> - check_eqb_universe_gen leqb_level_n_gen u1 u2. + levels_declared_sort u1 -> + levels_declared_sort u2 -> + eq_sort uctx.2 u1 u2 -> + check_eqb_sort_gen leqb_level_n_gen u1 u2. Proof using HG' Huctx'. move : u1 u2 => [| | u1] [| | u2] //. cbn. intros decl1 decl2 Hle. - eapply check_eqb_levelalg_complete_gen in Hle => //; eauto. - unfold check_eqb_universe_gen, leqb_universe_gen, check_leqb_levelalg_gen; cbn. - unfold check_eqb_levelalg_gen in Hle. - move/orP: Hle => [/orP [-> | ->] | /andP [H1 H2]] //. + eapply check_eqb_universe_complete_gen in Hle => //; eauto. + unfold check_eqb_sort_gen, leqb_sort_gen, check_leqb_universe_gen; cbn. + unfold check_eqb_universe_gen in Hle. + move/orP: Hle => [/orP [-> | e] | /andP [H1 H2]] //=. now rewrite orb_true_r. + apply eqb_eq in e as ->; rewrite eqb_refl //. toProp; right; toProp; toProp; right; assumption. Qed. - Definition check_eqb_universe_complete := - check_eqb_universe_complete_gen _ (leqb_level_n_spec _ _ Huctx' HC' HG'). + Definition check_eqb_sort_complete := + check_eqb_sort_complete_gen _ (leqb_level_n_spec _ _ Huctx' HC' HG'). End CheckLeq2. diff --git a/erasure/theories/EArities.v b/erasure/theories/EArities.v index 7061d66d9..f167c829a 100644 --- a/erasure/theories/EArities.v +++ b/erasure/theories/EArities.v @@ -331,7 +331,7 @@ Context {Σ : global_env_ext} {wfΣ : wf_ext Σ}. Variable Hcf : prop_sub_type = false. Lemma cumul_prop1 Γ A B u : - Universe.is_prop u -> + Sort.is_prop u -> isType Σ Γ A -> Σ ;;; Γ |- B : tSort u -> Σ ;;; Γ ⊢ A ≤ B -> @@ -342,7 +342,7 @@ Proof using Hcf wfΣ. Qed. Lemma cumul_prop2 Γ A B u : - Universe.is_prop u -> + Sort.is_prop u -> isType Σ Γ B -> Σ ;;; Γ ⊢ A ≤ B -> Σ ;;; Γ |- A : tSort u -> @@ -353,7 +353,7 @@ Proof using Hcf wfΣ. Qed. Lemma cumul_sprop1 Γ A B u : - Universe.is_sprop u -> + Sort.is_sprop u -> isType Σ Γ A -> Σ ;;; Γ |- B : tSort u -> Σ ;;; Γ ⊢ A ≤ B -> @@ -364,7 +364,7 @@ Proof using Hcf wfΣ. Qed. Lemma cumul_sprop2 Γ A B u : - Universe.is_sprop u -> + Sort.is_sprop u -> isType Σ Γ B -> Σ ;;; Γ ⊢ A ≤ B -> Σ ;;; Γ |- A : tSort u -> @@ -377,7 +377,7 @@ End Elim'. Lemma cumul_propositional (Σ : global_env_ext) Γ A B u : wf_ext Σ -> - is_propositional u -> + Sort.is_propositional u -> isType Σ Γ B -> Σ ;;; Γ ⊢ A ≤ B -> Σ ;;; Γ |- A : tSort u -> @@ -391,12 +391,12 @@ Proof. Qed. Lemma sort_typing_spine: - forall (Σ : global_env_ext) (Γ : context) (L : list term) (u : Universe.t) (x x0 : term), + forall (Σ : global_env_ext) (Γ : context) (L : list term) (u : sort) (x x0 : term), wf_ext Σ -> - is_propositional u -> + Sort.is_propositional u -> typing_spine Σ Γ x L x0 -> Σ;;; Γ |- x : tSort u -> - ∑ u', Σ;;; Γ |- x0 : tSort u' × is_propositional u'. + ∑ u', Σ;;; Γ |- x0 : tSort u' × Sort.is_propositional u'. Proof. intros Σ Γ L u x x0 HΣ ? t1 c0. assert (X : wf Σ) by apply HΣ. @@ -407,16 +407,10 @@ Proof. - eapply cumul_propositional in c0; auto. 2-3: tea. eapply inversion_Prod in c0 as (? & ? & ? & ? & e0) ; auto. eapply ws_cumul_pb_Sort_inv in e0. - unfold is_propositional in H. - destruct (Universe.is_prop u) eqn:isp => //. - eapply leq_universe_prop_r in e0 as H0; cbn; eauto. - eapply is_prop_sort_prod in H0. eapply IHt1; [unfold is_propositional; now rewrite -> H0|]. - change (tSort x0) with ((tSort x0) {0 := hd}). - eapply substitution0; eauto. - eapply leq_universe_sprop_r in e0 as H0; cbn; eauto. - eapply is_sprop_sort_prod in H0. eapply IHt1; [unfold is_propositional; now rewrite -> H0, orb_true_r|]. - change (tSort x0) with ((tSort x0) {0 := hd}). - eapply substitution0; eauto. + eapply IHt1. + 2: eapply @substitution0 with (T := tSort _); tea. + unfold compare_sort, leq_sort in *. + destruct u, x0, x => //. Qed. Lemma arity_type_inv (Σ : global_env_ext) Γ t T1 T2 : wf_ext Σ -> wf_local Σ Γ -> @@ -434,7 +428,7 @@ Qed. Lemma cumul_prop1' (Σ : global_env_ext) Γ A B u : wf_ext Σ -> isType Σ Γ A -> - is_propositional u -> + Sort.is_propositional u -> Σ ;;; Γ |- B : tSort u -> Σ ;;; Γ ⊢ A ≤ B -> Σ ;;; Γ |- A : tSort u. @@ -448,7 +442,7 @@ Qed. Lemma cumul_prop2' (Σ : global_env_ext) Γ A B u : wf_ext Σ -> isType Σ Γ A -> - is_propositional u -> + Sort.is_propositional u -> Σ ;;; Γ |- B : tSort u -> Σ ;;; Γ ⊢ B ≤ A -> Σ ;;; Γ |- A : tSort u. @@ -463,28 +457,22 @@ Lemma leq_term_propositional_sorted_l {Σ Γ v v' u u'} : wf_ext Σ -> PCUICEquality.leq_term Σ (global_ext_constraints Σ) v v' -> Σ;;; Γ |- v : tSort u -> - Σ;;; Γ |- v' : tSort u' -> is_propositional u -> - leq_universe (global_ext_constraints Σ) u' u. + Σ;;; Γ |- v' : tSort u' -> Sort.is_propositional u -> + leq_sort (global_ext_constraints Σ) u' u. Proof. intros wf leq Hv Hv' isp. - unfold is_propositional in isp. - destruct u => //. eapply leq_term_prop_sorted_l; eauto. - eapply leq_term_sprop_sorted_l; eauto. Qed. Lemma leq_term_propopositional_sorted_r {Σ Γ v v' u u'} : wf_ext Σ -> PCUICEquality.leq_term Σ (global_ext_constraints Σ) v v' -> Σ;;; Γ |- v : tSort u -> - Σ;;; Γ |- v' : tSort u' -> is_propositional u' -> - leq_universe (global_ext_constraints Σ) u u'. + Σ;;; Γ |- v' : tSort u' -> Sort.is_propositional u' -> + leq_sort (global_ext_constraints Σ) u u'. Proof. intros wfΣ leq hv hv' isp. - unfold is_propositional in isp. - destruct u' => //. eapply leq_term_prop_sorted_r; eauto. - eapply leq_term_sprop_sorted_r; eauto. Qed. Lemma Is_type_app (Σ : global_env_ext) Γ t L T : @@ -523,41 +511,23 @@ Proof. now apply PCUICValidity.validity in t2. Qed. -Lemma leq_universe_propositional_r {cf : checker_flags} (ϕ : ConstraintSet.t) (u1 u2 : Universe.t_) : - leq_universe ϕ u1 u2 -> is_propositional u2 -> is_propositional u1. +Lemma leq_sort_propositional_r {cf : checker_flags} (ϕ : ConstraintSet.t) (u1 u2 : sort) : + leq_sort ϕ u1 u2 -> Sort.is_propositional u2 -> Sort.is_propositional u1. Proof. - intros leq; unfold is_propositional. - destruct u2 => //. - apply leq_universe_prop_r in leq => //. - now rewrite leq. - intros _. - apply leq_universe_sprop_r in leq => //. - now rewrite leq orb_true_r. + destruct u1, u2 => //. Qed. -Lemma leq_universe_propositional_l {cf : checker_flags} (ϕ : ConstraintSet.t) (u1 u2 : Universe.t_) : +Lemma leq_sort_propositional_l {cf : checker_flags} (ϕ : ConstraintSet.t) (u1 u2 : sort) : prop_sub_type = false -> - leq_universe ϕ u1 u2 -> is_propositional u1 -> is_propositional u2. + leq_sort ϕ u1 u2 -> Sort.is_propositional u1 -> Sort.is_propositional u2. Proof. - intros ps leq; unfold is_propositional. - destruct u1 => //. - eapply leq_universe_prop_no_prop_sub_type in leq => //. - now rewrite leq. - intros _. - apply leq_universe_sprop_l in leq => //. - now rewrite leq orb_true_r. + destruct u1, u2 => //= -> //. Qed. Lemma is_propositional_sort_prod x2 x3 : - is_propositional (Universe.sort_of_product x2 x3) -> is_propositional x3. + Sort.is_propositional (Sort.sort_of_product x2 x3) -> Sort.is_propositional x3. Proof. - unfold is_propositional. - destruct (Universe.is_prop (Universe.sort_of_product x2 x3)) eqn:eq => //. - simpl. - intros _. - apply is_prop_sort_prod in eq. now rewrite eq. - destruct (Universe.is_sprop (Universe.sort_of_product x2 x3)) eqn:eq' => //. - apply is_sprop_sort_prod in eq'. now rewrite eq' !orb_true_r. + destruct x2, x3 => //. Qed. Lemma Is_type_lambda (Σ : global_env_ext) Γ na T1 t : @@ -576,7 +546,7 @@ Proof. - sq. eapply cumul_prop1' in e; eauto. eapply inversion_Prod in e as (? & ? & ? & ? & e) ; auto. eapply ws_cumul_pb_Sort_inv in e. - eapply leq_universe_propositional_r in e as H0; cbn; eauto. + eapply leq_sort_propositional_r in e as H0; cbn; eauto. eexists. split. eassumption. right. eexists. split. eassumption. eapply is_propositional_sort_prod in H0; eauto. eapply type_Lambda in h1; eauto. @@ -653,7 +623,7 @@ Qed. Definition isErasable_Type (Σ : global_env_ext) Γ T := (Is_conv_to_Arity Σ Γ T + - (∑ u : Universe.t, Σ;;; Γ |- T : tSort u × is_propositional u))%type. + (∑ u : sort, Σ;;; Γ |- T : tSort u × Sort.is_propositional u))%type. Lemma isErasable_any_type {Σ} {wfΣ : wf_ext Σ} {Γ t T} : isErasable Σ Γ t -> @@ -693,18 +663,6 @@ Proof. Qed. -Lemma is_propositional_bottom {Σ Γ T s s'} : - wf_ext Σ -> - prop_sub_type = false -> - Σ ;;; Γ ⊢ T ≤ tSort s -> - Σ ;;; Γ ⊢ T ≤ tSort s' -> - PCUICCumulProp.eq_univ_prop s s'. -Proof. - intros wf pst h h'; rewrite /PCUICCumulProp.eq_univ_prop. - split. split; eapply PCUICCumulProp.is_prop_bottom; tea. - split; eapply PCUICCumulProp.is_sprop_bottom; tea. -Qed. - Import PCUICGlobalEnv PCUICUnivSubst PCUICValidity PCUICCumulProp. Notation " Σ ;;; Γ |- t ~~ u " := (cumul_prop Σ Γ t u) (at level 50, Γ, t, u at next level) : type_scope. @@ -716,27 +674,29 @@ Lemma is_propositional_bottom' {Σ Γ T s s'} : Σ ;;; Γ |- T ~~ tSort s' -> PCUICCumulProp.eq_univ_prop s s'. Proof. - intros wf pst h h'; rewrite /PCUICCumulProp.eq_univ_prop. - pose proof (cumul_prop_trans _ _ _ _ _ _ (cumul_prop_sym _ _ _ _ _ h') h). - split. split; intros; eapply PCUICCumulProp.cumul_prop_props; tea. now symmetry. - split; intros; eapply PCUICCumulProp.cumul_sprop_props; tea. now symmetry. + intros. + eapply PCUICCumulProp.cumul_prop_sort. + etransitivity; tea. + now symmetry. +Qed. + +Lemma is_propositional_bottom {Σ Γ T s s'} : + wf_ext Σ -> + prop_sub_type = false -> + Σ ;;; Γ ⊢ T ≤ tSort s -> + Σ ;;; Γ ⊢ T ≤ tSort s' -> + PCUICCumulProp.eq_univ_prop s s'. +Proof. + move => wf pst /cumul_pb_cumul_prop h /cumul_pb_cumul_prop h'. + now eapply is_propositional_bottom'. Qed. Lemma is_propositional_lower {Σ s u u'} : - leq_universe Σ s u -> - leq_universe Σ s u' -> + leq_sort Σ s u -> + leq_sort Σ s u' -> PCUICCumulProp.eq_univ_prop u u'. Proof. - intros leu leu'. - unfold eq_univ_prop; split. - - split. intros pu. eapply leq_universe_prop_r in leu; tea => //. - eapply leq_universe_prop_no_prop_sub_type in leu'; trea => //. - intros pu'. eapply leq_universe_prop_r in leu'; tea => //. - eapply leq_universe_prop_no_prop_sub_type in leu; tea => //. - - split. intros pu. eapply leq_universe_sprop_r in leu; tea => //. - eapply leq_universe_sprop_l in leu'; tea => //. - intros pu'. eapply leq_universe_sprop_r in leu'; tea => //. - eapply leq_universe_sprop_l in leu; tea => //. + destruct s, u, u' => //. Qed. Lemma typing_spine_inj {Σ Γ Δ s args args' u u'} : @@ -780,7 +740,7 @@ Proof. rewrite (declared_inductive_type decli) in sp, sp'. rewrite subst_instance_it_mkProd_or_LetIn /= in sp, sp'. eapply typing_spine_inj in sp. 4:exact sp'. all:eauto. - destruct sp as [H H0]. apply/orP. rewrite H H0. now apply/orP. + destruct u, u'' => //. Qed. @@ -874,7 +834,7 @@ Proof. rewrite (declared_inductive_lookup_gen decli_). rewrite oib.(ind_arity_eq). rewrite /isPropositionalArity !destArity_it_mkProd_or_LetIn /=. - destruct (is_propositional (ind_sort x0)) eqn:isp; auto. + destruct (Sort.is_propositional (ind_sort x0)) eqn:isp; auto. elimtype False; eapply ise. red. eexists; intuition eauto. right. unfold type_of_constructor in e, X. @@ -885,7 +845,7 @@ Proof. rewrite subst_cstr_concl_head in e, X. destruct decli. eapply nth_error_Some_length in H1; eauto. rewrite -it_mkProd_or_LetIn_app in e, X. - exists (subst_instance_univ u (ind_sort x0)). + exists (subst_instance_sort u (ind_sort x0)). rewrite is_propositional_subst_instance => //. split; auto. eapply cumul_propositional; eauto. @@ -1025,7 +985,7 @@ Lemma not_isErasable Σ Γ f A u : (forall B, ∥Σ ;;; Γ |- f : B∥ -> ∥Σ ;;; Γ ⊢ A ≤ B∥) -> ~ ∥ isArity A ∥ -> ∥ Σ;;; Γ |- A : tSort u ∥ -> - ~ is_propositional u -> + ~ Sort.is_propositional u -> ~ ∥ Extract.isErasable Σ Γ f ∥. Proof. intros wfΣ Hlocal Hf Hnf Hprinc Harity Hfu Hu [[T [HT []]]]; sq. diff --git a/erasure/theories/EOptimizePropDiscr.v b/erasure/theories/EOptimizePropDiscr.v index 6ddf477db..7257c75df 100644 --- a/erasure/theories/EOptimizePropDiscr.v +++ b/erasure/theories/EOptimizePropDiscr.v @@ -297,7 +297,7 @@ Proof. - destruct t => //. Qed. -Lemma isType_tSort {cf:checker_flags} {Σ : global_env_ext} {Γ l A} {wfΣ : wf Σ} : Σ ;;; Γ |- tSort (Universe.make l) : A -> isType Σ Γ (tSort (Universe.make l)). +Lemma isType_tSort {cf:checker_flags} {Σ : global_env_ext} {Γ s A} {wfΣ : wf Σ} : Σ ;;; Γ |- tSort s : A -> isType Σ Γ (tSort s). Proof. intros HT. eapply inversion_Sort in HT as [l' [wfΓ Hs]]; auto. diff --git a/erasure/theories/ESubstitution.v b/erasure/theories/ESubstitution.v index 8e6c34765..9813cb182 100644 --- a/erasure/theories/ESubstitution.v +++ b/erasure/theories/ESubstitution.v @@ -384,7 +384,7 @@ Qed. Lemma subst_case_branch_context {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} ind (n : nat) mdecl idecl p br cdecl s k : PCUICAst.declared_constructor Σ (ind, n) mdecl idecl cdecl -> wf_predicate mdecl idecl p -> - All2 (PCUICEquality.compare_decls eq eq) (bcontext br) + PCUICEquality.eq_context_upto_names (bcontext br) (cstr_branch_context ind mdecl cdecl) -> subst_context s k (case_branch_context ind mdecl p (forget_types (bcontext br)) cdecl) = case_branch_context ind mdecl (map_predicate_k id (subst s) k p) (forget_types (bcontext br)) cdecl. diff --git a/erasure/theories/ErasureFunction.v b/erasure/theories/ErasureFunction.v index 4a17fef7b..e1b500218 100644 --- a/erasure/theories/ErasureFunction.v +++ b/erasure/theories/ErasureFunction.v @@ -23,7 +23,7 @@ Implicit Types (cf : checker_flags). #[local] Existing Instance extraction_normalizing. -Notation alpha_eq := (All2 (PCUICEquality.compare_decls eq eq)). +Notation alpha_eq := PCUICEquality.eq_context_upto_names. Ltac sq := repeat match goal with @@ -896,7 +896,7 @@ Equations? is_erasableb X_type X {normalization_in : forall Σ, wf_ext Σ -> Σ { | T with is_arity X_type X Γ _ T.π1 _ := { | true => true | false => let s := @sort_of_type extraction_checker_flags _ X_type X _ Γ T.π1 _ in - is_propositional s.π1 } }. + Sort.is_propositional s.π1 } }. Proof. - intros. specialize_Σ H. destruct wt; sq. pcuic. @@ -925,7 +925,7 @@ Proof. 2: eassumption. eauto. - destruct type_of_typing as [x Hx]. cbn -[sort_of_type is_arity] in *. destruct (sort_of_type _ _ _ _). cbn. - destruct (is_propositional x0) eqn:isp; constructor. + destruct (Sort.is_propositional x0) eqn:isp; constructor. * clear Heq. intros. pose proof (abstract_env_ext_wf _ H) as [wf]. specialize_Σ H. @@ -1325,7 +1325,7 @@ Definition erase_one_inductive_body (oib : one_inductive_body) : E.one_inductive let projs := map (fun pdecl => EAst.mkProjection pdecl.(proj_name)) oib.(ind_projs) in let is_propositional := match destArity [] oib.(ind_type) with - | Some (_, u) => is_propositional u + | Some (_, u) => Sort.is_propositional u | None => false (* dummy, impossible case *) end in diff --git a/erasure/theories/ErasureFunctionProperties.v b/erasure/theories/ErasureFunctionProperties.v index be8fb8007..ab2b0542b 100644 --- a/erasure/theories/ErasureFunctionProperties.v +++ b/erasure/theories/ErasureFunctionProperties.v @@ -723,13 +723,11 @@ Lemma leq_term_propositional_sorted_l {Σ Γ v v' u u'} : wf_ext Σ -> PCUICEquality.leq_term Σ (global_ext_constraints Σ) v v' -> Σ;;; Γ |- v : tSort u -> - Σ;;; Γ |- v' : tSort u' -> is_propositional u -> - leq_universe (global_ext_constraints Σ) u' u. + Σ;;; Γ |- v' : tSort u' -> Sort.is_propositional u -> + leq_sort (global_ext_constraints Σ) u' u. Proof. intros wfΣ leq hv hv' isp. - eapply orb_true_iff in isp as [isp | isp]. - - eapply leq_term_prop_sorted_l; eauto. - - eapply leq_term_sprop_sorted_l; eauto. + eapply leq_term_prop_sorted_l; eauto. Qed. Lemma map_erase_irrel X_type X {normalization_in1 normalization_in2 : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ} Γ t H1 H2 : diff --git a/erasure/theories/Extract.v b/erasure/theories/Extract.v index feff5b7c9..3a3f72ee9 100644 --- a/erasure/theories/Extract.v +++ b/erasure/theories/Extract.v @@ -17,7 +17,7 @@ Local Existing Instance extraction_checker_flags. - is of propositional type *) Definition isErasable Σ Γ t := ∑ T, Σ ;;; Γ |- t : T × - (isArity T + (∑ u, (Σ ;;; Γ |- T : tSort u) * is_propositional u))%type. + (isArity T + (∑ u, (Σ ;;; Γ |- T : tSort u) * Sort.is_propositional u))%type. (* A more positive notion of relevant terms. Showing that a term is not erasable requires quantification over all its possible typings. @@ -30,7 +30,7 @@ Definition nisErasable Σ Γ t := nf Σ Γ T, ~ isArity T, Σ;;; Γ |- T : tSort u & - ~ is_propositional u]. + ~ Sort.is_propositional u]. Lemma nisErasable_spec Σ Γ t : wf_ext Σ -> wf_local Σ Γ -> @@ -386,7 +386,7 @@ Definition computational_ind Σ ind := match List.nth_error decl.(ind_bodies) n with | Some body => match destArity [] body.(ind_type) with - | Some arity => negb (Universe.is_prop (snd arity)) + | Some arity => negb (Sort.is_prop (snd arity)) | None => false end | None => false diff --git a/erasure/theories/Prelim.v b/erasure/theories/Prelim.v index ba198aebe..49d362695 100644 --- a/erasure/theories/Prelim.v +++ b/erasure/theories/Prelim.v @@ -261,7 +261,7 @@ Lemma expand_lets_erasure (wfl := default_wcbv_flags) {Σ mdecl idecl cdecl c br declared_constructor Σ c mdecl idecl cdecl -> wf_branches idecl brs -> All2i (fun i cdecl br => - All2 (PCUICEquality.compare_decls eq eq) (bcontext br) + PCUICEquality.eq_context_upto_names (bcontext br) (cstr_branch_context c.1 mdecl cdecl)) 0 idecl.(ind_ctors) brs -> All (fun br => expand_lets (inst_case_branch_context p br) (bbody br) = bbody br) brs. @@ -312,7 +312,7 @@ Lemma subslet_cstr_branch_context {cf : checker_flags} {Σ : global_env_ext} {wf declared_constructor Σ (ind, n) mdecl idecl cdecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> consistent_instance_ext Σ (ind_universes mdecl) (puinst p) -> - PCUICEquality.R_global_instance Σ (eq_universe Σ) (leq_universe Σ) (IndRef ind) napp u (puinst p) -> + PCUICEquality.cmp_ind_universes Σ ind napp u (puinst p) -> spine_subst Σ Γ pars parsubst (ind_params mdecl)@[u] -> spine_subst Σ Γ (pparams p) parsubst' (ind_params mdecl)@[puinst p] -> assumption_context cdecl.(cstr_args) -> diff --git a/erasure/theories/Typed/Erasure.v b/erasure/theories/Typed/Erasure.v index 90fd70643..df57eefa6 100644 --- a/erasure/theories/Typed/Erasure.v +++ b/erasure/theories/Typed/Erasure.v @@ -420,7 +420,7 @@ Proof. destruct isT. now apply isType_welltyped. Qed. (** Definition of normalized arities *) Definition arity_ass := aname * term. -Fixpoint mkNormalArity (l : list arity_ass) (s : Universe.t) : term := +Fixpoint mkNormalArity (l : list arity_ass) (s : sort) : term := match l with | []%list => tSort s | ((na, A) :: l)%list => tProd na A (mkNormalArity l s) @@ -434,7 +434,7 @@ Qed. Record conv_arity {Σ Γ T} : Type := build_conv_arity { conv_ar_context : list arity_ass; - conv_ar_univ : Universe.t; + conv_ar_univ : sort; conv_ar_red : ∥closed_red Σ Γ T (mkNormalArity conv_ar_context conv_ar_univ)∥ }. @@ -594,7 +594,7 @@ flag_of_type Γ T isT with inspect (hnf (X_type := X_type) Γ T (fun Σ h => (ty end |} }; - | fot_view_sort univ := {| is_logical := Universe.is_prop univ; + | fot_view_sort univ := {| is_logical := Sort.is_prop univ; conv_ar := inl {| conv_ar_context := []; conv_ar_univ := univ; |} |} ; | fot_view_other T0 discr @@ -602,7 +602,7 @@ flag_of_type Γ T isT with inspect (hnf (X_type := X_type) Γ T (fun Σ h => (ty { | @existT K princK with inspect (reduce_to_sort Γ K _) := { | exist (Checked_comp (existT _ univ red_univ)) eq := - {| is_logical := Universe.is_prop univ; + {| is_logical := Sort.is_prop univ; conv_ar := inr _ |}; | exist (TypeError_comp t) eq := ! }; @@ -1005,7 +1005,7 @@ Equations (noeqns) erase_type_scheme_eta (erΓ : Vector.t tRel_kind #|Γ|) (t : term) (ar_ctx : list arity_ass) - (ar_univ : Universe.t) + (ar_univ : sort) (typ : ∥rΣ;;; Γ |- t : mkNormalArity ar_ctx ar_univ∥) (next_tvar : nat) : list type_var_info × box_type := erase_type_scheme_eta Γ erΓ t [] univ typ next_tvar => ([], (erase_type_aux Γ erΓ t _ None).2); @@ -1066,7 +1066,7 @@ Equations? (noeqns) erase_type_scheme (erΓ : Vector.t tRel_kind #|Γ|) (t : term) (ar_ctx : list arity_ass) - (ar_univ : Universe.t) + (ar_univ : sort) (typ : forall Σ0 (wfΣ : PCUICWfEnv.abstract_env_ext_rel X Σ0), ∥Σ0;;; Γ |- t : mkNormalArity ar_ctx ar_univ∥) (next_tvar : nat) : list type_var_info × box_type := erase_type_scheme Γ erΓ t [] univ typ next_tvar => ([], (erase_type_aux Γ erΓ t _ None).2); @@ -1308,7 +1308,7 @@ Proof. unshelve refine ( let is_propositional := match destArity [] (ind_type oib) with - | Some (_, u) => is_propositional u + | Some (_, u) => Sort.is_propositional u | None => false end in let oib_tvars := erase_ind_arity [] (PCUICEnvironment.ind_type oib) _ in diff --git a/examples/demo.v b/examples/demo.v index 6b65cf4ad..ff1349c19 100644 --- a/examples/demo.v +++ b/examples/demo.v @@ -113,7 +113,7 @@ MetaCoq Test Quote ((pair' _ _ true 4).(snd')). Definition one_i : one_inductive_entry := {| mind_entry_typename := "demoBool"; - mind_entry_arity := tSort Universe.type0; + mind_entry_arity := tSort Sort.type0; mind_entry_consnames := ["demoTrue"; "demoFalse"]; mind_entry_lc := [tRel 1; tRel 1]; |}. @@ -121,7 +121,7 @@ Definition one_i : one_inductive_entry := Definition one_i2 : one_inductive_entry := {| mind_entry_typename := "demoBool2"; - mind_entry_arity := tSort Universe.type0; + mind_entry_arity := tSort Sort.type0; mind_entry_consnames := ["demoTrue2"; "demoFalse2"]; mind_entry_lc := [tRel 0; tRel 0]; |}. @@ -150,7 +150,7 @@ Definition mkImpl (A B : term) : term := Definition one_list_i : one_inductive_entry := {| mind_entry_typename := "demoList"; - mind_entry_arity := tSort Universe.type0; + mind_entry_arity := tSort Sort.type0; mind_entry_consnames := ["demoNil"; "demoCons"]; mind_entry_lc := [tApp (tRel 1) [tRel 0]; mkImpl (tRel 0) (mkImpl (tApp (tRel 2) [tRel 1]) (tApp (tRel 3) [tRel 2]))]; @@ -161,7 +161,7 @@ Definition mut_list_i : mutual_inductive_entry := mind_entry_record := None; mind_entry_finite := Finite; mind_entry_params := [{| decl_name := bnamed "A"; decl_body := None; - decl_type := (tSort Universe.type0) |}]; + decl_type := (tSort Sort.type0) |}]; mind_entry_inds := [one_list_i]; mind_entry_universes := Monomorphic_entry (LevelSet.empty, ConstraintSet.empty); mind_entry_template := false; @@ -177,7 +177,7 @@ MetaCoq Unquote Inductive mut_list_i. Definition one_pt_i : one_inductive_entry := {| mind_entry_typename := "Point"; - mind_entry_arity := tSort Universe.type0; + mind_entry_arity := tSort Sort.type0; mind_entry_consnames := ["mkPoint"]; mind_entry_lc := [ mkImpl (tRel 0) (mkImpl (tRel 1) (tApp (tRel 3) [tRel 2]))]; @@ -188,7 +188,7 @@ Definition mut_pt_i : mutual_inductive_entry := mind_entry_record := Some (Some "pp"); mind_entry_finite := BiFinite; mind_entry_params := [{| decl_name := bnamed "A"; decl_body := None; - decl_type := (tSort Universe.type0) |}]; + decl_type := (tSort Sort.type0) |}]; mind_entry_inds := [one_pt_i]; mind_entry_universes := Monomorphic_entry ContextSet.empty; mind_entry_template := false; diff --git a/pcuic/theories/Bidirectional/BDFromPCUIC.v b/pcuic/theories/Bidirectional/BDFromPCUIC.v index 27923fa57..d92a5a6fb 100644 --- a/pcuic/theories/Bidirectional/BDFromPCUIC.v +++ b/pcuic/theories/Bidirectional/BDFromPCUIC.v @@ -10,20 +10,6 @@ Require Import Equations.Prop.DepElim. Implicit Types (cf : checker_flags) (Σ : global_env_ext). -(** Preliminary lemmas missing from MetaCoq *) -Lemma is_allowed_elimination_monotone `{checker_flags} Σ s1 s2 allowed : - leq_universe Σ s1 s2 -> is_allowed_elimination Σ allowed s2 -> is_allowed_elimination Σ allowed s1. -Proof. - destruct allowed, s2; cbnr; trivial; - destruct s1; cbnr; intros H1 H2; trivial; try now destruct H1. - { now left. } - destruct H2 as [|H2]; [now left|right]. - unfold_univ_rel. - specialize (H1 v Hv); specialize (H2 v Hv). - cbn in H2. - lia. -Qed. - Lemma ctx_inst_length {ty Γ args Δ} : PCUICTyping.ctx_inst ty Γ args Δ -> #|args| = context_assumptions Δ. @@ -69,7 +55,7 @@ Qed. Lemma conv_infer_sort `{checker_flags} Σ (wfΣ : wf Σ) Γ t s : Σ ;;; Γ |- t : tSort s -> (∑ T' : term, Σ ;;; Γ |- t ▹ T' × Σ ;;; Γ ⊢ T' ≤ tSort s) -> - {s' & Σ ;;; Γ |- t ▹□ s' × leq_universe Σ s' s}. + {s' & Σ ;;; Γ |- t ▹□ s' × leq_sort Σ s' s}. Proof. intros tyt (T'&?&Cumt). apply ws_cumul_pb_Sort_r_inv in Cumt as (?&?&?) ; auto. @@ -96,7 +82,7 @@ Lemma conv_infer_ind `{checker_flags} Σ (wfΣ : wf Σ) Γ t ind ui args : Σ ;;; Γ |- t : mkApps (tInd ind ui) args -> (∑ T', (Σ ;;; Γ |- t ▹ T') × (Σ ;;; Γ ⊢ T' ≤ mkApps (tInd ind ui) args)) -> ∑ ui' args', [× Σ ;;; Γ |- t ▹{ind} (ui',args'), - R_global_instance Σ (eq_universe Σ) (leq_universe Σ) (IndRef ind) #|args| ui' ui + cmp_ind_universes Σ ind #|args| ui' ui & ws_cumul_pb_terms Σ Γ args' args]. Proof. intros tyt (T'&?&Cumt). @@ -107,7 +93,7 @@ Proof. Qed. Lemma conv_lift_judgment `{checker_flags} Σ Γ na b ty : - lift_sorting (checking Σ Γ) (fun T u => ∑ u', Σ;;; Γ |- T ▹□ u' × leq_universe Σ u' u) (j_decl (mkdecl na b ty)) -> + lift_sorting (checking Σ Γ) (fun T u => ∑ u', Σ;;; Γ |- T ▹□ u' × leq_sort Σ u' u) (j_decl (mkdecl na b ty)) -> lift_sorting (checking Σ Γ) (infering_sort Σ Γ) (j_decl (mkdecl na b ty)). Proof. intro Hj. @@ -117,8 +103,8 @@ Proof. Qed. Lemma conv_lift_judgment_univ `{checker_flags} Σ Γ na b ty u : - lift_sorting (checking Σ Γ) (fun T u => ∑ u', Σ;;; Γ |- T ▹□ u' × leq_universe Σ u' u) (j_decl_s (mkdecl na b ty) (Some u)) -> - ∑ u', lift_sorting (checking Σ Γ) (infering_sort Σ Γ) (j_decl_s (mkdecl na b ty) (Some u')) × leq_universe Σ u' u. + lift_sorting (checking Σ Γ) (fun T u => ∑ u', Σ;;; Γ |- T ▹□ u' × leq_sort Σ u' u) (j_decl_s (mkdecl na b ty) (Some u)) -> + ∑ u', lift_sorting (checking Σ Γ) (infering_sort Σ Γ) (j_decl_s (mkdecl na b ty) (Some u')) × leq_sort Σ u' u. Proof. intros (Htm & u0 & (u' & Hty & Hle) & <-); cbn in *. exists u'; split; tas. @@ -131,7 +117,7 @@ Section BDFromPCUIC. (** The big theorem*) Lemma bidirectional_from_pcuic `{checker_flags} : env_prop (fun Σ Γ t T => {T' & Σ ;;; Γ |- t ▹ T' × Σ ;;; Γ ⊢ T' ≤ T}) - (fun Σ Γ j => lift_sorting (fun t T => Σ ;;; Γ |- t ◃ T) (fun T u => ∑ u', Σ ;;; Γ |- T ▹□ u' × leq_universe Σ u' u) j) + (fun Σ Γ j => lift_sorting (fun t T => Σ ;;; Γ |- t ◃ T) (fun T u => ∑ u', Σ ;;; Γ |- T ▹□ u' × leq_sort Σ u' u) j) (fun Σ Γ => wf_local_bd Σ Γ). Proof. apply typing_ind_env. @@ -174,7 +160,7 @@ Proof. + constructor ; cbn ; auto. 1: by apply wf_local_closed_context. constructor. - apply leq_universe_product_mon. + apply leq_sort_product_mon. all: assumption. - intros na A t ? ? ? CumA ? (?&?&?). @@ -414,7 +400,7 @@ Proof. Qed. Lemma typing_infering_sort `{checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ t u} : - Σ ;;; Γ |- t : tSort u -> ∑ u', Σ ;;; Γ |- t ▹□ u' × leq_universe Σ u' u. + Σ ;;; Γ |- t : tSort u -> ∑ u', Σ ;;; Γ |- t ▹□ u' × leq_sort Σ u' u. Proof. intros. apply conv_infer_sort ; tea. @@ -442,7 +428,7 @@ Qed. Lemma typing_infer_ind `{checker_flags} Σ (wfΣ : wf Σ) Γ t ind ui args : Σ ;;; Γ |- t : mkApps (tInd ind ui) args -> ∑ ui' args', [× Σ ;;; Γ |- t ▹{ind} (ui',args'), - R_global_instance Σ (eq_universe Σ) (leq_universe Σ) (IndRef ind) #|args| ui' ui + cmp_ind_universes Σ ind #|args| ui' ui & ws_cumul_pb_terms Σ Γ args' args]. Proof. intros. diff --git a/pcuic/theories/Bidirectional/BDStrengthening.v b/pcuic/theories/Bidirectional/BDStrengthening.v index 83a117378..40c0c72b5 100644 --- a/pcuic/theories/Bidirectional/BDStrengthening.v +++ b/pcuic/theories/Bidirectional/BDStrengthening.v @@ -358,7 +358,7 @@ Section OnFreeVars. on_free_vars P t -> on_free_vars P T. - Let Psort (Γ : context) (t : term) (u : Universe.t) := True. + Let Psort (Γ : context) (t : term) (u : sort) := True. Let Pprod Γ t (na : aname) A B := forall P, @@ -1058,7 +1058,7 @@ Qed. Lemma strengthening_type `{cf: checker_flags} {Σ : global_env_ext} {wfΣ : PCUICTyping.wf Σ} Γ Γ' Γ'' t s : Σ ;;; Γ ,,, Γ' ,,, lift_context #|Γ'| 0 Γ'' |- lift #|Γ'| #|Γ''| t : tSort s -> - ∑ s', (Σ ;;; Γ ,,, Γ'' |- t : tSort s') * (compare_universe Cumul Σ s' s). + ∑ s', Σ ;;; Γ ,,, Γ'' |- t : tSort s' × leq_sort Σ s' s. Proof. intros H; pose proof (H' := H); eapply strengthening in H. destruct H as [T' [? HT Hcumul HT']]. pose proof (Hcumul' := Hcumul). diff --git a/pcuic/theories/Bidirectional/BDTyping.v b/pcuic/theories/Bidirectional/BDTyping.v index 8d843ade7..a384ca756 100644 --- a/pcuic/theories/Bidirectional/BDTyping.v +++ b/pcuic/theories/Bidirectional/BDTyping.v @@ -31,13 +31,13 @@ Inductive infering `{checker_flags} (Σ : global_env_ext) (Γ : context) : term Σ ;;; Γ |- tRel n ▹ lift0 (S n) (decl_type decl) | infer_Sort s : - wf_universe Σ s -> - Σ ;;; Γ |- tSort s ▹ tSort (Universe.super s) + wf_sort Σ s -> + Σ ;;; Γ |- tSort s ▹ tSort (Sort.super s) | infer_Prod na A B s1 s2 : lift_sorting (checking Σ Γ) (infering_sort Σ Γ) (j_vass_s na A s1) -> Σ ;;; Γ ,, vass na A |- B ▹□ s2 -> - Σ ;;; Γ |- tProd na A B ▹ tSort (Universe.sort_of_product s1 s2) + Σ ;;; Γ |- tProd na A B ▹ tSort (Sort.sort_of_product s1 s2) | infer_Lambda na A t B : lift_sorting (checking Σ Γ) (infering_sort Σ Γ) (j_vass na A) -> @@ -85,8 +85,7 @@ Inductive infering `{checker_flags} (Σ : global_env_ext) (Γ : context) : term ctx_inst (checking Σ) Γ (pparams p) (List.rev mdecl.(ind_params)@[p.(puinst)]) -> isCoFinite mdecl.(ind_finite) = false -> - R_global_instance Σ (eq_universe Σ) (leq_universe Σ) - (IndRef ci) #|args| u (puinst p) -> + cmp_ind_universes Σ ci #|args| u (puinst p) -> All2 (convAlgo Σ Γ) (firstn (ci_npar ci) args) (pparams p) -> (* case_branch_typing *) wf_branches idecl brs -> @@ -127,7 +126,7 @@ Inductive infering `{checker_flags} (Σ : global_env_ext) (Γ : context) : term primitive_typing_hyps checking Σ Γ p -> Σ ;;; Γ |- tPrim p ▹ prim_type p prim_ty -with infering_sort `{checker_flags} (Σ : global_env_ext) (Γ : context) : term -> Universe.t -> Type := +with infering_sort `{checker_flags} (Σ : global_env_ext) (Γ : context) : term -> sort -> Type := | infer_sort_Sort t T u: Σ ;;; Γ |- t ▹ T -> red Σ Γ T (tSort u) -> @@ -243,7 +242,7 @@ Section BidirectionalInduction. Context (wfΣ : wf Σ). Context (Pcheck : context -> term -> term -> Type). Context (Pinfer : context -> term -> term -> Type). - Context (Psort : context -> term -> Universe.t -> Type). + Context (Psort : context -> term -> sort -> Type). Context (Pprod : context -> term -> aname -> term -> term -> Type). Context (Pind : context -> inductive -> term -> Instance.t -> list term -> Type). Context (Pj : context -> judgment -> Type). @@ -350,16 +349,16 @@ Section BidirectionalInduction. nth_error Γ n = Some decl -> Pinfer Γ (tRel n) (lift0 (S n) (decl_type decl))) -> - (forall (Γ : context) (s : Universe.t), - wf_universe Σ s-> - Pinfer Γ (tSort s) (tSort (Universe.super s))) -> + (forall (Γ : context) (s : sort), + wf_sort Σ s-> + Pinfer Γ (tSort s) (tSort (Sort.super s))) -> - (forall (Γ : context) (na : aname) (t b : term) (s1 s2 : Universe.t), + (forall (Γ : context) (na : aname) (t b : term) (s1 s2 : sort), lift_sorting (checking Σ Γ) (infering_sort Σ Γ) (j_vass_s na t s1) -> Pj Γ (j_vass_s na t s1) -> Σ ;;; Γ,, vass na t |- b ▹□ s2 -> Psort (Γ,, vass na t) b s2 -> - Pinfer Γ (tProd na t b) (tSort (Universe.sort_of_product s1 s2))) -> + Pinfer Γ (tProd na t b) (tSort (Sort.sort_of_product s1 s2))) -> (forall (Γ : context) (na : aname) (t b bty : term), lift_sorting (checking Σ Γ) (infering_sort Σ Γ) (j_vass na t) -> @@ -421,8 +420,7 @@ Section BidirectionalInduction. ctx_inst Pcheck Γ p.(pparams) (List.rev (subst_instance p.(puinst) mdecl.(ind_params))) -> isCoFinite mdecl.(ind_finite) = false -> - R_global_instance Σ (eq_universe Σ) (leq_universe Σ) - (IndRef ci) #|args| u (puinst p) -> + cmp_ind_universes Σ ci #|args| u (puinst p) -> All2 (convAlgo Σ Γ) (firstn (ci_npar ci) args) (pparams p) -> (* case_branch_typing *) wf_branches idecl brs -> @@ -471,7 +469,7 @@ Section BidirectionalInduction. primitive_typing_hyps (fun _ => Pcheck) Σ Γ p -> Pinfer Γ (tPrim p) (prim_type p prim_ty)) -> - (forall (Γ : context) (t T : term) (u : Universe.t), + (forall (Γ : context) (t T : term) (u : sort), Σ ;;; Γ |- t ▹ T -> Pinfer Γ t T -> red Σ Γ T (tSort u) -> diff --git a/pcuic/theories/Conversion/PCUICInstConv.v b/pcuic/theories/Conversion/PCUICInstConv.v index 8f41ffbfb..7552dc8b5 100644 --- a/pcuic/theories/Conversion/PCUICInstConv.v +++ b/pcuic/theories/Conversion/PCUICInstConv.v @@ -1869,14 +1869,16 @@ Proof. eapply red_primArray_type; cbn; eauto. Defined. -Lemma eq_term_upto_univ_inst Σ : - forall Re Rle napp u v σ, - Reflexive Re -> Reflexive Rle -> - eq_term_upto_univ_napp Σ Re Rle napp u v -> - eq_term_upto_univ_napp Σ Re Rle napp u.[σ] v.[σ]. +Lemma eq_term_upto_univ_inst Σ cmp_universe cmp_sort pb napp u v σ : + RelationClasses.Reflexive (cmp_universe Conv) -> + RelationClasses.Reflexive (cmp_universe pb) -> + RelationClasses.Reflexive (cmp_sort Conv) -> + RelationClasses.Reflexive (cmp_sort pb) -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp u v -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp u.[σ] v.[σ]. Proof using Type. - intros Re Rle napp u v σ hRe hRle h. - induction u in v, napp, Re, Rle, hRe, hRle, σ, h |- * using term_forall_list_ind. + intros refl_univ_conv refl_univ_pb refl_sort_conv refl_sort_pb h. + induction u in v, pb, napp, σ, refl_univ_pb, refl_sort_pb, h |- * using term_forall_list_ind. all: dependent destruction h. all: try solve [ simpl ; constructor ; eauto @@ -1890,24 +1892,18 @@ Proof using Type. - simpl. constructor. all: eauto. * rewrite /inst_predicate. destruct X; destruct e as [? [? [ectx ?]]]. - rewrite (All2_fold_length ectx). red. + rewrite (All2_length ectx). red. intuition auto; simpl; solve_all. - * induction X0 in a, brs' |- *. - + inversion a. constructor. - + inversion a. subst. simpl. - destruct X1 as [a0 e0], p0. - constructor; eauto. - split; eauto. - simpl. - rewrite (All2_fold_length a0). - now eapply e1. + * unfold eq_branches, eq_branch in *; solve_all. + rewrite (All2_length a1). + now eapply b0. - simpl. constructor. - apply All2_length in a as e. rewrite <- e. - generalize #|m|. intro k. + apply All2_length in e as eq. rewrite <- eq. + generalize #|m|. intro k. unfold eq_mfixpoint in *. eapply All2_map. simpl. solve_all. - simpl. constructor. - apply All2_length in a as e. rewrite <- e. - generalize #|m|. intro k. + apply All2_length in e as eq. rewrite <- eq. + generalize #|m|. intro k. unfold eq_mfixpoint in *. eapply All2_map. simpl. solve_all. - simpl. constructor. eapply onPrims_map_prop; tea. cbn; intuition eauto. diff --git a/pcuic/theories/Conversion/PCUICNamelessConv.v b/pcuic/theories/Conversion/PCUICNamelessConv.v index ddf115cb9..60a56bc2e 100644 --- a/pcuic/theories/Conversion/PCUICNamelessConv.v +++ b/pcuic/theories/Conversion/PCUICNamelessConv.v @@ -39,7 +39,7 @@ Local Ltac anonify := Local Ltac ih := lazymatch goal with - | ih : forall (v : term) (napp : nat), _ -> _ -> eq_term_upto_univ_napp _ _ _ _ _ _ -> ?u = _ + | ih : forall (v : term) (napp : nat), _ -> _ -> eq_term_upto_univ_napp _ _ _ _ _ _ _ -> ?u = _ |- ?u = ?v => eapply ih ; eassumption end. @@ -58,25 +58,23 @@ Qed. Lemma nameless_eqctx_IH ctx ctx' : forallb (nameless_decl nameless) ctx -> forallb (nameless_decl nameless) ctx' -> - eq_context_gen eq eq ctx ctx' -> + eq_context_upto_names ctx ctx' -> ctx = ctx'. Proof. + intros H H0 X. + apply All2_eq. solve_all. - induction X; auto. - all:destruct p; depelim H; depelim H0; auto; f_equal; subst; auto. - - unfold nameless_decl in i, i0; rtoProp. - f_equal. - eapply banon_eq_binder_annot; eauto. - - unfold nameless_decl in i, i0; rtoProp. - f_equal. - eapply banon_eq_binder_annot; eauto. + destruct b0; unfold nameless_decl in *; cbn in *; rtoProp. + all: f_equal. + all: eapply banon_eq_binder_annot; eauto. Qed. -Lemma eq_context_gen_upto ctx ctx' : - eq_context_gen eq eq ctx ctx' -> - eq_context_upto empty_global_env eq eq ctx ctx'. +Lemma eq_context_upto_names_eq_context_alpha ctx ctx' : + eq_context_upto_names ctx ctx' -> + eq_context_upto empty_global_env (fun _ => eq) (fun _ => eq) Conv ctx ctx'. Proof. - intros a; eapply All2_fold_impl; tea. + move/All2_fold_All2. + intros a; eapply All2_fold_impl; tea; cbn. intros. destruct X; subst; constructor; auto; try reflexivity. Qed. @@ -84,7 +82,7 @@ Lemma nameless_eq_term_spec : forall u v napp, nameless u -> nameless v -> - eq_term_upto_univ_napp empty_global_env eq eq napp u v -> + eq_term_upto_univ_napp empty_global_env (fun _ => eq) (fun _ => eq) Conv napp u v -> u = v. Proof. intros u v napp hu hv e. @@ -106,81 +104,41 @@ Proof. * eapply H0 ; eauto. * eapply IHl ; assumption. - f_equal ; try solve [ ih ]. - eapply eq_univ_make. assumption. + apply cmp_universe_instance_eq. assumption. - f_equal ; try solve [ ih ]. - eapply eq_univ_make. assumption. + apply cmp_universe_instance_eq. assumption. - f_equal ; try solve [ ih ]. - eapply eq_univ_make. assumption. + apply cmp_universe_instance_eq. assumption. - f_equal ; try solve [ ih ]. * destruct e as [eqpar [eqinst [eqctx eqret]]]. destruct X as [? [? ?]]. destruct p, p'; simpl in *. f_equal. + apply All2_eq; solve_all. - + red in eqinst. - apply Forall2_eq. eapply Forall2_map_inv in eqinst. - eapply (Forall2_impl eqinst); solve_all. - now apply Universe.make_inj in H. + + apply cmp_universe_instance_eq. assumption. + simpl in *. eapply nameless_eqctx_IH; eauto. + ih. - * revert brs' H3 H0 a. - induction l ; intros brs' h1 h2 h. - + destruct brs' ; inversion h. reflexivity. - + destruct brs' ; inversion h. subst. - cbn in h1, h2. destruct_andb. - inversion X. subst. simpl in H5. - move/andb_and: H5 => [/andb_and [Hac Hab] Hl]. - apply forallb_All in Hac. - f_equal. - ++ destruct a, b. cbn in *. destruct X1. - depelim h. destruct p0. depelim X0. simpl in *. - destruct p0 as []. - destruct X4. - f_equal; try ih. - { eapply nameless_eqctx_IH; eauto; solve_all. } - ++ eapply IHl ; tas. now depelim X0. + * apply All2_eq. unfold eq_branches, eq_branch in *. solve_all. + destruct x, y; cbn in *; f_equal. + + eapply nameless_eqctx_IH; eauto. + all: solve_all. + + ih. - f_equal ; try solve [ ih ]. - revert mfix' H1 H2 H H0 a. - induction m ; intros m' h1 h2 h3 h4 h. - + destruct m' ; inversion h. reflexivity. - + destruct m' ; inversion h. subst. - inversion X. subst. - cbn in h1, h2, h3, h4. destruct_andb. - f_equal. - * destruct a, d. cbn in *. destruct X0 as [[[? ?] ?] ?]. - destruct H0 as [Hty Hbod]. - unfold test_def in H4, H. cbn in H4, H. - destruct_andb. - f_equal. - -- now apply banon_eq_binder_annot. - -- eapply Hty; eassumption. - -- eapply Hbod ; eassumption. - -- eassumption. - * eapply IHm ; assumption. + unfold eq_mfixpoint in *. apply All2_eq. solve_all. + destruct x, y; unfold test_def in *; destruct_andb; cbn in *; f_equal; try solve [ ih ]. + 2: assumption. + now apply banon_eq_binder_annot. - f_equal ; try solve [ ih ]. - revert mfix' H1 H2 H H0 a. - induction m ; intros m' h1 h2 h3 h4 h. - + destruct m' ; inversion h. reflexivity. - + destruct m' ; inversion h. subst. - inversion X. subst. - cbn in h1, h2, h3, h4. destruct_andb. - f_equal. - * destruct a, d. cbn in *. destruct X0 as [[[? ?] ?] ?]. - destruct H0 as [Hty Hbod]. - unfold test_def in H4, H. cbn in H4, H. - destruct_andb. anonify. - f_equal. - -- now apply banon_eq_binder_annot. - -- eapply Hty; eassumption. - -- eapply Hbod ; eassumption. - -- assumption. - * eapply IHm ; assumption. + unfold eq_mfixpoint in *. apply All2_eq. solve_all. + destruct x, y; unfold test_def in *; destruct_andb; cbn in *; f_equal; try solve [ ih ]. + 2: assumption. + now apply banon_eq_binder_annot. - f_equal. destruct o; auto. f_equal. f_equal. cbn in X, hu, hv. rtoProp. - destruct a, a'; cbn in *. eapply Universe.make_inj in e. f_equal; intuition eauto. - solve_all. induction a0 => //. f_equal; eauto. - eapply r; intuition eauto. + destruct X as (hty & hdef & harr). eapply Universe.make'_inj in e. + destruct a, a'; cbn in *. f_equal; intuition eauto. + apply All2_eq. solve_all. Qed. Lemma banon_list l : forallb (banon ∘ anonymize) l. @@ -291,85 +249,63 @@ Proof. destruct nth_error => /= //. Qed. -Lemma R_global_instance_nl Σ Re Rle gr napp : - CRelationClasses.subrelation (R_global_instance Σ Re Rle gr napp) - (R_global_instance (nl_global_env Σ) Re Rle gr napp). +Lemma cmp_global_instance_nl Σ cmp_universe pb gr napp : + CRelationClasses.subrelation (cmp_global_instance Σ cmp_universe pb gr napp) + (cmp_global_instance (nl_global_env Σ) cmp_universe pb gr napp). Proof. intros t t'. - unfold R_global_instance, R_global_instance_gen. + unfold cmp_global_instance, cmp_global_instance_gen. now rewrite global_variance_nl_sigma_mon. Qed. -Lemma eq_context_nl_IH Σ Re ctx ctx' : - (forall (napp : nat) (t t' : term) - (Rle : Universe.t -> Universe.t -> Prop), - eq_term_upto_univ_napp Σ Re Rle napp t t' -> - eq_term_upto_univ_napp (nl_global_env Σ) Re Rle napp - (nl t) (nl t')) -> - eq_context_gen eq eq ctx ctx' -> - eq_context_gen eq eq +Lemma eq_context_nl_IH ctx ctx' : + eq_context_upto_names ctx ctx' -> + eq_context_upto_names (map (map_decl_anon nl) ctx) (map (map_decl_anon nl) ctx'). Proof. - intros aux H. - induction H; simpl; constructor; simpl; destruct p; simpl; - intuition (constructor; auto); subst; reflexivity. + intros H. apply All2_map, All2_impl with (1 := H); clear H. + intros ?? []; constructor. + all: assumption. Defined. -Lemma nl_eq_term_upto_univ : - forall Σ Re Rle napp t t', - eq_term_upto_univ_napp Σ Re Rle napp t t' -> - eq_term_upto_univ_napp (nl_global_env Σ) Re Rle napp (nl t) (nl t'). +Lemma nl_eq_term_upto_univ Σ cmp_universe cmp_sort pb napp t t' : + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp t t' -> + eq_term_upto_univ_napp (nl_global_env Σ) cmp_universe cmp_sort pb napp (nl t) (nl t'). Proof. - intros Σ Re Rle napp t t' h. - revert napp t t' Rle h. fix aux 5. - intros napp t t' Rle h. - destruct h. + induction t in napp, pb, t' |- * using term_forall_list_ind; intro e. + all: dependent destruction e. all: simpl. all: try solve [ econstructor ; eauto ]. - econstructor. - induction a. - + constructor. - + simpl. econstructor. all: eauto. + solve_all. - econstructor. all: try solve [ eauto ]. - eapply R_global_instance_nl; eauto. + eapply cmp_global_instance_nl; eauto. - econstructor. all: try solve [ eauto ]. - eapply R_global_instance_nl; eauto. + eapply cmp_global_instance_nl; eauto. - econstructor; eauto. + red. destruct e; intuition auto; simpl. - * induction a0; constructor; auto. + * solve_all. * eapply eq_context_nl_IH; tea. - * apply aux. auto. - + induction a; constructor; auto. + * solve_all. + + unfold eq_branches in *. solve_all. unfold eq_branch in *. intuition auto; simpl. * eapply eq_context_nl_IH; tea. - * destruct x, y; simpl in *. apply aux; auto. - - econstructor; eauto. - induction a; constructor; auto. - intuition auto. - * destruct x, y; simpl in *. apply aux; auto. - * destruct x, y; simpl in *. apply aux; auto. - - econstructor; eauto. - induction a; constructor; auto. - intuition auto. - * destruct x, y; simpl in *. apply aux; auto. - * destruct x, y; simpl in *. apply aux; auto. + * solve_all. + - econstructor; eauto. unfold eq_mfixpoint in *. + solve_all. + - econstructor; eauto. unfold eq_mfixpoint in *. + solve_all. - constructor. - destruct i as [? []], i' as [? []]; cbn in o; depelim o; cbn in *; constructor; eauto. - + now eapply aux. - + now eapply aux. - + cbn. induction a2. - ++ constructor. - ++ cbn; constructor; [now eapply aux|]. eapply IHa2. -Qed. - -Lemma eq_context_nl Σ Re Rle ctx ctx' : - eq_context_gen (eq_term_upto_univ Σ Re Re) - (eq_term_upto_univ Σ Re Rle) ctx ctx' -> - eq_context_gen - (eq_term_upto_univ (nl_global_env Σ) Re Re) - (eq_term_upto_univ (nl_global_env Σ) Re Rle) - (nlctx ctx) (nlctx ctx'). + destruct p as [? []], i' as [? []]; depelim o; try now constructor. + destruct X as (hty & hdef & harr). + constructor; cbn; eauto. + solve_all. +Qed. + +Lemma eq_context_nl Σ cmp_universe cmp_sort pb ctx ctx' : + eq_context_gen (fun pb => eq_term_upto_univ Σ cmp_universe cmp_sort pb) pb ctx ctx' -> + eq_context_gen (fun pb => eq_term_upto_univ (nl_global_env Σ) cmp_universe cmp_sort pb) pb (nlctx ctx) (nlctx ctx'). Proof. intros H. induction H; constructor; simpl; destruct p; intuition @@ -392,19 +328,18 @@ Proof. intros. apply nl_eq_term_upto_univ. assumption. Qed. -Lemma nl_compare_term {cf:checker_flags} le Σ: - forall φ t t', - compare_term le Σ φ t t' -> - compare_term le (nl_global_env Σ) φ (nl t) (nl t'). +Lemma nl_compare_term {cf:checker_flags} Σ φ pb t t' : + compare_term Σ φ pb t t' -> + compare_term (nl_global_env Σ) φ pb (nl t) (nl t'). Proof. - destruct le; intros. + destruct pb; intros. - apply nl_eq_term. assumption. - apply nl_leq_term. assumption. Qed. Corollary eq_term_nl_eq : forall u v, - eq_term_upto_univ empty_global_env eq eq u v -> + eq_term_upto_univ empty_global_env (fun _ => eq) (fun _ => eq) Conv u v -> nl u = nl v. Proof. intros u v h. @@ -424,12 +359,12 @@ Local Ltac ih3 := (*Lemma eq_context_nl_inv_IH Σ Re ctx ctx' : onctx (fun u : term => - forall (Rle : Universe.t -> Universe.t -> Prop) + forall (Rle : sort -> sort -> Prop) (napp : nat) (v : term), eq_term_upto_univ_napp Σ Re Rle napp (nl u) (nl v) -> eq_term_upto_univ_napp Σ Re Rle napp u v) ctx -> - eq_context_gen eq eq (map (map_decl_anon nl) ctx) (map (map_decl_anon nl) ctx') -> - eq_context_gen eq eq ctx ctx'. + eq_context_upto_names (map (map_decl_anon nl) ctx) (map (map_decl_anon nl) ctx') -> + eq_context_upto_names ctx ctx'. Proof. intros Hctx. unfold ondecl in *. induction ctx as [|[na [b|] ty] Γ] in ctx', Hctx |- *; @@ -488,7 +423,7 @@ Lemma binder_anonymize n : eq_binder_annot n (anonymize n). Proof. destruct n; reflexivity. Qed. #[global] Hint Resolve binder_anonymize : core. -#[global] Hint Constructors compare_decls : core. +#[global] Hint Constructors eq_decl_upto_names : core. Local Hint Unfold map_decl_anon : core. (* Lemma eq_term_upto_univ_tm_nl : @@ -543,8 +478,8 @@ Corollary eq_term_tm_nl : Proof. intros flags Σ G u. eapply eq_term_upto_univ_tm_nl. - - intro. eapply eq_universe_refl. - - intro. eapply eq_universe_refl. + - intro. eapply eq_sort_refl. + - intro. eapply eq_sort_refl. Qed. *) Lemma nl_decompose_prod_assum : @@ -800,31 +735,31 @@ Proof. Qed. Lemma nl_eq_decl {cf:checker_flags} : - forall le Σ φ d d', - compare_decl le Σ φ d d' -> - compare_decl le (nl_global_env Σ) φ (map_decl nl d) (map_decl nl d'). + forall Σ φ pb d d', + compare_decl Σ φ pb d d' -> + compare_decl (nl_global_env Σ) φ pb (map_decl nl d) (map_decl nl d'). Proof. - intros le Σ φ d d' []; constructor; destruct le; + intros Σ φ pb d d' []; constructor; destruct pb; intuition auto using nl_eq_term, nl_leq_term. Qed. Lemma nl_eq_decl' {cf:checker_flags} : - forall le Σ φ d d', - compare_decl le Σ φ d d' -> - compare_decl le (nl_global_env Σ) φ (map_decl_anon nl d) (map_decl_anon nl d'). + forall Σ φ pb d d', + compare_decl Σ φ pb d d' -> + compare_decl (nl_global_env Σ) φ pb (map_decl_anon nl d) (map_decl_anon nl d'). Proof. - intros le Σ φ d d' []; constructor; destruct le; + intros Σ φ pb d d' []; constructor; destruct pb; intuition auto using nl_eq_term, nl_leq_term. Qed. Lemma nl_eq_context {cf:checker_flags} : - forall le Σ φ Γ Γ', - compare_context le Σ φ Γ Γ' -> - compare_context le (nl_global_env Σ) φ (nlctx Γ) (nlctx Γ'). + forall Σ φ pb Γ Γ', + compare_context Σ φ pb Γ Γ' -> + compare_context (nl_global_env Σ) φ pb (nlctx Γ) (nlctx Γ'). Proof. - intros le Σ φ Γ Γ' h. + intros Σ φ pb Γ Γ' h. unfold eq_context, nlctx. - destruct le; now eapply eq_context_nl. + now eapply eq_context_nl. Qed. Lemma nl_decompose_app : @@ -1398,7 +1333,7 @@ Lemma nl_conv {cf:checker_flags} : Proof. intros ? Σ ? Γ A B h. induction h. - - constructor. unfold leq_term_ext. rewrite global_ext_constraints_nlg. + - constructor. rewrite global_ext_constraints_nlg. unfold nlg. destruct Σ. apply nl_eq_term. assumption. - eapply cumul_red_l. 2: eassumption. @@ -1414,7 +1349,7 @@ Lemma nl_cumul {cf:checker_flags} : Proof. intros ? Σ ? Γ A B h. induction h. - - constructor. unfold leq_term_ext. rewrite global_ext_constraints_nlg. + - constructor. rewrite global_ext_constraints_nlg. unfold nlg. destruct Σ. apply nl_leq_term. assumption. - eapply cumul_red_l. 2: eassumption. diff --git a/pcuic/theories/Conversion/PCUICRenameConv.v b/pcuic/theories/Conversion/PCUICRenameConv.v index d2c947fdf..4d63a6f23 100644 --- a/pcuic/theories/Conversion/PCUICRenameConv.v +++ b/pcuic/theories/Conversion/PCUICRenameConv.v @@ -220,13 +220,12 @@ Section Renaming. Context `{cf : checker_flags}. -Lemma eq_term_upto_univ_rename Σ : - forall Re Rle napp u v f, - eq_term_upto_univ_napp Σ Re Rle napp u v -> - eq_term_upto_univ_napp Σ Re Rle napp (rename f u) (rename f v). +Lemma eq_term_upto_univ_rename Σ cmp_universe cmp_sort pb napp u v f : + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp u v -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (rename f u) (rename f v). Proof using Type. - intros Re Rle napp u v f h. - induction u in v, napp, Rle, f, h |- * using term_forall_list_ind. + intros h. + induction u in v, napp, pb, f, h |- * using term_forall_list_ind. all: dependent destruction h. all: try solve [ simpl ; constructor ; eauto @@ -239,29 +238,19 @@ Proof using Type. - simpl. constructor. all: eauto. * rewrite /rename_predicate. destruct X; destruct e as [? [? [ectx ?]]]. - rewrite (All2_fold_length ectx). red. + rewrite (All2_length ectx). red. intuition auto; simpl; solve_all. - * red in X0. solve_all. - rewrite -(All2_fold_length a). + * red in X0. unfold eq_branches, eq_branch in *. solve_all. + rewrite -(All2_length a1). now eapply b0. - - simpl. constructor. - apply All2_length in a as e. rewrite <- e. + - simpl. constructor. unfold eq_mfixpoint in *. + apply All2_length in e as eq. rewrite <- eq. generalize #|m|. intro k. - induction X in mfix', a, f, k |- *. - + inversion a. constructor. - + inversion a. subst. - simpl. constructor. - * unfold map_def. intuition eauto. - * eauto. - - simpl. constructor. - apply All2_length in a as e. rewrite <- e. + solve_all. + - simpl. constructor. unfold eq_mfixpoint in *. + apply All2_length in e as eq. rewrite <- eq. generalize #|m|. intro k. - induction X in mfix', a, f, k |- *. - + inversion a. constructor. - + inversion a. subst. - simpl. constructor. - * unfold map_def. intuition eauto. - * eauto. + solve_all. - simpl. constructor. eapply onPrims_map_prop; tea. cbn; intuition eauto. Qed. diff --git a/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v b/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v index 62b6b30c6..be8df6415 100644 --- a/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v +++ b/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v @@ -6,7 +6,7 @@ From MetaCoq.PCUIC Require Import PCUICAst PCUICOnOne PCUICAstUtils PCUICInducti PCUICLiftSubst PCUICEquality PCUICUnivSubst PCUICCases PCUICCumulativity PCUICTyping PCUICReduction PCUICWeakeningEnv - PCUICClosed PCUICPosition PCUICGuardCondition. + PCUICClosed PCUICPosition. Require Import Equations.Prop.DepElim. From Equations Require Import Equations. @@ -36,13 +36,13 @@ Qed. Lemma eq_valuation v v' (H1 : forall s, valuation_mono v s = valuation_mono v' s) (H2 : forall n, valuation_poly v n = valuation_poly v' n) - : forall u : Universe.t, Universe.to_cuniv v u = Universe.to_cuniv v' u. + : forall u : sort, Sort.to_csort v u = Sort.to_csort v' u. Proof. intros [| | u]; cbnr. f_equal. assert (He : forall e : LevelExpr.t, val v e = val v' e). { intros [[] b]; cbnr; rewrite ?H1 ?H2; reflexivity. } rewrite !val_fold_right. - induction ((List.rev (LevelAlgExpr.exprs u).2)); cbn; congruence. + induction ((List.rev (Universe.exprs u).2)); cbn; congruence. Qed. (* Lemma is_prop_subst_instance_level u l @@ -66,10 +66,10 @@ Proof. destruct nth_error; cbnr. Qed. -Lemma subst_instance_univ0_val u exprs v v' +Lemma subst_instance_universe_val u exprs v v' (H1 : forall s, valuation_mono v s = valuation_mono v' s) (H2 : forall n, val v (nth n u Level.lzero) = valuation_poly v' n) - : val v (subst_instance_univ0 u exprs) = val v' exprs. + : val v (subst_instance_universe u exprs) = val v' exprs. Proof. symmetry. apply val_caract. split. @@ -84,13 +84,13 @@ Proof. symmetry; now apply subst_instance_level_expr_val. Qed. -Lemma subst_instance_univ_val u s v v' +Lemma subst_instance_sort_val u s v v' (H1 : forall s, valuation_mono v s = valuation_mono v' s) (H2 : forall n, val v (nth n u Level.lzero) = valuation_poly v' n) - : Universe.to_cuniv v (subst_instance_univ u s) = Universe.to_cuniv v' s. + : Sort.to_csort v (subst_instance_sort u s) = Sort.to_csort v' s. Proof. destruct s as [ | | exprs]; cbnr. - f_equal; now apply subst_instance_univ0_val. + f_equal; now apply subst_instance_universe_val. Qed. Definition subst_instance_valuation (u : Instance.t) (v : valuation) := @@ -105,120 +105,102 @@ Proof. Qed. -Lemma subst_instance_univ0_val' u exprs v - : val v (subst_instance_univ0 u exprs) = val (subst_instance_valuation u v) exprs. +Lemma subst_instance_universe_val' u exprs v + : val v (subst_instance_universe u exprs) = val (subst_instance_valuation u v) exprs. Proof. - now apply subst_instance_univ0_val. + now apply subst_instance_universe_val. Qed. -Lemma subst_instance_univ_val' u l v - : Universe.to_cuniv v (subst_instance_univ u l) = Universe.to_cuniv (subst_instance_valuation u v) l. +Lemma subst_instance_sort_val' u l v + : Sort.to_csort v (subst_instance_sort u l) = Sort.to_csort (subst_instance_valuation u v) l. Proof. - now apply subst_instance_univ_val. + now apply subst_instance_sort_val. Qed. -Lemma subst_instance_univ_make' (l : LevelExpr.t) u : - subst_instance u (LevelAlgExpr.make l) = LevelAlgExpr.make (subst_instance_level_expr u l). +Lemma subst_instance_universe_make' (l : LevelExpr.t) u : + subst_instance u (Universe.make l) = Universe.make (subst_instance_level_expr u l). Proof. reflexivity. Qed. -Lemma subst_instance_univ_make l u : - subst_instance_univ u (Universe.make l) - = Universe.make (subst_instance_level u l). +Lemma subst_instance_universe_make l u : + subst_instance_universe u (Universe.make' l) + = Universe.make' (subst_instance u l). Proof. destruct l; cbnr. rewrite nth_nth_error. destruct nth_error; cbnr. Qed. -Class SubstUnivPreserving Re := Build_SubstUnivPreserving : - forall s u1 u2, R_universe_instance Re u1 u2 -> - Re (subst_instance_univ u1 s) (subst_instance_univ u2 s). +Class SubstUnivPreserving eq_universe {A} `{UnivSubst A} (eqA : A -> A -> Prop) := Build_SubstUnivPreserving : + forall u u1 u2, cmp_universe_instance eq_universe u1 u2 -> + eqA (subst_instance u1 u) (subst_instance u2 u). -Lemma subst_equal_inst_inst Re : - SubstUnivPreserving Re -> - forall u u1 u2, R_universe_instance Re u1 u2 -> - R_universe_instance Re (subst_instance u1 u) +Lemma subst_equal_inst_inst Re Re' : + SubstUnivPreserving Re Re' -> + forall u u1 u2, cmp_universe_instance Re u1 u2 -> + cmp_universe_instance Re' (subst_instance u1 u) (subst_instance u2 u). Proof. intros hRe u. induction u; cbnr; try now constructor. - intros u1 u2; unfold R_universe_instance; cbn; constructor. - - pose proof (hRe (Universe.make a) u1 u2 H) as HH. - now rewrite !subst_instance_univ_make in HH. + intros u1 u2; unfold cmp_universe_instance; cbn; constructor. + - pose proof (hRe (Universe.make' a) u1 u2 H) as HH. + now rewrite /subst_instance !subst_instance_universe_make in HH. - exact (IHu u1 u2 H). Qed. -Lemma subst_equal_inst_global_inst Σ Re Rle gr napp : - RelationClasses.Reflexive Re -> - SubstUnivPreserving Re -> - RelationClasses.subrelation Re Rle -> - forall u u1 u2, R_universe_instance Re u1 u2 -> - R_global_instance Σ Re Rle gr napp (subst_instance u1 u) +Lemma subst_equal_inst_global_inst Σ cmp_universe pb gr napp : + SubstUnivPreserving (cmp_universe Conv) (cmp_universe Conv) -> + forall u u1 u2, cmp_universe_instance (cmp_universe Conv) u1 u2 -> + cmp_global_instance Σ cmp_universe pb gr napp (subst_instance u1 u) (subst_instance u2 u). Proof. - intros reflRe hRe subr u u1 u2 Ru1u2. - unfold R_global_instance, R_global_instance_gen, R_opt_variance. - destruct global_variance_gen as [v|]; auto using subst_equal_inst_inst. - induction u in v |- *; cbnr; try now constructor. - - destruct v; simpl; auto. - split; auto. - destruct t; simpl; auto. - * pose proof (hRe (Universe.make a) u1 u2 Ru1u2) as HH. - now rewrite !subst_instance_univ_make in HH. - * pose proof (hRe (Universe.make a) u1 u2 Ru1u2) as HH. - now rewrite !subst_instance_univ_make in HH. + intros subst_conv u u1 u2 Ru1u2. + unfold cmp_global_instance, cmp_global_instance_gen, cmp_opt_variance. + destruct global_variance_gen as [| |v]. + - now eapply subst_equal_inst_inst. + - len. + - left. now eapply subst_equal_inst_inst. Qed. -Lemma eq_term_upto_univ_subst_instance Σ Re Rle napp : - RelationClasses.Reflexive Re -> - SubstUnivPreserving Re -> - RelationClasses.subrelation Re Rle -> +Lemma eq_term_upto_univ_subst_instance Σ cmp_universe cmp_sort pb napp : + SubstUnivPreserving (cmp_universe Conv) (cmp_universe Conv) -> + SubstUnivPreserving (cmp_universe Conv) (cmp_sort Conv) -> + SubstUnivPreserving (cmp_universe Conv) (cmp_sort pb) -> forall t u1 u2, - R_universe_instance Re u1 u2 -> - eq_term_upto_univ_napp Σ Re Rle napp (subst_instance u1 t) + cmp_universe_instance (cmp_universe Conv) u1 u2 -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (subst_instance u1 t) (subst_instance u2 t). Proof. - intros ref hRe subr t. - induction t in napp, Re, Rle, ref, hRe, subr |- * using term_forall_list_ind; intros u1 u2 hu. - all: cbn; try constructor; eauto using subst_equal_inst_inst. - all: try eapply All2_map, All_All2; tea; cbn; intros; rdest; eauto. - all: try (eapply X0 || eapply IHt || eapply IHt1 || eapply IHt2 || eapply e || eapply e0); try typeclasses eauto; auto. - all: eauto using subst_equal_inst_global_inst. - - rewrite /eq_predicate /=. intuition auto. - * solve_all. eapply All_All2; tea; cbn; intros; rdest; eauto. - eapply X; eauto. tc. - * eapply subst_equal_inst_inst => //. - * solve_all. reflexivity. - * eapply X => //. - - solve_all. reflexivity. - - destruct p as [? []]; cbn in X; constructor; cbn; intuition eauto; cbn. - * rewrite -!subst_instance_univ_make. now eapply hRe. - * now eapply a1. - * now eapply a0. - * solve_all. eapply All_All2; tea. intuition eauto. now apply X. + intros hsubst_conv hsubst_sort_conv hsubst_sort_pb t. + induction t in napp, pb, hsubst_sort_pb |- * using term_forall_list_ind; intros u1 u2 hu. + all: cbn; try constructor; eauto using subst_equal_inst_inst, subst_equal_inst_global_inst. + all: solve_all; unfold eq_predicate, eq_branches, eq_branch, eq_mfixpoint in *. + all: try eapply All2_map, All_All2; tea; cbn; intros; rdest; eauto using subst_equal_inst_inst. + - solve_all. + - reflexivity. + - reflexivity. + - destruct p as [? []]; try now constructor. + destruct X as (hty & hdef & harr). + constructor; cbn; eauto. + * rewrite /= -!subst_instance_universe_make. + now eapply hsubst_conv. + * solve_all. Qed. #[global] Instance eq_universe_SubstUnivPreserving {cf:checker_flags} φ : - SubstUnivPreserving (eq_universe φ). + SubstUnivPreserving (eq_universe φ) (eq_universe φ). Proof. - intros [| | exprs]; cbnr. - intros u1 u2 hu. + intros exprs u1 u2 hu. unfold_univ_rel. assert (He : forall e, val v (subst_instance_level_expr u1 e) = val v (subst_instance_level_expr u2 e)). { destruct e as [[] b]; cbnr. case_eq (nth_error u1 n). - - intros l1 X. eapply Forall2_nth_error_Some_l in hu. - 2: now rewrite -> nth_error_map, X. - destruct hu as [l2 [H1 H2]]. - rewrite nth_error_map in H1. - destruct (nth_error u2 n) as [l2'|]; [|discriminate]. - apply some_inj in H1; subst. clear u1 u2 X. + - intros l1 X. eapply Forall2_nth_error_Some_l in hu; tea. + destruct hu as [l2 [-> H2]]. specialize (H2 v Hv). - destruct l1, l2'; cbn in *; noconf H2; try lia. - - intros X. eapply Forall2_nth_error_None_l in hu. - 2: now rewrite -> nth_error_map, X. - rewrite nth_error_map in hu. + cbn in *. lia. + - intros X. eapply Forall2_nth_error_None_l in hu; tea. destruct (nth_error u2 n); [discriminate|reflexivity]. } simpl. apply val_caract; split. @@ -235,25 +217,19 @@ Qed. #[global] Instance leq_universe_SubstUnivPreserving {cf:checker_flags} φ : - SubstUnivPreserving (leq_universe φ). + SubstUnivPreserving (leq_universe φ) (leq_universe φ). Proof. - intros [| | exprs] u1 u2 hu; cbnr. + intros exprs u1 u2 hu. unfold_univ_rel. assert (He : forall e, val v (subst_instance_level_expr u1 e) <= val v (subst_instance_level_expr u2 e)). { destruct e as [[] b]; cbnr. case_eq (nth_error u1 n). - - intros l1 X. eapply Forall2_nth_error_Some_l in hu. - 2: now rewrite -> nth_error_map, X. - destruct hu as [l2 [H1 H2]]. - rewrite nth_error_map in H1. - destruct (nth_error u2 n) as [l2'|]; [|discriminate]. - apply some_inj in H1; subst. clear u1 u2 X. + - intros l1 X. eapply Forall2_nth_error_Some_l in hu; tea. + destruct hu as [l2 [-> H2]]. specialize (H2 v Hv). - destruct l1, l2'; cbn in *; noconf H2; try lia. - - intros X. eapply Forall2_nth_error_None_l in hu. - 2: now rewrite -> nth_error_map, X. - rewrite nth_error_map in hu. + cbn in *. lia. + - intros X. eapply Forall2_nth_error_None_l in hu; tea. destruct (nth_error u2 n); [discriminate|reflexivity]. } simpl. rewrite Z.sub_0_r. @@ -276,9 +252,21 @@ Proof. Qed. #[global] -Instance compare_universe_substu {cf} le Σ : SubstUnivPreserving (compare_universe le Σ). +Instance compare_universe_substu {cf} φ pb : SubstUnivPreserving (eq_universe φ) (compare_universe φ pb). +Proof. + destruct pb; tc. + intros u ui ui' H. + apply leq_universe_SubstUnivPreserving. + eapply cmp_universe_instance_impl'; tea. tc. +Qed. + +#[global] +Instance compare_sort_substu {cf:checker_flags} φ pb : + SubstUnivPreserving (eq_universe φ) (compare_sort φ pb). Proof. - destruct le; tc. + intros s u1 u2 hu. + destruct s as [| | u]; cbnr. rewrite compare_sort_type. + now eapply Build_SubstUnivPreserving. Qed. Global Instance subst_instance_def {A} `(UnivSubst A) : UnivSubst (def A) @@ -312,10 +300,10 @@ Proof. Qed. Lemma subst_instance_univ0_two u1 u2 exprs : - subst_instance_univ0 u1 (subst_instance_univ0 u2 exprs) - = subst_instance_univ0 (subst_instance u1 u2) exprs. + subst_instance_universe u1 (subst_instance_universe u2 exprs) + = subst_instance_universe (subst_instance u1 u2) exprs. Proof. - unfold subst_instance_univ0. + unfold subst_instance_universe. eapply eq_univ'. intro l; split; intro Hl; apply map_spec in Hl as [l' [H1 H2]]; apply map_spec; subst. @@ -327,8 +315,8 @@ Qed. Lemma subst_instance_univ_two u1 u2 s : - subst_instance_univ u1 (subst_instance_univ u2 s) - = subst_instance_univ (subst_instance u1 u2) s. + subst_instance_sort u1 (subst_instance_sort u2 s) + = subst_instance_sort (subst_instance u1 u2) s. Proof. destruct s; cbnr. f_equal. apply subst_instance_univ0_two. @@ -440,27 +428,33 @@ Proof. + now apply In_subst_instance_cstrs'. Qed. +Lemma is_propositional_subst_instance_univ u l + : Sort.is_propositional (subst_instance_sort u l) = Sort.is_propositional l. +Proof. + destruct l; cbnr. +Qed. + Lemma is_prop_subst_instance_univ u l - : Universe.is_prop (subst_instance_univ u l) = Universe.is_prop l. + : Sort.is_prop (subst_instance_sort u l) = Sort.is_prop l. Proof. destruct l; cbnr. Qed. Lemma is_sprop_subst_instance_univ u l - : Universe.is_sprop (subst_instance_univ u l) = Universe.is_sprop l. + : Sort.is_sprop (subst_instance_sort u l) = Sort.is_sprop l. Proof. destruct l; cbnr. Qed. Lemma is_prop_subst_instance u x0 : - Universe.is_prop x0 -> Universe.is_prop (subst_instance_univ u x0). + Sort.is_prop x0 -> Sort.is_prop (subst_instance_sort u x0). Proof. now rewrite is_prop_subst_instance_univ. Qed. -Lemma sup_subst_instance_univ0 u s1 s2 : - subst_instance u (LevelAlgExpr.sup s1 s2) - = LevelAlgExpr.sup (subst_instance u s1) (subst_instance u s2). +Lemma sup_subst_instance_univ0 ui u1 u2 : + subst_instance ui (Universe.sup u1 u2) + = Universe.sup (subst_instance ui u1) (subst_instance ui u2). Proof. apply eq_univ'. cbn. intro x; split; intro Hx. @@ -475,8 +469,8 @@ Proof. Qed. Lemma sup_subst_instance_univ u s1 s2 : - subst_instance_univ u (Universe.sup s1 s2) - = Universe.sup (subst_instance_univ u s1) (subst_instance_univ u s2). + subst_instance_sort u (Sort.sup s1 s2) + = Sort.sup (subst_instance_sort u s1) (subst_instance_sort u s2). Proof. destruct s1, s2; cbnr. f_equal. apply sup_subst_instance_univ0. @@ -785,36 +779,52 @@ Qed. Global Instance leq_universe_subst_instance {cf : checker_flags} : SubstUnivPreserved leq_universe. Proof. - intros φ φ' u HH [| | exprs] [| | exprs'] Hle; cbnr; trivial. + intros φ φ' u HH exprs exprs' Hle. unfold_univ_rel eqn:H. - rewrite !subst_instance_univ0_val'; tas. + rewrite !subst_instance_universe_val'; tas. apply Hle. - eapply satisfies_subst_instance; tea. + eapply satisfies_subst_instance_ctr; tea. Qed. Global Instance eq_universe_subst_instance {cf : checker_flags} : SubstUnivPreserved eq_universe. Proof. - intros φ φ' u HH [| | exprs] [| | exprs'] Hle; cbnr; trivial. + intros φ φ' u HH exprs exprs' Hle; cbnr; trivial. unfold_univ_rel eqn:H. - rewrite !subst_instance_univ0_val'; tas. + rewrite !subst_instance_universe_val'; tas. apply Hle. - eapply satisfies_subst_instance; tea. + eapply satisfies_subst_instance_ctr; tea. Qed. -Lemma precompose_subst_instance Rle u i i' : - precompose (R_universe_instance Rle) (subst_instance u) i i' - <~> R_universe_instance (precompose Rle (subst_instance_univ u)) i i'. +Global Instance leq_sort_subst_instance {cf : checker_flags} : SubstUnivPreserved leq_sort. Proof. - unfold R_universe_instance, subst_instance. - replace (List.map Universe.make (List.map (subst_instance_level u) i)) - with (List.map (subst_instance_univ u) (List.map Universe.make i)). - 1: replace (List.map Universe.make (List.map (subst_instance_level u) i')) - with (List.map (subst_instance_univ u) (List.map Universe.make i')). - 1: split. - 1: apply Forall2_map_inv. - 1: apply Forall2_map. - all: rewrite !map_map; apply map_ext. - all: intro; apply subst_instance_univ_make. + intros φ φ' u HH [| | exprs] [| | exprs'] Hle; cbnr; trivial. + eapply Build_SubstUnivPreserved; tea. +Qed. + +Global Instance eq_sort_subst_instance {cf : checker_flags} : SubstUnivPreserved eq_sort. +Proof. + intros φ φ' u HH [| | exprs] [| | exprs'] Hle; cbnr; trivial. + eapply Build_SubstUnivPreserved; tea. +Qed. + +Global Instance compare_universe_subst_instance {cf : checker_flags} pb : SubstUnivPreserved (fun φ => compare_universe φ pb). +Proof. + destruct pb; tc. +Qed. + +Global Instance compare_sort_subst_instance {cf : checker_flags} pb : SubstUnivPreserved (fun φ => compare_sort φ pb). +Proof. + destruct pb; tc. +Qed. + +Lemma precompose_subst_instance cmp_universe u i i' : + precompose (cmp_universe_instance cmp_universe) (subst_instance u) i i' + <~> cmp_universe_instance (precompose cmp_universe (subst_instance_universe u)) i i'. +Proof. + unfold cmp_universe_instance, subst_instance, on_rel. + split; intro H; [apply Forall2_map_inv in H | apply Forall2_map]; apply Forall2_impl with (1 := H); intros. + - rewrite !subst_instance_universe_make //. + - rewrite -!subst_instance_universe_make //. Qed. Definition precompose_subst_instance__1 Rle u i i' @@ -831,91 +841,112 @@ Proof. Qed. Lemma subst_instance_make'_make u l : - subst_instance u (LevelAlgExpr.make (LevelExpr.make l)) = - LevelAlgExpr.make (LevelExpr.make (subst_instance_level u l)). + subst_instance u (Universe.make (LevelExpr.make l)) = + Universe.make (LevelExpr.make (subst_instance_level u l)). Proof. - now rewrite subst_instance_univ_make' subst_instance_level_expr_make. + now rewrite subst_instance_universe_make' subst_instance_level_expr_make. Qed. -Lemma precompose_subst_instance_global Σ Re Rle gr napp u i i' : - precompose (R_global_instance Σ Re Rle gr napp) (subst_instance u) i i' - <~> R_global_instance Σ (precompose Re (subst_instance_univ u)) - (precompose Rle (subst_instance_univ u)) gr napp i i'. +Lemma precompose_subst_instance_global Σ cmp_universe pb gr napp u i i' : + precompose (cmp_global_instance Σ cmp_universe pb gr napp) (subst_instance u) i i' + <~> cmp_global_instance Σ (fun pb => precompose (cmp_universe pb) (subst_instance_universe u)) + pb gr napp i i'. Proof. - unfold R_global_instance, R_global_instance_gen, R_opt_variance, subst_instance. - destruct global_variance_gen as [v|]; eauto using precompose_subst_instance. - induction i in i', v |- *; destruct i', v; simpl; try split; auto. - - destruct (IHi i' []). intros; auto. - - destruct (IHi i' []). intros; auto. - - destruct (IHi i' v). intros []; split; auto. - destruct t0; simpl in *; auto. - * now rewrite !subst_instance_make'_make. - * now rewrite !subst_instance_make'_make. - - destruct (IHi i' v). intros []; split; auto. - destruct t0; simpl in *; auto. - * now rewrite !subst_instance_make'_make in H. - * now rewrite !subst_instance_make'_make in H. + unfold cmp_global_instance, cmp_global_instance_gen, cmp_opt_variance, subst_instance. + destruct global_variance_gen as [| |v]. + - apply precompose_subst_instance. + - len. + - split. all: intros [H|H]; [left|right]. + 1,3: now apply precompose_subst_instance. + all: [> rewrite -(map_id v) in H; apply Forall3_map_inv in H | rewrite -(map_id v); apply Forall3_map]; + apply Forall3_impl with (1 := H); clear v i i' H; intros v ??. + all: destruct v => //=; unfold on_rel in *. + all: rewrite !subst_instance_universe_make //. Qed. -Definition precompose_subst_instance_global__1 Σ Re Rle gr napp u i i' - := fst (precompose_subst_instance_global Σ Re Rle gr napp u i i'). +Definition precompose_subst_instance_global__1 Σ cmp_universe pb gr napp u i i' + := fst (precompose_subst_instance_global Σ cmp_universe pb gr napp u i i'). -Definition precompose_subst_instance_global__2 Σ Re Rle gr napp u i i' - := snd (precompose_subst_instance_global Σ Re Rle gr napp u i i'). +Definition precompose_subst_instance_global__2 Σ cmp_universe pb gr napp u i i' + := snd (precompose_subst_instance_global Σ cmp_universe pb gr napp u i i'). Global Instance eq_term_upto_univ_subst_preserved {cf : checker_flags} Σ - (Re Rle : ConstraintSet.t -> Universe.t -> Universe.t -> Prop) napp - {he: SubstUnivPreserved Re} {hle: SubstUnivPreserved Rle} - : SubstUnivPreserved (fun φ => eq_term_upto_univ_napp Σ (Re φ) (Rle φ) napp). + (cmp_universe : forall _ _ (_ _ : Universe.t), Prop) (cmp_sort : forall _ _ (_ _ : sort), Prop) pb napp + {huniverse : SubstUnivPreserved (fun φ => cmp_universe φ Conv)} {huniverse2 : SubstUnivPreserved (fun φ => cmp_universe φ pb)} + {hsort : SubstUnivPreserved (fun φ => cmp_sort φ Conv)} {hsort2 : SubstUnivPreserved (fun φ => cmp_sort φ pb)} + : SubstUnivPreserved (fun φ => eq_term_upto_univ_napp Σ (cmp_universe φ) (cmp_sort φ) pb napp). Proof. intros φ φ' u HH t t'. - specialize (he _ _ _ HH). - specialize (hle _ _ _ HH). - clear HH. cbn in he. - induction t in napp, t', Rle, hle |- * using term_forall_list_ind; + specialize (huniverse _ _ _ HH). + specialize (huniverse2 _ _ _ HH). + specialize (hsort _ _ _ HH). + specialize (hsort2 _ _ _ HH). + clear HH. cbn in huniverse, huniverse2, hsort, hsort2. + induction t in napp, pb, huniverse2, hsort2, t' |- * using term_forall_list_ind; inversion 1; subst; cbn; constructor; - eauto using precompose_subst_instance__2, R_universe_instance_impl'. + eauto using precompose_subst_instance__2, cmp_universe_instance_impl'. + all: unfold eq_predicate, eq_branches, eq_branch, eq_mfixpoint in *. all: try (apply All2_map; eapply All2_impl'; tea; eapply All_impl; eauto; cbn; intros; aa). - - inv X. - eapply precompose_subst_instance_global__2. - eapply R_global_instance_impl_same_napp; eauto. - - inv X. - eapply precompose_subst_instance_global__2. - eapply R_global_instance_impl_same_napp; eauto. + - eapply precompose_subst_instance_global__2. + eapply cmp_global_instance_impl_same_napp; eauto. + - eapply precompose_subst_instance_global__2. + eapply cmp_global_instance_impl_same_napp; eauto. - destruct X2 as [? [? [? ?]]]. repeat split; simpl; eauto; solve_all. * eapply precompose_subst_instance. - eapply R_universe_instance_impl; eauto. - - destruct p as [? []]; depelim X1; cbn in X; try constructor; intuition eauto. - * cbn. rewrite -!subst_instance_univ_make. now eapply he. - * now eapply a2. - * now eapply a0. - * cbn. solve_all. + eapply cmp_universe_instance_impl; eauto. + - destruct p as [? []]; depelim X1; try now constructor. + destruct X as (hty & hdef & harr). + constructor; cbn; eauto. + * rewrite /= -!subst_instance_universe_make. + now eapply huniverse. + * solve_all. Qed. -Lemma leq_term_subst_instance {cf : checker_flags} Σ : SubstUnivPreserved (leq_term Σ). +Lemma leq_term_subst_instance {cf : checker_flags} Σ : SubstUnivPreserved (fun φ => leq_term Σ φ). Proof. apply eq_term_upto_univ_subst_preserved; cbn; apply _. Qed. -Lemma eq_term_subst_instance {cf : checker_flags} Σ : SubstUnivPreserved (eq_term Σ). +Lemma eq_term_subst_instance {cf : checker_flags} Σ : SubstUnivPreserved (fun φ => eq_term Σ φ). Proof. apply eq_term_upto_univ_subst_preserved; cbn; exact _. Qed. -Lemma compare_term_subst_instance {cf : checker_flags} pb Σ : SubstUnivPreserved (compare_term pb Σ). -Proof. apply eq_term_upto_univ_subst_preserved; cbn; try destruct pb; exact _. Qed. +Lemma compare_term_subst_instance {cf : checker_flags} Σ pb : SubstUnivPreserved (fun φ => compare_term Σ φ pb). +Proof. destruct pb; [apply eq_term_subst_instance|apply leq_term_subst_instance]. Qed. + +Global Instance compare_decls_subst_preserved {cf : checker_flags} Σ + (cmp_universe : forall _ _ (_ _ : Universe.t), Prop) (cmp_sort : forall _ _ (_ _ : sort), Prop) pb + {huniverse : SubstUnivPreserved (fun φ => cmp_universe φ Conv)} {huniverse2 : SubstUnivPreserved (fun φ => cmp_universe φ pb)} + {hsort : SubstUnivPreserved (fun φ => cmp_sort φ Conv)} {hsort2 : SubstUnivPreserved (fun φ => cmp_sort φ pb)} + : SubstUnivPreserved (fun φ => compare_decls (fun pb => eq_term_upto_univ Σ (cmp_universe φ) (cmp_sort φ) pb) pb). +Proof. + intros φ φ' u HH d d' []; constructor; cbn; auto. + all: now eapply eq_term_upto_univ_subst_preserved. +Qed. + +Global Instance eq_context_upto_subst_preserved {cf : checker_flags} Σ + (cmp_universe : forall _ _ (_ _ : Universe.t), Prop) (cmp_sort : forall _ _ (_ _ : sort), Prop) pb + {huniverse : SubstUnivPreserved (fun φ => cmp_universe φ Conv)} {huniverse2 : SubstUnivPreserved (fun φ => cmp_universe φ pb)} + {hsort : SubstUnivPreserved (fun φ => cmp_sort φ Conv)} {hsort2 : SubstUnivPreserved (fun φ => cmp_sort φ pb)} + : SubstUnivPreserved (fun φ => eq_context_upto Σ (cmp_universe φ) (cmp_sort φ) pb). +Proof. + intros φ φ' u HH Γ Δ. + induction 1; cbn; constructor; auto. + now eapply compare_decls_subst_preserved. +Qed. (** Now routine lemmas ... *) -Lemma In_subst_instance x u (l : LevelAlgExpr.t) : +Lemma In_subst_instance x u (l : Universe.t) : LevelExprSet.In x (subst_instance u l) <-> (exists x', LevelExprSet.In x' l /\ x = subst_instance u x'). Proof. unfold subst_instance; cbn. - unfold subst_instance_univ0. + unfold subst_instance_universe. now rewrite map_spec. Qed. Lemma subst_instance_univ_super l u - : subst_instance_univ u (Universe.super l) = Universe.super (subst_instance u l). + : subst_instance_sort u (Sort.super l) = Sort.super (subst_instance u l). Proof. destruct l; cbnr. f_equal. apply eq_univ'. @@ -967,11 +998,9 @@ Qed. Lemma product_subst_instance u s1 s2 - : subst_instance_univ u (Universe.sort_of_product s1 s2) - = Universe.sort_of_product (subst_instance_univ u s1) (subst_instance_univ u s2). + : subst_instance_sort u (Sort.sort_of_product s1 s2) + = Sort.sort_of_product (subst_instance_sort u s1) (subst_instance_sort u s2). Proof. - unfold Universe.sort_of_product. - rewrite is_prop_subst_instance_univ; tas. destruct s2; cbn; try reflexivity. destruct s1; cbn; try reflexivity. f_equal. @@ -1488,23 +1517,23 @@ Lemma is_allowed_elimination_subst_instance {cf : checker_flags} (Σ : global_en valid_constraints (global_ext_constraints (Σ.1, univs)) (subst_instance_cstrs inst Σ) -> is_allowed_elimination Σ al u -> - is_allowed_elimination (global_ext_constraints (Σ.1, univs)) al (subst_instance_univ inst u). + is_allowed_elimination (global_ext_constraints (Σ.1, univs)) al (subst_instance_sort inst u). Proof. destruct al, u as [| | u]; trivial. - intros val [H|isal]; [cbn in H; discriminate | right]. + intros val [H|isal] => //; right. cbn in isal |- *. unfold_univ_rel eqn:H. - eapply satisfies_subst_instance in Hv; eauto. - specialize (isal _ Hv). - rewrite subst_instance_univ0_val'; auto. + eapply satisfies_subst_instance_ctr in val; eauto. + specialize (isal _ val). + rewrite subst_instance_universe_val'; auto. Qed. -Global Instance compare_decl_subst_instance {cf : checker_flags} pb Σ : SubstUnivPreserved (compare_decl pb Σ). +Global Instance compare_decl_subst_instance {cf : checker_flags} pb Σ : SubstUnivPreserved (fun φ => compare_decl Σ φ pb). Proof. intros φ1 φ2 u HH ? ? [] => /=; constructor; auto; eapply compare_term_subst_instance; tea. Qed. -Global Instance compare_context_subst_instance {cf : checker_flags} pb Σ : SubstUnivPreserved (compare_context pb Σ). +Global Instance compare_context_subst_instance {cf : checker_flags} pb Σ : SubstUnivPreserved (fun φ => compare_context Σ φ pb). Proof. intros φ φ' u HH Γ Γ' X. eapply All2_fold_map, All2_fold_impl; tea. intros. eapply compare_decl_subst_instance; eassumption. @@ -1513,7 +1542,7 @@ Qed. Lemma subst_instance_destArity Γ A u : destArity (subst_instance u Γ) (subst_instance u A) = match destArity Γ A with - | Some (ctx, s) => Some (subst_instance u ctx, subst_instance_univ u s) + | Some (ctx, s) => Some (subst_instance u ctx, subst_instance_sort u s) | None => None end. Proof. @@ -1655,13 +1684,12 @@ Proof. - apply hin. Qed. -Lemma wf_universe_subst_instance {cf : checker_flags} (Σ : global_env_ext) univs u s : +Lemma wf_universe_subst_instance {cf : checker_flags} (Σ : global_env_ext) univs ui u : wf Σ -> - wf_universe Σ s -> - consistent_instance_ext (Σ.1, univs) Σ.2 u -> - wf_universe (Σ.1, univs) (subst_instance u s). + wf_universe Σ u -> + consistent_instance_ext (Σ.1, univs) Σ.2 ui -> + wf_universe (Σ.1, univs) (subst_instance ui u). Proof. - destruct s as [| | t]; cbnr. intros wfΣ Hl Hu e [[l n] [inl ->]]%In_subst_instance. destruct l as [|s|n']; simpl; auto. - apply global_ext_levels_InSet. @@ -1677,7 +1705,7 @@ Proof. destruct u; try discriminate. lsets. * destruct Hu as [declu [us vc]]. unfold subst_instance. simpl. - destruct (nth_error u n') eqn:hnth. + destruct (nth_error ui n') eqn:hnth. 2: simpl; apply global_ext_levels_InSet. eapply forallb_Forall in declu. eapply nth_error_forall in declu; eauto. @@ -1685,6 +1713,16 @@ Proof. + now apply not_var_global_levels in Hl. Qed. +Lemma wf_sort_subst_instance {cf : checker_flags} (Σ : global_env_ext) univs ui s : + wf Σ -> + wf_sort Σ s -> + consistent_instance_ext (Σ.1, univs) Σ.2 ui -> + wf_sort (Σ.1, univs) (subst_instance ui s). +Proof. + destruct s as [| | u]; cbnr. + apply wf_universe_subst_instance. +Qed. + Definition global_context_set Σ : ContextSet.t := universes Σ. Lemma global_context_set_sub_ext Σ φ : @@ -1903,8 +1941,8 @@ Section SubstIdentity. Lemma consistent_instance_ext_subst_abs_univ Σ u : wf_ext_wk Σ -> - wf_universe Σ u -> - subst_instance_univ (abstract_instance Σ.2) u = u. + wf_sort Σ u -> + subst_instance_sort (abstract_instance Σ.2) u = u. Proof using Type. intros wf cu. destruct u; simpl; auto. f_equal. @@ -1935,7 +1973,7 @@ Section SubstIdentity. now rewrite [subst_instance_instance _ _](consistent_instance_ext_subst_abs _ _ _ wf cu). Qed. - Lemma wf_universe_type1 Σ : wf_universe Σ Universe.type1. + Lemma wf_sort_type1 Σ : wf_sort Σ Sort.type1. Proof using Type. simpl. intros l hin%LevelExprSet.singleton_spec. @@ -1943,10 +1981,10 @@ Section SubstIdentity. apply global_ext_levels_InSet. Qed. - Lemma wf_universe_super {Σ u} : wf_universe Σ u -> wf_universe Σ (Universe.super u). + Lemma wf_sort_super {Σ u} : wf_sort Σ u -> wf_sort Σ (Sort.super u). Proof using Type. destruct u; cbn. - 1-2:intros _ l hin%LevelExprSet.singleton_spec; subst l; apply wf_universe_type1; + 1-2:intros _ l hin%LevelExprSet.singleton_spec; subst l; apply wf_sort_type1; now apply LevelExprSet.singleton_spec. intros Hl. intros l hin. @@ -2001,7 +2039,7 @@ Section SubstIdentity. - now rewrite consistent_instance_ext_subst_abs_univ. - rewrite consistent_instance_ext_subst_abs_univ //. - now apply wf_universe_super. + now apply wf_sort_super. - rewrite product_subst_instance. do 2 f_equal; tas. now noconf b0. @@ -2056,15 +2094,18 @@ Section SubstIdentity. + destruct a0 as (_ & X & _); tas. + destruct b as (X & _); tas. - eapply nth_error_all in X0 as (_ & X0 & _); tea. - - destruct p as [? []]; cbn => //. do 2 f_equal. + - destruct p as [? []]; cbnr. do 2 f_equal. depelim X0. specialize (hty X1); specialize (hdef X1). - unfold mapu_array_model; destruct a; cbn -[Universe.make] in * => //=; f_equal; intuition eauto. - * destruct array_level => //. - rewrite subst_instance_univ_make in b. now injection b. + unfold mapu_array_model; destruct a; cbn -[Universe.make'] in *. + f_equal; intuition eauto. + * rewrite /subst_instance subst_instance_universe_make in b. + now injection b as e. * solve_all. - depelim X0; cbn => //=. depelim X. simp prim_type. cbn. f_equal; intuition eauto. - do 2 f_equal. cbn -[Universe.make] in b. rewrite subst_instance_univ_make in b. - now injection b. + do 2 f_equal. + cbn -[Universe.make'] in b. + rewrite /subst_instance subst_instance_universe_make in b. + now injection b as e. Qed. Lemma typed_subst_abstract_instance Σ Γ t T : diff --git a/pcuic/theories/Conversion/PCUICWeakeningConfigConv.v b/pcuic/theories/Conversion/PCUICWeakeningConfigConv.v index a3a9c9e6b..8dadbaf65 100644 --- a/pcuic/theories/Conversion/PCUICWeakeningConfigConv.v +++ b/pcuic/theories/Conversion/PCUICWeakeningConfigConv.v @@ -12,24 +12,21 @@ Require Import ssreflect. Set Default Goal Selector "!". Implicit Types (cf : checker_flags). -Lemma compare_term_config_impl {cf1 cf2} pb Σ φ t t' +Lemma compare_term_config_impl {cf1 cf2} Σ φ pb t t' : config.impl cf1 cf2 - -> @compare_term cf1 pb Σ φ t t' -> @compare_term cf2 pb Σ φ t t'. + -> @compare_term cf1 Σ φ pb t t' -> @compare_term cf2 Σ φ pb t t'. Proof. intro H. apply eq_term_upto_univ_impl; auto. - all: repeat change (@eq_universe ?cf) with (@compare_universe cf Conv). - all: repeat change (@leq_universe ?cf) with (@compare_universe cf Cumul). - 3: destruct pb. - 4: transitivity (@compare_universe cf1 Cumul φ); tc. - all: intros ??; now eapply cmp_universe_config_impl. + 1,2: intros ??; now eapply cmp_universe_config_impl. + 1,2: intros ??; now eapply cmp_sort_config_impl. Qed. Lemma eq_term_config_impl {cf1 cf2} Σ φ t t' - : config.impl cf1 cf2 -> @compare_term cf1 Conv Σ φ t t' -> @compare_term cf2 Conv Σ φ t t'. + : config.impl cf1 cf2 -> @compare_term cf1 Σ φ Conv t t' -> @compare_term cf2 Σ φ Conv t t'. Proof. eapply compare_term_config_impl with (pb := Conv). Qed. Lemma leq_term_config_impl {cf1 cf2} Σ ctrs t u - : config.impl cf1 cf2 -> @compare_term cf1 Cumul Σ ctrs t u -> @compare_term cf2 Cumul Σ ctrs t u. + : config.impl cf1 cf2 -> @compare_term cf1 Σ ctrs Cumul t u -> @compare_term cf2 Σ ctrs Cumul t u. Proof. apply compare_term_config_impl with (pb := Cumul). Qed. Lemma compare_decl_config_impl {cf1 cf2} pb Σ φ d d' @@ -46,61 +43,6 @@ Proof. intros Hcf. induction 1; constructor; auto; eapply (@compare_decl_config_impl cf1 cf2); eassumption. Qed. -(* TODO: Factor with PCUICWeakeningEnvConv.R_global_instance_weaken_env *) -Lemma R_global_instance_weaken_subrel Σ Re Re' Rle Rle' gr napp : - RelationClasses.subrelation Re Re' -> - RelationClasses.subrelation Rle Rle' -> - RelationClasses.subrelation Re Rle' -> - subrelation (R_global_instance Σ Re Rle gr napp) (R_global_instance Σ Re' Rle' gr napp). -Proof. - intros he hle hele t t'. - rewrite /R_global_instance_gen /R_opt_variance. - destruct global_variance_gen as [v|] eqn:look. - - induction t in v, t' |- *; destruct v, t'; simpl; auto. - intros []; split; auto. - destruct t0; simpl; auto. - - eauto using R_universe_instance_impl'. -Qed. - -(* TODO: Factor with PCUICWeakeningEnvConv.eq_term_upto_univ_weaken_env *) -#[global] -Instance eq_term_upto_univ_weaken_subrel Σ Re Re' Rle Rle' napp : - RelationClasses.subrelation Re Re' -> - RelationClasses.subrelation Rle Rle' -> - RelationClasses.subrelation Re Rle' -> - CRelationClasses.subrelation (eq_term_upto_univ_napp Σ Re Rle napp) - (eq_term_upto_univ_napp Σ Re' Rle' napp). -Proof. - intros he hele hle t t'. - induction t in napp, t', Rle, Rle', hle, hele |- * using PCUICInduction.term_forall_list_ind; - try (inversion 1; subst; constructor; - eauto using R_universe_instance_impl'; fail). - - inversion 1; subst; constructor. - eapply All2_impl'; tea. - eapply All_impl; eauto. - - inversion 1; subst; constructor. - eapply R_global_instance_weaken_subrel; [ .. | eassumption ]. all:eauto. - - inversion 1; subst; constructor. - eapply R_global_instance_weaken_subrel; [ .. | eassumption ]. all:eauto. - - inversion 1; subst; destruct X as [? [? ?]]; constructor; eauto. - * destruct X2 as [? [? ?]]. - constructor; intuition auto; solve_all. - + eauto using R_universe_instance_impl'. - * eapply All2_impl'; tea. - eapply All_impl; eauto. - cbn. intros x [? ?] y [? ?]. split; eauto. - - inversion 1; subst; constructor. - eapply All2_impl'; tea. - eapply All_impl; eauto. - cbn. intros x [? ?] y [[[? ?] ?] ?]. repeat split; eauto. - - inversion 1; subst; constructor. - eapply All2_impl'; tea. - eapply All_impl; eauto. - cbn. intros x [? ?] y [[[? ?] ?] ?]. repeat split; eauto. - - intros h; depelim h; constructor; cbn in X; intuition eauto. - depelim o; cbn in X; constructor; intuition eauto. solve_all. -Qed. - Lemma weakening_config_cumul_gen {cf1 cf2} pb Σ Γ M N : config.impl cf1 cf2 -> @cumulAlgo_gen cf1 Σ Γ pb M N -> @@ -137,33 +79,25 @@ Proof. - eapply cumul_Evar. solve_all. - eapply cumul_Case. * cbv [cumul_predicate] in *; destruct_head'_prod. repeat split; tas. - + eapply R_universe_instance_impl'; - [ hnf; intros * ?; eapply (@cmp_universe_config_impl cf1 cf2) | ]; - eassumption. - * solve_all. - * solve_all. - - eapply cumul_Fix. solve_all. - - eapply cumul_CoFix; solve_all. + eapply cmp_universe_instance_impl'; + [ hnf; intros * ?; eapply (@cmp_universe_config_impl cf1 cf2) | ]; + eassumption. + * assumption. + * unfold cumul_branches, cumul_branch in *. solve_all. + - eapply cumul_Fix. unfold cumul_mfixpoint in *. solve_all. + - eapply cumul_CoFix. unfold cumul_mfixpoint in *. solve_all. - eapply cumul_Prim; solve_all. destruct X; constructor; eauto. * now eapply (@cmp_universe_config_impl cf1 cf2). * solve_all. - eapply cumul_Ind; eauto. 2:solve_all. - eapply @R_global_instance_weaken_subrel; [ .. | eassumption ]. - all: repeat change (@eq_universe ?cf) with (@compare_universe cf Conv). - all: repeat change (@leq_universe ?cf) with (@compare_universe cf Cumul). - 3: destruct pb. - all: try (hnf; intros *; eapply (@cmp_universe_config_impl cf1 cf2); eassumption). - all: now etransitivity; [ | hnf; intros *; eapply (@cmp_universe_config_impl cf1 cf2); eassumption ]; tc. + eapply @cmp_global_instance_impl; [ .. | eassumption ]. + 3: auto with arith. all: intros ??; now apply (@cmp_universe_config_impl cf1 cf2). - eapply cumul_Construct; eauto. 2:solve_all. - eapply @R_global_instance_weaken_subrel; [ .. | eassumption ]. - all: repeat change (@eq_universe ?cf) with (@compare_universe cf Conv). - all: repeat change (@leq_universe ?cf) with (@compare_universe cf Cumul). - 3: destruct pb. - all: try (hnf; intros *; eapply (@cmp_universe_config_impl cf1 cf2); eassumption). - all: now etransitivity; [ | hnf; intros *; eapply (@cmp_universe_config_impl cf1 cf2); eassumption ]; tc. - - eapply cumul_Sort. eapply (@cmp_universe_config_impl cf1 cf2); eassumption. - - eapply cumul_Const. eapply R_universe_instance_impl'; eauto; tc. + eapply @cmp_global_instance_impl; [ .. | eassumption ]. + 3: auto with arith. all: intros ??; now apply (@cmp_universe_config_impl cf1 cf2). + - eapply cumul_Sort. eapply (@cmp_sort_config_impl cf1 cf2); eassumption. + - eapply cumul_Const. eapply cmp_universe_instance_impl'; eauto; tc. hnf; intros *; eapply (@cmp_universe_config_impl cf1 cf2); eassumption. Defined. diff --git a/pcuic/theories/Conversion/PCUICWeakeningEnvConv.v b/pcuic/theories/Conversion/PCUICWeakeningEnvConv.v index e9de6488c..335ef405c 100644 --- a/pcuic/theories/Conversion/PCUICWeakeningEnvConv.v +++ b/pcuic/theories/Conversion/PCUICWeakeningEnvConv.v @@ -14,15 +14,11 @@ Implicit Types (cf : checker_flags). Lemma compare_term_subset {cf} pb Σ φ φ' t t' : ConstraintSet.Subset φ φ' - -> compare_term pb Σ φ t t' -> compare_term pb Σ φ' t t'. + -> compare_term Σ φ pb t t' -> compare_term Σ φ' pb t t'. Proof. intro H. apply eq_term_upto_univ_impl; auto. - all: change eq_universe with (compare_universe Conv). - all: change leq_universe with (compare_universe Cumul). - 3: destruct pb. - 4: transitivity (compare_universe Cumul φ). - 4: tc. - all: intros ??; now eapply cmp_universe_subset. + 1,2: intros ??; now eapply cmp_universe_subset. + 1,2: intros ??; now eapply cmp_sort_subset. Qed. Lemma eq_term_subset {cf} Σ φ φ' t t' @@ -35,14 +31,14 @@ Proof. apply compare_term_subset with (pb := Cumul). Qed. Lemma compare_decl_subset {cf} pb Σ φ φ' d d' : ConstraintSet.Subset φ φ' - -> compare_decl pb Σ φ d d' -> compare_decl pb Σ φ' d d'. + -> compare_decl Σ φ pb d d' -> compare_decl Σ φ' pb d d'. Proof. intros Hφ []; constructor; eauto using compare_term_subset. Qed. Lemma compare_context_subset {cf} pb Σ φ φ' Γ Γ' : ConstraintSet.Subset φ φ' - -> compare_context pb Σ φ Γ Γ' -> compare_context pb Σ φ' Γ Γ'. + -> compare_context Σ φ pb Γ Γ' -> compare_context Σ φ' pb Γ Γ'. Proof. intros Hφ. induction 1; constructor; auto; eapply compare_decl_subset; eassumption. Qed. @@ -54,77 +50,85 @@ Section ExtendsWf. Let wf := on_global_env Pcmp P. -Lemma global_variance_sigma_mon {Σ Σ' gr napp v} : +Lemma global_variance_sigma_mon {Σ Σ'} gr napp : wf Σ' -> extends Σ Σ' -> - global_variance Σ gr napp = Some v -> - global_variance Σ' gr napp = Some v. + match global_variance Σ gr napp with + | Variance v => global_variance Σ' gr napp = Variance v + | AllEqual => True + | AllIrrelevant => global_variance Σ' gr napp = AllIrrelevant + end. Proof using P Pcmp cf. intros wfΣ' ext. rewrite /global_variance_gen /lookup_constructor /lookup_constructor_gen /lookup_inductive /lookup_inductive_gen /lookup_minductive /lookup_minductive_gen. - destruct gr as [|ind|[ind i]|] => /= //. + destruct gr as [|ind|[ind i]|] => //=. - destruct (lookup_env Σ ind) eqn:look => //. eapply extends_lookup in look; eauto. rewrite look //. + destruct g => //=; destruct nth_error => //=. + destruct destArity as [[ctx s]|] => //=. + destruct Nat.leb => //=. + destruct ind_variance => //=. - destruct (lookup_env Σ (inductive_mind i)) eqn:look => //. eapply extends_lookup in look; eauto. rewrite look //. + destruct g => //=; destruct nth_error => //=; destruct nth_error => //=. + destruct Nat.leb => //=. Qed. -(** The definition of [R_global_instance] is defined so that it is weakenable. *) -Lemma R_global_instance_weaken_env Σ Σ' Re Re' Rle Rle' gr napp : +(** The definition of [cmp_global_instance] is defined so that it is weakenable. *) +Lemma cmp_global_instance_weaken_env Σ Σ' cmp_universe cmp_universe' pb pb' gr napp : wf Σ' -> extends Σ Σ' -> - RelationClasses.subrelation Re Re' -> - RelationClasses.subrelation Rle Rle' -> - RelationClasses.subrelation Re Rle' -> - subrelation (R_global_instance Σ Re Rle gr napp) (R_global_instance Σ' Re' Rle' gr napp). + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe' Conv) -> + RelationClasses.subrelation (cmp_universe pb) (cmp_universe' pb') -> + subrelation (cmp_global_instance Σ cmp_universe pb gr napp) (cmp_global_instance Σ' cmp_universe' pb' gr napp). Proof using P Pcmp cf. - intros wfΣ ext he hle hele t t'. - rewrite /R_global_instance_gen /R_opt_variance. - destruct global_variance_gen as [v|] eqn:look. - - rewrite (global_variance_sigma_mon wfΣ ext look). - induction t in v, t' |- *; destruct v, t'; simpl; auto. - intros []; split; auto. - destruct t0; simpl; auto. - - destruct (global_variance Σ' gr napp) => //. - * induction t in l, t' |- *; destruct l, t'; simpl; intros H; inv H; auto. - split; auto. destruct t0; simpl; auto. - * eauto using R_universe_instance_impl'. + intros wfΣ ext sub_conv sub_pb t t'. + unfold cmp_global_instance_gen. + move: (global_variance_sigma_mon gr napp wfΣ ext). + destruct global_variance_gen as [| |v] => //. + all: [> intros _ | intros ->; cbn ..]; auto. + 1: intro H; apply: cmp_instance_opt_variance; move: H => /=. + - now apply cmp_universe_instance_impl. + - intros [H | H]; [left | right]. + 1: eapply cmp_universe_instance_impl; tea. + eapply cmp_universe_instance_variance_impl; eassumption. Qed. #[global] -Instance eq_term_upto_univ_weaken_env Σ Σ' Re Re' Rle Rle' napp : +Instance eq_term_upto_univ_weaken_env Σ Σ' cmp_universe cmp_universe' cmp_sort cmp_sort' pb pb' napp : wf Σ' -> extends Σ Σ' -> - RelationClasses.subrelation Re Re' -> - RelationClasses.subrelation Rle Rle' -> - RelationClasses.subrelation Re Rle' -> - CRelationClasses.subrelation (eq_term_upto_univ_napp Σ Re Rle napp) - (eq_term_upto_univ_napp Σ' Re' Rle' napp). + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe' Conv) -> + RelationClasses.subrelation (cmp_universe pb) (cmp_universe' pb') -> + RelationClasses.subrelation (cmp_sort Conv) (cmp_sort' Conv) -> + RelationClasses.subrelation (cmp_sort pb) (cmp_sort' pb') -> + CRelationClasses.subrelation (eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp) + (eq_term_upto_univ_napp Σ' cmp_universe' cmp_sort' pb' napp). Proof using P Pcmp cf. - intros wfΣ ext he hele hle t t'. - induction t in napp, t', Rle, Rle', hle, hele |- * using PCUICInduction.term_forall_list_ind; + intros wfΣ ext univ_sub_conv univ_sub_pb sort_sub_conv sort_sub_pb t t'. + induction t in napp, t', pb, pb', univ_sub_pb, sort_sub_pb, t' |- * using PCUICInduction.term_forall_list_ind; try (inversion 1; subst; constructor; - eauto using R_universe_instance_impl'; fail). + eauto using cmp_universe_instance_impl'; fail). - inversion 1; subst; constructor. eapply All2_impl'; tea. eapply All_impl; eauto. - inversion 1; subst; constructor. - eapply R_global_instance_weaken_env. 6:eauto. all:eauto. + eapply cmp_global_instance_weaken_env. 5:eauto. all:eauto. - inversion 1; subst; constructor. - eapply R_global_instance_weaken_env. 6:eauto. all:eauto. + eapply cmp_global_instance_weaken_env. 5:eauto. all:eauto. - inversion 1; subst; destruct X as [? [? ?]]; constructor; eauto. * destruct X2 as [? [? ?]]. constructor; intuition auto; solve_all. - + eauto using R_universe_instance_impl'. + + eauto using cmp_universe_instance_impl'. * eapply All2_impl'; tea. eapply All_impl; eauto. cbn. intros x [? ?] y [? ?]. split; eauto. - inversion 1; subst; constructor. eapply All2_impl'; tea. eapply All_impl; eauto. - cbn. intros x [? ?] y [[[? ?] ?] ?]. repeat split; eauto. + cbn. intros x [? ?] y (?&?&?&?). repeat split; eauto. - inversion 1; subst; constructor. eapply All2_impl'; tea. eapply All_impl; eauto. - cbn. intros x [? ?] y [[[? ?] ?] ?]. repeat split; eauto. + cbn. intros x [? ?] y (?&?&?&?). repeat split; eauto. - inversion 1; subst; constructor. depelim X1; constructor; cbn in X; intuition eauto. solve_all. Qed. @@ -148,7 +152,7 @@ Proof using P Pcmp. intros wfΣ ext. induction 1; simpl. - econstructor. eapply compare_term_subset. - + now eapply global_ext_constraints_app. + + eapply global_ext_constraints_app. apply ext. + simpl in *. eapply eq_term_upto_univ_weaken_env in c; simpl; eauto. all:typeclasses eauto. - econstructor 2; eauto. eapply weakening_env_red1; eauto. @@ -177,13 +181,7 @@ Lemma weakening_env_cumulSpec0 Σ Σ' φ Γ pb M N : cumulSpec0 (Σ', φ) Γ pb M N. Proof. intros HΣ' Hextends Ind. - pose proof (subrelations_leq_extends _ _ φ Hextends). revert H. - assert (RelationClasses.subrelation - (eq_universe (global_ext_constraints (Σ,φ))) - (leq_universe (global_ext_constraints (Σ',φ)))). - { typeclasses eauto. } revert H. - generalize (leq_universe (global_ext_constraints (Σ',φ))); intros Rle Hlee Hle . - revert pb Γ M N Ind Σ' Rle Hle Hlee HΣ' Hextends. + revert pb Γ M N Ind Σ' HΣ' Hextends. induction 1. all:intros; try solve [econstructor; eauto with extends; intuition auto]. all: lazymatch goal with @@ -192,24 +190,24 @@ Proof. end. - eapply cumul_Evar. solve_all. - eapply cumul_Case. - * cbv [cumul_predicate] in *; destruct_head'_prod. repeat split; tas. + * cbv [cumul_predicate] in *; destruct_head'_prod. clear c0. repeat split; tas. + solve_all. - + eapply R_universe_instance_impl'; try apply subrelations_extends; eassumption. + + eapply cmp_universe_instance_impl'; tea. tc. + eauto. - * solve_all. - * solve_all. - - eapply cumul_Fix; solve_all. - - eapply cumul_CoFix; solve_all. + * eauto. + * unfold cumul_branches, cumul_branch in *. solve_all. + - eapply cumul_Fix; unfold cumul_mfixpoint in *; solve_all. + - eapply cumul_CoFix; unfold cumul_mfixpoint in *; solve_all. - eapply cumul_Prim; solve_all. destruct X; constructor; eauto. - * unfold compare_universe. eapply subrel_extends_eq; tea. + * eapply subrel_extends_cmp_universe; tea. * solve_all. - eapply cumul_Ind; eauto. 2:solve_all. - eapply @R_global_instance_weaken_env. 1,2,6:eauto. all: tc. + eapply @cmp_global_instance_weaken_env. 1,2,5:eauto. all: tc. - eapply cumul_Construct; eauto. 2:solve_all. - eapply @R_global_instance_weaken_env. 1,2,6:eauto. all: tc. + eapply @cmp_global_instance_weaken_env. 1,2,5:eauto. all: tc. - eapply cumul_Sort. eapply subrelations_compare_extends; tea. - - eapply cumul_Const. eapply R_universe_instance_impl'; eauto; tc. + - eapply cumul_Const. eapply cmp_universe_instance_impl'; eauto; tc. Defined. diff --git a/pcuic/theories/PCUICAlpha.v b/pcuic/theories/PCUICAlpha.v index 8a58d572d..6a8a6efd0 100644 --- a/pcuic/theories/PCUICAlpha.v +++ b/pcuic/theories/PCUICAlpha.v @@ -18,8 +18,8 @@ Implicit Types cf : checker_flags. Notation "`≡α`" := upto_names. Infix "≡α" := upto_names (at level 60). -Notation "`≡Γ`" := (eq_context_upto empty_global_env eq eq). -Infix "≡Γ" := (eq_context_upto empty_global_env eq eq) (at level 20, no associativity). +Notation "`≡Γ`" := (eq_context_upto empty_global_env (fun _ => eq) (fun _ => eq) Conv). +Infix "≡Γ" := (eq_context_upto empty_global_env (fun _ => eq) (fun _ => eq) Conv) (at level 20, no associativity). #[global] Instance upto_names_terms_refl : CRelationClasses.Reflexive (All2 `≡α`). @@ -27,11 +27,11 @@ Proof. intro; apply All2_refl; reflexivity. Qed. Lemma eq_context_upto_empty_impl {cf} {Σ : global_env_ext} ctx ctx' : ctx ≡Γ ctx' -> - eq_context_upto Σ (eq_universe Σ) (eq_universe Σ) ctx ctx'. + eq_context Σ Σ ctx ctx'. Proof. intros; eapply All2_fold_impl; tea. intros ???? []; constructor; subst; auto; - eapply eq_term_upto_univ_empty_impl; tea; tc. + eapply upto_names_impl; tea; tc. Qed. Section Alpha. @@ -71,13 +71,13 @@ Section Alpha. eauto using nth_error_Some_length. Qed. - Lemma decompose_app_upto {Σ Re Rle x y hd tl} : - eq_term_upto_univ Σ Re Rle x y -> + Lemma decompose_app_upto {Σ cmp_universe cmp_sort pb x y hd tl} : + eq_term_upto_univ Σ cmp_universe cmp_sort pb x y -> decompose_app x = (hd, tl) -> - ∑ hd' tl', (y = mkApps hd' tl') * - eq_term_upto_univ_napp Σ Re Rle #|tl| hd hd' * - negb (isApp hd') * - All2 (eq_term_upto_univ Σ Re Re) tl tl'. + ∑ hd' tl', y = mkApps hd' tl' × + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb #|tl| hd hd' × + negb (isApp hd') × + All2 (eq_term_upto_univ Σ cmp_universe cmp_sort Conv) tl tl'. Proof using Type. intros eq dapp. pose proof (decompose_app_notApp _ _ _ dapp). @@ -111,9 +111,9 @@ Section Alpha. destruct t; congruence. Qed. - Lemma upto_names_destInd Re Rle t u : - eq_term_upto_univ empty_global_env Re Rle t u -> - rel_option (fun '(ind, u) '(ind', u') => (ind = ind') * R_universe_instance Re u u')%type (destInd t) (destInd u). + Lemma upto_names_destInd cmp_universe cmp_sort pb napp t u : + eq_term_upto_univ_napp empty_global_env cmp_universe cmp_sort pb napp t u -> + rel_option (fun '(ind, u) '(ind', u') => (ind = ind') * cmp_universe_instance (cmp_universe Conv) u u')%type (destInd t) (destInd u). Proof using Type. induction 1; simpl; constructor; try congruence. split; auto. @@ -137,20 +137,17 @@ Section Alpha. destruct X0 as [eqctx eqt]. apply (eq_context_upto_smash_context empty_global_env [] []) in eqctx; try constructor. apply eq_context_upto_rev' in eqctx. - eapply (eq_context_upto_nth_error empty_global_env _ _ _ _ rarg) in eqctx. + eapply (eq_context_upto_nth_error empty_global_env _ _ _ _ _ rarg) in eqctx. subst rarg'. destruct (nth_error (List.rev (smash_context [] c)) rarg). - inv eqctx. destruct X0. + all: inv eqctx => //. destruct X0. destruct (decompose_app) eqn:eqdec. - destruct (decompose_app_upto e eqdec) as [hd' [tl' [[[eq eqhd] napp] eqtl]]]. + destruct (decompose_app_upto e eqdec) as (hd' & tl' & eq & eqhd & napp & eqtl). rewrite eq. rewrite decompose_app_mkApps; auto. - eapply (eq_term_upto_univ_empty_impl _ Logic.eq Logic.eq Logic.eq Logic.eq #|l0| 0) in eqhd. - all:try typeclasses eauto. apply upto_names_destInd in eqhd. inv eqhd; auto. destruct a as [ind u], b0 as [ind' u']; simpl in *; auto. destruct X0 as [-> _]; auto. - now inv eqctx. Qed. Lemma upto_names_check_cofix mfix mfix' : @@ -169,10 +166,8 @@ Section Alpha. do 2 destruct decompose_prod_assum. destruct X as [_ eqt]. destruct (decompose_app) eqn:eqdec. - destruct (decompose_app_upto eqt eqdec) as [hd' [tl' [[[eq eqhd] napp] eqtl]]]. + destruct (decompose_app_upto eqt eqdec) as (hd' & tl' & eq & eqhd & napp & eqtl). rewrite eq. rewrite decompose_app_mkApps; auto. - eapply (eq_term_upto_univ_empty_impl _ Logic.eq Logic.eq Logic.eq Logic.eq #|l0| 0) in eqhd. - all:try typeclasses eauto. apply upto_names_destInd in eqhd. inv eqhd; auto. destruct a as [ind u], b as [ind' u']; simpl in *; auto. @@ -231,7 +226,7 @@ Section Alpha. Lemma All_decls_alpha_pb_ws_decl {le P} {Γ : context} {d d'} : (forall le t t', is_open_term Γ t -> is_open_term Γ t' -> upto_names' t t' -> P le t t') -> - compare_decls upto_names' upto_names' d d' -> + compare_decls (fun pb => eq_term_upto_univ empty_global_env (fun _ => eq) (fun _ => eq) pb) Conv d d' -> ws_decl Γ d -> ws_decl Γ d' -> All_decls_alpha_pb le P d d'. @@ -275,82 +270,36 @@ Section Alpha. Qed. - Lemma eq_context_upto_map2_set_binder_name Σ pctx pctx' Γ Δ : - pctx ≡Γ pctx' -> - eq_context_upto Σ eq eq Γ Δ -> - eq_context_upto Σ eq eq - (map2 set_binder_name (forget_types pctx) Γ) - (map2 set_binder_name (forget_types pctx') Δ). - Proof using Type. - intros eqp. - induction 1 in pctx, pctx', eqp |- *. - - induction eqp; cbn; constructor. - - depelim eqp. simpl. constructor. - simpl. constructor; auto. - destruct c, p; constructor; auto. - Qed. - - Lemma eq_context_upto_lift_context Σ Re Rle : - RelationClasses.subrelation Re Rle -> - forall u v n k, - eq_context_upto Σ Re Rle u v -> - eq_context_upto Σ Re Rle (lift_context n k u) (lift_context n k v). - Proof using Type. - intros re u v n k. - induction 1. - - constructor. - - rewrite !lift_context_snoc; constructor; eauto. - depelim p; constructor; simpl; intuition auto; - rewrite -(length_of X); - apply eq_term_upto_univ_lift; auto. - Qed. - Lemma eq_context_upto_subst_instance Σ : - forall u v i, + forall pb u v i, valid_constraints (global_ext_constraints Σ) (subst_instance_cstrs i Σ) -> - eq_context_upto Σ eq eq u v -> - eq_context_upto Σ eq eq (subst_instance i u) (subst_instance i v). + eq_context_upto Σ (fun _ => eq) (fun _ => eq) pb u v -> + eq_context_upto Σ (fun _ => eq) (fun _ => eq) pb (subst_instance i u) (subst_instance i v). Proof using Type. - intros u v i vc. - induction 1. - - constructor. - - rewrite !PCUICUnivSubst.subst_instance_cons. constructor; eauto. - depelim p; constructor; simpl; intuition auto. - eapply (PCUICUnivSubstitutionConv.eq_term_upto_univ_subst_preserved Σ (fun _ => eq) (fun _ => eq)). - intros x y u v ? ? ->; reflexivity. - intros x y u v ? ? ->; reflexivity. exact vc. - assumption. - eapply (PCUICUnivSubstitutionConv.eq_term_upto_univ_subst_preserved Σ (fun _ => eq) (fun _ => eq)). - intros x y u v ? ? ->; reflexivity. - intros x y u v ? ? ->; reflexivity. exact vc. - assumption. - eapply (PCUICUnivSubstitutionConv.eq_term_upto_univ_subst_preserved Σ (fun _ => eq) (fun _ => eq)). - intros x y u v ? ? ->; reflexivity. - intros x y u v ? ? ->; reflexivity. exact vc. - assumption. + intros pb u v i vc. + eapply PCUICUnivSubstitutionConv.eq_context_upto_subst_preserved with (cmp_universe := fun _ _ => eq) (cmp_sort := fun _ _ => eq). + 5: eassumption. + all: intros ??????[]; reflexivity. Qed. - Lemma eq_context_gen_upto ctx ctx' : - eq_context_gen eq eq ctx ctx' -> - eq_context_upto empty_global_env eq eq ctx ctx'. + Lemma eq_context_upto_names_eq_context_alpha ctx ctx' : + eq_context_upto_names ctx ctx' -> + ctx ≡Γ ctx'. Proof using Type. - intros a; eapply All2_fold_impl; tea. - intros. destruct X; subst; constructor; auto; try reflexivity. + apply eq_context_upto_names_eq_context_upto; tc. Qed. Lemma case_predicate_context_equiv {ind mdecl idecl p p'} : eq_predicate upto_names' eq p p' -> - eq_context_upto empty_global_env eq eq - (case_predicate_context ind mdecl idecl p) - (case_predicate_context ind mdecl idecl p'). + case_predicate_context ind mdecl idecl p ≡Γ case_predicate_context ind mdecl idecl p'. Proof using Type. intros [eqpars [eqinst [eqctx eqret]]]. rewrite /case_predicate_context /case_predicate_context_gen. - apply eq_context_upto_map2_set_binder_name => //. - now eapply eq_context_gen_upto. + eapply eq_context_gen_map2_set_binder_name => //. + now eapply eq_context_upto_names_eq_context_alpha. rewrite /pre_case_predicate_context_gen. - eapply R_universe_instance_eq in eqinst. rewrite -eqinst. + eapply cmp_universe_instance_eq in eqinst. rewrite -eqinst. apply eq_context_upto_subst_context; tea; tc. reflexivity. now apply All2_rev. @@ -363,9 +312,9 @@ Section Alpha. (case_branch_context ind mdecl p' (forget_types bctx') cdecl). Proof using Type. intros [eqpars [eqinst [eqctx eqret]]] eqctx'. - eapply R_universe_instance_eq in eqinst. + eapply cmp_universe_instance_eq in eqinst. rewrite /case_branch_context /case_branch_context_gen -eqinst. - apply eq_context_upto_map2_set_binder_name => //. + eapply eq_context_gen_map2_set_binder_name => //; tea. rewrite /pre_case_branch_context_gen. apply eq_context_upto_subst_context; tea; tc. reflexivity. @@ -383,7 +332,7 @@ Section Alpha. (case_branch_type ind mdecl idecl p' br' ptm' c cdecl).2. Proof using Type. intros [eqpars [eqinst [eqctx eqret]]] eqctx'. - eapply R_universe_instance_eq in eqinst. + eapply cmp_universe_instance_eq in eqinst. intros ptm ptm'. rewrite /case_branch_type /case_branch_type_gen -eqinst. cbn. eapply eq_term_mkApps. @@ -395,53 +344,40 @@ Section Alpha. - eapply All2_app. * eapply All2_map, All2_refl. intros. - eapply eq_term_upto_univ_empty_impl; tea; tc. - eapply eq_term_upto_univ_substs. tc. + eapply eq_term_upto_univ_empty_impl; cycle -1. + eapply eq_term_upto_univ_substs; tc. reflexivity. now eapply All2_rev. + all: tc. * constructor. 2:constructor. - eapply eq_term_upto_univ_empty_impl; tea; tc. - eapply eq_term_upto_univ_mkApps. len. - reflexivity. + eapply eq_term_upto_univ_empty_impl with (pb := Conv); cycle -1. + eapply eq_term_upto_univ_mkApps; cycle -1. eapply All2_app. - + eapply All2_map. eapply (All2_impl eqpars). - intros. now eapply eq_term_upto_univ_lift. - + eapply All2_refl. reflexivity. - Qed. + eapply All2_map. eapply (All2_impl eqpars). + intros. now eapply eq_term_upto_univ_lift. - Lemma eq_binder_annots_eq_context_gen_ctx {Δ : context} {nas} : - All2 (fun x y => eq_binder_annot x y.(decl_name)) nas Δ -> - eq_context_gen eq eq (map2 set_binder_name nas Δ) Δ. - Proof using Type. - induction Δ in nas |- * using PCUICInduction.ctx_length_rev_ind; simpl; intros hlen. - - depelim hlen. simpl. reflexivity. - - destruct nas as [|nas na] using rev_case => //; - pose proof (All2_length hlen) as hlen';len in hlen'; simpl in hlen'; try lia. - eapply All2_app_inv_l in hlen as (l1'&l2'&heq&alnas&allna). - depelim allna. depelim allna. - rewrite map2_app => /= //; try lia. unfold aname. lia. - eapply app_inj_tail in heq as [<- <-]. - simpl. eapply All2_fold_app; auto. - constructor. constructor. - destruct d as [na' [d|] ty]; constructor; cbn in *; auto; - try reflexivity. + eapply All2_refl. reflexivity. + + len. reflexivity. + + all: tc. Qed. Import PCUICUnivSubstitutionConv PCUICUnivSubstitutionTyp. Lemma inst_case_predicate_context_eq {Σ : global_env_ext} {wfΣ : wf Σ} {ind mdecl idecl p} : wf_predicate mdecl idecl p -> - eq_context_gen eq eq (ind_predicate_context ind mdecl idecl) (pcontext p) -> - eq_context_gen eq eq (case_predicate_context ind mdecl idecl p) (inst_case_predicate_context p). + eq_context_upto_names (ind_predicate_context ind mdecl idecl) (pcontext p) -> + eq_context_upto_names (case_predicate_context ind mdecl idecl p) (inst_case_predicate_context p). Proof using Type. intros wfp eq. rewrite /case_predicate_context /case_predicate_context_gen. epose proof (wf_pre_case_predicate_context_gen wfp). etransitivity. - now apply eq_binder_annots_eq_context_gen_ctx. + now apply eq_binder_annots_eq_ctx. rewrite /pre_case_predicate_context_gen /inst_case_predicate_context. rewrite /inst_case_context. - eapply eq_context_gen_subst_context. - now eapply eq_context_gen_eq_univ_subst_preserved. + eapply eq_context_upto_names_subst_context. + now eapply eq_context_upto_names_univ_subst_preserved. Qed. Lemma ctx_inst_eq_context {P Q Γ Γ' s Δ}: @@ -455,19 +391,17 @@ Section Alpha. Lemma wf_local_eq_context_upto_names {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Δ Δ'} : wf_local Σ (Γ,,, Δ) -> - eq_context_gen eq eq Δ' Δ -> + eq_context_upto_names Δ' Δ -> wf_local Σ (Γ ,,, Δ'). Proof using Type. intros a eq. - eapply All2_fold_All2 in eq. induction eq; depelim a; cbn; try solve [constructor; auto]; depelim r; subst; constructor; auto. all: apply lift_typing_impl with (1 := l) => ?? Hs. all: eapply (closed_context_cumulativity _ (pb:=Conv)); tea; [apply IHeq; pcuic|]. all: eapply ws_cumul_ctx_pb_rel_app. all: eapply eq_context_upto_conv_context_rel; fvs. - all: eapply eq_context_gen_upto. - all: now eapply All2_fold_All2 in eq. + all: now eapply eq_context_upto_names_eq_context_alpha. Qed. Lemma case_branch_type_eq_context_gen_1 {ind mdecl idecl cdecl p n br} {ctx ctx' ret} : @@ -492,7 +426,7 @@ Section Alpha. len. eapply eq_term_upto_univ_lift. eapply eq_term_upto_univ_impl; revgoals. eapply eq_term_upto_univ_it_mkLambda_or_LetIn; tea. - 2:reflexivity. 2:lia. all:tc. + reflexivity. lia. all:tc. Qed. Lemma eq_context_conversion {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Δ} {t T} : @@ -513,7 +447,9 @@ Section Alpha. Lemma upto_names_conv_context (Σ : global_env_ext) Γ Δ : Γ ≡Γ Δ -> conv_context cumulAlgo_gen Σ Γ Δ. Proof using Type. - eapply eq_context_upto_empty_conv_context. + intro H. + apply compare_context_cumul_pb_context. + now eapply eq_context_upto_empty_impl. Qed. Lemma isType_eq_context_conversion {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Δ} {T} : @@ -549,14 +485,14 @@ Section Alpha. Lemma typing_alpha_prop : env_prop (fun Σ Γ u A => forall Δ v, - eq_term_upto_univ empty_global_env eq eq u v -> + u ≡α v -> Γ ≡Γ Δ -> Σ ;;; Δ |- v : A) (fun Σ Γ j => forall Δ, Γ ≡Γ Δ -> lift_typing0 (fun t T => - forall u, eq_term_upto_univ empty_global_env eq eq t u -> + forall u, t ≡α u -> Σ ;;; Δ |- u : T) j) (fun Σ Γ => forall Δ, Γ ≡Γ Δ -> wf_local Σ Δ). Proof using Type*. @@ -577,7 +513,7 @@ Section Alpha. assert (isType Σ Γ (lift0 (S n) (decl_type decl))). { eapply validity. econstructor; eauto. } specialize (ih _ eqctx). - epose proof (eq_context_upto_nth_error _ _ _ _ _ _ eqctx). + epose proof (eq_context_upto_nth_error _ _ _ _ _ _ _ eqctx). erewrite hnth in X0. depelim X0. eapply type_Cumul. eapply type_Rel ; tea. @@ -598,7 +534,7 @@ Section Alpha. eapply lift_sorting_forget_univ. eapply lift_judgment_alpha with (1 := ihA _ eqctx) => //. * constructor. - -- now eapply eq_context_upto_empty_conv_context. + -- now eapply upto_names_conv_context. -- constructor. assumption. constructor. eapply upto_names_impl_eq_term. assumption. - intros na A t B ih hA ihA hB ihB Δ v e eqctx; invs e. @@ -655,13 +591,13 @@ Section Alpha. eapply upto_names_impl_eq_term. eapply eq_term_upto_univ_subst ; now auto. - intros cst u decl ? ? hdecl hcons Δ v e e'; invs e. - eapply R_universe_instance_eq in H2. subst. + eapply cmp_universe_instance_eq in H2. subst. constructor; eauto. - intros ind u mdecl idecl isdecl ? ? hcons Δ v e e'; invs e. - eapply R_universe_instance_eq in H2. subst. + eapply cmp_universe_instance_eq in H2. subst. econstructor ; eauto. - intros ind i u mdecl idecl cdecl isdecl ? ? ? Δ v e e'; invs e. - eapply R_universe_instance_eq in H4. subst. + eapply cmp_universe_instance_eq in H4. subst. econstructor ; eauto. - intros ind p c brs args ps mdecl idecl isdecl X X0 H Hpctx cpc wfp cup wfpctx Hret IHret @@ -675,7 +611,7 @@ Section Alpha. { destruct wfp. split; auto. { now rewrite <-(All2_length eqpars). } eapply Forall2_All2 in H1. eapply All2_Forall2. - eapply All2_fold_All2 in eqctx. eapply All2_sym in eqctx. + eapply All2_sym in eqctx. eapply (All2_trans' (@eq_binder_annot name name)); tea. 2:{ eapply All2_map; tea. eapply All2_impl; tea. simpl; intros. destruct X1; simpl; now symmetry. } @@ -683,7 +619,7 @@ Section Alpha. have wfcpc' := wfcpc (Δ ,,, case_predicate_context ind mdecl idecl p'). forward wfcpc'. { eapply eq_context_upto_cat; auto. apply (case_predicate_context_equiv eqp). } - eapply R_universe_instance_eq in eqinst. + eapply cmp_universe_instance_eq in eqinst. assert (isType Σ Δ (mkApps ptm (args ++ [c]))). { eapply isType_eq_context_conversion. eapply validity. econstructor; eauto. constructor; eauto. constructor; eauto. @@ -692,13 +628,12 @@ Section Alpha. + have cu' : consistent_instance_ext Σ (ind_universes mdecl) (puinst p'). { now rewrite -eqinst. } have convctx' : eq_context_upto_names (pcontext p') (ind_predicate_context ind mdecl idecl). - { etransitivity; tea. symmetry. now eapply All2_fold_All2 in eqctx. } - assert (eqp' : eq_context_gen eq eq (inst_case_predicate_context p') + { etransitivity; tea. now symmetry. } + assert (eqp' : eq_context_upto_names (inst_case_predicate_context p') (case_predicate_context ind mdecl idecl p')). { rewrite /inst_case_predicate_context. rewrite /case_predicate_context /case_predicate_context_gen in wfcpc. - symmetry. apply inst_case_predicate_context_eq; tea. - eapply All2_fold_All2. now symmetry. } + symmetry. apply inst_case_predicate_context_eq; tea. now symmetry. } assert (wf_local Σ (Δ,,, inst_case_predicate_context p')). { eapply wf_local_eq_context_upto_names. exact wfcpc'. assumption. } @@ -728,7 +663,6 @@ Section Alpha. red. do 2 red in wfbr. eapply Forall2_All2 in wfbr. eapply All2_Forall2. eapply All2_map_left. - eapply All2_fold_All2 in eqbrctx. eapply All2_map_left_inv in wfbr. eapply All2_trans'; tea. 2:{ eapply All2_symP; tea. tc. } @@ -772,15 +706,15 @@ Section Alpha. forward a. { eapply eq_context_conversion; tea. eapply eq_context_upto_cat; auto. reflexivity. - eapply eq_context_gen_upto. now symmetry. } + eapply eq_context_upto_names_eq_context_alpha. now symmetry. } do 2 forward a by auto. eapply (All2i_All2_All2i_All2i Hbrs X3 a). intros n cdecl br br' [wfbr [wfbrctx wfbrty]]. destruct wfbrty as (IHbrctx & (Hbbody & IHbbody) & (Hbty & IHbty)). intros [eqbctx eqbodies] [wfbr' wfcpars wfcparsn wfcbctx Hbr'ty]. split; intuition auto. - etransitivity. symmetry. eapply All2_fold_All2. exact eqbctx. assumption. - eapply eq_context_gen_upto in eqbctx. + etransitivity. symmetry. exact eqbctx. assumption. + eapply eq_context_upto_names_eq_context_alpha in eqbctx. assert (cbreq := case_branch_context_equiv (ind:=ind) (mdecl:=mdecl) (cdecl:=cdecl) eqp eqbctx). rewrite case_branch_type_fst. intuition auto. @@ -819,33 +753,30 @@ Section Alpha. - intros mfix n decl types hguard hnth hwf hmfix ihmfix hmfixb ihmfixb wffix Δ v e e'; invs e. eapply All2_nth_error_Some in hnth as hnth' ; eauto. destruct hnth' as [decl' [hnth' hh]]. - destruct hh as [[[ety eqann] ebo] era]. + destruct hh as (ety & eqann & ebo & era). assert (hwf' : wf_local Σ (Γ ,,, fix_context mfix')). { apply PCUICWeakeningTyp.All_mfix_wf; auto. eapply (All2_All_mix_left ihmfix) in X. clear -X. induction X; constructor; simpl; auto. - destruct r as [Hty [[[eqty eqann] eqbod] eqrarg]]. + destruct r as [Hty (eqty & eqann & eqbod & eqrarg)]. eapply lift_judgment_alpha with (1 := Hty _ ltac:(reflexivity)) => //. } assert (convctx : conv_context cumulAlgo_gen Σ (Γ ,,, fix_context mfix) (Γ ,,, fix_context mfix')). { eapply eq_context_upto_univ_conv_context. - eapply (eq_context_impl _ eq). intros x y eqx. subst. reflexivity. - 1-2:typeclasses eauto. + eapply eq_context_upto_cat. 1: reflexivity. + eapply eq_context_upto_empty_impl. change (fix_context mfix) with (fix_context_gen 0 mfix). change (fix_context mfix') with (fix_context_gen 0 mfix'). + generalize 0 at 2 3. + unfold fix_context_gen. + eapply (All2_All_mix_left ihmfix) in X. + clear -X. + induction X; try constructor; simpl; intros n; auto. + destruct r as [Hty (eqty & eqbod & eqrarg & eqann)]. eapply eq_context_upto_cat. - * apply eq_context_upto_refl; typeclasses eauto. - * generalize 0 at 3 4. - unfold fix_context_gen. - eapply (All2_All_mix_left ihmfix) in X. - clear -X. - induction X; try constructor; simpl; intros n; auto. - destruct r as [Hty [[[eqty eqbod] eqrarg] eqann]]. - eapply eq_context_upto_cat. - + constructor; constructor; auto. - eapply eq_term_upto_univ_empty_impl; eauto. - 4:now eapply eq_term_upto_univ_lift. all:tc. - + apply IHX. } + + constructor; constructor; auto. + now eapply eq_term_upto_univ_lift. + + apply IHX. } assert(#|fix_context mfix| = #|fix_context mfix'|). { now rewrite !fix_context_length (All2_length X). } specialize (hwf (Δ ,,, types)) as hwfΔ. @@ -864,10 +795,10 @@ Section Alpha. * eapply (All2_All_mix_left ihmfix) in X. clear -X. induction X; constructor; simpl; auto. - destruct r as [Hty [[[eqty eqann] eqbod] eqrarg]]. + destruct r as [Hty (eqty & eqann & eqbod & eqrarg)]. eapply lift_judgment_alpha with (1 := Hty _ ltac:(reflexivity)) => //. - * solve_all. - specialize (b2 (Γ ,,, types)) as IHb. + * unfold eq_mfixpoint in *. solve_all. + specialize (b1 (Γ ,,, types)) as IHb. forward IHb by eapply eq_context_upto_cat; reflexivity. eapply @lift_judgment_alpha with (tm' := Some _) in IHb; tea. 1: apply lift_typing_impl with (1 := IHb) => t T HT. @@ -877,12 +808,12 @@ Section Alpha. unfold wf_fixpoint, wf_fixpoint_gen. move/andP => [] hm ho. apply/andP; split. - { solve_all. move: b3 b. + { unfold eq_mfixpoint in *. solve_all. move: b0 a4. generalize (dbody x) (dbody y). clear=> t t' isL eq. destruct t => //. now depelim eq. } move: ho; enough (map check_one_fix mfix = map check_one_fix mfix') as ->; auto. - apply upto_names_check_fix. solve_all. + apply upto_names_check_fix. unfold eq_mfixpoint in *. solve_all. + eapply All_nth_error in hmfix; tea. + apply eq_term_upto_univ_cumulSpec, eq_term_leq_term, upto_names_impl_eq_term. now symmetry. @@ -890,32 +821,29 @@ Section Alpha. - intros mfix n decl types hguard hnth hwf hmfix ihmfix hmfixb ihmfixb wffix Δ v e e'; invs e. eapply All2_nth_error_Some in hnth as hnth' ; eauto. destruct hnth' as [decl' [hnth' hh]]. - destruct hh as [[[ety eqann] ebo] era]. + destruct hh as (ety & eqann & ebo & era). assert (hwf' : wf_local Σ (Γ ,,, fix_context mfix')). { apply PCUICWeakeningTyp.All_mfix_wf; auto. eapply (All2_All_mix_left ihmfix) in X. clear -X. induction X; constructor; simpl; auto. - destruct r as [Hty [[[eqty eqann] eqbod] eqrarg]]. + destruct r as [Hty (eqty & eqann & eqbod & eqrarg)]. eapply lift_judgment_alpha with (1 := Hty _ ltac:(reflexivity)) => //. } assert (convctx : conv_context cumulAlgo_gen Σ (Γ ,,, fix_context mfix) (Γ ,,, fix_context mfix')). { eapply eq_context_upto_univ_conv_context. - eapply (eq_context_impl _ eq). intros x y eqx. subst. reflexivity. - 1-2:typeclasses eauto. - change (fix_context mfix) with (fix_context_gen 0 mfix). - change (fix_context mfix') with (fix_context_gen 0 mfix'). - eapply eq_context_upto_cat. - * apply eq_context_upto_refl; typeclasses eauto. - * generalize 0 at 3 4. + eapply eq_context_upto_cat. 1: reflexivity. + eapply eq_context_upto_empty_impl. + change (fix_context mfix) with (fix_context_gen 0 mfix). + change (fix_context mfix') with (fix_context_gen 0 mfix'). + generalize 0 at 2 3. unfold fix_context_gen. eapply (All2_All_mix_left ihmfix) in X. clear -X. induction X; try constructor; simpl; intros n; auto. - destruct r as [Hty [[[eqty eqbod] eqrarg] eqann]]. + destruct r as [Hty (eqty & eqbod & eqrarg & eqann)]. eapply eq_context_upto_cat. + constructor; constructor; auto. - eapply eq_term_upto_univ_empty_impl; eauto. - 4:now eapply eq_term_upto_univ_lift. all:tc. + now eapply eq_term_upto_univ_lift. + apply IHX. } assert(#|fix_context mfix| = #|fix_context mfix'|). { now rewrite !fix_context_length (All2_length X). } @@ -935,10 +863,10 @@ Section Alpha. * eapply (All2_All_mix_left ihmfix) in X. clear -X. induction X; constructor; simpl; auto. - destruct r as [Hty [[[eqty eqann] eqbod] eqrarg]]. + destruct r as [Hty (eqty & eqann & eqbod & eqrarg)]. eapply lift_judgment_alpha with (1 := Hty _ ltac:(reflexivity)) => //. - * solve_all. - specialize (b2 (Γ ,,, types)) as IHb. + * unfold eq_mfixpoint in *. solve_all. + specialize (b1 (Γ ,,, types)) as IHb. forward IHb by eapply eq_context_upto_cat; reflexivity. eapply @lift_judgment_alpha with (tm' := Some _) in IHb; tea. 1: apply lift_typing_impl with (1 := IHb) => t T HT. @@ -947,7 +875,7 @@ Section Alpha. * revert wffix. unfold wf_cofixpoint, wf_cofixpoint_gen. enough (map check_one_cofix mfix = map check_one_cofix mfix') as ->; auto. - apply upto_names_check_cofix. solve_all. + apply upto_names_check_cofix. unfold eq_mfixpoint in *. solve_all. + eapply All_nth_error in hmfix; tea. + apply eq_term_upto_univ_cumulSpec, eq_term_leq_term, upto_names_impl_eq_term. now symmetry. @@ -966,7 +894,7 @@ Section Alpha. eapply eq_term_upto_univ_cumulSpec. eapply eq_term_leq_term. eapply e1. * eapply eq_context_conversion in Hs; eauto. - * simp prim_type. eapply Universe.make_inj in e. rewrite e. + * simp prim_type. eapply Universe.make'_inj in e. rewrite e. eapply eq_term_upto_univ_cumulSpec. eapply upto_names_impl_leq_term. constructor. constructor. reflexivity. now symmetry. @@ -993,42 +921,29 @@ Section Alpha. Local Ltac inv H := inversion H; subst; clear H. - Lemma eq_term_upto_univ_napp_0 n t t' : - eq_term_upto_univ_napp empty_global_env eq eq n t t' -> + Lemma eq_term_upto_univ_napp_0 pb n t t' : + eq_term_upto_univ_napp empty_global_env (fun _ => eq) (fun _ => eq) pb n t t' -> t ≡α t'. Proof using Type. apply eq_term_upto_univ_empty_impl; typeclasses eauto. Qed. - Lemma upto_names_eq_term_refl Σ Re n t t' : - RelationClasses.Reflexive Re -> - t ≡α t' -> - eq_term_upto_univ_napp Σ Re Re n t t'. - Proof using Type. - intros. - eapply eq_term_upto_univ_empty_impl; tea; tc. - all:intros x y ->; reflexivity. - Qed. - - Lemma upto_names_eq_term_upto_univ Σ Re Rle napp t u : - RelationClasses.Reflexive Re -> - RelationClasses.Reflexive Rle -> - RelationClasses.Symmetric Re -> - RelationClasses.Transitive Re -> - RelationClasses.Transitive Rle -> - RelationClasses.subrelation Re Rle -> - eq_term_upto_univ_napp Σ Re Rle napp t u -> + Lemma upto_names_eq_term_upto_univ Σ cmp_universe cmp_sort pb napp t u : + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe pb) -> + RelationClasses.PreOrder (cmp_universe Conv) -> + RelationClasses.PreOrder (cmp_universe pb) -> + RelationClasses.PreOrder (cmp_sort Conv) -> + RelationClasses.PreOrder (cmp_sort pb) -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp t u -> forall t' u', t ≡α t' -> u ≡α u' -> - eq_term_upto_univ_napp Σ Re Rle napp t' u'. + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp t' u'. Proof using Type. intros. - eapply (upto_names_eq_term_refl Σ Re) in X0; tea. - eapply (upto_names_eq_term_refl Σ Re) in X1; tea. - symmetry in X0. - eapply eq_term_upto_univ_trans; tea. - eapply eq_term_upto_univ_impl; tea. reflexivity. reflexivity. - eapply eq_term_upto_univ_trans; tea. - eapply eq_term_upto_univ_impl; tea. reflexivity. reflexivity. + eapply symmetry, upto_names_impl in X0; tea. + eapply upto_names_impl in X1; tea. + eapply eq_term_upto_univ_trans; cycle -1. + eapply eq_term_upto_univ_trans; cycle -1. + all: tea; tc. Qed. Lemma upto_names_leq_term Σ φ t u t' u' diff --git a/pcuic/theories/PCUICArities.v b/pcuic/theories/PCUICArities.v index 6875e69ef..ff594b694 100644 --- a/pcuic/theories/PCUICArities.v +++ b/pcuic/theories/PCUICArities.v @@ -21,7 +21,7 @@ Implicit Types cf : checker_flags. Notation isWAT := (isWfArity typing). Lemma isType_Sort {cf:checker_flags} {Σ Γ s} : - wf_universe Σ s -> + wf_sort Σ s -> wf_local Σ Γ -> isType Σ Γ (tSort s). Proof. @@ -143,7 +143,7 @@ Section WfEnv. ∑ T' ctx' s', [× Σ ;;; Γ ⊢ T ⇝ T', (destArity [] T' = Some (ctx', s')), Σ ⊢ Γ ,,, smash_context [] ctx = Γ ,,, ctx' & - leq_universe (global_ext_constraints Σ) s s'] + leq_sort (global_ext_constraints Σ) s s'] | None => unit end. Proof using wfΣ. @@ -265,7 +265,7 @@ Section WfEnv. Proof using wfΣ. intro HH. apply lift_sorting_it_impl_gen with HH => // H. - assert (Hs := typing_wf_universe _ H). + assert (Hs := typing_wf_sort _ H). apply inversion_LetIn in H; tas. destruct H as (A' & Ht & HB & H). eapply (type_ws_cumul_pb (pb:=Cumul)) with (A' {0 := t}). eapply substitution_let in HB; eauto. * pcuic. @@ -396,14 +396,14 @@ Section WfEnv. Σ ;;; Γ ,, d |- t : tSort s -> match decl_body d return Type with | Some b => Σ ;;; Γ |- mkProd_or_LetIn d t : tSort s - | None => Σ ;;; Γ |- mkProd_or_LetIn d t : tSort (Universe.sort_of_product u s) + | None => Σ ;;; Γ |- mkProd_or_LetIn d t : tSort (Sort.sort_of_product u s) end. Proof using wfΣ. destruct d as [na [b|] dty] => [Hd Ht|Hd Ht]; rewrite /mkProd_or_LetIn /=. - have wf := typing_wf_local Ht. depelim wf. eapply type_Cumul. econstructor; eauto. - econstructor; eauto. now eapply typing_wf_universe in Ht; pcuic. + econstructor; eauto. now eapply typing_wf_sort in Ht; pcuic. eapply convSpec_cumulSpec, red1_cumulSpec. constructor. - have wf := typing_wf_local Ht. depelim wf; clear l. @@ -412,18 +412,18 @@ Section WfEnv. Qed. Lemma type_it_mkProd_or_LetIn {Γ Γ' u t s} : - wf_universe Σ u -> + wf_sort Σ u -> type_local_ctx (lift_typing typing) Σ Γ Γ' u -> Σ ;;; Γ ,,, Γ' |- t : tSort s -> - Σ ;;; Γ |- it_mkProd_or_LetIn Γ' t : tSort (Universe.sort_of_product u s). + Σ ;;; Γ |- it_mkProd_or_LetIn Γ' t : tSort (Sort.sort_of_product u s). Proof using wfΣ. revert Γ u s t. induction Γ'; simpl; auto; move=> Γ u s t wfu equ Ht. - eapply type_Cumul; eauto. econstructor; eauto using typing_wf_local with pcuic. - eapply typing_wf_universe in Ht; auto with pcuic. - eapply cumul_Sort. eapply leq_universe_product. - - specialize (IHΓ' Γ u (Universe.sort_of_product u s)); auto. + eapply typing_wf_sort in Ht; auto with pcuic. + eapply cumul_Sort. eapply leq_sort_product. + - specialize (IHΓ' Γ u (Sort.sort_of_product u s)); auto. unfold app_context in Ht. eapply type_Cumul. eapply IHΓ'; auto. @@ -434,7 +434,7 @@ Section WfEnv. + simpl. exact X0.2.π2.1. + eapply type_Cumul; eauto. econstructor; eauto with pcuic. - eapply cumul_Sort. eapply leq_universe_product. } + eapply cumul_Sort. eapply leq_sort_product. } eapply (type_mkProd_or_LetIn {| decl_body := None |}) => /=; eauto. econstructor; eauto with pcuic. eapply typing_wf_local in Ht. @@ -445,17 +445,17 @@ Section WfEnv. Fixpoint sort_of_products us s := match us with | [] => s - | u :: us => sort_of_products us (Universe.sort_of_product u s) + | u :: us => sort_of_products us (Sort.sort_of_product u s) end. - Lemma leq_universe_sort_of_products_mon {u u' v v'} : - Forall2 (leq_universe Σ) u u' -> - leq_universe Σ v v' -> - leq_universe Σ (sort_of_products u v) (sort_of_products u' v'). + Lemma leq_sort_sort_of_products_mon {u u' v v'} : + Forall2 (leq_sort Σ) u u' -> + leq_sort Σ v v' -> + leq_sort Σ (sort_of_products u v) (sort_of_products u' v'). Proof using Type. intros hu; induction hu in v, v' |- *; simpl; auto with pcuic. intros lev. eapply IHhu. - eapply leq_universe_product_mon => //. + eapply leq_sort_product_mon => //. Qed. Lemma type_it_mkProd_or_LetIn_sorts {Γ Γ' us t s} : @@ -618,7 +618,7 @@ Section WfEnv. rewrite it_mkProd_or_LetIn_app /= /mkProd_or_LetIn /=. intros Hs. - assert (wfs' := typing_wf_universe wfΣ Hs). + assert (wfs' := typing_wf_sort wfΣ Hs). eapply inversion_LetIn in Hs as (T' & wfT' & HT' & hlt); auto. eapply substitution_let in HT'; auto. eapply ws_cumul_pb_LetIn_l_inv in hlt; auto. @@ -634,7 +634,7 @@ Section WfEnv. now rewrite -subst_app_simpl -H0 firstn_skipn in IHn. intros Hs. - assert (wfs' := typing_wf_universe wfΣ Hs). + assert (wfs' := typing_wf_sort wfΣ Hs). eapply inversion_Prod in Hs as (s1 & s2 & wfty & Hty & hlt); auto. pose proof (subslet_app_inv sub) as [subl subr]. depelim subl; depelim subl. rewrite subst_empty in t0. rewrite H0 in subr. @@ -647,8 +647,8 @@ Section WfEnv. eapply type_Cumul. simpl in X. eapply X. econstructor; eauto with pcuic. eapply ws_cumul_pb_Sort_inv in hlt. eapply cumul_Sort. - transitivity (Universe.sort_of_product s1 s2). - eapply leq_universe_product. auto. + transitivity (Sort.sort_of_product s1 s2). + eapply leq_sort_product. auto. rewrite {2}Hl in IHn. now rewrite -subst_app_simpl -H0 firstn_skipn in IHn. Qed. diff --git a/pcuic/theories/PCUICAst.v b/pcuic/theories/PCUICAst.v index c27249eb3..ecf543a07 100644 --- a/pcuic/theories/PCUICAst.v +++ b/pcuic/theories/PCUICAst.v @@ -196,7 +196,7 @@ Inductive term := | tRel (n : nat) | tVar (i : ident) (* For free variables (e.g. in a goal) *) | tEvar (n : nat) (l : list term) -| tSort (u : Universe.t) +| tSort (u : sort) | tProd (na : aname) (A B : term) | tLambda (na : aname) (A t : term) | tLetIn (na : aname) (b B t : term) (* let na := b : B in t *) @@ -405,7 +405,7 @@ Instance subst_instance_constr : UnivSubst term := match c with | tRel _ | tVar _ => c | tEvar ev args => tEvar ev (List.map (subst_instance_constr u) args) - | tSort s => tSort (subst_instance_univ u s) + | tSort s => tSort (subst_instance_sort u s) | tConst c u' => tConst c (subst_instance_instance u u') | tInd i u' => tInd i (subst_instance_instance u u') | tConstruct ind k u' => tConstruct ind k (subst_instance_instance u u') @@ -431,7 +431,7 @@ Instance subst_instance_constr : UnivSubst term := (** Tests that the term is closed over [k] universe variables *) Fixpoint closedu (k : nat) (t : term) : bool := match t with - | tSort univ => closedu_universe k univ + | tSort s => closedu_sort k s | tInd _ u => closedu_instance k u | tConstruct _ _ u => closedu_instance k u | tConst _ u => closedu_instance k u diff --git a/pcuic/theories/PCUICCasesContexts.v b/pcuic/theories/PCUICCasesContexts.v index 1ca76ba3f..500bbee39 100644 --- a/pcuic/theories/PCUICCasesContexts.v +++ b/pcuic/theories/PCUICCasesContexts.v @@ -81,10 +81,11 @@ Lemma alpha_eq_smash_context Δ Δ' : Proof. induction 1. * constructor. - * destruct x; depelim r; simpl; auto. + * destruct r; simpl; auto. rewrite !(smash_context_acc _ [_]). eapply All2_app; auto; repeat constructor; subst; simpl; auto. rewrite (All2_length X) -(alpha_eq_extended_subst l l' 0) // (alpha_eq_context_assumptions l l') //. + now constructor. Qed. Lemma alpha_eq_lift_context n k Δ Δ' : @@ -95,7 +96,7 @@ Proof. * constructor. * rewrite !lift_context_snoc; destruct x; depelim r; simpl; subst; auto; constructor; auto; repeat constructor; subst; simpl; auto; - now rewrite (All2_length X). + rewrite (All2_length X); now constructor. Qed. Lemma alpha_eq_subst_context s k Δ Δ' : @@ -106,7 +107,7 @@ Proof. * constructor. * rewrite !subst_context_snoc; destruct x; depelim r; simpl; subst; auto; constructor; auto; repeat constructor; subst; simpl; auto; - now rewrite (All2_length X). + rewrite (All2_length X); now constructor. Qed. Lemma inst_case_predicate_context_eq {mdecl idecl ind p} : diff --git a/pcuic/theories/PCUICCasesHelper.v b/pcuic/theories/PCUICCasesHelper.v index a276514d8..2ff8c1ec9 100644 --- a/pcuic/theories/PCUICCasesHelper.v +++ b/pcuic/theories/PCUICCasesHelper.v @@ -447,7 +447,7 @@ Lemma type_Case_helper (rettyp : term) (brs : list term) (indices : list term) - (ps : Universe.t) (Σ : global_env_ext) Γ : + (ps : sort) (Σ : global_env_ext) Γ : wf_ext Σ -> declared_inductive Σ ind mib oib -> @@ -497,7 +497,7 @@ Proof. { do 2 constructor=> //=. rewrite /expand_lets_ctx /expand_lets_k_ctx /subst_context /lift_context !forget_types_fold_context_k. - apply: PCUICEquality.eq_context_gen_binder_annot; reflexivity. + apply PCUICEquality.eq_context_upto_names_binder_annot; reflexivity. } pose proof (discrtypok := validity discrtyp). @@ -526,8 +526,7 @@ Proof. hnf=>/=. rewrite /cstr_branch_context /expand_lets_ctx /expand_lets_k_ctx. rewrite /subst_context /lift_context !forget_types_fold_context_k. - apply: PCUICEquality.eq_context_gen_binder_annot. - apply: All2_fold_refl; reflexivity. + apply PCUICEquality.eq_context_upto_names_binder_annot. reflexivity. } constructor=> //. @@ -566,7 +565,7 @@ Lemma type_Case_subst_helper (rettyp : term) (brs : list term) (indices : list term) - (ps : Universe.t) (Σ : global_env_ext) Γ : + (ps : sort) (Σ : global_env_ext) Γ : wf_ext Σ -> declared_inductive Σ ind mib oib -> @@ -614,7 +613,7 @@ Proof. { do 2 constructor=> //=. rewrite /expand_lets_ctx /expand_lets_k_ctx /subst_context /lift_context !forget_types_fold_context_k. - apply: PCUICEquality.eq_context_gen_binder_annot; reflexivity. + apply PCUICEquality.eq_context_upto_names_binder_annot; reflexivity. } @@ -699,7 +698,7 @@ Lemma type_Case_simple_subst_helper (rettyp : term) (brs : list term) (indices : list term) - (ps : Universe.t) (Σ : global_env_ext) Γ : + (ps : sort) (Σ : global_env_ext) Γ : wf_ext Σ -> declared_inductive Σ ind mib oib -> @@ -748,7 +747,7 @@ Proof. { do 2 constructor=> //=. rewrite /expand_lets_ctx /expand_lets_k_ctx /subst_context /lift_context !forget_types_fold_context_k. - apply: PCUICEquality.eq_context_gen_binder_annot; reflexivity. + apply PCUICEquality.eq_context_upto_names_binder_annot; reflexivity. } diff --git a/pcuic/theories/PCUICClassification.v b/pcuic/theories/PCUICClassification.v index bea465ba7..c8587ef75 100644 --- a/pcuic/theories/PCUICClassification.v +++ b/pcuic/theories/PCUICClassification.v @@ -669,7 +669,7 @@ Section classification. now eapply invert_cumul_prod_ind in cum. - move=> [hargs ccum']. rewrite expand_lets_mkApps subst_mkApps /= in ccum'. - eapply invert_cumul_ind_ind in ccum' as ((? & ?) & ?). + eapply invert_cumul_ind_ind in ccum' as ((? & r) & ?). len in r. eapply ReflectEq.eqb_eq in i0. now subst ind'. Qed. diff --git a/pcuic/theories/PCUICConfluence.v b/pcuic/theories/PCUICConfluence.v index 3a8e83619..d143f756a 100644 --- a/pcuic/theories/PCUICConfluence.v +++ b/pcuic/theories/PCUICConfluence.v @@ -224,18 +224,6 @@ Proof. now eapply All2_fold_refl. Qed. -Lemma on_one_decl_compare_decl Σ Re Rle x y : - RelationClasses.Reflexive Re -> - RelationClasses.Reflexive Rle -> - on_one_decl - (fun (y0 v' : term) => eq_term_upto_univ Σ Re Rle y0 v') x y -> - compare_decls (eq_term_upto_univ Σ Re Rle) (eq_term_upto_univ Σ Re Rle) x y. -Proof. - intros heq hle. - destruct x as [na [b|] ty], y as [na' [b'|] ty']; cbn; intuition (subst; auto); - constructor; auto; reflexivity. -Qed. - Lemma OnOne2_disj {A} (P Q : A -> A -> Type) (l l' : list A) : OnOne2 (fun x y => P x y + Q x y)%type l l' <~> OnOne2 P l l' + OnOne2 Q l l'. @@ -248,26 +236,25 @@ Qed. Notation red1_ctx_rel Σ Δ := (OnOne2_local_env (fun (Γ : context) => on_one_decl - (fun (x0 y0 : term) => red1 Σ (Δ,,, Γ) x0 y0))). + (fun (t u : term) => red1 Σ (Δ ,,, Γ) t u))). -Notation eq_one_decl Σ Re Rle := +Notation eq_one_decl Σ cmp_universe cmp_sort pb := (OnOne2_local_env (fun _ => on_one_decl - (fun (x0 y0 : term) => - eq_term_upto_univ Σ Re Rle x0 y0))). - -Lemma red1_eq_context_upto_l {Σ Σ' Rle Re Γ Δ u v} : - RelationClasses.Reflexive Rle -> - SubstUnivPreserving Rle -> - RelationClasses.Reflexive Re -> - SubstUnivPreserving Re -> - RelationClasses.subrelation Re Rle -> + (fun (t u : term) => + eq_term_upto_univ Σ cmp_universe cmp_sort pb t u))). + +Lemma red1_eq_context_upto_l {Σ Σ' cmp_universe cmp_sort pb Γ Δ u v} : + RelationClasses.Reflexive (cmp_universe Conv) -> + RelationClasses.Reflexive (cmp_universe pb) -> + RelationClasses.Reflexive (cmp_sort Conv) -> + RelationClasses.Reflexive (cmp_sort pb) -> red1 Σ Γ u v -> - eq_context_upto Σ' Re Rle Γ Δ -> + eq_context_upto Σ' cmp_universe cmp_sort pb Γ Δ -> ∑ v', red1 Σ Δ u v' * - eq_term_upto_univ Σ' Re Re v v'. + eq_term_upto_univ Σ' cmp_universe cmp_sort Conv v v'. Proof. - intros hle hle' he he' hlee h e. + intros refl_univ_conv refl_univ_pb refl_sort_conv refl_sort_pb h e. induction h in Δ, e |- * using red1_ind_all. all: try solve [ eexists ; split ; [ @@ -286,7 +273,7 @@ Proof. all: try solve [ match goal with | r : red1 _ (?Γ ,, ?d) _ _ |- _ => - assert (e' : eq_context_upto Σ' Re Rle (Γ,, d) (Δ,, d)) + assert (e' : eq_context_upto Σ' cmp_universe cmp_sort pb (Γ,, d) (Δ,, d)) ; [ constructor ; [ eauto | constructor; eauto ] ; eapply eq_term_upto_univ_refl ; eauto @@ -302,7 +289,7 @@ Proof. ]. - assert (h : ∑ b', (option_map decl_body (nth_error Δ i) = Some (Some b')) * - eq_term_upto_univ Σ' Re Re body b'). + eq_term_upto_univ Σ' cmp_universe cmp_sort Conv body b'). { induction i in Γ, Δ, H, e |- *. - destruct e. + cbn in *. discriminate. @@ -344,25 +331,25 @@ Proof. specialize (IH (Δ ,,, inst_case_branch_context p x)). forward IH by now apply eq_context_upto_cat. exact IH. } eapply (OnOne2_exist' _ (fun x y => on_Trel_eq (red1 Σ (Δ ,,, inst_case_branch_context p x)) bbody bcontext x y) - (fun x y => on_Trel_eq (eq_term_upto_univ Σ' Re Re) bbody bcontext x y)) in X as [brr [Hred Heq]]; tea. + (fun x y => on_Trel_eq (eq_term_upto_univ Σ' cmp_universe cmp_sort Conv) bbody bcontext x y)) in X as [brr [Hred Heq]]; tea. 2:{ intros x y [[v' [redv' eq]] eqctx]. exists {| bcontext := bcontext x; bbody := v' |}. intuition auto. } eexists; split. eapply case_red_brs; tea. econstructor; eauto; try reflexivity. - eapply OnOne2_All2; tea => /=; intuition eauto; try reflexivity. + eapply OnOne2_All2; tea => /=; unfold eq_branch; intuition eauto; try reflexivity. now rewrite b. - destruct (IHh _ e) as [x [redl redr]]. exists (tApp x M2). split. constructor; auto. - constructor. eapply eq_term_upto_univ_impl. 5:eauto. - all:auto. 1-3:typeclasses eauto. + constructor. eapply eq_term_upto_univ_impl. 6:eauto. + all:auto. 1-4:typeclasses eauto. reflexivity. - assert (h : ∑ ll, OnOne2 (red1 Σ Δ) l ll * - All2 (eq_term_upto_univ Σ' Re Re) l' ll + All2 (eq_term_upto_univ Σ' cmp_universe cmp_sort Conv) l' ll ). { induction X. - destruct p as [p1 p2]. @@ -391,11 +378,7 @@ Proof. (d'.(dname), d'.(dbody), d'.(rarg)) ) mfix0 mfix' * - All2 (fun x y => - eq_term_upto_univ Σ' Re Re (dtype x) (dtype y) * - eq_term_upto_univ Σ' Re Re (dbody x) (dbody y) * - (rarg x = rarg y) * - (eq_binder_annot (dname x) (dname y)))%type mfix1 mfix'). + eq_mfixpoint (eq_term_upto_univ Σ' cmp_universe cmp_sort Conv) mfix1 mfix'). { induction X. - destruct p as [[p1 p2] p3]. eapply p2 in e as hh. destruct hh as [? [? ?]]. @@ -426,51 +409,12 @@ Proof. (d.(dname), d.(dtype), d.(rarg)) = (d'.(dname), d'.(dtype), d'.(rarg)) ) mfix0 mfix' * - All2 (fun x y => - eq_term_upto_univ Σ' Re Re (dtype x) (dtype y) * - eq_term_upto_univ Σ' Re Re (dbody x) (dbody y) * - (rarg x = rarg y) * - eq_binder_annot (dname x) (dname y))%type mfix1 mfix'). - { (* Maybe we should use a lemma using firstn or skipn to keep - fix_context intact. Anything general? - *) - Fail induction X using OnOne2_ind_l. - (* This FAILs because it reduces the type of X before unifying - unfortunately... - *) - change ( - OnOne2 - ((fun L (x y : def term) => - (red1 Σ (Γ ,,, fix_context L) (dbody x) (dbody y) - × (forall Δ : context, - eq_context_upto Σ' Re Rle (Γ ,,, fix_context L) Δ -> - ∑ v' : term, - red1 Σ Δ (dbody x) v' × eq_term_upto_univ Σ' Re Re (dbody y) v')) - × (dname x, dtype x, rarg x) = (dname y, dtype y, rarg y)) mfix0) mfix0 mfix1 - ) in X. - Fail induction X using OnOne2_ind_l. - revert mfix0 mfix1 X. - refine (OnOne2_ind_l _ (fun (L : mfixpoint term) (x y : def term) => - ((red1 Σ (Γ ,,, fix_context L) (dbody x) (dbody y) - × (forall Δ0 : context, - eq_context_upto Σ' Re Rle (Γ ,,, fix_context L) Δ0 -> - ∑ v' : term, - red1 Σ Δ0 (dbody x) v' × eq_term_upto_univ Σ' Re Re (dbody y) v')) - × (dname x, dtype x, rarg x) = (dname y, dtype y, rarg y))) - (fun L mfix0 mfix1 o => ∑ mfix' : list (def term), - OnOne2 - (fun d d' : def term => - red1 Σ (Δ ,,, fix_context L) (dbody d) (dbody d') - × (dname d, dtype d, rarg d) = (dname d', dtype d', rarg d')) mfix0 mfix' - × All2 - (fun x y : def term => - ((eq_term_upto_univ Σ' Re Re (dtype x) (dtype y) - × eq_term_upto_univ Σ' Re Re (dbody x) (dbody y)) × - (rarg x = rarg y)) * - eq_binder_annot (dname x) (dname y)) mfix1 mfix') _ _). - - intros L x y l [[p1 p2] p3]. + eq_mfixpoint (eq_term_upto_univ Σ' cmp_universe cmp_sort Conv) mfix1 mfix'). + { set (Ξ := fix_context _) in *. clearbody Ξ. + induction X. + - destruct p as [[p1 p2] p3]. assert ( - e' : eq_context_upto Σ' Re Rle (Γ ,,, fix_context L) (Δ ,,, fix_context L) + e' : eq_context_upto Σ' cmp_universe cmp_sort pb (Γ ,,, Ξ) (Δ ,,, Ξ) ). { eapply eq_context_upto_cat ; eauto. reflexivity. } eapply p2 in e' as hh. destruct hh as [? [? ?]]. @@ -484,7 +428,7 @@ Proof. * eapply All2_same. intros. repeat split ; eauto. all: eapply eq_term_upto_univ_refl ; eauto. - - intros L x l l' h [? [? ?]]. + - destruct IHX as [? [? ?]]. eexists. constructor. + eapply OnOne2_tl. eassumption. + constructor ; eauto. @@ -501,11 +445,7 @@ Proof. (d.(dname), d.(dbody), d.(rarg)) = (d'.(dname), d'.(dbody), d'.(rarg)) ) mfix0 mfix' * - All2 (fun x y => - eq_term_upto_univ Σ' Re Re (dtype x) (dtype y) * - eq_term_upto_univ Σ' Re Re (dbody x) (dbody y) * - (rarg x = rarg y) * - eq_binder_annot (dname x) (dname y))%type mfix1 mfix' + eq_mfixpoint (eq_term_upto_univ Σ' cmp_universe cmp_sort Conv) mfix1 mfix' ). { induction X. - destruct p as [[p1 p2] p3]. @@ -537,50 +477,12 @@ Proof. (d.(dname), d.(dtype), d.(rarg)) = (d'.(dname), d'.(dtype), d'.(rarg)) ) mfix0 mfix' * - All2 (fun x y => - eq_term_upto_univ Σ' Re Re (dtype x) (dtype y) * - eq_term_upto_univ Σ' Re Re (dbody x) (dbody y) * - (rarg x = rarg y) * - eq_binder_annot (dname x) (dname y))%type mfix1 mfix'). - { (* Maybe we should use a lemma using firstn or skipn to keep - fix_context intact. Anything general? - *) - Fail induction X using OnOne2_ind_l. - (* This FAILs because it reduces the type of X before unifying - unfortunately... - *) - change ( - OnOne2 - ((fun L (x y : def term) => - (red1 Σ (Γ ,,, fix_context L) (dbody x) (dbody y) - × (forall Δ : context, - eq_context_upto Σ' Re Rle (Γ ,,, fix_context L) Δ -> - ∑ v' : term, - red1 Σ Δ (dbody x) v' × eq_term_upto_univ Σ' Re Re (dbody y) v' )) - × (dname x, dtype x, rarg x) = (dname y, dtype y, rarg y)) mfix0) mfix0 mfix1 - ) in X. - Fail induction X using OnOne2_ind_l. - revert mfix0 mfix1 X. - refine (OnOne2_ind_l _ (fun (L : mfixpoint term) (x y : def term) => - (red1 Σ (Γ ,,, fix_context L) (dbody x) (dbody y) - × (forall Δ0 : context, - eq_context_upto Σ' Re Rle (Γ ,,, fix_context L) Δ0 -> - ∑ v' : term, - red1 Σ Δ0 (dbody x) v' × eq_term_upto_univ Σ' Re Re (dbody y) v' )) - × (dname x, dtype x, rarg x) = (dname y, dtype y, rarg y)) (fun L mfix0 mfix1 o => ∑ mfix' : list (def term), - (OnOne2 - (fun d d' : def term => - red1 Σ (Δ ,,, fix_context L) (dbody d) (dbody d') - × (dname d, dtype d, rarg d) = (dname d', dtype d', rarg d')) mfix0 mfix' - × All2 - (fun x y : def term => - ((eq_term_upto_univ Σ' Re Re (dtype x) (dtype y) - × eq_term_upto_univ Σ' Re Re (dbody x) (dbody y)) × - rarg x = rarg y) * - eq_binder_annot (dname x) (dname y)) mfix1 mfix')) _ _). - - intros L x y l [[p1 p2] p3]. + eq_mfixpoint (eq_term_upto_univ Σ' cmp_universe cmp_sort Conv) mfix1 mfix'). + { set (Ξ := fix_context _) in *. clearbody Ξ. + induction X. + -destruct p as [[p1 p2] p3]. assert ( - e' : eq_context_upto Σ' Re Rle (Γ ,,, fix_context L) (Δ ,,, fix_context L) + e' : eq_context_upto Σ' cmp_universe cmp_sort pb (Γ ,,, Ξ) (Δ ,,, Ξ) ). { eapply eq_context_upto_cat ; eauto. reflexivity. } eapply p2 in e' as hh. destruct hh as [? [? ?]]. @@ -594,7 +496,7 @@ Proof. * eapply All2_same. intros. repeat split ; eauto. all: eapply eq_term_upto_univ_refl ; eauto. - - intros L x l l' h [? [? ?]]. + - destruct IHX as [? [? ?]]. eexists. constructor. + eapply OnOne2_tl. eassumption. + constructor ; eauto. @@ -607,7 +509,7 @@ Proof. + constructor; assumption. - assert (h : ∑ ll, OnOne2 (red1 Σ Δ) (array_value arr) ll * - All2 (eq_term_upto_univ Σ' Re Re) value ll + All2 (eq_term_upto_univ Σ' cmp_universe cmp_sort Conv) value ll ). { induction X. - destruct p as [p1 p2]. @@ -641,17 +543,35 @@ Proof. eapply All2_refl; reflexivity. Qed. -Lemma eq_context_gen_context_assumptions {eq leq Γ Δ} : - eq_context_gen eq leq Γ Δ -> +Lemma eq_context_upto_names_context_assumptions {Γ Δ} : + eq_context_upto_names Γ Δ -> + context_assumptions Γ = context_assumptions Δ. +Proof. + induction 1; simpl; auto. + destruct r => /= //; try lia. +Qed. + +Lemma eq_context_upto_names_extended_subst {Γ Δ n} : + eq_context_upto_names Γ Δ -> + extended_subst Γ n = extended_subst Δ n. +Proof. + induction 1 in n |- *; cbn; auto. + destruct r; subst; cbn. f_equal; auto. + rewrite IHX. + now rewrite (eq_context_upto_names_context_assumptions X). +Qed. + +Lemma eq_context_gen_context_assumptions {cmp pb Γ Δ} : + eq_context_gen cmp pb Γ Δ -> context_assumptions Γ = context_assumptions Δ. Proof. induction 1; simpl; auto; destruct p => /= //; try lia. Qed. -Lemma eq_context_extended_subst {Σ Re Rle Γ Δ k} : - eq_context_gen (eq_term_upto_univ Σ Re Re) (eq_term_upto_univ Σ Re Rle) Γ Δ -> - All2 (eq_term_upto_univ Σ Re Re) (extended_subst Γ k) (extended_subst Δ k). +Lemma eq_context_extended_subst {Σ cmp_universe cmp_sort pb Γ Δ k} : + eq_context_gen (fun pb => eq_term_upto_univ Σ cmp_universe cmp_sort pb) pb Γ Δ -> + All2 (eq_term_upto_univ Σ cmp_universe cmp_sort Conv) (extended_subst Γ k) (extended_subst Δ k). Proof. intros Heq. induction Heq in k |- *; simpl. @@ -661,58 +581,44 @@ Proof. * constructor. + rewrite (eq_context_gen_context_assumptions Heq). len. rewrite (All2_fold_length Heq). - eapply eq_term_upto_univ_substs; eauto. tc. - eapply eq_term_upto_univ_lift, e0. + eapply eq_term_upto_univ_substs; eauto; tc. + eapply eq_term_upto_univ_lift, eqb. + eapply IHHeq. Qed. -Lemma eq_context_gen_eq_context_upto Σ Re Rle Γ Γ' : - RelationClasses.Reflexive Re -> - RelationClasses.Reflexive Rle -> - eq_context_gen eq eq Γ Γ' -> - eq_context_upto Σ Re Rle Γ Γ'. +Lemma eq_context_upto_names_eq_context_upto Σ cmp_universe cmp_sort pb : + RelationClasses.Reflexive (cmp_universe Conv) -> + RelationClasses.Reflexive (cmp_universe pb) -> + RelationClasses.Reflexive (cmp_sort Conv) -> + RelationClasses.Reflexive (cmp_sort pb) -> + subrelation eq_context_upto_names (eq_context_upto Σ cmp_universe cmp_sort pb). Proof. - intros. + intros ** Γ Γ' X. + apply All2_fold_All2 in X. eapply All2_fold_impl; tea. cbn; intros ????. move => []; constructor; subst; auto; reflexivity. Qed. -Lemma red1_eq_context_upto_univ_l {Σ Σ' Re Rle Γ ctx ctx' ctx''} : - RelationClasses.Reflexive Re -> - RelationClasses.Reflexive Rle -> - RelationClasses.Transitive Re -> - RelationClasses.Transitive Rle -> - SubstUnivPreserving Re -> - SubstUnivPreserving Rle -> - RelationClasses.subrelation Re Rle -> - eq_context_gen (eq_term_upto_univ Σ' Re Re) - (eq_term_upto_univ Σ' Re Re) ctx ctx' -> +Lemma red1_eq_context_upto_univ_l {Σ Σ' cmp_universe cmp_sort Γ ctx ctx' ctx''} : + RelationClasses.PreOrder (cmp_universe Conv) -> + RelationClasses.PreOrder (cmp_sort Conv) -> + eq_context_gen (fun pb => eq_term_upto_univ Σ' cmp_universe cmp_sort pb) Conv ctx ctx' -> OnOne2_local_env (fun (Γ' : context) => on_one_decl - (fun (u v : term) => - forall (Rle : Relation_Definitions.relation Universe.t) - (napp : nat) (u' : term), - RelationClasses.Reflexive Re -> - RelationClasses.Reflexive Rle -> - RelationClasses.Transitive Re -> - RelationClasses.Transitive Rle -> - SubstUnivPreserving Re -> - SubstUnivPreserving Rle -> - (forall x y : Universe.t, Re x y -> Rle x y) -> - eq_term_upto_univ_napp Σ' Re Rle napp u u' -> + (fun (u v : term) => forall (pb : conv_pb) (napp : nat) (u' : term), + eq_term_upto_univ_napp Σ' cmp_universe cmp_sort pb napp u u' -> ∑ v' : term, - red1 Σ (Γ,,, Γ') u' v' - × eq_term_upto_univ_napp Σ' Re Rle napp v v')) ctx ctx'' -> + red1 Σ (Γ ,,, Γ') u' v' + × eq_term_upto_univ_napp Σ' cmp_universe cmp_sort pb napp v v')) ctx ctx'' -> ∑ pctx, red1_ctx_rel Σ Γ ctx' pctx * - eq_context_gen (eq_term_upto_univ Σ' Re Re) (eq_term_upto_univ Σ' Re Re) ctx'' pctx. + eq_context_gen (fun pb => eq_term_upto_univ Σ' cmp_universe cmp_sort pb) Conv ctx'' pctx. Proof. - intros. - rename X into e, X0 into X. + intros preorder_univ_conv preorder_sort_conv e X. induction X in e, ctx' |- *. - red in p. simpl in p. depelim e. depelim c. destruct p as [-> p]. - eapply p in e1 as hh ; eauto. + eapply p in eqt as hh ; eauto. destruct hh as [? [? ?]]. eapply red1_eq_context_upto_l in r; cycle -1. { eapply eq_context_upto_cat; tea. @@ -726,7 +632,7 @@ Proof. - depelim e. depelim c. destruct p as [-> [[p ->]|[p ->]]]. - { eapply p in e2 as hh ; eauto. + { eapply p in eqt as hh ; eauto. destruct hh as [? [? ?]]. eapply red1_eq_context_upto_l in r; cycle -1. { eapply eq_context_upto_cat; tea. @@ -738,7 +644,7 @@ Proof. left. split; tea. reflexivity. + constructor. all: eauto. constructor; auto. now transitivity x. } - { eapply p in e1 as hh ; eauto. + { eapply p in eqb as hh ; eauto. destruct hh as [? [? ?]]. eapply red1_eq_context_upto_l in r; cycle -1. { eapply eq_context_upto_cat; tea. @@ -766,9 +672,10 @@ Qed. *) Global Instance eq_context_upto_univ_subst_preserved {cf:checker_flags} Σ - (Re Rle : ConstraintSet.t -> Universe.t -> Universe.t -> Prop) - {he: SubstUnivPreserved Re} {hle: SubstUnivPreserved Rle} - : SubstUnivPreserved (fun φ => eq_context_upto Σ (Re φ) (Rle φ)). + (cmp_universe : forall _ _ (_ _ : Universe.t), Prop) (cmp_sort : forall _ _ (_ _ : sort), Prop) pb + {univ_conv: SubstUnivPreserved (fun φ => cmp_universe φ Conv)} {univ_pb: SubstUnivPreserved (fun φ => cmp_universe φ pb)} + {sort_conv: SubstUnivPreserved (fun φ => cmp_sort φ Conv)} {sort_pb: SubstUnivPreserved (fun φ => cmp_sort φ pb)} + : SubstUnivPreserved (fun φ => eq_context_upto Σ (cmp_universe φ) (cmp_sort φ) pb). Proof. intros φ φ' u vc Γ Δ eqc. eapply All2_fold_map. @@ -777,86 +684,113 @@ Proof. destruct X; constructor; cbn; auto; eapply eq_term_upto_univ_subst_preserved; tc; eauto. Qed. -Lemma eq_context_gen_eq_univ_subst_preserved u Γ Δ : - eq_context_gen eq eq Γ Δ -> - eq_context_gen eq eq (subst_instance u Γ) (subst_instance u Δ). +Lemma eq_context_upto_names_univ_subst_preserved u Γ Δ : + eq_context_upto_names Γ Δ -> + eq_context_upto_names (subst_instance u Γ) (subst_instance u Δ). Proof. intros onctx. - eapply All2_fold_map. - eapply All2_fold_impl; tea. + eapply All2_map. + eapply All2_impl; tea. cbn; intros. destruct X; constructor; cbn; auto; now subst. Qed. -Lemma eq_term_upto_univ_subst_instance' {cf:checker_flags} Σ Re Rle : - RelationClasses.Reflexive Re -> - SubstUnivPreserving Re -> - RelationClasses.Transitive Re -> - RelationClasses.Transitive Rle -> - RelationClasses.subrelation Re Rle -> - SubstUnivPreserved (fun _ => Re) -> - SubstUnivPreserved (fun _ => Rle) -> +Lemma eq_term_upto_univ_subst_instance' {cf:checker_flags} Σ cmp_universe cmp_sort pb : + RelationClasses.Transitive (cmp_universe Conv) -> + RelationClasses.Transitive (cmp_universe pb) -> + RelationClasses.Transitive (cmp_sort Conv) -> + RelationClasses.Transitive (cmp_sort pb) -> + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe pb) -> + SubstUnivPreserving (cmp_universe Conv) (cmp_universe Conv) -> + SubstUnivPreserving (cmp_universe Conv) (cmp_sort Conv) -> + SubstUnivPreserving (cmp_universe Conv) (cmp_sort pb) -> + SubstUnivPreserved (fun _ => cmp_universe Conv) -> + SubstUnivPreserved (fun _ => cmp_universe pb) -> + SubstUnivPreserved (fun _ => cmp_sort Conv) -> + SubstUnivPreserved (fun _ => cmp_sort pb) -> forall x y napp u1 u2, - R_universe_instance Re u1 u2 -> - eq_term_upto_univ_napp Σ Re Rle napp x y -> - eq_term_upto_univ_napp Σ Re Rle napp (subst_instance u1 x) (subst_instance u2 y). + cmp_universe_instance (cmp_universe Conv) u1 u2 -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp x y -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (subst_instance u1 x) (subst_instance u2 y). Proof. intros. eapply eq_term_upto_univ_trans with (subst_instance u2 x); tc. now eapply eq_term_upto_univ_subst_instance. - eapply (eq_term_upto_univ_subst_preserved Σ (fun _ => Re) (fun _ => Rle) napp ConstraintSet.empty ConstraintSet.empty u2). + eapply (eq_term_upto_univ_subst_preserved Σ (fun _ => cmp_universe) (fun _ => cmp_sort) pb napp ConstraintSet.empty ConstraintSet.empty u2). red. destruct check_univs => //. assumption. Qed. -Lemma eq_context_upto_univ_subst_instance Σ Re Rle : - RelationClasses.Reflexive Re -> - SubstUnivPreserving Re -> - RelationClasses.subrelation Re Rle -> +Lemma eq_context_upto_univ_subst_instance Σ cmp_universe cmp_sort pb : + SubstUnivPreserving (cmp_universe Conv) (cmp_universe Conv) -> + SubstUnivPreserving (cmp_universe Conv) (cmp_sort Conv) -> + SubstUnivPreserving (cmp_universe Conv) (cmp_sort pb) -> forall x u1 u2, - R_universe_instance Re u1 u2 -> - eq_context_upto Σ Re Rle (subst_instance u1 x) (subst_instance u2 x). + cmp_universe_instance (cmp_universe Conv) u1 u2 -> + eq_context_upto Σ cmp_universe cmp_sort pb (subst_instance u1 x) (subst_instance u2 x). Proof. - intros ref hRe subr t. + intros substu_univ substu_sort_conv substu_sort_pb t. induction t. intros. - rewrite /subst_instance /=. constructor. - rewrite /subst_instance /=. constructor; auto. destruct a as [na [b|] ty]; cbn; constructor; cbn; eauto using eq_term_upto_univ_subst_instance. - apply eq_term_upto_univ_subst_instance; eauto. tc. Qed. -Lemma eq_context_upto_univ_subst_instance' Σ Re Rle : - RelationClasses.Reflexive Re -> - RelationClasses.Reflexive Rle -> - RelationClasses.Transitive Re -> - RelationClasses.Transitive Rle -> - SubstUnivPreserving Re -> - RelationClasses.subrelation Re Rle -> +Lemma eq_context_upto_univ_subst_instance' {cf:checker_flags} Σ cmp_universe cmp_sort pb : + RelationClasses.Transitive (cmp_universe Conv) -> + RelationClasses.Transitive (cmp_universe pb) -> + RelationClasses.Transitive (cmp_sort Conv) -> + RelationClasses.Transitive (cmp_sort pb) -> + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe pb) -> + SubstUnivPreserving (cmp_universe Conv) (cmp_universe Conv) -> + SubstUnivPreserving (cmp_universe Conv) (cmp_sort Conv) -> + SubstUnivPreserving (cmp_universe Conv) (cmp_sort pb) -> + SubstUnivPreserved (fun _ => cmp_universe Conv) -> + SubstUnivPreserved (fun _ => cmp_universe pb) -> + SubstUnivPreserved (fun _ => cmp_sort Conv) -> + SubstUnivPreserved (fun _ => cmp_sort pb) -> forall x y u1 u2, - R_universe_instance Re u1 u2 -> - eq_context_gen eq eq x y -> - eq_context_upto Σ Re Rle (subst_instance u1 x) (subst_instance u2 y). + cmp_universe_instance (cmp_universe Conv) u1 u2 -> + eq_context_upto Σ cmp_universe cmp_sort pb x y -> + eq_context_upto Σ cmp_universe cmp_sort pb (subst_instance u1 x) (subst_instance u2 y). Proof. - intros ref refl' tr trle hRe subr x y u1 u2 ru eqxy. + intros ???????????? x y u1 u2 ru eqxy. eapply All2_fold_trans. intros ?????????. eapply compare_decl_trans. eapply eq_term_upto_univ_trans; tc. eapply eq_term_upto_univ_trans; tc. - eapply eq_context_gen_eq_context_upto; tea. - eapply eq_context_gen_eq_univ_subst_preserved; tea. eapply eq_context_upto_univ_subst_instance; tc. tea. + eapply eq_context_upto_univ_subst_preserved with (cmp_universe := fun _ => cmp_universe) (cmp_sort := fun _ => cmp_sort); tea; tc. + unfold_univ_rel eqn:He. + instantiate (1 := CS.empty). instantiate (1 := CS.empty) in Hv. + apply Hv. +Qed. + +Lemma eq_context_upto_names_subst_instance Σ cmp_universe cmp_sort pb : + SubstUnivPreserving (cmp_universe Conv) (cmp_universe Conv) -> + SubstUnivPreserving (cmp_universe Conv) (cmp_sort Conv) -> + SubstUnivPreserving (cmp_universe Conv) (cmp_sort pb) -> + forall x y u1 u2, + cmp_universe_instance (cmp_universe Conv) u1 u2 -> + eq_context_upto_names x y -> + eq_context_upto Σ cmp_universe cmp_sort pb (subst_instance u1 x) (subst_instance u2 y). +Proof. + intros substu_univ substu_sort_conv substu_sort_pb x y u1 u2 ru eqxy. + induction eqxy; cbn; constructor; eauto. + destruct r; constructor; cbn; eauto. + all: now apply eq_term_upto_univ_subst_instance. Qed. (*Lemma eq_context_upto_eq_univ_subst_instance {cf:checker_flags} Σ φ Re Rle : RelationClasses.Reflexive (Re φ) -> RelationClasses.Transitive (Re φ) -> RelationClasses.Transitive (Rle φ) -> - SubstUnivPreserving (Re φ) -> + SubstUnivPreserving (Re φ) (Re φ) -> RelationClasses.subrelation (Re φ) (Rle φ) -> SubstUnivPreserved Re -> SubstUnivPreserved Rle -> forall x y u1 u2, - R_universe_instance (Re φ) u1 u2 -> + cmp_universe_instance (Re φ) u1 u2 -> valid_constraints φ (subst_instance_cstrs u1 φ) -> eq_context_upto Σ eq eq x y -> eq_context_upto Σ (Re φ) (Rle φ) (subst_instance u1 x) (subst_instance u2 y). @@ -872,21 +806,24 @@ Proof. eapply eq_context_upto_univ_subst_instance; tc. tea. Qed.*) -Lemma red1_eq_term_upto_univ_l {Σ Σ' : global_env} Re Rle napp Γ u v u' : - RelationClasses.Reflexive Re -> - RelationClasses.Reflexive Rle -> - RelationClasses.Transitive Re -> - RelationClasses.Transitive Rle -> - SubstUnivPreserving Re -> - SubstUnivPreserving Rle -> - RelationClasses.subrelation Re Rle -> - eq_term_upto_univ_napp Σ' Re Rle napp u u' -> +Lemma red1_eq_term_upto_univ_l {Σ Σ' : global_env} cmp_universe cmp_sort pb napp Γ u v u' : + RelationClasses.PreOrder (cmp_universe Conv) -> + RelationClasses.PreOrder (cmp_universe pb) -> + RelationClasses.PreOrder (cmp_sort Conv) -> + RelationClasses.PreOrder (cmp_sort pb) -> + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe pb) -> + RelationClasses.subrelation (cmp_sort Conv) (cmp_sort pb) -> + SubstUnivPreserving (cmp_universe Conv) (cmp_universe Conv) -> + SubstUnivPreserving (cmp_universe Conv) (cmp_sort Conv) -> + SubstUnivPreserving (cmp_universe Conv) (cmp_sort pb) -> + eq_term_upto_univ_napp Σ' cmp_universe cmp_sort pb napp u u' -> red1 Σ Γ u v -> ∑ v', red1 Σ Γ u' v' * - eq_term_upto_univ_napp Σ' Re Rle napp v v'. + eq_term_upto_univ_napp Σ' cmp_universe cmp_sort pb napp v v'. Proof. - intros he he' tRe tRle hle hle' hR e h. - induction h in napp, u', e, he, he', tRe, tRle, Rle, hle, hle', hR |- * using red1_ind_all. + intros preorder_univ_conv preorder_univ_pb preorder_sort_conv preorder_sort_pb + sub_univ sub_sort substu_univ substu_sort_conv substu_sort_pb e h. + induction h in pb, napp, u', e, preorder_univ_pb, preorder_sort_pb, sub_univ, sub_sort, substu_sort_pb |- * using red1_ind_all. all: try solve [ dependent destruction e ; edestruct IHh as [? [? ?]] ; [ .. | eassumption | ] ; eauto ; tc ; @@ -899,30 +836,24 @@ Proof. idtac. 10,15:solve [ dependent destruction e ; - edestruct (IHh Rle) as [? [? ?]] ; [ .. | tea | ] ; eauto; + edestruct (IHh pb) as [? [? ?]] ; [ .. | tea | ] ; eauto; clear h; lazymatch goal with | r : red1 _ (?Γ,, vass ?na ?A) ?u ?v, - e : eq_term_upto_univ_napp _ _ _ _ ?A ?B + e : eq_term_upto_univ_napp _ _ _ _ _ ?A ?B |- _ => let hh := fresh "hh" in eapply red1_eq_context_upto_l in r as hh ; revgoals; - [ - constructor (* with (nb := na) *) ; [ - eapply (eq_context_upto_refl _ Re Re); eauto + [ constructor ; [ + eapply (eq_context_upto_refl _ _ _ Conv); eauto ; tc | constructor; tea ] - | reflexivity - | assumption - | assumption - | assumption - | assumption - | destruct hh as [? [? ?]] - ] + | tc ..]; + destruct hh as [? [? ?]] end; eexists ; split; [ solve [ econstructor ; eauto ] | constructor ; eauto ; - eapply eq_term_upto_univ_trans ; eauto ; + eapply eq_term_upto_univ_trans ; eauto ; tc ; eapply eq_term_upto_univ_leq ; eauto ] ]. @@ -940,13 +871,13 @@ Proof. - dependent destruction e. eexists. split. + constructor. eassumption. - + eapply eq_term_upto_univ_refl ; assumption. + + eapply eq_term_upto_univ_refl ; tc. - dependent destruction e. apply eq_term_upto_univ_mkApps_l_inv in e0 as [? [? [[h1 h2] h3]]]. subst. dependent destruction h1. - eapply All2_nth_error_Some in a as [t' [hnth [eqctx eqbod]]]; tea. - have lenctxass := eq_context_gen_context_assumptions eqctx. - have lenctx := All2_fold_length eqctx. + eapply All2_nth_error_Some in e1 as [t' [hnth [eqctx eqbod]]]; tea. + have lenctxass := eq_context_upto_names_context_assumptions eqctx. + have lenctx := All2_length eqctx. eexists. split. + constructor; tea. epose proof (All2_length h2). congruence. @@ -963,18 +894,18 @@ Proof. eapply eq_context_extended_subst; tea. rewrite /inst_case_branch_context. eapply eq_context_upto_subst_context; tc. - eapply eq_context_upto_univ_subst_instance'. - 7,8:tea. all:tc. apply e. + eapply eq_context_upto_names_subst_instance. + 4,5:tea. all:tc. apply e. now eapply All2_rev, e. } now eapply All2_rev, All2_skipn. - apply eq_term_upto_univ_napp_mkApps_l_inv in e as [? [? [[h1 h2] h3]]]. subst. dependent destruction h1. unfold unfold_fix in H. case_eq (nth_error mfix idx) ; - try (intros e ; rewrite e in H ; discriminate H). - intros d e. rewrite e in H. inversion H. subst. clear H. - eapply All2_nth_error_Some in a as hh ; try eassumption. - destruct hh as [d' [e' [[[? ?] erarg] eann]]]. + try (intros hnth ; rewrite hnth in H ; discriminate H). + intros d hnth. rewrite hnth in H. inversion H. subst. clear H. + eapply All2_nth_error_Some in e as hh ; try eassumption. + destruct hh as [d' [e' (? & ? & erarg & eann)]]. unfold is_constructor in H0. case_eq (nth_error args (rarg d)) ; try (intros bot ; rewrite bot in H0 ; discriminate H0). @@ -989,9 +920,9 @@ Proof. eapply isConstruct_app_eq_term_l ; eassumption. + eapply eq_term_upto_univ_napp_mkApps. * eapply eq_term_upto_univ_substs ; eauto. - -- eapply (eq_term_upto_univ_leq _ _ _ 0) ; eauto with arith. + -- eapply (eq_term_upto_univ_leq _ _ _ _ 0) ; eauto with arith. -- unfold fix_subst. - apply All2_length in a as el. rewrite <- el. + apply All2_length in e as el. rewrite <- el. generalize #|mfix|. intro n. induction n. ++ constructor. @@ -1003,18 +934,18 @@ Proof. dependent destruction h1. unfold unfold_cofix in H. destruct (nth_error mfix idx) eqn:hnth; noconf H. - eapply All2_nth_error_Some in a0 as hh ; tea. - destruct hh as [d' [e' [[[? ?] erarg] eann]]]. + eapply All2_nth_error_Some in e0 as hh ; tea. + destruct hh as [d' [e' (? & ? & erarg & eann)]]. eexists. split. + eapply red_cofix_case. unfold unfold_cofix. rewrite e'. reflexivity. + constructor. all: eauto. eapply eq_term_upto_univ_mkApps. all: eauto. eapply eq_term_upto_univ_substs ; eauto; try exact _. - eapply (eq_term_upto_univ_leq _ _ _ 0); auto with arith. - typeclasses eauto. + eapply (eq_term_upto_univ_leq _ _ _ _ 0); auto with arith. + 1,2: typeclasses eauto. unfold cofix_subst. - apply All2_length in a0 as el. rewrite <- el. + apply All2_length in e0 as el. rewrite <- el. generalize #|mfix|. intro n. induction n. * constructor. @@ -1025,20 +956,20 @@ Proof. dependent destruction h1. unfold unfold_cofix in H. case_eq (nth_error mfix idx) ; - try (intros e ; rewrite e in H ; discriminate H). - intros d e. rewrite e in H. inversion H. subst. clear H. + try (intros hnth ; rewrite hnth in H ; discriminate H). + intros d hnth. rewrite hnth in H. inversion H. subst. clear H. eapply All2_nth_error_Some in e as hh ; try eassumption. - destruct hh as [d' [e' [[[? ?] erarg] eann]]]. + destruct hh as [d' [e' (? & ? & erarg & eann)]]. eexists. split. + eapply red_cofix_proj. unfold unfold_cofix. rewrite e'. reflexivity. + constructor. eapply eq_term_upto_univ_mkApps. all: eauto. eapply eq_term_upto_univ_substs ; eauto; try exact _. - eapply (eq_term_upto_univ_leq _ _ _ 0); auto with arith. - typeclasses eauto. + eapply (eq_term_upto_univ_leq _ _ _ _ 0); auto with arith. + 1,2: typeclasses eauto. unfold cofix_subst. - apply All2_length in a as el. rewrite <- el. + apply All2_length in e as el. rewrite <- el. generalize #|mfix|. intro n. induction n. * constructor. @@ -1047,7 +978,7 @@ Proof. - dependent destruction e. eexists. split. + econstructor. all: eauto. - + eapply (eq_term_upto_univ_leq _ _ _ 0); tas. auto. auto with arith. + + eapply (eq_term_upto_univ_leq _ _ _ _ 0); tas. auto. auto with arith. now apply eq_term_upto_univ_subst_instance. - dependent destruction e. apply eq_term_upto_univ_mkApps_l_inv in e as [? [? [[h1 h2] h3]]]. subst. @@ -1057,52 +988,46 @@ Proof. eexists. split. + constructor. eassumption. + eapply eq_term_upto_univ_leq ; eauto. - eapply eq_term_eq_term_napp; auto. typeclasses eauto. + eapply eq_term_eq_term_napp; auto. - dependent destruction e. edestruct IHh as [? [? ?]] ; [ .. | eassumption | ] ; eauto. clear h. lazymatch goal with | r : red1 _ (?Γ,, vdef ?na ?a ?A) ?u ?v, - e1 : eq_term_upto_univ _ _ _ ?A ?B, - e2 : eq_term_upto_univ _ _ _ ?a ?b + e1 : eq_term_upto_univ _ _ _ _ ?A ?B, + e2 : eq_term_upto_univ _ _ _ _ ?a ?b |- _ => let hh := fresh "hh" in eapply red1_eq_context_upto_l in r as hh ; revgoals ; [ constructor (* with (nb := na) *) ; [ - eapply (eq_context_upto_refl _ Re Re) ; eauto + eapply (eq_context_upto_refl _ _ _ Conv) ; eauto ; tc | econstructor; tea ] - | reflexivity - | assumption - | assumption - | assumption - | assumption - | destruct hh as [? [? ?]] - ] + | tc ..]; + destruct hh as [? [? ?]] end. eexists. split. + eapply letin_red_body ; eauto. + constructor ; eauto. - eapply eq_term_upto_univ_trans ; eauto. + eapply eq_term_upto_univ_trans ; eauto ; tc. eapply eq_term_upto_univ_leq ; eauto. - dependent destruction e. destruct e as [? [? [? ?]]]. eapply OnOne2_prod_inv in X as [_ X]. assert (h : ∑ args, OnOne2 (red1 Σ Γ) (pparams p') args * - All2 (eq_term_upto_univ Σ' Re Re) params' args + All2 (eq_term_upto_univ Σ' cmp_universe cmp_sort Conv) params' args ). { destruct p, p' as []; cbn in *. - induction X in a0, pparams, pparams0, X |- *. - - depelim a0. - eapply p in e as hh ; eauto. + induction X in a, pparams, pparams0, X |- *. + - depelim a. + eapply p in e as hh ; eauto; tc. destruct hh as [? [? ?]]. eexists. split. + constructor; tea. + constructor. all: eauto. - + tc. - - depelim a0. - destruct (IHX _ a0) as [? [? ?]]. + - depelim a. + destruct (IHX _ a) as [? [? ?]]. eexists. split. + eapply OnOne2_tl. eassumption. + constructor. all: eauto. @@ -1117,12 +1042,12 @@ Proof. eapply IHh in e => //. destruct e as [v' [red eq]]. eapply red1_eq_context_upto_l in red. - 7:{ eapply eq_context_upto_cat. + 6:{ eapply eq_context_upto_cat. 2:{ instantiate (1:=PCUICCases.inst_case_predicate_context p'). rewrite /inst_case_predicate_context /inst_case_context. eapply eq_context_upto_subst_context; tc. - eapply eq_context_upto_univ_subst_instance'. - 7,8:tea. all:tc. + eapply eq_context_upto_names_subst_instance. + 4,5:tea. all:tc. now eapply All2_rev. } eapply eq_context_upto_refl; tc. } all:tc. @@ -1137,22 +1062,19 @@ Proof. eapply OnOne2_prod_assoc in X as [_ X]. assert (h : ∑ brs0, OnOne2 (fun br br' => - on_Trel_eq (red1 Σ (Γ ,,, inst_case_branch_context p' br)) bbody bcontext br br') brs' brs0 * - All2 (fun x y => - eq_context_gen eq eq (bcontext x) (bcontext y) * - (eq_term_upto_univ Σ' Re Re (bbody x) (bbody y)) - )%type brs'0 brs0 + on_Trel_eq (red1 Σ (Γ ,,, inst_case_branch_context p' br)) bbody bcontext br br') brs' brs0 × + eq_branches (fun t u => eq_term_upto_univ Σ' cmp_universe cmp_sort Conv t u) brs'0 brs0 ). - { induction X in a, brs' |- *. + { induction X in e1, brs' |- *. - destruct p0 as [p2 p3]. - dependent destruction a. destruct p0 as [h1 h2]. + dependent destruction e1. destruct e1 as [h1 h2]. eapply p2 in h2 as hh ; eauto. destruct hh as [? [? ?]]. - eapply (red1_eq_context_upto_l (Re:=Re) (Rle:=Rle) (Δ := Γ ,,, inst_case_branch_context p' y)) in r; cycle -1. + eapply (red1_eq_context_upto_l (cmp_universe := cmp_universe) (cmp_sort := cmp_sort) (pb := pb) (Δ := Γ ,,, inst_case_branch_context p' y)) in r; cycle -1. { eapply eq_context_upto_cat; tea. reflexivity. rewrite /inst_case_branch_context /inst_case_context. eapply eq_context_upto_subst_context; tc. - eapply eq_context_upto_univ_subst_instance'. 7,8:tea. all:tc. + eapply eq_context_upto_names_subst_instance. 4,5:tea. all:tc. apply e. apply All2_rev, e. } all:tc. destruct r as [v' [redv' eqv']]. @@ -1162,8 +1084,8 @@ Proof. + constructor. all: eauto. split ; eauto. cbn. transitivity (bcontext hd) ; eauto. now rewrite p3. simpl. now transitivity x. - - dependent destruction a. - destruct (IHX _ a) as [? [? ?]]. + - dependent destruction e1. + destruct (IHX _ e2) as [? [? ?]]. eexists. split. + eapply OnOne2_tl. eassumption. + constructor. all: eauto. @@ -1176,17 +1098,16 @@ Proof. - dependent destruction e. assert (h : ∑ args, OnOne2 (red1 Σ Γ) args' args * - All2 (eq_term_upto_univ Σ' Re Re) l' args + All2 (eq_term_upto_univ Σ' cmp_universe cmp_sort Conv) l' args ). { induction X in a, args' |- *. - destruct p as [p1 p2]. dependent destruction a. - eapply p2 in e as hh ; eauto. + eapply p2 in e as hh ; eauto; tc. destruct hh as [? [? ?]]. eexists. split. + constructor. eassumption. + constructor. all: eauto. - + tc. - dependent destruction a. destruct (IHX _ a) as [? [? ?]]. eexists. split. @@ -1203,18 +1124,14 @@ Proof. red1 Σ Γ d0.(dtype) d1.(dtype) × (d0.(dname), d0.(dbody), d0.(rarg)) = (d1.(dname), d1.(dbody), d1.(rarg)) - ) mfix' mfix * - All2 (fun x y => - eq_term_upto_univ Σ' Re Re x.(dtype) y.(dtype) * - eq_term_upto_univ Σ' Re Re x.(dbody) y.(dbody) * - (x.(rarg) = y.(rarg)) * - eq_binder_annot (dname x) (dname y))%type mfix1 mfix + ) mfix' mfix × + eq_mfixpoint (eq_term_upto_univ Σ' cmp_universe cmp_sort Conv) mfix1 mfix ). - { induction X in a, mfix' |- *. + { induction X in e, mfix' |- *. - destruct p as [[p1 p2] p3]. - dependent destruction a. - destruct p as [[[h1 h2] h3] h4]. - eapply p2 in h1 as hh ; eauto. + dependent destruction e. + destruct p as (h1 & h2 & h3 & h4). + eapply p2 in h1 as hh ; eauto; tc. destruct hh as [? [? ?]]. eexists. split. + constructor. @@ -1223,9 +1140,8 @@ Proof. + constructor. all: eauto. simpl. inversion p3. repeat split ; eauto. - + tc. - - dependent destruction a. destruct p as [[[h1 h2] h3] h4]. - destruct (IHX _ a) as [? [? ?]]. + - dependent destruction e. destruct p as (h1 & h2 & h3 & h4). + destruct (IHX _ e) as [? [? ?]]. eexists. split. + eapply OnOne2_tl. eassumption. + constructor. all: eauto. @@ -1240,83 +1156,46 @@ Proof. red1 Σ (Γ ,,, fix_context mfix0) x.(dbody) y.(dbody) × (dname x, dtype x, rarg x) = (dname y, dtype y, rarg y) ) mfix' mfix * - All2 (fun x y => - eq_term_upto_univ Σ' Re Re x.(dtype) y.(dtype) * - eq_term_upto_univ Σ' Re Re x.(dbody) y.(dbody) * - (x.(rarg) = y.(rarg)) * - eq_binder_annot (dname x) (dname y)) mfix1 mfix - ). - { revert mfix' a. - refine (OnOne2_ind_l _ (fun L x y => (red1 Σ (Γ ,,, fix_context L) (dbody x) (dbody y) - × (forall Rle napp (u' : term), - RelationClasses.Reflexive Re -> - RelationClasses.Reflexive Rle -> - RelationClasses.Transitive Re -> - RelationClasses.Transitive Rle -> - SubstUnivPreserving Re -> - SubstUnivPreserving Rle -> - (forall u u'0 : Universe.t, Re u u'0 -> Rle u u'0) -> - eq_term_upto_univ_napp Σ' Re Rle napp (dbody x) u' -> - ∑ v' : term, - red1 Σ (Γ ,,, fix_context L) u' v' - × eq_term_upto_univ_napp Σ' Re Rle napp (dbody y) v' )) - × (dname x, dtype x, rarg x) = (dname y, dtype y, rarg y)) (fun L mfix0 mfix1 o => forall mfix', All2 - (fun x y : def term => - ((eq_term_upto_univ Σ' Re Re (dtype x) (dtype y) - × eq_term_upto_univ Σ' Re Re (dbody x) (dbody y)) × - rarg x = rarg y) * eq_binder_annot (dname x) (dname y)) mfix0 mfix' -> ∑ mfix : list (def term), - ( OnOne2 - (fun x y : def term => - red1 Σ (Γ ,,, fix_context L) (dbody x) (dbody y) - × (dname x, dtype x, rarg x) = (dname y, dtype y, rarg y)) mfix' mfix ) * - ( All2 - (fun x y : def term => - ((eq_term_upto_univ Σ' Re Re (dtype x) (dtype y) - × eq_term_upto_univ Σ' Re Re (dbody x) (dbody y)) × - (rarg x = rarg y)) * eq_binder_annot (dname x) (dname y)) mfix1 mfix )) _ _ _ _ X). - - clear X. intros L x y l [[p1 p2] p3] mfix' h. - dependent destruction h. destruct p as [[[h1 h2] h3] h4]. - eapply p2 in h2 as hh ; eauto. + eq_mfixpoint (fun t u => eq_term_upto_univ Σ' cmp_universe cmp_sort Conv t u) mfix1 mfix + ). + { set (Ξ := fix_context _) in *. clearbody Ξ. + induction X in e, mfix' |- *. + - destruct p as [[p1 p2] p3]. + dependent destruction e. + destruct p as (h1 & h2 & h3 & h4). + eapply p2 in h2 as hh ; eauto; tc. destruct hh as [? [? ?]]. eexists. split. - + constructor. constructor. + + constructor. instantiate (1 := mkdef _ _ _ _ _). - simpl. eauto. reflexivity. - + constructor. constructor; simpl. all: eauto. - inversion p3. - simpl. repeat split ; eauto. destruct y0. simpl in *. - congruence. - - clear X. intros L x l l' h ih mfix' ha. - dependent destruction ha. destruct p as [[h1 h2] h3]. - destruct (ih _ ha) as [? [? ?]]. + simpl. eauto. + + constructor. all: eauto. + simpl. inversion p3. + repeat split ; eauto. + - dependent destruction e. destruct p as (h1 & h2 & h3 & h4). + destruct (IHX _ e) as [? [? ?]]. eexists. split. - + eapply OnOne2_tl. eauto. - + constructor. constructor. all: eauto. + + eapply OnOne2_tl. eassumption. + + constructor. all: eauto. } - destruct h as [mfix [? ?]]. + destruct h as [mfix [? ?]]. clear X. assert (h : ∑ mfix, OnOne2 (fun x y => red1 Σ (Γ ,,, fix_context mfix') x.(dbody) y.(dbody) × (dname x, dtype x, rarg x) = (dname y, dtype y, rarg y) ) mfix' mfix × - All2 (fun x y => - eq_term_upto_univ Σ' Re Re x.(dtype) y.(dtype) * - eq_term_upto_univ Σ' Re Re x.(dbody) y.(dbody) * - (x.(rarg) = y.(rarg)) * - eq_binder_annot (dname x) (dname y) - ) mfix1 mfix %type + eq_mfixpoint (fun t u => eq_term_upto_univ Σ' cmp_universe cmp_sort Conv t u) mfix1 mfix ). - { clear X. - assert (hc : eq_context_upto Σ' - Re Rle + { assert (hc : eq_context_upto Σ' + cmp_universe cmp_sort pb (Γ ,,, fix_context mfix0) (Γ ,,, fix_context mfix') ). { eapply eq_context_upto_cat. - - eapply eq_context_upto_refl; assumption. - - clear -he hle tRe tRle hR a. induction a. + - eapply eq_context_upto_refl; tc. + - clear o. induction e. + constructor. - + destruct r as [[[? ?] ?] ?]. + + destruct r as (? & ? & ? & ?). eapply All2_eq_context_upto. eapply All2_rev. eapply All2_mapi. @@ -1328,26 +1207,26 @@ Proof. eapply eq_term_upto_univ_impl; eauto. all:typeclasses eauto. * eapply All2_impl ; eauto. - intros ? ? [[[? ?] ?] ?] i. split; [split|]. + intros ? ? (? & ? & ? & ?) i. split; [split|]. -- assumption. -- cbn. constructor. -- cbn. eapply eq_term_upto_univ_lift. eapply eq_term_upto_univ_impl; eauto. - typeclasses eauto. + all: typeclasses eauto. } - clear a. + clear e. eapply OnOne2_impl_exist_and_All ; try eassumption. - clear o a0. - intros x x' y [r e] [[[? ?] ?] ?]. - inversion e. clear e. + clear o e0. + intros x x' y [r e] (? & ? & ? & ?). + noconf e. eapply red1_eq_context_upto_l in r as [? [? ?]]. - 7: eassumption. all: tea. + 6: eassumption. all: tc. eexists. constructor. - instantiate (1 := mkdef _ _ _ _ _). simpl. + instantiate (1 := mkdef _ _ _ _ _). all: simpl. intuition eauto. intuition eauto. - - rewrite H1. eauto. - - eapply eq_term_upto_univ_trans; tea. + - rewrite H0. eauto. + - eapply eq_term_upto_univ_trans; tea; tc. - etransitivity ; eauto. - now simpl. } @@ -1362,17 +1241,13 @@ Proof. (d0.(dname), d0.(dbody), d0.(rarg)) = (d1.(dname), d1.(dbody), d1.(rarg)) ) mfix' mfix * - All2 (fun x y => - eq_term_upto_univ Σ' Re Re x.(dtype) y.(dtype) * - eq_term_upto_univ Σ' Re Re x.(dbody) y.(dbody) * - (x.(rarg) = y.(rarg)) * - eq_binder_annot (dname x) (dname y))%type mfix1 mfix + eq_mfixpoint (fun t u => eq_term_upto_univ Σ' cmp_universe cmp_sort Conv t u) mfix1 mfix ). - { induction X in a, mfix' |- *. + { induction X in e, mfix' |- *. - destruct p as [[p1 p2] p3]. - dependent destruction a. - destruct p as [[[h1 h2] h3] h4]. - eapply p2 in h1 as hh ; eauto. + dependent destruction e. + destruct p as (h1 & h2 & h3 & h4). + eapply p2 in h1 as hh ; eauto; tc. destruct hh as [? [? ?]]. eexists. split. + constructor. @@ -1381,9 +1256,8 @@ Proof. + constructor. all: eauto. simpl. inversion p3. repeat split ; eauto. - + tc. - - dependent destruction a. destruct p as [[h1 h2] h3]. - destruct (IHX _ a) as [? [? ?]]. + - dependent destruction e. destruct p as (h1 & h2 & h3 & h4). + destruct (IHX _ e) as [? [? ?]]. eexists. split. + eapply OnOne2_tl. eassumption. + constructor. all: eauto. @@ -1398,83 +1272,46 @@ Proof. red1 Σ (Γ ,,, fix_context mfix0) x.(dbody) y.(dbody) × (dname x, dtype x, rarg x) = (dname y, dtype y, rarg y) ) mfix' mfix * - All2 (fun x y => - eq_term_upto_univ Σ' Re Re x.(dtype) y.(dtype) * - eq_term_upto_univ Σ' Re Re x.(dbody) y.(dbody) * - (x.(rarg) = y.(rarg)) * - eq_binder_annot (dname x) (dname y) - ) mfix1 mfix + eq_mfixpoint (fun t u => eq_term_upto_univ Σ' cmp_universe cmp_sort Conv t u) mfix1 mfix ). - { revert mfix' a. - refine (OnOne2_ind_l _ (fun L x y => (red1 Σ (Γ ,,, fix_context L) (dbody x) (dbody y) - × (forall Rle napp (u' : term), - RelationClasses.Reflexive Re -> - RelationClasses.Reflexive Rle -> - RelationClasses.Transitive Re -> - RelationClasses.Transitive Rle -> - SubstUnivPreserving Re -> - SubstUnivPreserving Rle -> - (forall u u'0 : Universe.t, Re u u'0 -> Rle u u'0) -> - eq_term_upto_univ_napp Σ' Re Rle napp (dbody x) u' -> - ∑ v' : term, - red1 Σ (Γ ,,, fix_context L) u' v' - × eq_term_upto_univ_napp Σ' Re Rle napp (dbody y) v')) - × (dname x, dtype x, rarg x) = (dname y, dtype y, rarg y)) (fun L mfix0 mfix1 o => forall mfix', All2 - (fun x y : def term => - ((eq_term_upto_univ Σ' Re Re (dtype x) (dtype y) - × eq_term_upto_univ Σ' Re Re (dbody x) (dbody y)) × - rarg x = rarg y) * eq_binder_annot (dname x) (dname y)) mfix0 mfix' -> ∑ mfix : list (def term), - ( OnOne2 - (fun x y : def term => - red1 Σ (Γ ,,, fix_context L) (dbody x) (dbody y) - × (dname x, dtype x, rarg x) = (dname y, dtype y, rarg y)) mfix' mfix ) * - ( All2 - (fun x y : def term => - ((eq_term_upto_univ Σ' Re Re (dtype x) (dtype y) - × eq_term_upto_univ Σ' Re Re (dbody x) (dbody y)) × - rarg x = rarg y) * eq_binder_annot (dname x) (dname y)) mfix1 mfix )) _ _ _ _ X). - - clear X. intros L x y l [[p1 p2] p3] mfix' h. - dependent destruction h. destruct p as [[[h1 h2] h3] h4]. - eapply p2 in h2 as hh ; eauto. + { set (Ξ := fix_context _) in *. clearbody Ξ. + induction X in e, mfix' |- *. + - destruct p as [[p1 p2] p3]. + dependent destruction e. + destruct p as (h1 & h2 & h3 & h4). + eapply p2 in h2 as hh ; eauto; tc. destruct hh as [? [? ?]]. - noconf p3. hnf in H. noconf H. - eexists. split; simpl. + eexists. split. + constructor. instantiate (1 := mkdef _ _ _ _ _). simpl. eauto. + constructor. all: eauto. - simpl. repeat split ; eauto; congruence. - - clear X. intros L x l l' h ih mfix' ha. - dependent destruction ha. destruct p as [[h1 h2] h3]. - destruct (ih _ ha) as [? [? ?]]. + simpl. inversion p3. + repeat split ; eauto. + - dependent destruction e. destruct p as (h1 & h2 & h3 & h4). + destruct (IHX _ e) as [? [? ?]]. eexists. split. - + eapply OnOne2_tl. eauto. + + eapply OnOne2_tl. eassumption. + constructor. all: eauto. } - destruct h as [mfix [? ?]]. + destruct h as [mfix [? ?]]. clear X. assert (h : ∑ mfix, OnOne2 (fun x y => red1 Σ (Γ ,,, fix_context mfix') x.(dbody) y.(dbody) × (dname x, dtype x, rarg x) = (dname y, dtype y, rarg y) ) mfix' mfix × - All2 (fun x y => - eq_term_upto_univ Σ' Re Re x.(dtype) y.(dtype) * - eq_term_upto_univ Σ' Re Re x.(dbody) y.(dbody) * - (x.(rarg) = y.(rarg)) * - eq_binder_annot (dname x) (dname y) - ) mfix1 mfix + eq_mfixpoint (fun t u => eq_term_upto_univ Σ' cmp_universe cmp_sort Conv t u) mfix1 mfix ). - { clear X. - assert (hc : eq_context_upto Σ' - Re Rle + { assert (hc : eq_context_upto Σ' + cmp_universe cmp_sort pb (Γ ,,, fix_context mfix0) (Γ ,,, fix_context mfix') ). { eapply eq_context_upto_cat. - - eapply eq_context_upto_refl; assumption. - - clear -he he' hle hle' hR a. induction a. + - eapply eq_context_upto_refl; tc. + - clear o. induction e. + constructor. - + destruct r as [[[? ?] ?] ?]. + + destruct r as (? & ? & ? & ?). eapply All2_eq_context_upto. eapply All2_rev. eapply All2_mapi. @@ -1486,25 +1323,25 @@ Proof. eapply eq_term_upto_univ_impl; eauto. all:typeclasses eauto. * eapply All2_impl ; eauto. - intros ? ? [[[? ?] ?] ?] i. split; [split|]. + intros ? ? (? & ? & ? & ?) i. split; [split|]. -- assumption. -- cbn. constructor. -- cbn. eapply eq_term_upto_univ_lift. eapply eq_term_upto_univ_impl; eauto. all:typeclasses eauto. } - clear a. + clear e. eapply OnOne2_impl_exist_and_All ; try eassumption. - clear o a0. - intros x x' y [r e] [[? ?] ?]. - inversion e. clear e. + clear o e0. + intros x x' y [r e] (? & ? & ? & ?). + noconf e. eapply red1_eq_context_upto_l in r as [? [? ?]]. - 7: eassumption. all: tea. + 6: eassumption. all: tc. eexists. instantiate (1 := mkdef _ _ _ _ _). simpl. intuition eauto. - - rewrite H1. eauto. - - eapply eq_term_upto_univ_trans ; tea. + - rewrite H0. eauto. + - eapply eq_term_upto_univ_trans ; tea; tc. - etransitivity ; eauto. - congruence. } @@ -1515,19 +1352,18 @@ Proof. - depelim e. depelim o. assert (h : ∑ args, OnOne2 (red1 Σ Γ) (array_value a') args * - All2 (eq_term_upto_univ Σ' Re Re) value args + All2 (eq_term_upto_univ Σ' cmp_universe cmp_sort Conv) value args ). - { revert X a0. clear r e e0. + { revert X a0. clear c e e0. generalize (array_value arr), (array_value a'). intros l l' X a. induction X in l', a |- *. - destruct p as [p1 p2]. dependent destruction a. - eapply p2 in e as hh ; eauto. + eapply p2 in e as hh ; eauto; tc. destruct hh as [? [? ?]]. eexists. split. + constructor. eassumption. + constructor. all:eauto. - + tc. - dependent destruction a. destruct (IHX _ a) as [? [? ?]]. eexists. split. @@ -1548,123 +1384,95 @@ Proof. + do 2 constructor; eauto. Qed. -Lemma Forall2_flip {A} (R : A -> A -> Prop) (x y : list A) : - Forall2 (flip R) y x -> Forall2 R x y. -Proof. - induction 1; constructor; auto. -Qed. - -Lemma R_universe_instance_flip R u u' : - R_universe_instance (flip R) u' u -> - R_universe_instance R u u'. -Proof. - unfold R_universe_instance. - apply Forall2_flip. -Qed. - -Lemma eq_context_upto_flip {Σ Re Rle Γ Δ} - `{!RelationClasses.Reflexive Re} - `{!RelationClasses.Symmetric Re} - `{!RelationClasses.Transitive Re} - `{!RelationClasses.Reflexive Rle} - `{!RelationClasses.Transitive Rle} - `{!RelationClasses.subrelation Re Rle} : - eq_context_upto Σ Re Rle Γ Δ -> - eq_context_upto Σ Re (flip Rle) Δ Γ. -Proof. - induction 1; constructor; auto; depelim p; constructor; auto. - - now symmetry. - - now eapply eq_term_upto_univ_napp_flip; try typeclasses eauto. - - now symmetry. - - now eapply eq_term_upto_univ_napp_flip; try typeclasses eauto. - - now eapply eq_term_upto_univ_napp_flip; try typeclasses eauto. -Qed. - -Lemma red1_eq_context_upto_r {Σ Σ' Re Rle Γ Δ u v} : - RelationClasses.Equivalence Re -> - RelationClasses.PreOrder Rle -> - SubstUnivPreserving Re -> - SubstUnivPreserving Rle -> - RelationClasses.subrelation Re Rle -> +Lemma red1_eq_context_upto_r {Σ Σ' cmp_universe cmp_sort pb Γ Δ u v} : + RelationClasses.PreOrder (cmp_universe Conv) -> + RelationClasses.Reflexive (cmp_universe pb) -> + RelationClasses.PreOrder (cmp_sort Conv) -> + RelationClasses.Reflexive (cmp_sort pb) -> red1 Σ Γ u v -> - eq_context_upto Σ' Re Rle Δ Γ -> + eq_context_upto Σ' cmp_universe cmp_sort pb Δ Γ -> ∑ v', red1 Σ Δ u v' * - eq_term_upto_univ Σ' Re Re v' v. + eq_term_upto_univ Σ' cmp_universe cmp_sort Conv v' v. Proof. intros. - destruct (@red1_eq_context_upto_l Σ Σ' (flip Rle) Re Γ Δ u v); auto; try typeclasses eauto. - - intros x; red; reflexivity. - - intros s u1 u2 Ru. red. apply R_universe_instance_flip in Ru. now apply H2. - - intros x y rxy; red. now symmetry in rxy. - - now apply eq_context_upto_flip. - - exists x. intuition auto. - now eapply eq_term_upto_univ_sym. + destruct (@red1_eq_context_upto_l Σ Σ' (fun pb => flip (cmp_universe pb)) (fun pb => flip (cmp_sort pb)) pb Γ Δ u v) as (v' & r & e); tas. + - intro x. red. reflexivity. + - intro x. red. reflexivity. + - eapply eq_context_upto_flip; [..|eassumption]; tc. + - exists v'; split; tas. + eapply eq_term_upto_univ_napp_flip; [..|eassumption]; tc. Qed. -Lemma red1_eq_term_upto_univ_r {Σ Σ' Re Rle napp Γ u v u'} : - RelationClasses.Reflexive Re -> - RelationClasses.Reflexive Rle -> - RelationClasses.Symmetric Re -> - RelationClasses.Transitive Re -> - RelationClasses.Transitive Rle -> - SubstUnivPreserving Re -> - SubstUnivPreserving Rle -> - RelationClasses.subrelation Re Rle -> - eq_term_upto_univ_napp Σ' Re Rle napp u' u -> +Lemma red1_eq_term_upto_univ_r {Σ Σ' cmp_universe cmp_sort pb napp Γ u v u'} : + RelationClasses.PreOrder (cmp_universe Conv) -> + RelationClasses.PreOrder (cmp_universe pb) -> + RelationClasses.PreOrder (cmp_sort Conv) -> + RelationClasses.PreOrder (cmp_sort pb) -> + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe pb) -> + RelationClasses.subrelation (cmp_sort Conv) (cmp_sort pb) -> + SubstUnivPreserving (cmp_universe Conv) (cmp_universe Conv) -> + SubstUnivPreserving (cmp_universe Conv) (cmp_sort Conv) -> + SubstUnivPreserving (cmp_universe Conv) (cmp_sort pb) -> + eq_term_upto_univ_napp Σ' cmp_universe cmp_sort pb napp u' u -> red1 Σ Γ u v -> ∑ v', red1 Σ Γ u' v' × - eq_term_upto_univ_napp Σ' Re Rle napp v' v. + eq_term_upto_univ_napp Σ' cmp_universe cmp_sort pb napp v' v. Proof. - intros he he' hse hte htle sre srle hR h uv. - destruct (@red1_eq_term_upto_univ_l Σ Σ' Re (flip Rle) napp Γ u v u'); auto. - - now eapply flip_Transitive. + intros preorder_univ_conv preorder_sort_pb preorder_sort_conv preoder_sort_pb sub_univ sub_sort hsubst_univ hsubst_sort_conv hsubst_sort_pb h uv. + destruct (@red1_eq_term_upto_univ_l Σ Σ' (fun pb => flip (cmp_universe pb)) (fun pb => flip (cmp_sort pb)) pb napp Γ u v u') as (v' & r & e). + all: eauto using RelationClasses.flip_PreOrder. + 1,2: intros ??; unfold flip; cbn; eauto. + - red. intros s u1 u2 ru. + eapply cmp_universe_instance_flip in ru; cbnr. + now apply hsubst_univ. - red. intros s u1 u2 ru. - apply R_universe_instance_flip in ru. - now apply srle. - - intros x y X. symmetry in X. apply hR in X. apply X. - - eapply eq_term_upto_univ_napp_flip; eauto. - - exists x. intuition auto. - eapply (@eq_term_upto_univ_napp_flip Σ' Re (flip Rle) Rle); eauto. - + now eapply flip_Transitive. - + unfold flip. intros ? ? H. symmetry in H. eauto. + eapply cmp_universe_instance_flip in ru; cbnr. + now apply hsubst_sort_conv. + - red. intros s u1 u2 ru. + eapply cmp_universe_instance_flip in ru; cbnr. + now apply hsubst_sort_pb. + - eapply eq_term_upto_univ_napp_flip; [..|eassumption]. all: reflexivity. + - exists v'. split; tas. + eapply eq_term_upto_univ_napp_flip; [..|eassumption]; tc. Qed. Section RedEq. Context (Σ : global_env_ext). - Context {Re Rle : Universe.t -> Universe.t -> Prop} - {refl : RelationClasses.Reflexive Re} - {refl': RelationClasses.Reflexive Rle} - {pres : SubstUnivPreserving Re} - {pres' : SubstUnivPreserving Rle} - {sym : RelationClasses.Symmetric Re} - {trre : RelationClasses.Transitive Re} - {trle : RelationClasses.Transitive Rle}. - Context (inclre : RelationClasses.subrelation Re Rle). - - Lemma red_eq_term_upto_univ_r {Γ T V U} : - eq_term_upto_univ Σ Re Rle T U -> red Σ Γ U V -> - ∑ T', red Σ Γ T T' * eq_term_upto_univ Σ Re Rle T' V. - Proof using inclre pres pres' refl refl' sym trle trre. + Context {cmp_universe : conv_pb -> Universe.t -> Universe.t -> Prop} {cmp_sort : conv_pb -> sort -> sort -> Prop} {pb : conv_pb} + {preorder_univ_conv : RelationClasses.PreOrder (cmp_universe Conv)} + {preorder_univ_pb : RelationClasses.PreOrder (cmp_universe pb)} + {preorder_sort_conv : RelationClasses.PreOrder (cmp_sort Conv)} + {preorder_sort_pb : RelationClasses.PreOrder (cmp_sort pb)} + {sub_univ : RelationClasses.subrelation (cmp_universe Conv) (cmp_universe pb)} + {sub_sort : RelationClasses.subrelation (cmp_sort Conv) (cmp_sort pb)} + {hsubst_univ : SubstUnivPreserving (cmp_universe Conv) (cmp_universe Conv)} + {hsubst_sort_conv : SubstUnivPreserving (cmp_universe Conv) (cmp_sort Conv)} + {hsubst_sort_pb : SubstUnivPreserving (cmp_universe Conv) (cmp_sort pb)}. + + Lemma red_eq_term_upto_univ_l {Σ' Γ u v u'} : + eq_term_upto_univ Σ' cmp_universe cmp_sort pb u u' -> + red Σ Γ u v -> + ∑ v', + red Σ Γ u' v' * eq_term_upto_univ Σ' cmp_universe cmp_sort pb v v'. + Proof using preorder_univ_conv preorder_univ_pb preorder_sort_conv preorder_sort_conv preorder_sort_pb sub_univ sub_sort hsubst_univ hsubst_sort_conv hsubst_sort_pb. intros eq r. - induction r in T, eq |- *. - - eapply red1_eq_term_upto_univ_r in eq as [v' [r' eq']]; eauto. - - exists T; split; eauto. + induction r in u', eq |- *. + - eapply red1_eq_term_upto_univ_l in eq as [v' [r' eq']]; eauto. + - exists u'. split; auto. - case: (IHr1 _ eq) => T' [r' eq']. case: (IHr2 _ eq') => T'' [r'' eq'']. exists T''. split=>//. now transitivity T'. Qed. - Lemma red_eq_term_upto_univ_l {Γ u v u'} : - eq_term_upto_univ Σ Re Rle u u' -> + Lemma red_eq_term_upto_univ_r {Σ' Γ u v u'} : + eq_term_upto_univ Σ' cmp_universe cmp_sort pb u' u -> red Σ Γ u v -> - ∑ v', - red Σ Γ u' v' * - eq_term_upto_univ Σ Re Rle v v'. - Proof using inclre pres pres' refl refl' trle trre. + ∑ v', red Σ Γ u' v' * eq_term_upto_univ Σ' cmp_universe cmp_sort pb v' v. + Proof using preorder_univ_conv preorder_univ_pb preorder_sort_conv preorder_sort_conv preorder_sort_pb sub_univ sub_sort hsubst_univ hsubst_sort_conv hsubst_sort_pb. intros eq r. induction r in u', eq |- *. - - eapply red1_eq_term_upto_univ_l in eq as [v' [r' eq']]; eauto. + - eapply red1_eq_term_upto_univ_r in eq as [v' [r' eq']]; eauto. - exists u'. split; auto. - case: (IHr1 _ eq) => T' [r' eq']. case: (IHr2 _ eq') => T'' [r'' eq'']. @@ -1673,6 +1481,57 @@ Section RedEq. Qed. End RedEq. +Section RedEqContext. + Context (Σ : global_env_ext). + Context {cmp_universe : conv_pb -> Universe.t -> Universe.t -> Prop} {cmp_sort : conv_pb -> sort -> sort -> Prop} {pb : conv_pb} + {preorder_univ_conv : RelationClasses.PreOrder (cmp_universe Conv)} + {preorder_univ_pb : RelationClasses.PreOrder (cmp_universe pb)} + {preorder_sort_conv : RelationClasses.PreOrder (cmp_sort Conv)} + {preorder_sort_pb : RelationClasses.PreOrder (cmp_sort pb)} + {sub_univ : RelationClasses.subrelation (cmp_universe Conv) (cmp_universe pb)} + {sub_sort : RelationClasses.subrelation (cmp_sort Conv) (cmp_sort pb)} + {hsubst_univ : SubstUnivPreserving (cmp_universe Conv) (cmp_universe Conv)} + {hsubst_sort_conv : SubstUnivPreserving (cmp_universe Conv) (cmp_sort Conv)} + {hsubst_sort_pb : SubstUnivPreserving (cmp_universe Conv) (cmp_sort pb)}. + + Lemma red_eq_context_upto_l {Γ Δ} {u} {v} : + eq_context_upto Σ cmp_universe cmp_sort pb Γ Δ -> + red Σ Γ u v -> + ∑ v', + red Σ Δ u v' * + eq_term_upto_univ Σ cmp_universe cmp_sort Conv v v'. + Proof using preorder_univ_conv preorder_univ_pb preorder_sort_conv preorder_sort_conv preorder_sort_pb sub_univ sub_sort hsubst_univ hsubst_sort_conv hsubst_sort_pb. + intros eq r. + induction r. + - eapply red1_eq_context_upto_l in eq as [v' [r' eq']]; eauto; tc. + - exists x. split; auto. reflexivity. + - case: IHr1 => T' [r' eq']. + case: IHr2 => T'' [r'' eq'']. + eapply (red_eq_term_upto_univ_l _ (pb := Conv) (u:=y) (v:=T'') (u':=T')) in r'' as (T''' & r'' & eq'''); tc; tea. + exists T'''; split. + + now transitivity T'. + + now transitivity T''. + Qed. + + Lemma red_eq_context_upto_r {Γ Δ} {u} {v} : + eq_context_upto Σ cmp_universe cmp_sort pb Δ Γ -> + red Σ Γ u v -> + ∑ v', + red Σ Δ u v' * + eq_term_upto_univ Σ cmp_universe cmp_sort Conv v' v. + Proof using preorder_univ_conv preorder_univ_pb preorder_sort_conv preorder_sort_conv preorder_sort_pb sub_univ sub_sort hsubst_univ hsubst_sort_conv hsubst_sort_pb. + intros eq r. + induction r. + - eapply red1_eq_context_upto_r in eq as [v' [r' eq']]; eauto; tc. + - exists x. split; auto. reflexivity. + - case: IHr1 => T' [r' eq']. + case: IHr2 => T'' [r'' eq'']. + eapply (red_eq_term_upto_univ_r _ (pb := Conv) (u:=y) (v:=T'') (u':=T')) in r'' as (T''' & r'' & eq'''); tc; tea. + exists T'''; split. + + now transitivity T'. + + now transitivity T''. + Qed. +End RedEqContext. Polymorphic Derive Signature for Relation.clos_refl_trans. @@ -2313,7 +2172,7 @@ Section PredRed. - depelim X1; try solve [repeat constructor]; eauto. depelim X2; cbn in H0; rtoProp. eapply red_primArray_congr; eauto. - + now eapply Universe.make_inj in e. + + now eapply Universe.make'_inj in e. + solve_all. Qed. @@ -3083,7 +2942,7 @@ Section RedConfluence. Proof using Type. move/on_free_vars_ctx_All_fold => a eqctx. apply on_free_vars_ctx_All_fold. - eapply eq_context_upto_names_gen in eqctx. + eapply All2_fold_All2 in eqctx. eapply All2_fold_All_fold_mix_left in eqctx; tea. cbn in eqctx. induction eqctx. - constructor; auto. @@ -3293,8 +3152,7 @@ Section RedConfluence. exists body'; split => //. rewrite -lift0_inst. econstructor; eauto. destruct (nth_error Δ x) eqn:hnth' => //. - eapply eq_context_upto_names_gen in eqctx'. - eapply All2_fold_nth in eqctx' as [d' [hnth'' [eqctx'' eqd]]]; tea. + eapply All2_nth_error_Some in eqctx' as [d' [hnth'' eqd]]; tea. depelim eqd. subst. noconf eq. subst. noconf eq. rewrite hnth'' //. Qed. @@ -3604,9 +3462,10 @@ Section RedConfluence. eq_context_upto_names Γ Γ' -> option_map decl_body (nth_error Γ' n) = Some d. Proof using Type. - move: Γ' n d; induction Γ; destruct n; simpl; intros; try congruence. - noconf H. depelim X. depelim c; subst; simpl => //. - depelim X. apply IHΓ; auto. + destruct nth_error as [decl|] eqn:hnth => //. + intros [= <-] eqctx. + eapply All2_nth_error_Some in eqctx as (decl' & -> & eqd); tea. + destruct eqd; reflexivity. Qed. Lemma decl_type_eq_context_upto_names Γ Γ' n d : @@ -3614,9 +3473,10 @@ Section RedConfluence. eq_context_upto_names Γ Γ' -> option_map decl_type (nth_error Γ' n) = Some d. Proof using Type. - move: Γ' n d; induction Γ; destruct n; simpl; intros; try congruence. - noconf H. depelim X. depelim c; subst; simpl => //. - depelim X. simpl. apply IHΓ; auto. + destruct nth_error as [decl|] eqn:hnth => //. + intros [= <-] eqctx. + eapply All2_nth_error_Some in eqctx as (decl' & -> & eqd); tea. + destruct eqd; reflexivity. Qed. Lemma eq_context_upto_names_app Γ Γ' Δ : @@ -3634,9 +3494,9 @@ Section RedConfluence. Proof using Type. move=> Hctx. eapply context_pres_let_bodies_red1. - eapply eq_context_upto_names_gen in Hctx. + eapply All2_fold_All2 in Hctx. eapply All2_fold_impl; tea => /= _ _ ? ? [] /=; - rewrite /pres_let_bodies /= //; intros; congruence. + rewrite /pres_let_bodies /= //. Qed. Lemma clos_rt_red1_eq_context_upto_names Γ Γ' t u : @@ -3670,7 +3530,7 @@ Section RedConfluence. induction X in X0, Δ, Δ', X1 |- *. depelim X1. depelim X0. constructor. depelim X1. depelim X0. constructor. eapply IHX; tea. - depelim r; depelim c; subst; depelim a; try constructor; eauto. + destruct a; depelim e; depelim r; subst; try constructor; eauto. 1,3:now etransitivity. all:eapply red_eq_context_upto_names; eauto. Qed. @@ -3685,7 +3545,7 @@ Section RedConfluence. induction X in X0, Δ, Δ', X1 |- *. depelim X1. depelim X0. constructor. depelim X1. depelim X0. constructor. eapply IHX; tea. - depelim r; depelim c; subst; depelim a; try constructor; eauto. + destruct a; depelim e; depelim r; subst; try constructor; eauto. 1,3:now etransitivity. all:eapply red_eq_context_upto_names; eauto. Qed. @@ -3854,32 +3714,31 @@ Section RedConfluence. End RedConfluence. (** Currently provable, but not if we add eta / sprop *) -Lemma eq_term_upto_univ_napp_on_free_vars {cf:checker_flags} {Σ : global_env} {P eq leq napp} {t u} : - eq_term_upto_univ_napp Σ eq leq napp t u -> +Lemma eq_term_upto_univ_napp_on_free_vars {cf:checker_flags} {Σ : global_env} {P cmp_universe cmp_sort pb napp} {t u} : + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp t u -> on_free_vars P t -> on_free_vars P u. Proof. - intros eqt ont. revert P t ont u eq leq napp eqt. + intros eqt ont. revert P t ont u pb napp eqt. apply: term_on_free_vars_ind; intros; depelim eqt. all:simpl; auto. all:try solve [solve_all]. - destruct e as [? [? [? ?]]]. - rewrite -(All2_fold_length a1). rewrite -(All2_length a0). + rewrite -(All2_length a). + unfold eq_branches, eq_branch in *. solve_all. rewrite test_context_k_closed_on_free_vars_ctx. eapply eq_context_upto_names_on_free_vars; tea. - now eapply eq_context_upto_names_gen in a1. rewrite test_context_k_closed_on_free_vars_ctx. - destruct a. + destruct a1. eapply eq_context_upto_names_on_free_vars; tea. - now eapply eq_context_upto_names_gen in a2. - destruct a as [hctx ihctx hb ihb]. - rewrite -(All2_fold_length a2). now eapply ihb. - - rewrite -(All2_length a). solve_all. + destruct a1 as [hctx ihctx hb ihb]. + rewrite -(All2_length a2). now eapply ihb. + - rewrite -(All2_length e). unfold eq_mfixpoint in *. solve_all. apply/andP; split; eauto. len in b2. eapply b2. eauto. - - rewrite -(All2_length a). solve_all. + - rewrite -(All2_length e). unfold eq_mfixpoint in *. solve_all. apply/andP; split; eauto. len in b2. eapply b2. eauto. - depelim o; cbn in *; solve_all. diff --git a/pcuic/theories/PCUICConsistency.v b/pcuic/theories/PCUICConsistency.v index c649d80af..ae4c67e07 100644 --- a/pcuic/theories/PCUICConsistency.v +++ b/pcuic/theories/PCUICConsistency.v @@ -19,13 +19,11 @@ From MetaCoq.PCUIC Require Import PCUICTyping PCUICEquality PCUICAst PCUICAstUti From Equations Require Import Equations. -Definition Prop_univ := Universe.of_levels (inl PropLevel.lProp). - Definition False_oib : one_inductive_body := {| ind_name := "False"; ind_indices := []; - ind_sort := Prop_univ; - ind_type := tSort Prop_univ; + ind_sort := sProp; + ind_type := tSort sProp; ind_kelim := IntoAny; ind_ctors := []; ind_projs := []; @@ -77,4 +75,4 @@ Proof. unshelve eapply declared_minductive_to_gen in Hdecl; eauto. red in Hdecl. rewrite Hdecl in typ_false'. cbn in typ_false'. inversion typ_false'. -Qed. \ No newline at end of file +Qed. diff --git a/pcuic/theories/PCUICContextConversion.v b/pcuic/theories/PCUICContextConversion.v index 43817615d..d5efe4fbd 100644 --- a/pcuic/theories/PCUICContextConversion.v +++ b/pcuic/theories/PCUICContextConversion.v @@ -391,8 +391,8 @@ Proof. now transitivity y. Qed. -Definition compare_context {cf} pb Σ := - eq_context_upto Σ (eq_universe Σ) (compare_universe pb Σ). +Definition compare_context {cf} Σ pb := + PCUICEquality.compare_context Σ Σ pb. Section ContextConversion. Context {cf : checker_flags}. @@ -404,9 +404,9 @@ Section ContextConversion. Hint Resolve conv_ctx_refl' cumul_ctx_refl' : pcuic. - Lemma fill_le {Γ : closed_context} {t u : open_term Γ} {t' u'} : - leq_term Σ.1 Σ t u -> red Σ Γ t t' -> red Σ Γ u u' -> - ∑ t'' u'', red Σ Γ t' t'' * red Σ Γ u' u'' * leq_term Σ Σ t'' u''. + Lemma fill_pb {Γ : closed_context} {pb} {t u : open_term Γ} {t' u'} : + compare_term Σ.1 Σ pb t u -> red Σ Γ t t' -> red Σ Γ u u' -> + ∑ t'' u'', red Σ Γ t' t'' * red Σ Γ u' u'' * compare_term Σ Σ pb t'' u''. Proof using wfΣ. intros tu tt' uu'. eapply red_eq_term_upto_univ_l in tu; try exact tt'. all:try tc. @@ -417,19 +417,19 @@ Section ContextConversion. exists t'', unf. intuition auto. Qed. + Lemma fill_le {Γ : closed_context} {t u : open_term Γ} {t' u'} : + leq_term Σ.1 Σ t u -> red Σ Γ t t' -> red Σ Γ u u' -> + ∑ t'' u'', red Σ Γ t' t'' * red Σ Γ u' u'' * leq_term Σ Σ t'' u''. + Proof using wfΣ. + apply fill_pb. + Qed. + Lemma fill_eq {Γ : closed_context} {t u : open_term Γ} {t' u'} : eq_term Σ.1 Σ t u -> red Σ Γ t t' -> red Σ Γ u u' -> ∑ t'' u'', red Σ Γ t' t'' * red Σ Γ u' u'' * eq_term Σ.1 Σ t'' u''. Proof using wfΣ. - intros tu tt' uu'. - pose proof tu as tu2. - eapply red_eq_term_upto_univ_l in tu; try exact tt'; try tc. - destruct tu as [u'' [uu'' t'u'']]. - destruct (red_confluence uu' uu'') as [unf [ul ur]]. - eapply red_eq_term_upto_univ_r in t'u''; try exact ur; try tc. - destruct t'u'' as [t'' [t't'' t''unf]]. - exists t'', unf. intuition auto. - Qed. + apply fill_pb. + Qed. Lemma red_ctx_ws_cumul_ctx_pb {l Γ Γ'} : Σ ⊢ Γ ⇝ Γ' -> Σ ⊢ Γ ≤[l] Γ'. Proof using wfΣ. @@ -456,18 +456,18 @@ Section ContextConversion. Hint Resolve red_ctx_closed_left red_ctx_closed_right : fvs. Lemma red_compare_term_l {pb Γ} {u v u' : term} : - compare_term pb Σ Σ u u' -> + compare_term Σ Σ pb u u' -> red Σ Γ u v -> - ∑ v' : term, red Σ Γ u' v' × compare_term pb Σ Σ v v'. + ∑ v' : term, red Σ Γ u' v' × compare_term Σ Σ pb v v'. Proof using Type. destruct pb; cbn; apply red_eq_term_upto_univ_l; tc. Qed. Lemma red_compare_term_r {pb Γ} {u v u' : term} : - compare_term pb Σ Σ u u' -> + compare_term Σ Σ pb u u' -> red Σ Γ u' v -> - ∑ v' : term, red Σ Γ u v' × compare_term pb Σ Σ v' v. + ∑ v' : term, red Σ Γ u v' × compare_term Σ Σ pb v' v. Proof using Type. destruct pb; cbn; apply red_eq_term_upto_univ_r; tc. @@ -475,9 +475,9 @@ Section ContextConversion. Lemma closed_red_compare_term_l {pb Γ} {u v u' : term} : is_open_term Γ u' -> - compare_term pb Σ Σ u u' -> + compare_term Σ Σ pb u u' -> Σ ;;; Γ ⊢ u ⇝ v -> - ∑ v' : term, Σ ;;; Γ ⊢ u' ⇝ v' × compare_term pb Σ Σ v v'. + ∑ v' : term, Σ ;;; Γ ⊢ u' ⇝ v' × compare_term Σ Σ pb v v'. Proof using Type. intros isop comp [clΓ clu red]. destruct (red_compare_term_l comp red) as [nf [r eq]]. @@ -486,9 +486,9 @@ Section ContextConversion. Lemma closed_red_compare_term_r {pb Γ} {u v u' : term} : is_open_term Γ u -> - compare_term pb Σ Σ u u' -> + compare_term Σ Σ pb u u' -> Σ ;;; Γ ⊢ u' ⇝ v -> - ∑ v' : term, Σ ;;; Γ ⊢ u ⇝ v' × compare_term pb Σ Σ v' v. + ∑ v' : term, Σ ;;; Γ ⊢ u ⇝ v' × compare_term Σ Σ pb v' v. Proof using Type. intros isop comp [clΓ clu red]. destruct (red_compare_term_r comp red) as [nf [r eq]]. @@ -513,7 +513,7 @@ Section ContextConversion. Lemma ws_cumul_pb_red {pb} {Γ t u} : Σ ;;; Γ ⊢ t ≤[pb] u <~> ∑ v v', [× Σ ;;; Γ ⊢ t ⇝ v, Σ ;;; Γ ⊢ u ⇝ v' & - compare_term pb Σ (global_ext_constraints Σ) v v']. + compare_term Σ (global_ext_constraints Σ) pb v v']. Proof using wfΣ. split. - move/ws_cumul_pb_alt; intros (v & v' & [clΓ clt clu red red' leq]). @@ -588,63 +588,14 @@ Section ContextConversion. now exists v, v'. Qed. - Lemma red_eq_context_upto_l {R Re} {Γ Δ} {u} {v} - `{RelationClasses.Reflexive _ R} `{RelationClasses.Transitive _ R} `{SubstUnivPreserving R} - `{RelationClasses.Reflexive _ Re} `{RelationClasses.Transitive _ Re} `{SubstUnivPreserving Re} - `{RelationClasses.subrelation _ Re R} : - red Σ Γ u v -> - eq_context_upto Σ Re R Γ Δ -> - ∑ v', - red Σ Δ u v' * - eq_term_upto_univ Σ Re Re v v'. - Proof using Type. - intros r HΓ. - induction r. - - eapply (red1_eq_context_upto_l _ (Rle:=R)) in r; eauto. - destruct r as [v [? ?]]. exists v. intuition pcuic. - - exists x. split; auto. reflexivity. - - destruct IHr1 as [v' [? ?]]; eauto with fvs. - destruct IHr2 as [v'' [? ?]]; eauto with fvs. - eapply (red_eq_term_upto_univ_l _ _ (u:=y) (v:=v'') (u':=v')) in e; try tc. all:pcuic. - destruct e as [? [? ?]]. - exists x0; split; eauto. - now transitivity v'. - eapply eq_term_upto_univ_trans with v''; auto. - Qed. - - Lemma red_eq_context_upto_r {R Re Γ Δ} {u} {v} - `{RelationClasses.Equivalence _ Re} `{SubstUnivPreserving Re} - `{RelationClasses.PreOrder _ R} `{SubstUnivPreserving R} - `{RelationClasses.subrelation _ Re R} : - red Σ Δ u v -> - eq_context_upto Σ Re R Γ Δ -> - ∑ v', - red Σ Γ u v' * - eq_term_upto_univ Σ Re Re v v'. - Proof using Type. - intros r HΓ. - induction r. - - eapply (@red1_eq_context_upto_r Σ Σ Re R) in r; eauto. - destruct r as [v [? ?]]. exists v. intuition pcuic. - now symmetry. - - exists x. split; auto. reflexivity. - - destruct IHr1 as [v' [? ?]]. - destruct IHr2 as [v'' [? ?]]. - unshelve eapply (red_eq_term_upto_univ_l Σ _ (Γ := Γ) (u:=y) (v:=v'') (u':=v')) in e. all:pcuic. - destruct e as [? [? ?]]. - exists x0; split; eauto. - transitivity v'; auto. - eapply eq_term_upto_univ_trans with v''; auto; tc. - Qed. - Lemma closed_red_eq_context_upto_l {pb Γ Δ} {u} {v} : is_closed_context Δ -> Σ ;;; Γ ⊢ u ⇝ v -> - compare_context pb Σ Γ Δ -> + compare_context Σ pb Γ Δ -> ∑ v', Σ ;;; Δ ⊢ u ⇝ v' × eq_term Σ Σ v v'. Proof using Type. intros clΔ [onΓ onu r] c. - destruct (red_eq_context_upto_l r c) as [nf [red eq]]. + destruct (red_eq_context_upto_l _ c r) as [nf [red eq]]. exists nf. split; auto. split; eauto with fvs. now rewrite -(All2_fold_length c). Qed. @@ -652,26 +603,27 @@ Section ContextConversion. Lemma closed_red_eq_context_upto_r {pb Γ Δ} {u} {v} : is_closed_context Γ -> Σ ;;; Δ ⊢ u ⇝ v -> - compare_context pb Σ Γ Δ -> + compare_context Σ pb Γ Δ -> ∑ v', Σ ;;; Γ ⊢ u ⇝ v' × eq_term Σ Σ v v'. Proof using Type. intros clΔ [onΓ onu r] c. - destruct (red_eq_context_upto_r r c) as [nf [red eq]]. + destruct (red_eq_context_upto_r _ c r) as [nf [red eq]]. + symmetry in eq. exists nf. split; auto. split; eauto with fvs. now rewrite (All2_fold_length c). Qed. Lemma cumul_trans_red_leqterm {Γ : closed_context} {t u v : open_term Γ} : Σ ;;; Γ |- t <= u -> Σ ;;; Γ |- u <= v -> - ∑ l o r, red Σ Γ t l * - red Σ Γ u o * - red Σ Γ v r * - leq_term Σ.1 Σ l o * leq_term Σ.1 Σ o r. + ∑ l o r, red Σ Γ t l × + red Σ Γ u o × + red Σ Γ v r × + leq_term Σ.1 Σ l o × leq_term Σ.1 Σ o r. Proof using wfΣ. intros X X0. intros. - eapply cumul_alt in X as [t0 [u0 [[redl redr] eq]]]. - eapply cumul_alt in X0 as [u1 [v0 [[redl' redr'] eq']]]. + eapply cumul_alt in X as [t0 [u0 (redl & redr & eq)]]. + eapply cumul_alt in X0 as [u1 [v0 (redl' & redr' & eq')]]. destruct (red_confluence redr redl') as [unf [nfl nfr]]. eapply red_eq_term_upto_univ_r in eq; try tc. 2:tea. destruct eq as [t1 [red'0 eq2]]. @@ -684,36 +636,64 @@ Section ContextConversion. transitivity v0; auto. eapply eq2. eapply eq1. Qed. - Lemma conv_eq_context_upto {Γ} {Δ} {T U} : - eq_context_upto Σ (eq_universe Σ) (eq_universe Σ) Γ Δ -> - Σ ;;; Γ |- T = U -> - Σ ;;; Δ |- T = U. + Lemma cumul_pb_compare_context {pb pb' Γ Δ T U} : + compare_context Σ pb Γ Δ -> + Σ ;;; Δ |- T <=[pb'] U -> + Σ ;;; Γ |- T <=[pb'] U. Proof using Type. intros eqctx cum. - eapply conv_alt_red in cum as [nf [nf' [[redl redr] ?]]]. - eapply (red_eq_context_upto_l (R:=eq_universe _) (Re:=eq_universe _)) in redl; tea; tc. - eapply (red_eq_context_upto_l (R:=eq_universe _) (Re:=eq_universe _)) in redr; tea; tc. + eapply cumul_alt in cum as (nf & nf' & redl & redr & ?). + eapply red_eq_context_upto_r in redl; tea; tc. + eapply red_eq_context_upto_r in redr; tea; tc. destruct redl as [v' [redv' eqv']]. destruct redr as [v'' [redv'' eqv'']]. - eapply conv_alt_red. exists v', v''; intuition auto. + eapply cumul_alt. exists v', v''; repeat split; auto. transitivity nf. - now symmetry. now transitivity nf'. + eapply eq_term_upto_univ_leq; tc; auto. + transitivity nf' => //. + eapply eq_term_upto_univ_leq; tc; auto. + now symmetry. Qed. - Lemma conv_leq_context_upto {Γ Δ T U} : - eq_context_upto Σ (eq_universe Σ) (leq_universe Σ) Γ Δ -> - Σ ;;; Δ |- T = U -> - Σ ;;; Γ |- T = U. + (* Conversion is untyped so this currently holds as compare_context + just allows cumulativity on types, which do not participate in reduction. + However the useful lemma is the one above that shows we can lift a + conversion from a large context to a smaller one (contravariance). + *) + Local Remark cumul_pb_compare_context_inv {pb pb' Γ Δ T U} : + compare_context Σ pb Γ Δ -> + Σ ;;; Γ |- T <=[pb'] U -> + Σ ;;; Δ |- T <=[pb'] U. Proof using Type. intros eqctx cum. - eapply conv_alt_red in cum as [nf [nf' [[redl redr] ?]]]. - eapply (red_eq_context_upto_r (Re:=eq_universe _) (R:=leq_universe _)) in redl; tea. - eapply (red_eq_context_upto_r (Re:=eq_universe _) (R:=leq_universe _)) in redr; tea. + eapply cumul_alt in cum as (nf & nf' & redl & redr & ?). + eapply red_eq_context_upto_l in redl; tea; tc. + eapply red_eq_context_upto_l in redr; tea; tc. destruct redl as [v' [redv' eqv']]. destruct redr as [v'' [redv'' eqv'']]. - eapply conv_alt_red. exists v', v''; intuition auto. + eapply cumul_alt. exists v', v''; repeat split; auto. transitivity nf. - now symmetry. now transitivity nf'. + eapply eq_term_upto_univ_leq; tc; auto. + now symmetry. + transitivity nf' => //. + eapply eq_term_upto_univ_leq; tc; auto. + Qed. + + Lemma conv_eq_context_upto {Γ} {Δ} {T U} : + eq_context Σ Σ Γ Δ -> + Σ ;;; Γ |- T = U -> + Σ ;;; Δ |- T = U. + Proof using Type. + intro eqctx. symmetry in eqctx. + now eapply cumul_pb_compare_context. + Qed. + + Lemma conv_leq_context_upto {Γ Δ T U} : + leq_context Σ Σ Γ Δ -> + Σ ;;; Δ |- T = U -> + Σ ;;; Γ |- T = U. + Proof using Type. + apply cumul_pb_compare_context. Qed. (* Conversion is untyped so this currently holds as context ws_cumul_pb @@ -721,42 +701,24 @@ Section ContextConversion. However the useful lemma is the one above that shows we can lift a conversion from a large context to a smaller one (contravariance). *) - Local Remark conv_eq_context_upto_leq_inv {Γ Δ T U} : - eq_context_upto Σ (eq_universe Σ) (leq_universe Σ) Γ Δ -> + Local Remark conv_leq_context_upto_inv {Γ Δ T U} : + leq_context Σ Σ Γ Δ -> Σ ;;; Γ |- T = U -> Σ ;;; Δ |- T = U. Proof using Type. - intros eqctx cum. - eapply conv_alt_red in cum as [nf [nf' [[redl redr] ?]]]. - eapply (red_eq_context_upto_l (Re:=eq_universe _) (R:=leq_universe _)) in redl; tea. - eapply (red_eq_context_upto_l (Re:=eq_universe _) (R:=leq_universe _)) in redr; tea. - destruct redl as [v' [redv' eqv']]. - destruct redr as [v'' [redv'' eqv'']]. - eapply conv_alt_red. exists v', v''; intuition auto. - transitivity nf. - now symmetry. now transitivity nf'. + apply cumul_pb_compare_context_inv. Qed. Lemma cumul_leq_context_upto {Γ Δ T U} : - eq_context_upto Σ (eq_universe Σ) (leq_universe Σ) Δ Γ -> + leq_context Σ Σ Δ Γ -> Σ ;;; Γ |- T <= U -> Σ ;;; Δ |- T <= U. Proof using Type. - intros eqctx cum. - eapply cumul_alt in cum as [nf [nf' [[redl redr] ?]]]. - eapply (red_eq_context_upto_r (Re:=eq_universe Σ) (R:=leq_universe _)) in redl; tea. - eapply (red_eq_context_upto_r (Re:=eq_universe Σ) (R:=leq_universe _)) in redr; tea. - destruct redl as [v' [redv' eqv']]. - destruct redr as [v'' [redv'' eqv'']]. - eapply cumul_alt. exists v', v''; intuition auto. - unfold leq_term_ext. transitivity nf. - apply eq_term_leq_term. now symmetry. - transitivity nf'; auto. - now apply eq_term_leq_term. + apply cumul_pb_compare_context. Qed. Lemma ws_cumul_pb_compare_context {pb pb' Γ Δ T U} : - compare_context pb Σ Δ Γ -> + compare_context Σ pb Δ Γ -> is_closed_context Δ -> Σ ;;; Γ ⊢ T ≤[pb'] U -> Σ ;;; Δ ⊢ T ≤[pb'] U. @@ -777,7 +739,7 @@ Section ContextConversion. Qed. Local Remark ws_cumul_pb_compare_context_inv {pb pb' Γ Δ T U} : - compare_context pb Σ Γ Δ -> + compare_context Σ pb Γ Δ -> is_closed_context Δ -> Σ ;;; Γ ⊢ T ≤[pb'] U -> Σ ;;; Δ ⊢ T ≤[pb'] U. @@ -797,109 +759,82 @@ Section ContextConversion. now apply eq_term_leq_term. Qed. - (* Local Remark cumul_leq_context_upto_inv {Γ Δ T U} : - eq_context_upto Σ (eq_universe Σ) (leq_universe Σ) Γ Δ -> - Σ ;;; Γ |- T <= U -> - Σ ;;; Δ |- T <= U. - Proof. - intros eqctx cum. - eapply cumul_alt in cum as [nf [nf' [[redl redr] ?]]]. - eapply (red_eq_context_upto_l (Re:=eq_universe Σ) (R:=leq_universe Σ) (Δ:=Δ)) in redl; tas. - eapply (red_eq_context_upto_l (Re:=eq_universe Σ) (R:=leq_universe Σ) (Δ:=Δ)) in redr; tas. - destruct redl as [v' [redv' eqv']]. - destruct redr as [v'' [redv'' eqv'']]. - eapply cumul_alt. exists v', v''; intuition auto. - eapply leq_term_trans with nf. - apply eq_term_leq_term. now apply eq_term_sym. - eapply leq_term_trans with nf'; auto. - now apply eq_term_leq_term. - Qed. *) - - Lemma eq_context_upto_impl {Re Rle} {Re' Rle'} {Γ Δ} - `{RelationClasses.subrelation _ Re Re'} - `{RelationClasses.subrelation _ Rle Rle'} - `{RelationClasses.subrelation _ Re' Rle'} : - eq_context_upto Σ Re Rle Γ Δ -> - eq_context_upto Σ Re' Rle' Γ Δ. - Proof using Type. - induction 1; constructor; auto. - eapply compare_decls_impl; eauto. - intros x y h. - eapply eq_term_upto_univ_impl. 5:eauto. all:try tc || auto. - intros x y h. - eapply eq_term_upto_univ_impl. 5:eauto. all:try tc || auto. - transitivity Re'; auto. - Qed. - Lemma eq_leq_context_upto Γ Δ : - eq_context_upto Σ (eq_universe Σ) (eq_universe Σ) Γ Δ -> - eq_context_upto Σ (eq_universe Σ) (leq_universe Σ) Γ Δ. - Proof using Type. apply eq_context_upto_impl. Qed. + eq_context Σ Σ Γ Δ -> + leq_context Σ Σ Γ Δ. + Proof using Type. apply eq_context_upto_impl. all: tc. Qed. Lemma cumul_eq_context_upto {Γ Δ T U} : - eq_context_upto Σ (eq_universe Σ) (eq_universe Σ) Γ Δ -> + eq_context Σ Σ Γ Δ -> Σ ;;; Γ |- T <= U -> Σ ;;; Δ |- T <= U. Proof using Type. - intros eqctx cum. symmetry in eqctx. - apply eq_leq_context_upto in eqctx. - eapply cumul_leq_context_upto; eauto. + intro H. symmetry in H. revert H. + apply cumul_pb_compare_context. Qed. Lemma ws_cumul_pb_eq_context_upto {pb Γ Δ T U} : - eq_context_upto Σ (eq_universe Σ) (eq_universe Σ) Γ Δ -> + eq_context Σ Σ Γ Δ -> is_closed_context Δ -> Σ ;;; Γ ⊢ T ≤[pb] U -> Σ ;;; Δ ⊢ T ≤[pb] U. Proof using wfΣ. - intros eqctx cl cum. symmetry in eqctx. - eapply (ws_cumul_pb_compare_context (pb:=Conv)) in cum; tea. + intros eqctx cl. symmetry in eqctx. + now eapply ws_cumul_pb_compare_context. Qed. - Lemma conv_alt_red_ctx {Γ : closed_context} {Γ'} {T U : open_term Γ} : - Σ ;;; Γ |- T = U -> - @red_ctx Σ Γ Γ' -> - Σ ;;; Γ' |- T = U. + Lemma cumul_pb_alt_red_ctx {Γ : closed_context} {Γ' pb} {T U : open_term Γ} : + Σ ;;; Γ |- T <=[pb] U -> + red_ctx Σ Γ Γ' -> + Σ ;;; Γ' |- T <=[pb] U. Proof using wfΣ. intros H Hctx. - eapply conv_alt_red in H. apply conv_alt_red. - destruct H as [T' [U' [[redv redv'] leqvv']]]. + eapply cumul_alt in H. apply cumul_alt. + destruct H as (T' & U' & redv & redv' & leqvv'). destruct (red_red_ctx _ _ redv Hctx) as [Tj [redTj redT'j]]. destruct (red_red_ctx _ _ redv' Hctx) as [Uj [redUUj redU'j]]. - destruct (fill_eq (Γ := inj_closed Γ' byfvs) (t := inj_open T' byfvs) (u := inj_open U' byfvs) leqvv' redT'j redU'j) as [Tnf [Unf [[redTnf redUnf] eqnf]]]. + destruct (fill_pb (Γ := inj_closed Γ' byfvs) (t := inj_open T' byfvs) (u := inj_open U' byfvs) leqvv' redT'j redU'j) as [Tnf [Unf [[redTnf redUnf] eqnf]]]. exists Tnf, Unf; intuition eauto. now transitivity Tj. now transitivity Uj. Qed. - Lemma conv_alt_red_ctx_inv {Γ Γ' : closed_context} {T U : open_term Γ} : - Σ ;;; Γ |- T = U -> + Lemma cumul_pb_alt_red_ctx_inv {Γ Γ' : closed_context} {pb} {T U : open_term Γ} : + Σ ;;; Γ |- T <=[pb] U -> red_ctx Σ Γ' Γ -> - Σ ;;; Γ' |- T = U. + Σ ;;; Γ' |- T <=[pb] U. Proof using wfΣ. intros H Hctx. - apply conv_alt_red in H as [v [v' [[redl redr] leq]]]. + apply cumul_alt in H as (v & v' & redl & redr & leq). pose proof (red_red_ctx_inv redl Hctx). pose proof (red_red_ctx_inv redr Hctx). - apply conv_alt_red. + apply cumul_alt. exists v, v'. split. pcuic. auto. Qed. + Lemma conv_alt_red_ctx {Γ : closed_context} {Γ'} {T U : open_term Γ} : + Σ ;;; Γ |- T = U -> + red_ctx Σ Γ Γ' -> + Σ ;;; Γ' |- T = U. + Proof using wfΣ. + apply cumul_pb_alt_red_ctx. + Qed. + + Lemma conv_alt_red_ctx_inv {Γ Γ' : closed_context} {T U : open_term Γ} : + Σ ;;; Γ |- T = U -> + red_ctx Σ Γ' Γ -> + Σ ;;; Γ' |- T = U. + Proof using wfΣ. + apply cumul_pb_alt_red_ctx_inv. + Qed. + Lemma cumul_alt_red_ctx {Γ : closed_context} {Γ'} {T U : open_term Γ} : Σ ;;; Γ |- T <= U -> @red_ctx Σ Γ Γ' -> Σ ;;; Γ' |- T <= U. Proof using wfΣ. - intros H Hctx. - eapply cumul_alt in H. apply cumul_alt. - destruct H as [T' [U' [[redv redv'] leqvv']]]. - destruct (red_red_ctx _ _ redv Hctx) as [Tj [redTj redT'j]]. - destruct (red_red_ctx _ _ redv' Hctx) as [Uj [redUUj redU'j]]. - destruct (fill_le (Γ := inj_closed Γ' byfvs) (t := inj_open T' byfvs) (u := inj_open U' byfvs) leqvv' redT'j redU'j) as [Tnf [Unf [[redTnf redUnf] eqnf]]]. - exists Tnf, Unf; intuition eauto. - now transitivity Tj. - now transitivity Uj. + apply cumul_pb_alt_red_ctx. Qed. Lemma cumul_alt_red_ctx_inv {Γ Γ' : closed_context} {T U : open_term Γ} : @@ -907,13 +842,7 @@ Section ContextConversion. red_ctx Σ Γ' Γ -> Σ ;;; Γ' |- T <= U. Proof using wfΣ. - intros H Hctx. - apply cumul_alt in H as [v [v' [[redl redr] leq]]]. - pose proof (red_red_ctx_inv redl Hctx). - pose proof (red_red_ctx_inv redr Hctx). - apply cumul_alt. - exists v, v'. - split. pcuic. auto. + apply cumul_pb_alt_red_ctx_inv. Qed. Lemma ws_cumul_pb_red_ctx_inv {pb Γ Γ'} {T U} : @@ -957,7 +886,7 @@ Section ContextConversion. Lemma ws_cumul_ctx_pb_red {pb} {Γ Γ' : context} : ws_cumul_ctx_pb pb Σ Γ Γ' -> ∑ Δ Δ', Σ ⊢ Γ ⇝ Δ × Σ ⊢ Γ' ⇝ Δ' × - eq_context_upto Σ (eq_universe Σ) (compare_universe pb Σ) Δ Δ'. + compare_context Σ pb Δ Δ'. Proof using wfΣ. intros Hctx. induction Hctx. @@ -1087,62 +1016,75 @@ End ContextConversion. #[global] Hint Resolve conv_ctx_refl' : pcuic. #[global] Hint Constructors All_decls_alpha_pb : pcuic. -Lemma eq_context_upto_conv_context {cf:checker_flags} (Σ : global_env_ext) Re : - RelationClasses.subrelation Re (eq_universe Σ) -> - subrelation (eq_context_upto Σ Re Re) (fun Γ Γ' => conv_context cumulAlgo_gen Σ Γ Γ'). +Lemma compare_context_cumul_pb_context {cf} Σ pb : + subrelation (compare_context Σ pb) (cumul_pb_context cumulAlgo_gen pb Σ). Proof. - intros HRe Γ Δ h. induction h. + intros Γ Δ h. induction h. - constructor. - constructor; tas. - depelim p; constructor; auto; constructor; tas; - eapply eq_term_upto_univ_impl; tea; auto. + destruct p; constructor; auto; constructor; tas. Qed. -Lemma eq_context_upto_cumul_context {cf:checker_flags} (Σ : global_env_ext) Re Rle : - RelationClasses.subrelation Re (eq_universe Σ) -> - RelationClasses.subrelation Rle (leq_universe Σ) -> - RelationClasses.subrelation Re Rle -> - subrelation (eq_context_upto Σ Re Rle) (fun Γ Γ' => cumul_context cumulAlgo_gen Σ Γ Γ'). +Lemma eq_context_upto_cumul_pb_context {cf:checker_flags} (Σ : global_env_ext) cmp_universe cmp_sort pb pb' : + RelationClasses.subrelation (cmp_universe Conv) (eq_universe Σ) -> + RelationClasses.subrelation (cmp_universe pb) (compare_universe Σ pb') -> + RelationClasses.subrelation (cmp_sort Conv) (eq_sort Σ) -> + RelationClasses.subrelation (cmp_sort pb) (compare_sort Σ pb') -> + subrelation (eq_context_upto Σ cmp_universe cmp_sort pb) (cumul_pb_context cumulAlgo_gen pb' Σ). Proof. - intros HRe HRle hR Γ Δ h. induction h. - - constructor. - - constructor; tas. - depelim p; constructor; auto; constructor; tas. - eapply eq_term_upto_univ_impl. 5:eauto. all:tea. - now transitivity Rle. auto. - eapply eq_term_upto_univ_impl; eauto. - eapply eq_term_upto_univ_impl. 5:eauto. all:tea. - now transitivity Rle. auto. + intros. + etransitivity. 2: apply compare_context_cumul_pb_context. + eapply eq_context_upto_impl; tc. +Qed. + +Lemma eq_context_upto_conv_context {cf:checker_flags} (Σ : global_env_ext) cmp_universe cmp_sort : + RelationClasses.subrelation (cmp_universe Conv) (eq_universe Σ) -> + RelationClasses.subrelation (cmp_sort Conv) (eq_sort Σ) -> + subrelation (eq_context_upto Σ cmp_universe cmp_sort Conv) (conv_context cumulAlgo_gen Σ). +Proof. + intros. + apply eq_context_upto_cumul_pb_context; tc. +Qed. + +Lemma eq_context_upto_cumul_context {cf:checker_flags} (Σ : global_env_ext) cmp_universe cmp_sort : + RelationClasses.subrelation (cmp_universe Conv) (eq_universe Σ) -> + RelationClasses.subrelation (cmp_universe Cumul) (leq_universe Σ) -> + RelationClasses.subrelation (cmp_sort Conv) (eq_sort Σ) -> + RelationClasses.subrelation (cmp_sort Cumul) (leq_sort Σ) -> + subrelation (eq_context_upto Σ cmp_universe cmp_sort Cumul) (fun Γ Γ' => cumul_context cumulAlgo_gen Σ Γ Γ'). +Proof. + intros. + apply eq_context_upto_cumul_pb_context; tc. Qed. #[global] Instance eq_subrel_eq_univ {cf:checker_flags} Σ : RelationClasses.subrelation eq (eq_universe Σ). Proof. intros x y []. reflexivity. Qed. -Lemma eq_context_upto_empty_conv_context {cf:checker_flags} (Σ : global_env_ext) : - subrelation (eq_context_upto empty_global_env eq eq) (fun Γ Γ' => conv_context cumulAlgo_gen Σ Γ Γ'). +#[global] +Instance eq_subrel_eq_sort {cf:checker_flags} Σ : RelationClasses.subrelation eq (eq_sort Σ). +Proof. intros x y []. reflexivity. Qed. + +Lemma eq_context_upto_names_conv_context {cf:checker_flags} (Σ : global_env_ext) : + subrelation eq_context_upto_names (fun Γ Γ' => conv_context cumulAlgo_gen Σ Γ Γ'). Proof. - intros Γ Δ h. induction h. - - constructor. - - constructor; tas. - depelim p; constructor; auto; constructor. - all:eapply eq_term_upto_univ_empty_impl; tea; try typeclasses eauto. + etransitivity. + 2: apply compare_context_cumul_pb_context. + eapply eq_context_upto_names_eq_context_upto; tc. Qed. Lemma eq_context_upto_univ_conv_context {cf:checker_flags} {Σ : global_env_ext} Γ Δ : - eq_context_upto Σ.1 (eq_universe Σ) (eq_universe Σ) Γ Δ -> + eq_context Σ.1 Σ Γ Δ -> conv_context cumulAlgo_gen Σ Γ Δ. Proof. - intros h. eapply eq_context_upto_conv_context; tea. - reflexivity. + apply compare_context_cumul_pb_context. Qed. Lemma eq_context_upto_univ_cumul_context {cf:checker_flags} {Σ : global_env_ext} Γ Δ : - eq_context_upto Σ.1 (eq_universe Σ) (leq_universe Σ) Γ Δ -> + leq_context Σ.1 Σ Γ Δ -> cumul_context cumulAlgo_gen Σ Γ Δ. Proof. - intros h. eapply eq_context_upto_cumul_context; tea. - reflexivity. tc. tc. + apply compare_context_cumul_pb_context. Qed. Lemma conv_context_app_same {cf:checker_flags} Σ Γ Γ' Δ : @@ -1165,7 +1107,7 @@ Proof. constructor; reflexivity. Qed. -#[global] Hint Extern 4 (eq_term_upto_univ _ _ _ _ _) => reflexivity : pcuic. +#[global] Hint Extern 4 (eq_term_upto_univ _ _ _ _ _ _) => reflexivity : pcuic. Lemma context_cumulativity_wf_app {cf:checker_flags} Σ Γ Γ' Δ : cumul_context cumulAlgo_gen Σ Γ' Γ -> diff --git a/pcuic/theories/PCUICContexts.v b/pcuic/theories/PCUICContexts.v index fe5ace964..f90d157c1 100644 --- a/pcuic/theories/PCUICContexts.v +++ b/pcuic/theories/PCUICContexts.v @@ -159,11 +159,11 @@ Lemma type_local_ctx_instantiate {cf:checker_flags} Σ ind mdecl Γ Δ u s : declared_minductive Σ.1 ind mdecl -> type_local_ctx (lift_typing typing) (Σ.1, ind_universes mdecl) Γ Δ s -> consistent_instance_ext Σ (ind_universes mdecl) u -> - type_local_ctx (lift_typing typing) Σ (subst_instance u Γ) (subst_instance u Δ) (subst_instance_univ u s). + type_local_ctx (lift_typing typing) Σ (subst_instance u Γ) (subst_instance u Δ) (subst_instance_sort u s). Proof. intros Hctx Hu. induction Δ; simpl in *; intuition auto. - { destruct Σ as [Σ univs]. eapply (wf_universe_subst_instance (Σ, ind_universes mdecl)); eauto. } + { destruct Σ as [Σ univs]. eapply (wf_sort_subst_instance (Σ, ind_universes mdecl)); eauto. } destruct a as [na [b|] ty]; simpl; destruct X as (Hwfctx & Hj); split; eauto. - eapply lift_typing_fu_impl with (1 := Hj) => //= ?? Hs. eapply instantiate_minductive in Hs; eauto. @@ -179,7 +179,7 @@ Lemma sorts_local_ctx_instantiate {cf:checker_flags} Σ ind mdecl Γ Δ u s : sorts_local_ctx (lift_typing typing) (Σ.1, ind_universes mdecl) Γ Δ s -> consistent_instance_ext Σ (ind_universes mdecl) u -> sorts_local_ctx (lift_typing typing) Σ (subst_instance u Γ) (subst_instance u Δ) - (List.map (subst_instance_univ u) s). + (List.map (subst_instance_sort u) s). Proof. intros Hctx Hu. induction Δ in s |- *; simpl in *; intuition auto. diff --git a/pcuic/theories/PCUICConvCumInversion.v b/pcuic/theories/PCUICConvCumInversion.v index 53b5e80af..b0f9da422 100644 --- a/pcuic/theories/PCUICConvCumInversion.v +++ b/pcuic/theories/PCUICConvCumInversion.v @@ -20,11 +20,10 @@ Definition conv_cum {cf:checker_flags} pb Σ Γ u v := Lemma eq_term_eq_termp {cf:checker_flags} leq (Σ : global_env_ext) x y : eq_term Σ Σ x y -> - eq_termp leq Σ x y. + eq_termp Σ leq x y. Proof. destruct leq; [easy|]. - cbn. - apply eq_term_upto_univ_leq; cbn; auto. + apply eq_term_leq_term. Qed. Lemma alt_into_ws_cumul_pb_terms {cf Σ} {wfΣ : wf Σ} {Γ l l'} : @@ -43,7 +42,7 @@ Lemma red_ctx_rel_par_conv {cf Σ Γ Γ0 Γ0' Γ1 Γ1'} {wfΣ : wf Σ} : is_closed_context (Γ ,,, Γ1) -> red_ctx_rel Σ Γ Γ0 Γ0' -> red_ctx_rel Σ Γ Γ1 Γ1' -> - eq_context_upto Σ (eq_universe Σ) (eq_universe Σ) Γ0' Γ1' -> + eq_context Σ Σ Γ0' Γ1' -> ws_cumul_ctx_pb_rel Conv Σ Γ Γ0 Γ1. Proof. intros clΓ0 clΓ1 r0 r1 eq. @@ -57,10 +56,9 @@ Proof. eapply (red_ctx_ws_cumul_ctx_pb (l:=Conv)) in r0. eapply (red_ctx_ws_cumul_ctx_pb (l:=Conv)) in r1. apply ws_cumul_ctx_pb_rel_app. etransitivity; tea. - symmetry. etransitivity; tea. - eapply (eq_context_upto_cat _ _ _ Γ _ Γ) in eq. 2:reflexivity. - eapply (eq_context_upto_ws_cumul_ctx_pb (pb:=Conv)) in eq. 2-3:fvs. - now symmetry. + etransitivity. 2: now symmetry. + eapply eq_context_upto_ws_cumul_ctx_pb. 1-2:fvs. + eapply eq_context_upto_cat. 1: reflexivity. assumption. Qed. Lemma into_red_terms {Σ Γ ts ts'} : @@ -73,13 +71,6 @@ Proof. move=> /= clΓ /andP[clx cll]. constructor; eauto using into_closed_red. Qed. -Lemma alpha_eq_context_gen Γ Δ : - eq_context_upto_names Γ Δ -> - eq_context_gen eq eq Γ Δ. -Proof. - induction 1; constructor; auto. -Qed. - Lemma untyped_subslet_ass {Γ s Δ} : assumption_context Δ -> #|s| = context_assumptions Δ -> @@ -107,8 +98,8 @@ Lemma inst_case_ws_cumul_ctx_pb {cf Σ} {wfΣ : wf Σ} {ind mdecl idecl Γ pars on_free_vars_ctx (closedP #|pars'| xpredT) ctx' -> is_closed_context Γ -> ws_cumul_pb_terms Σ Γ pars pars' -> - R_universe_instance (eq_universe Σ) puinst puinst' -> - eq_context_gen eq eq ctx ctx' -> + cmp_universe_instance (eq_universe Σ) puinst puinst' -> + eq_context_upto_names ctx ctx' -> Σ ⊢ Γ,,, inst_case_context pars puinst ctx = Γ,,, inst_case_context pars' puinst' ctx'. Proof. intros decli wfp wfp' onp onp' clΓ eqpars eqinst eqctx. @@ -139,7 +130,7 @@ Proof. rewrite on_free_vars_ctx_subst_instance -lenpars. eapply on_free_vars_ctx_impl; tea. apply shiftnP_up. lia. } eapply eq_context_upto_cat; [reflexivity|]. - eapply eq_context_upto_univ_subst_instance'; tc. 1:reflexivity. + eapply eq_context_upto_names_subst_instance; tc. 1:reflexivity. assumption. - cbn. eapply subst_instance_ws_cumul_ctx_pb_rel => //. @@ -159,16 +150,15 @@ Qed. #[global] Hint Resolve sq : core. -Lemma conv_cum_alt {cf:checker_flags} {leq} {Σ : global_env_ext} {Γ t t'} (wfΣ : ∥ wf Σ ∥) : - conv_cum leq Σ Γ t t' <-> - ∥∑ v v', [× Σ ;;; Γ ⊢ t ⇝ v, Σ ;;; Γ ⊢ t' ⇝ v' & eq_termp leq Σ v v']∥. +Lemma conv_cum_alt {cf:checker_flags} {pb} {Σ : global_env_ext} {Γ t t'} (wfΣ : ∥ wf Σ ∥) : + conv_cum pb Σ Γ t t' <-> + ∥∑ v v', [× Σ ;;; Γ ⊢ t ⇝ v, Σ ;;; Γ ⊢ t' ⇝ v' & eq_termp Σ pb v v']∥. Proof. destruct wfΣ. assert (forall P Q, (P <~> Q) -> (∥P∥ <-> ∥Q∥)) by (intros P Q H; split; intros [p]; constructor; apply H in p; auto). - destruct leq; cbn; apply H. - * eapply (ws_cumul_pb_alt_closed (pb:=Conv)). - * eapply (ws_cumul_pb_alt_closed (pb:=Cumul)). + apply H. + apply ws_cumul_pb_alt_closed. Qed. Lemma conv_conv_cum_l {cf:checker_flags} : @@ -215,10 +205,10 @@ Section fixed. rewrite !decompose_app_mkApps; by easy. Qed. - Lemma eq_term_upto_univ_napp_nonind Re Rle napp t t' : - eq_term_upto_univ_napp Σ Re Rle napp t t' -> + Lemma eq_term_upto_univ_napp_nonind cmp_universe cmp_sort pb napp t t' : + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp t t' -> isIndConstructApp t = false -> - eq_term_upto_univ Σ Re Rle t t'. + eq_term_upto_univ Σ cmp_universe cmp_sort pb t t'. Proof using Type. intros eq not_ind. generalize 0. @@ -240,30 +230,30 @@ Section fixed. apply IHr. Qed. - Lemma eq_termp_mkApps_inv leq v args v' args' : + Lemma eq_termp_mkApps_inv pb v args v' args' : isApp v = false -> isApp v' = false -> - eq_termp leq Σ (mkApps v args) (mkApps v' args') -> - eq_termp_napp leq Σ #|args| v v' × All2 (fun x y => eq_term Σ Σ x y) args args'. + eq_termp Σ pb (mkApps v args) (mkApps v' args') -> + eq_termp_napp Σ pb #|args| v v' × All2 (fun x y => eq_term Σ Σ x y) args args'. Proof using Type. intros noapp1 noapp2 eq. apply eq_term_upto_univ_mkApps_inv in eq as (?&?) => //. Qed. - Definition conv_cum_napp leq Γ napp t t' := + Definition conv_cum_napp pb Γ napp t t' := match t with | tInd _ _ - | tConstruct _ _ _ => ∥eq_termp_napp leq Σ napp t t'∥ - | _ => conv_cum leq Σ Γ t t' + | tConstruct _ _ _ => ∥eq_termp_napp Σ pb napp t t'∥ + | _ => conv_cum pb Σ Γ t t' end. - Lemma conv_cum_mkApps_inv leq Γ hd args hd' args' : - conv_cum leq Σ Γ (mkApps hd args) (mkApps hd' args') -> + Lemma conv_cum_mkApps_inv pb Γ hd args hd' args' : + conv_cum pb Σ Γ (mkApps hd args) (mkApps hd' args') -> isApp hd = false -> isApp hd' = false -> whnf RedFlags.default Σ Γ (mkApps hd args) -> whnf RedFlags.default Σ Γ (mkApps hd' args') -> - ∥conv_cum_napp leq Γ #|args| hd hd' × ws_cumul_pb_terms Σ Γ args args'∥. + ∥conv_cum_napp pb Γ #|args| hd hd' × ws_cumul_pb_terms Σ Γ args args'∥. Proof using wfΣ. intros conv notapp notapp' wh wh'. eapply conv_cum_alt in conv as [(?&?&[r1 r2 e])]; auto. @@ -295,13 +285,13 @@ Section fixed. try (constructor; constructor; rewrite a; auto). sq. exists (tPrim i'), (tPrim i'0). split => //. all:eauto with pcuic. - eapply (eq_term_upto_univ_napp_nonind _ _ 0); eauto. now constructor. + now constructor. - eapply alt_into_ws_cumul_pb_terms => //. clear -a1 a a0. induction a1 in args, args', x2, a, x3, a0, a1 |- *; depelim a; depelim a0; [now constructor|]. constructor. - + apply conv_alt_red. + + apply cumul_alt. now exists x, y. + now apply IHa1. Qed. @@ -375,9 +365,9 @@ Section fixed. eapply on_free_vars_ctx_inst_case_context; tea => //. now rewrite test_context_k_closed_on_free_vars_ctx. + eapply red_on_free_vars in r1; tea. - { len. rewrite (All2_fold_length a5). + { len. rewrite (All2_length a4). now setoid_rewrite shiftnP_add in p1. } - len. rewrite -shiftnP_add (All2_fold_length a5). + len. rewrite -shiftnP_add (All2_length a4). eapply on_ctx_free_vars_inst_case_context; auto. 1:now rewrite test_context_k_closed_on_free_vars_ctx. now erewrite -> on_free_vars_ctx_on_ctx_free_vars. } @@ -390,8 +380,8 @@ Section fixed. all:eapply into_closed_red; eauto. - rename a0 into brsa1. rename a2 into brsa2. - rename a3 into brseq. - clear -wfΣ decli brsa1 brsa2 brseq clΓ wfp wfp' a a1 p0 p5 p4 p9 r3 eqpars. + rename e0 into brseq. + clear -wfΣ decli brsa1 brsa2 brseq clΓ wfp wfp' a a1 p0 p5 p4 p9 c eqpars. induction brseq in brs, brs', brsa1, brsa2, p4, p9 |- *; depelim brsa1; depelim brsa2; [constructor|]. destruct p0, p1, r. @@ -420,7 +410,7 @@ Section fixed. move/andP: fv' => []. len. now setoid_rewrite shiftnP_add. } move/andP: fv => [] fv fvx1. len. eapply red_on_free_vars in fvx1; tea. - { rewrite e (All2_fold_length a0) -e0. now setoid_rewrite shiftnP_add in fvx1. } + { rewrite e (All2_length a0) -e0. now setoid_rewrite shiftnP_add in fvx1. } rewrite shiftnP_add. relativize (#|bcontext x1| + _). 1:rewrite -> on_free_vars_ctx_on_ctx_free_vars. 2:now len. now eapply ws_cumul_ctx_pb_closed_right in eqctx. } @@ -465,20 +455,22 @@ Section fixed. { rewrite on_free_vars_ctx_app clΓ /=. apply on_free_vars_fix_context; solve_all. } have clmfixctx' : is_closed_context (Γ ,,, fix_context mfix'). { rewrite on_free_vars_ctx_app clΓ /=. apply on_free_vars_fix_context; solve_all. } + unfold eq_mfixpoint in *. solve_all. move: clmfixctx clmfixctx'. - clear -wfΣ a a0 a1 clΓ. + clear -wfΣ a a0 e clΓ. cut (#|mfix| = #|mfix'|); - [|now apply All2_length in a; apply All2_length in a0; apply All2_length in a1]. - revert a a0 a1. - generalize mfix at 1 2 4 5 6. - generalize mfix' at 1 2 4 5. - intros ctx_fix ctx_fix'. + [|now apply All2_length in a; apply All2_length in a0; apply All2_length in e]. + revert a a0 e. + set mfix as ctx_fix in |-. set mfix' as ctx_fix' in |-. + change (fix_context mfix) with (fix_context ctx_fix). change (fix_context mfix') with (fix_context ctx_fix'). + change #|mfix| with #|ctx_fix|. change #|mfix'| with #|ctx_fix'|. + clearbody ctx_fix ctx_fix'. intros all1 all2 all len_eq. induction all in mfix, mfix', all1, all2, all |- *; depelim all1; depelim all2; subst; [constructor|]. constructor; [|now auto]. - destruct r as ((?&(((? & ?) & ?)&?))&?), p as (?&?&?&?&?), p0 as (?&?&?&?&?). + destruct r as ((?&(? & ? & ? & ?))&?), p as (?&?&?&?&?), p0 as (?&?&?&?&?). split; auto; try congruence. - eapply ws_cumul_pb_alt_closed; exists (dtype x), (dtype y). split; eauto. all:eapply into_closed_red; eauto. @@ -525,20 +517,22 @@ Section fixed. { rewrite on_free_vars_ctx_app clΓ /=. apply on_free_vars_fix_context; solve_all. } have clmfixctx' : is_closed_context (Γ ,,, fix_context mfix'). { rewrite on_free_vars_ctx_app clΓ /=. apply on_free_vars_fix_context; solve_all. } + unfold eq_mfixpoint in *. solve_all. move: clmfixctx clmfixctx'. - clear -wfΣ a a0 a1 clΓ. + clear -wfΣ a a0 e clΓ. cut (#|mfix| = #|mfix'|); - [|now apply All2_length in a; apply All2_length in a0; apply All2_length in a1]. - revert a a0 a1. - generalize mfix at 1 2 4 5 6. - generalize mfix' at 1 2 4 5. - intros ctx_fix ctx_fix'. + [|now apply All2_length in a; apply All2_length in a0; apply All2_length in e]. + revert a a0 e. + set mfix as ctx_fix in |-. set mfix' as ctx_fix' in |-. + change (fix_context mfix) with (fix_context ctx_fix). change (fix_context mfix') with (fix_context ctx_fix'). + change #|mfix| with #|ctx_fix|. change #|mfix'| with #|ctx_fix'|. + clearbody ctx_fix ctx_fix'. intros all1 all2 all len_eq. induction all in mfix, mfix', all1, all2, all |- *; depelim all1; depelim all2; subst; [constructor|]. constructor; [|now auto]. - destruct r as ((?&(((? & ?) & ?)&?))&?), p as (?&?&?&?&?), p0 as (?&?&?&?&?). + destruct r as ((?&(? & ? & ? & ?))&?), p as (?&?&?&?&?), p0 as (?&?&?&?&?). split; auto; try congruence. - eapply ws_cumul_pb_alt_closed; exists (dtype x), (dtype y). split; eauto. all:eapply into_closed_red; eauto. diff --git a/pcuic/theories/PCUICConversion.v b/pcuic/theories/PCUICConversion.v index e602f3fdf..89c49a3b4 100644 --- a/pcuic/theories/PCUICConversion.v +++ b/pcuic/theories/PCUICConversion.v @@ -38,7 +38,7 @@ Ltac pcuic := intuition eauto 5 with pcuic || (try solve [repeat red; cbn in *; intuition auto; eauto 5 with pcuic || (try lia || congruence)]). #[global] -Hint Resolve eq_universe_leq_universe' : pcuic. +Hint Resolve eq_leq_sort' : pcuic. Derive Signature for assumption_context. Derive Signature for clos_refl_trans_1n. @@ -91,7 +91,7 @@ Section CumulSpecIsCumulAlgo. * change (fun Γ t u => Σ ;;; Γ ⊢ t ≤s[Conv] u) with (convSpec Σ). destruct p as [p x]. cbn in *. try repeat split; cbn; try reflexivity; eauto. * induction X; econstructor. - + destruct p0 as [ [ _ hbody ] hhd ]. rewrite hhd. split; eauto. reflexivity. + + unfold cumul_branch. destruct p0 as [ [ _ hbody ] hhd ]. rewrite hhd. split; eauto. reflexivity. + apply All2_reflexivity. eapply Prod_reflexivity; intro x; reflexivity. + split; reflexivity. + exact IHX. @@ -99,7 +99,7 @@ Section CumulSpecIsCumulAlgo. change (fun t u => Σ ;;; Γ ⊢ t ≤s[Conv] u) with (convSpec Σ Γ). induction X; econstructor; eauto; try reflexivity. * exact p.2. - - eapply cumul_Fix. set (mfixAbs := mfix0). unfold mfixAbs at 2. clearbody mfixAbs. + - eapply cumul_Fix. unfold cumul_mfixpoint. set (Ξ := fix_context mfix0). clearbody Ξ. induction X; econstructor; eauto; try reflexivity. * destruct p as [ [ _ hdtype ] e ]. pose proof (erarg := snd_eq e). pose proof (edbody := snd_eq (fst_eq e)). @@ -107,16 +107,15 @@ Section CumulSpecIsCumulAlgo. repeat split; eauto ; try reflexivity. * apply All2_reflexivity. repeat eapply Prod_reflexivity; intro x; reflexivity. * repeat split; reflexivity. - - eapply cumul_Fix. set (mfixAbs := mfix0). unfold mfixAbs at 2. - assert (Habs : mfixAbs = mfix0) by reflexivity. clearbody mfixAbs. - induction X; destruct Habs; econstructor; eauto; try reflexivity. + - eapply cumul_Fix. unfold cumul_mfixpoint. set (Ξ := fix_context mfix0) in *. clearbody Ξ. + induction X; econstructor; eauto; try reflexivity. * destruct p as [ [ _ hdtype ] e ]. pose proof (erarg := snd_eq e). pose proof (edbody := snd_eq (fst_eq e)). pose proof (edname := fst_eq (fst_eq e)). clear e. destruct erarg, edbody, edname. repeat split; eauto ; try reflexivity. * apply All2_reflexivity. repeat eapply Prod_reflexivity; intro x; reflexivity. * repeat split; reflexivity. - - eapply cumul_CoFix. set (mfixAbs := mfix0). unfold mfixAbs at 2. clearbody mfixAbs. + - eapply cumul_CoFix. unfold cumul_mfixpoint. set (Ξ := fix_context mfix0) in *. clearbody Ξ. induction X; econstructor; eauto; try reflexivity. * destruct p as [ [ _ hdtype ] e ]. pose proof (erarg := snd_eq e). pose proof (edbody := snd_eq (fst_eq e)). @@ -124,9 +123,8 @@ Section CumulSpecIsCumulAlgo. repeat split; eauto ; try reflexivity. * apply All2_reflexivity. repeat eapply Prod_reflexivity; intro x; reflexivity. * repeat split; reflexivity. - - eapply cumul_CoFix. set (mfixAbs := mfix0). unfold mfixAbs at 2. - assert (Habs : mfixAbs = mfix0) by reflexivity. clearbody mfixAbs. - induction X; destruct Habs; econstructor; eauto; try reflexivity. + - eapply cumul_CoFix. unfold cumul_mfixpoint. set (Ξ := fix_context mfix0) in *. clearbody Ξ. + induction X; econstructor; eauto; try reflexivity. * destruct p as [ [ _ hdtype ] e ]. pose proof (erarg := snd_eq e). pose proof (edbody := snd_eq (fst_eq e)). pose proof (edname := fst_eq (fst_eq e)). clear e. destruct erarg, edbody, edname. @@ -138,13 +136,11 @@ Section CumulSpecIsCumulAlgo. + apply X0. + reflexivity. - eapply cumul_Prim. constructor; eauto; trea. - eapply All2_reflexivity; intro; reflexivity. - eapply cumul_Prim; constructor; eauto; trea. - eapply All2_reflexivity; intro; reflexivity. Defined. - Proposition convSpec_cumulSpec (Γ : context) (M N : term) : - Σ ;;; Γ |- M =s N -> Σ ;;; Γ |- M <=s N. + Proposition convSpec_cumulSpec (Γ : context) (pb : conv_pb) (M N : term) : + Σ ;;; Γ |- M =s N -> Σ ;;; Γ ⊢ M ≤s[pb] N. Proof. intro Hconv. apply cumul_Sym. apply cumul_Sym. assumption. Defined. @@ -162,7 +158,7 @@ Section CumulSpecIsCumulAlgo. Ltac try_with_nil := match goal with H : _ |- _ => eapply (H _ _ _ [] []); eauto end. Proposition eq_term_upto_univ_napp_cumulSpec (Γ : context) {pb} M N args args' : - compare_term_napp pb Σ Σ #|args| M N -> + compare_term_napp Σ Σ pb #|args| M N -> All2 (cumulSpec0 Σ Γ Conv) args args' -> cumulSpec0 Σ Γ pb (mkApps M args) (mkApps N args'). Proof. @@ -184,7 +180,8 @@ Section CumulSpecIsCumulAlgo. + intuition. + try_with_nil. intuition. * try_with_nil. - * unfold tCaseBrsProp in X0. eapply All2_All_mix_left in X0. 2: tea. + * unfold tCaseBrsProp in X0. unfold cumul_branches, eq_branches, cumul_branch, eq_branch in *. + eapply All2_All_mix_left in X0. 2: tea. eapply All2_impl. 1: eassumption. cbn. intuition. try_with_nil. - apply cumul_mkApps; eauto. eapply cumul_Fix. unfold tFixProp in *. @@ -196,7 +193,7 @@ Section CumulSpecIsCumulAlgo. Defined. Proposition eq_term_upto_univ_cumulSpec (Γ : context) {pb} M N : - compare_term pb Σ Σ M N -> cumulSpec0 Σ Γ pb M N. + compare_term Σ Σ pb M N -> cumulSpec0 Σ Γ pb M N. Proof. intros. eapply (eq_term_upto_univ_napp_cumulSpec _ _ _ [] []); eauto. Defined. @@ -205,13 +202,9 @@ Section CumulSpecIsCumulAlgo. Σ ;;; Γ ⊢ M ≤[pb] N -> Σ ;;; Γ ⊢ M ≤s[pb] N. Proof. induction 1. - - destruct pb; eapply eq_term_upto_univ_cumulSpec; eauto. - - destruct pb; revgoals. - * eapply cumul_Trans; eauto. apply convSpec_cumulSpec. apply red1_cumulSpec ; assumption. - * eapply cumul_Trans; eauto. apply red1_cumulSpec ; assumption. - - destruct pb; revgoals. - * eapply cumul_Trans; eauto. apply cumul_Sym. apply red1_cumulSpec ; assumption. - * eapply cumul_Trans; eauto. apply cumul_Sym. apply red1_cumulSpec ; assumption. + - eapply eq_term_upto_univ_cumulSpec; eauto. + - eapply cumul_Trans; eauto. apply convSpec_cumulSpec. apply red1_cumulSpec ; assumption. + - eapply cumul_Trans; eauto. apply cumul_Sym. apply red1_cumulSpec ; assumption. Defined. End CumulSpecIsCumulAlgo. @@ -266,7 +259,7 @@ Qed. #[global] Hint Resolve closed_red_open_right : fvs. Ltac fvs := eauto 10 with fvs. -#[global] Hint Resolve eq_universe_leq_universe : core. +#[global] Hint Resolve eq_leq_sort : core. Section ConvCongruences. Context {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ}. @@ -319,10 +312,10 @@ Section ConvCongruences. Lemma ws_cumul_pb_Sort_inv {Γ s s'} pb : Σ ;;; Γ ⊢ tSort s ≤[pb] tSort s' -> - compare_universe pb Σ s s'. + compare_sort Σ pb s s'. Proof using Type. intros H; depind H. - - destruct pb; now inversion c. + - now inversion c. - depelim r. solve_discr. - depelim r. solve_discr. Qed. @@ -332,7 +325,7 @@ Section ConvCongruences. False. Proof using Type. intros H. depind H. - - destruct pb; now inversion c. + - now inversion c. - depelim r. solve_discr. - depelim r; solve_discr. + eapply IHws_cumul_pb. reflexivity. @@ -343,7 +336,7 @@ Section ConvCongruences. Σ ;;; Γ ⊢ tProd na dom codom ≤[pb] tSort s -> False. Proof using Type. intros H; depind H; auto. - - destruct pb; now inversion c. + - now inversion c. - depelim r. + solve_discr. + eapply IHws_cumul_pb; reflexivity. @@ -353,10 +346,10 @@ Section ConvCongruences. Lemma ws_cumul_pb_Sort_l_inv {Γ s T} pb : Σ ;;; Γ ⊢ tSort s ≤[pb] T -> - ∑ s', Σ ;;; Γ ⊢ T ⇝ tSort s' × compare_universe pb Σ s s'. + ∑ s', Σ ;;; Γ ⊢ T ⇝ tSort s' × compare_sort Σ pb s s'. Proof using Type. intros H. depind H. - - destruct pb; inversion c; eauto using into_closed_red. + - inversion c; eauto using into_closed_red. - depelim r. solve_discr. - destruct IHws_cumul_pb as [s' [redv leq]]. exists s'. split; auto. eapply into_closed_red; tea. @@ -365,10 +358,10 @@ Section ConvCongruences. Lemma ws_cumul_pb_Sort_r_inv {Γ s T} pb : Σ ;;; Γ ⊢ T ≤[pb] tSort s -> - ∑ s', Σ ;;; Γ ⊢ T ⇝ tSort s' × compare_universe pb Σ s' s. + ∑ s', Σ ;;; Γ ⊢ T ⇝ tSort s' × compare_sort Σ pb s' s. Proof using Type. intros H. depind H. - - destruct pb; inversion c; eauto using into_closed_red. + - inversion c; eauto using into_closed_red. - destruct IHws_cumul_pb as [s' [redv leq]]. exists s'. split; auto. eapply into_closed_red; tea. eapply red_step with v; eauto with fvs. @@ -1065,16 +1058,16 @@ Section Inversions. Qed. Lemma eq_term_upto_univ_conv_arity_l : - forall Re Rle Γ u v, + forall cmp_universe cmp_sort pb Γ u v, isArity u -> is_closed_context Γ -> is_open_term Γ u -> is_open_term Γ v -> - eq_term_upto_univ Σ Re Rle u v -> + eq_term_upto_univ Σ cmp_universe cmp_sort pb u v -> Is_conv_to_Arity Σ Γ v. Proof using Type. - intros Re Rle Γ u v a clΓ clu clv e. - induction u in Γ, clΓ, clv, clu, a, v, Rle, e |- *. all: try (cbn [isArity] in *; congruence). + intros cmp_universe cmp_sort pb Γ u v a clΓ clu clv e. + induction u in Γ, clΓ, clv, clu, a, v, pb, e |- *. all: try (cbn [isArity] in *; congruence). all: dependent destruction e. - eexists. split. + constructor. eapply closed_red_refl => //. @@ -1100,16 +1093,16 @@ Section Inversions. Qed. Lemma eq_term_upto_univ_conv_arity_r : - forall Re Rle Γ u v, + forall cmp_universe cmp_sort pb Γ u v, isArity u -> is_closed_context Γ -> is_open_term Γ u -> is_open_term Γ v -> - eq_term_upto_univ Σ Re Rle v u -> + eq_term_upto_univ Σ cmp_universe cmp_sort pb v u -> Is_conv_to_Arity Σ Γ v. Proof using Type. - intros Re Rle Γ u v a clΓ clu clv e. - induction u in Γ, clΓ, clv, clu, a, v, Rle, e |- *. all: try (cbn [isArity] in *; congruence). + intros cmp_universe cmp_sort pb Γ u v a clΓ clu clv e. + induction u in Γ, clΓ, clv, clu, a, v, pb, e |- *. all: try (cbn [isArity] in *; congruence). all: dependent destruction e. - eexists. split. + constructor. eapply closed_red_refl => //. @@ -1285,28 +1278,28 @@ Section Inversions. Notation invert_red_ind := red_mkApps_tInd. Lemma compare_term_mkApps_l_inv {pb} {u : term} {l : list term} {t : term} : - compare_term pb Σ Σ (mkApps u l) t -> + compare_term Σ Σ pb (mkApps u l) t -> ∑ (u' : term) (l' : list term), - [× eq_term_upto_univ_napp Σ (eq_universe Σ) (compare_universe pb Σ) #|l| u u', + [× compare_term_napp Σ Σ pb #|l| u u', All2 (eq_term Σ Σ) l l' & t = mkApps u' l']. Proof using wfΣ. - destruct pb => /= => /eq_term_upto_univ_mkApps_l_inv; firstorder. + move => /= => /eq_term_upto_univ_mkApps_l_inv; firstorder. Qed. Lemma compare_term_mkApps_r_inv {pb} {u : term} {l : list term} {t : term} : - compare_term pb Σ Σ t (mkApps u l) -> + compare_term Σ Σ pb t (mkApps u l) -> ∑ (u' : term) (l' : list term), - [× eq_term_upto_univ_napp Σ (eq_universe Σ) (compare_universe pb Σ) #|l| u' u, + [× compare_term_napp Σ Σ pb #|l| u' u, All2 (eq_term Σ Σ) l' l & t = mkApps u' l']. Proof using wfΣ. - destruct pb => /= => /eq_term_upto_univ_mkApps_r_inv; firstorder. + move => /= => /eq_term_upto_univ_mkApps_r_inv; firstorder. Qed. Lemma ws_cumul_pb_Ind_l_inv {pb Γ ind ui l T} : Σ ;;; Γ ⊢ mkApps (tInd ind ui) l ≤[pb] T -> ∑ ui' l', [× Σ ;;; Γ ⊢ T ⇝ (mkApps (tInd ind ui') l'), - R_global_instance Σ (eq_universe Σ) (compare_universe pb Σ) (IndRef ind) #|l| ui ui' & + cumul_Ind_univ Σ pb ind #|l| ui ui' & All2 (fun a a' => Σ ;;; Γ ⊢ a = a') l l']. Proof using wfΣ. move/ws_cumul_pb_red=> [v [v' [redv redv' leqvv']]]. @@ -1356,7 +1349,7 @@ Section Inversions. Σ ;;; Γ ⊢ T ≤[pb] mkApps (tInd ind ui) l -> ∑ ui' l', [× Σ ;;; Γ ⊢ T ⇝ (mkApps (tInd ind ui') l'), - R_global_instance Σ (eq_universe Σ) (compare_universe pb Σ) (IndRef ind) #|l| ui' ui & + cumul_Ind_univ Σ pb ind #|l| ui' ui & ws_cumul_pb_terms Σ Γ l' l]. Proof using wfΣ. move/ws_cumul_pb_red=> [v [v' [redv redv' leqvv']]]. @@ -1381,7 +1374,7 @@ Section Inversions. Lemma ws_cumul_pb_Ind_inv {pb Γ ind ind' ui ui' l l'} : Σ ;;; Γ ⊢ mkApps (tInd ind ui) l ≤[pb] mkApps (tInd ind' ui') l' -> [× ind = ind', - R_global_instance Σ (eq_universe Σ) (compare_universe pb Σ) (IndRef ind) #|l| ui ui', + cumul_Ind_univ Σ pb ind #|l| ui ui', is_closed_context Γ & ws_cumul_pb_terms Σ Γ l l']. Proof using wfΣ. move/ws_cumul_pb_red=> [v [v' [redv redv' leqvv']]]. @@ -1405,13 +1398,13 @@ Section Inversions. ∑ u' args', [× Σ ;;; Γ ⊢ T ⇝ mkApps (tConst cst u') args', All2 (fun args args' => Σ ;;; Γ ⊢ args ≤[Conv] args') args args' & - PCUICEquality.R_universe_instance (eq_universe Σ) u u']. + PCUICEquality.cmp_universe_instance (eq_universe Σ) u u']. Proof using wfΣ. intros hdecl hb H. eapply ws_cumul_pb_red in H as (v & v' & [tv tv' eqp]). epose proof (invert_red_axiom_app hdecl hb tv) as [args' [-> ?]]. eapply compare_term_mkApps_l_inv in eqp as [t' [l' []]]; subst v'. - depelim e. + depelim c. exists u', l'. split => //. eapply closed_red_open_right in tv'. rewrite on_free_vars_mkApps /= in tv'. solve_all. @@ -1427,13 +1420,13 @@ Section Inversions. ∑ u' args', [× Σ ;;; Γ ⊢ T ⇝ mkApps (tConst cst u') args', All2 (fun args args' => Σ ;;; Γ ⊢ args ≤[Conv] args') args' args & - PCUICEquality.R_universe_instance (eq_universe Σ) u' u]. + PCUICEquality.cmp_universe_instance (eq_universe Σ) u' u]. Proof using wfΣ. intros hdecl hb H. eapply ws_cumul_pb_red in H as (v & v' & [tv tv' eqp]). epose proof (invert_red_axiom_app hdecl hb tv') as [args' [-> ?]]. eapply compare_term_mkApps_r_inv in eqp as [t' [l' []]]; subst v. - depelim e. + depelim c. exists u0, l'. split => //. eapply closed_red_open_right in tv. rewrite on_free_vars_mkApps /= in tv. solve_all. @@ -1620,13 +1613,13 @@ Qed. Definition ws_cumul_pb_predicate {cf} Σ Γ p p' := [× ws_cumul_pb_terms Σ Γ p.(pparams) p'.(pparams), - R_universe_instance (eq_universe Σ) (puinst p) (puinst p'), - eq_context_gen eq eq (pcontext p) (pcontext p') & + cmp_universe_instance (eq_universe Σ) (puinst p) (puinst p'), + eq_context_upto_names (pcontext p) (pcontext p') & Σ ;;; Γ ,,, inst_case_predicate_context p ⊢ preturn p = preturn p']. Definition ws_cumul_pb_brs {cf} Σ Γ p := All2 (fun br br' => - eq_context_gen eq eq (bcontext br) (bcontext br') × + eq_context_upto_names (bcontext br) (bcontext br') × Σ ;;; Γ ,,, inst_case_branch_context p br ⊢ bbody br = bbody br'). Section Inversions. @@ -1712,7 +1705,7 @@ Section Inversions. Lemma invert_cumul_ind_ind {Γ ind ind' u u' args args'} : Σ ;;; Γ ⊢ mkApps (tInd ind u) args ≤ mkApps (tInd ind' u') args' -> - (eqb ind ind' * PCUICEquality.R_global_instance Σ (eq_universe Σ) (leq_universe Σ) (IndRef ind) #|args| u u' * + (eqb ind ind' * cumul_Ind_univ Σ Cumul ind #|args| u u' * ws_cumul_pb_terms Σ Γ args args'). Proof using wfΣ. intros ht; eapply ws_cumul_pb_Ind_l_inv in ht as (? & ? & [? ? ?]); auto. @@ -1929,7 +1922,7 @@ Section ConvRedConv. Qed. #[global] - Instance all_eq_term_refl : Reflexive (All2 (eq_term_upto_univ Σ.1 (eq_universe Σ) (eq_universe Σ))). + Instance all_eq_term_refl : Reflexive (All2 (eq_term_upto_univ Σ.1 (compare_universe Σ) (compare_sort Σ) Conv)). Proof using Type. intros x. apply All2_same. intros. reflexivity. Qed. @@ -1948,7 +1941,7 @@ Section ConvRedConv. ws_cumul_ctx_pb false Σ (Γ ,,, Δ) (Γ' ,,, Δ') -> #|Γ| = #|Γ'| -> ∑ Δ1 Δ1', red_ctx_rel Σ Γ Δ Δ1 × red_ctx_rel Σ Γ' Δ' Δ1' × - eq_context_upto Σ (eq_universe Σ) (eq_universe Σ) Δ1 Δ1'. + eq_context_upto Σ (compare_universe Σ) (compare_sort Σ) Conv Δ1 Δ1'. Proof. intros. pose proof (closed_con) @@ -2082,8 +2075,8 @@ Section ConvRedConv. Proof using Type. intros x; eapply All2_refl; reflexivity. Qed. Instance eqbrs_refl : Reflexive (All2 (fun x y : branch term => - eq_context_gen eq eq (bcontext x) (bcontext y) * - eq_term_upto_univ Σ.1 (eq_universe Σ) (eq_universe Σ) (bbody x) (bbody y))). + eq_context_upto_names (bcontext x) (bcontext y) * + eq_term_upto_univ Σ.1 (compare_universe Σ) (compare_sort Σ) Conv (bbody x) (bbody y))). Proof using Type. intros brs; eapply All2_refl; split; reflexivity. Qed. Lemma ws_cumul_pb_Case_p {Γ ci c brs p p'} : @@ -2192,27 +2185,27 @@ Section ConvRedConv. rewrite [is_open_term _ _]is_open_case_split onp onbrs /= andb_true_r //. Qed. - Lemma eq_context_gen_subst_context : + Lemma eq_context_upto_names_subst_context : forall u v n k, - eq_context_gen eq eq u v -> - eq_context_gen eq eq (subst_context n k u) (subst_context n k v). + eq_context_upto_names u v -> + eq_context_upto_names (subst_context n k u) (subst_context n k v). Proof using Type. - intros re u v n. + intros u v n k. induction 1. - constructor. - rewrite !subst_context_snoc; constructor; eauto. - depelim p; constructor; simpl; intuition auto; subst; - rewrite -(length_of X); auto. + rewrite -(All2_length X). + destruct r; constructor; assumption. Qed. - Lemma eq_context_gen_inst_case_context {Γ Δ Δ' pars puinst} : - eq_context_gen eq eq Δ Δ' -> - eq_context_gen eq eq (Γ ,,, inst_case_context pars puinst Δ) (Γ ,,, inst_case_context pars puinst Δ'). + Lemma eq_context_upto_names_inst_case_context {Γ Δ Δ' pars puinst} : + eq_context_upto_names Δ Δ' -> + eq_context_upto_names (Γ ,,, inst_case_context pars puinst Δ) (Γ ,,, inst_case_context pars puinst Δ'). Proof using Type. intros. - apply All2_fold_app; [reflexivity|]. + apply All2_app; [|reflexivity]. rewrite /inst_case_context. - now eapply eq_context_gen_subst_context, eq_context_gen_eq_univ_subst_preserved. + now eapply eq_context_upto_names_subst_context, eq_context_upto_names_univ_subst_preserved. Qed. Lemma ws_cumul_pb_Case_one_brs {Γ indn p c brs brs'} : @@ -2222,7 +2215,7 @@ Section ConvRedConv. is_open_brs Γ p brs -> is_open_brs Γ p brs' -> OnOne2 (fun u v => - eq_context_gen eq eq u.(bcontext) v.(bcontext) × + eq_context_upto_names u.(bcontext) v.(bcontext) × Σ ;;; (Γ ,,, inst_case_branch_context p u) ⊢ u.(bbody) = v.(bbody)) brs brs' -> Σ ;;; Γ ⊢ tCase indn p c brs = tCase indn p c brs'. Proof using wfΣ. @@ -2238,7 +2231,7 @@ Section ConvRedConv. + rewrite [is_open_term _ _]is_open_case_split onp onc /=. move: onbrs' i1. rewrite !forallb_app => /andP[] -> /= /andP[] => /andP[] => -> /= _ ->. - now rewrite andb_true_r shiftnP_add app_length inst_case_branch_context_length /= -(All2_fold_length a). + now rewrite andb_true_r shiftnP_add app_length inst_case_branch_context_length /= -(All2_length a). + constructor; try reflexivity. eapply All2_app; try reflexivity. constructor; try split; try reflexivity; cbn => //. @@ -2255,13 +2248,13 @@ Section ConvRedConv. 2:{ eapply IHh => //. move: onbrs' i2. rewrite !forallb_app => /andP[] -> /= /andP[] => /andP[] => -> /= _ ->. - now rewrite andb_true_r shiftnP_add app_length inst_case_branch_context_length /= (All2_fold_length a). } + now rewrite andb_true_r shiftnP_add app_length inst_case_branch_context_length /= (All2_length a). } eapply into_closed_red; eauto => //. { constructor. constructor. eapply OnOne2_app. constructor; auto. cbn. split; auto. eapply red1_eq_context_upto_names; tea. rewrite /inst_case_branch_context /=. - now eapply eq_context_upto_names_gen, eq_context_gen_inst_case_context. } + now eapply eq_context_upto_names_inst_case_context. } rewrite [is_open_term _ _]is_open_case_split onp onc /= //. Qed. @@ -2269,7 +2262,7 @@ Section ConvRedConv. Lemma is_open_brs_OnOne2 Γ p x y : is_open_brs Γ p x -> OnOne2 (fun u v : branch term => - eq_context_gen eq eq (bcontext u) (bcontext v) * + eq_context_upto_names (bcontext u) (bcontext v) * (Σ ;;; Γ,,, inst_case_branch_context p u ⊢ bbody u = bbody v)) y x -> is_open_brs Γ p y. Proof using wfΣ. @@ -2283,7 +2276,6 @@ Section ConvRedConv. now rewrite shiftnP_add. } rewrite !test_context_k_closed_on_free_vars_ctx in cl *. eapply eq_context_upto_names_on_free_vars; tea. - eapply eq_context_upto_names_gen. now symmetry. - now move: op => /= /andP[] => ->. Qed. @@ -2304,12 +2296,11 @@ Section ConvRedConv. split; [eapply ws_cumul_pb_is_open_term_left|eapply ws_cumul_pb_is_open_term_right]; tea. instantiate (1:=bbody x). instantiate (1 := Conv). eapply ws_cumul_pb_eq_context_upto; tea. - { eapply eq_context_gen_eq_context_upto; tc. - now eapply eq_context_gen_inst_case_context. } + { eapply eq_context_upto_names_eq_context_upto; tc. + now eapply eq_context_upto_names_inst_case_context. } eapply ws_cumul_pb_is_closed_context in cv. eapply eq_context_upto_names_on_free_vars; tea. - eapply eq_context_upto_names_gen. - now eapply eq_context_gen_inst_case_context. } + now eapply eq_context_upto_names_inst_case_context. } induction h. - apply ws_cumul_pb_compare; tas. 1-2:rewrite [is_open_term _ _]is_open_case_split onp onc /= //. @@ -2352,10 +2343,7 @@ Section ConvRedConv. (if b then tFix else tCoFix) mfix idx. Lemma eq_term_fix_or_cofix b mfix idx mfix' : - All2 (fun x y : def term => - ((eq_term_upto_univ Σ.1 (eq_universe Σ) (eq_universe Σ) (dtype x) (dtype y) - × eq_term_upto_univ Σ.1 (eq_universe Σ) (eq_universe Σ) (dbody x) (dbody y)) × rarg x = rarg y) * - eq_binder_annot (dname x) (dname y)) mfix mfix' -> + eq_mfixpoint (eq_term Σ Σ) mfix mfix' -> eq_term Σ Σ (fix_or_cofix b mfix idx) (fix_or_cofix b mfix' idx). Proof using Type. destruct b; constructor; auto. @@ -2453,8 +2441,8 @@ Section ConvRedConv. OnOne2 (fun u v => dtype u = dtype v × Σ ;;; Γ ,,, fix_context mfix ⊢ dbody u = dbody v × - (rarg u = rarg v) * - (eq_binder_annot (dname u) (dname v)) + rarg u = rarg v × + eq_binder_annot (dname u) (dname v) ) mfix mfix' -> Σ ;;; Γ ⊢ fix_or_cofix b mfix idx = fix_or_cofix b mfix' idx. Proof using wfΣ. @@ -2468,7 +2456,7 @@ Section ConvRedConv. cbn. eapply All2_app; [eapply All2_refl; reflexivity|]. constructor; cbn; [|constructor]. - constructor; auto. f_equal. auto. + rewrite -hty. constructor; auto. + cbn. eapply All2_app; eauto. constructor; auto. constructor; auto. } @@ -2546,21 +2534,20 @@ Section ConvRedConv. assert (thm : Σ ;;; Γ ⊢ fix_or_cofix b mfix idx = fix_or_cofix b mfix' idx × #|mfix| = #|mfix'| × - eq_context_upto Σ eq eq (Γ ,,, fix_context mfix) (Γ ,,, fix_context mfix') + eq_context_upto_names (Γ ,,, fix_context mfix) (Γ ,,, fix_context mfix') ). { eapply (All2_many_OnOne2_pres _ (fun x => True)) in h. 2:intuition. induction h. - - split; try reflexivity. - + constructor => //; rewrite ?is_open_fix_or_cofix //. - cbn; reflexivity. - + split; reflexivity. + - repeat split; try reflexivity. + constructor => //; rewrite ?is_open_fix_or_cofix //. + cbn; reflexivity. - destruct r as [hl [r _]]. assert (is_open_mfix Γ y). { eapply (is_open_fix_onone2) in r; intuition auto. now rewrite fix_context_length -(OnOne2_length r) -(rtrans_clos_length h). } destruct (IHh H) as [? []]. - split. + repeat split. 2: lia. + etransitivity. * eassumption. * apply ws_cumul_pb_fix_one_body; tea; eauto with fvs. @@ -2568,12 +2555,10 @@ Section ConvRedConv. intros [na ty bo ra] [na' ty' bo' ra'] [? [hh ?]]. simpl in *. intuition eauto. eapply ws_cumul_pb_eq_context_upto. 3: eassumption. - 1:eapply eq_context_impl. 4: eassumption. - all:tc. + 1: apply eq_context_upto_names_eq_context_upto; tas; tc. rewrite on_free_vars_ctx_app onΓ /=. apply on_free_vars_fix_context. solve_all. - + split; [lia|]. - etransitivity. + + etransitivity. * eassumption. * apply OnOne2_split in r as [[na ty bo ra] [[na' ty' bo' ra'] [l1 [l2 [[? [? [? ?]]] [? ?]]]]]]. @@ -2581,15 +2566,12 @@ Section ConvRedConv. rewrite 2!fix_context_fix_context_alt. rewrite 2!map_app. simpl. unfold def_sig at 2 5. simpl. - eapply eq_context_upto_cat. - -- eapply eq_context_upto_refl; auto. - -- eapply eq_context_upto_rev'. - rewrite 2!mapi_app. cbn. - eapply eq_context_upto_cat. - ++ constructor; tas; revgoals. - ** constructor; tas. eapply eq_term_upto_univ_refl. all: auto. - ** eapply eq_context_upto_refl; auto. - ++ eapply eq_context_upto_refl; auto. + eapply All2_app; try reflexivity. + eapply All2_rev. + rewrite 2!mapi_app. cbn. + eapply All2_app; try reflexivity. + constructor; try reflexivity. + constructor. assumption. } apply thm. Qed. @@ -3179,14 +3161,12 @@ Section ConvSubst. Lemma eq_context_upto_ws_cumul_ctx_pb {pb Γ Γ'} : is_closed_context Γ -> is_closed_context Γ' -> - eq_context_upto Σ (eq_universe Σ) (compare_universe pb Σ) Γ Γ' -> + compare_context Σ pb Γ Γ' -> ws_cumul_ctx_pb pb Σ Γ Γ'. Proof using wfΣ. intros cl cl' eq. apply into_ws_cumul_ctx_pb; auto. - destruct pb; revgoals. - { now eapply eq_context_upto_univ_cumul_context. } - { now eapply eq_context_upto_univ_conv_context. } + now apply compare_context_cumul_pb_context. Qed. Lemma substitution_ws_cumul_ctx_pb {Γ Δ Δ' Γ' s s'} : @@ -3394,7 +3374,7 @@ Qed. Lemma subst_instance_ws_cumul_ctx_pb {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Δ u u'} pb : wf_local Σ (subst_instance u Δ) -> - R_universe_instance (eq_universe (global_ext_constraints Σ)) u u' -> + cmp_universe_instance (eq_universe (global_ext_constraints Σ)) u u' -> ws_cumul_ctx_pb pb Σ (subst_instance u Δ) (subst_instance u' Δ). Proof. move=> wf equ. @@ -3445,7 +3425,7 @@ Hint Rewrite is_closed_context_subst_instance is_open_term_subst_instance : fvs. Lemma eq_term_compare_term {cf} pb Σ t u : eq_term Σ Σ t u -> - compare_term pb Σ Σ t u. + compare_term Σ Σ pb t u. Proof. destruct pb; cbn; auto. now apply eq_term_leq_term. @@ -3453,7 +3433,7 @@ Qed. Lemma subst_instance_ws_cumul_ctx_pb_rel {cf:checker_flags} {Σ} {wfΣ : wf Σ} {Γ Δ u u' pb} : is_closed_context (Γ ,,, Δ) -> - R_universe_instance (eq_universe Σ) u u' -> + cmp_universe_instance (eq_universe Σ) u u' -> ws_cumul_ctx_pb_rel pb Σ Γ (subst_instance u Δ) (subst_instance u' Δ). Proof. move=> equ. @@ -3500,7 +3480,7 @@ Proof. Qed. Lemma eq_term_inds {cf:checker_flags} (Σ : global_env_ext) u u' ind mdecl : - R_universe_instance (eq_universe (global_ext_constraints Σ)) u u' -> + cmp_universe_instance (eq_universe (global_ext_constraints Σ)) u u' -> All2 (eq_term Σ Σ) (inds (inductive_mind ind) u (ind_bodies mdecl)) (inds (inductive_mind ind) u' (ind_bodies mdecl)). Proof. @@ -3509,13 +3489,11 @@ Proof. induction n; constructor; auto. clear IHn. repeat constructor. destruct ind; simpl in *. - eapply (R_global_instance_empty_impl _ _ _ _ _ _ 0). - 4:{ unfold R_global_instance, R_global_instance_gen. simpl. eauto. } - all:typeclasses eauto. + apply cmp_instance_opt_variance; simpl; assumption. Qed. Lemma conv_inds {cf:checker_flags} (Σ : global_env_ext) Γ u u' ind mdecl : - R_universe_instance (eq_universe (global_ext_constraints Σ)) u u' -> + cmp_universe_instance (eq_universe (global_ext_constraints Σ)) u u' -> is_closed_context Γ -> ws_cumul_pb_terms Σ Γ (inds (inductive_mind ind) u (ind_bodies mdecl)) (inds (inductive_mind ind) u' (ind_bodies mdecl)). @@ -3525,29 +3503,20 @@ Proof. induction n; constructor; auto. clear IHn. repeat constructor; auto. destruct ind; simpl in *. - eapply (R_global_instance_empty_impl _ _ _ _ _ _ 0). - 4:{ unfold R_global_instance, R_global_instance_gen. simpl. eauto. } - all:typeclasses eauto. + apply cmp_instance_opt_variance; simpl; assumption. Qed. -Lemma R_global_instance_length Σ Req Rle ref napp i i' : - R_global_instance Σ Req Rle ref napp i i' -> #|i| = #|i'|. +Lemma cmp_global_instance_length Σ Req Rle ref napp i i' : + cmp_global_instance Σ Req Rle ref napp i i' -> #|i| = #|i'|. Proof. - unfold R_global_instance, R_global_instance_gen. - destruct global_variance_gen. - { induction i in l, i' |- *; destruct l, i'; simpl; auto; try lia; try easy. - * specialize (IHi i' []). simpl in IHi. intuition auto with all. - * intros []. intuition eauto with all. - } - { unfold R_universe_instance. - intros H % Forall2_length. now rewrite !map_length in H. } + apply cmp_opt_variance_length. Qed. -Lemma R_universe_instance_variance_irrelevant Re Rle i i' : +Lemma cmp_universe_instance_variance_irrelevant cmp_universe pb i i' : #|i| = #|i'| -> - R_universe_instance_variance Re Rle [] i i'. + cmp_opt_variance cmp_universe pb AllIrrelevant i i'. Proof. - now induction i in i' |- *; destruct i'; simpl; auto. + auto. Qed. Lemma ws_cumul_pb_it_mkProd_or_LetIn {cf pb Σ} {wfΣ : wf Σ} (Δ Γ Γ' : context) (B B' : term) : @@ -3878,7 +3847,7 @@ Section MoreCongruenceLemmas. Defined. Lemma ws_cumul_pb_Ind {pb Γ ind ui ui' l l'} : - [× R_global_instance Σ (eq_universe Σ) (compare_universe pb Σ) (IndRef ind) #|l| ui ui', + [× cumul_Ind_univ Σ pb ind #|l| ui ui', is_closed_context Γ & ws_cumul_pb_terms Σ Γ l l'] -> Σ ;;; Γ ⊢ mkApps (tInd ind ui) l ≤[pb] mkApps (tInd ind ui') l'. intros [Rglob Rclosed Hll']. apply ws_cumul_pb_terms_alt in Hll'. destruct Hll' as [l0 [l0' [Hl0 Hl0' Hl0l0']]]. @@ -3904,7 +3873,7 @@ Section MoreCongruenceLemmas. Defined. Lemma ws_cumul_pb_Construct {pb Γ i k ui ui' l l'} : - [× R_global_instance Σ (eq_universe Σ) (compare_universe pb Σ) (ConstructRef i k) #|l| ui ui', + [× cumul_Construct_univ Σ pb i k #|l| ui ui', is_closed_context Γ & ws_cumul_pb_terms Σ Γ l l'] -> Σ ;;; Γ ⊢ mkApps (tConstruct i k ui) l ≤[pb] mkApps (tConstruct i k ui') l'. intros [Rglob Rclosed Hll']. apply ws_cumul_pb_terms_alt in Hll'. destruct Hll' as [l0 [l0' [Hl0 Hl0' Hl0l0']]]. @@ -4029,10 +3998,10 @@ Proof. unfold inst_case_predicate_context. apply PCUICOnFreeVarsConv.on_free_vars_ctx_inst_case_context ; eauto. ++ rewrite shiftnP_add in Hreturn. rewrite <- inst_case_predicate_context_length in Hreturn. rewrite <- app_length in Hreturn. eassumption. - ++ rewrite shiftnP_add in Hreturn'. rewrite <- (All2_fold_length Hpcon) in Hreturn'. + ++ rewrite shiftnP_add in Hreturn'. rewrite <- (All2_length Hpcon) in Hreturn'. rewrite <- inst_case_predicate_context_length in Hreturn'. rewrite <- app_length in Hreturn'. eassumption. - * unfold ws_cumul_pb_brs. + * unfold cumul_branches, cumul_branch, ws_cumul_pb_brs in *. repeat toAll. eapply All2_impl. 1: tea. cbn; intros; destruct_head'_prod. split; eauto. rewrite -> test_context_k_closed_on_free_vars_ctx in *. repeat match goal with H : _ |- _ => progress toProp H end; destruct_head'_and. @@ -4040,7 +4009,7 @@ Proof. + apply PCUICOnFreeVarsConv.on_free_vars_ctx_inst_case_context ; eauto; repeat toAll; eauto. + let H := multimatch goal with H : _ |- _ => H end in erewrite -> shiftnP_add, <- inst_case_branch_context_length, <- app_length in H; exact H. - + rewrite -> shiftnP_add in *. rewrite <- (All2_fold_length ltac:(eassumption)) in *. erewrite <- inst_case_branch_context_length in *. + + rewrite -> shiftnP_add in *. rewrite <- (All2_length ltac:(eassumption)) in *. erewrite <- inst_case_branch_context_length in *. rewrite <- app_length in *. tea. - intros; eapply ws_cumul_pb_Proj_c; eauto. - intros Γ mfix mfix' idx Hmfixmfix' Hmfixmfix'_dep HΓ H H'. cbn in *. diff --git a/pcuic/theories/PCUICCumulProp.v b/pcuic/theories/PCUICCumulProp.v index c43281d5d..71bd00c95 100644 --- a/pcuic/theories/PCUICCumulProp.v +++ b/pcuic/theories/PCUICCumulProp.v @@ -29,8 +29,8 @@ Lemma cumul_sort_confluence {Σ} {wfΣ : wf Σ} {Γ A u v} : Σ ;;; Γ ⊢ A ≤ tSort u -> Σ ;;; Γ ⊢ A ≤ tSort v -> ∑ v', (Σ ;;; Γ ⊢ A = tSort v') * - (leq_universe (global_ext_constraints Σ) v' u /\ - leq_universe (global_ext_constraints Σ) v' v). + (leq_sort (global_ext_constraints Σ) v' u /\ + leq_sort (global_ext_constraints Σ) v' v). Proof using Type. move=> H H'. eapply ws_cumul_pb_Sort_r_inv in H as [u'u ?]. @@ -49,8 +49,8 @@ Lemma cumul_ind_confluence {Σ : global_env_ext} {wfΣ : wf Σ} {Γ A ind u v l [× Σ ;;; Γ ⊢ A ⇝ (mkApps (tInd ind v') l''), ws_cumul_pb_terms Σ Γ l l'', ws_cumul_pb_terms Σ Γ l' l'', - R_global_instance Σ (eq_universe Σ) (leq_universe Σ) (IndRef ind) #|l| v' u & - R_global_instance Σ (eq_universe Σ) (leq_universe Σ) (IndRef ind) #|l'| v' v]. + cmp_ind_universes Σ ind #|l| v' u & + cmp_ind_universes Σ ind #|l'| v' v]. Proof using Type. move=> H H'. eapply ws_cumul_pb_Ind_r_inv in H as [u'u [l'u [redl ru ?]]]. @@ -83,33 +83,45 @@ Proof using Type. now eapply wf_local_closed_context. Qed. +Lemma is_propositional_bottom {Σ Γ T s s'} : + wf_ext Σ -> + Σ ;;; Γ ⊢ T ≤ tSort s -> + Σ ;;; Γ ⊢ T ≤ tSort s' -> + Sort.is_propositional s -> Sort.is_propositional s'. +Proof using Hcf. + intros wfΣ hs hs'. + destruct (cumul_sort_confluence hs hs') as [x' [conv [leq leq']]]. + move: leq leq'. + destruct x', s, s' => //=. + now rewrite Hcf. +Qed. + Lemma is_prop_bottom {Σ Γ T s s'} : wf_ext Σ -> Σ ;;; Γ ⊢ T ≤ tSort s -> Σ ;;; Γ ⊢ T ≤ tSort s' -> - Universe.is_prop s -> Universe.is_prop s'. + Sort.is_prop s -> Sort.is_prop s'. Proof using Hcf. intros wfΣ hs hs'. destruct (cumul_sort_confluence hs hs') as [x' [conv [leq leq']]]. - intros isp. - eapply leq_universe_prop_r in leq; eauto. - unshelve eapply (leq_universe_prop_no_prop_sub_type _ _ _ _ leq'); eauto. + move: leq leq'. + destruct x', s, s' => //=. + now rewrite Hcf. Qed. Lemma is_sprop_bottom {Σ Γ T s s'} : wf_ext Σ -> Σ ;;; Γ ⊢ T ≤ tSort s -> Σ ;;; Γ ⊢ T ≤ tSort s' -> - Universe.is_sprop s -> Universe.is_sprop s'. + Sort.is_sprop s -> Sort.is_sprop s'. Proof using Type. intros wfΣ hs hs'. destruct (cumul_sort_confluence hs hs') as [x' [conv [leq leq']]]. - intros isp. - eapply leq_universe_sprop_r in leq; eauto. - unshelve eapply (leq_universe_sprop_l _ _ _ leq'); eauto. + move: leq leq'. + destruct x', s, s' => //=. Qed. -Lemma prop_sort_eq {Σ Γ u u'} : Universe.is_prop u -> Universe.is_prop u' -> +Lemma prop_sort_eq {Σ Γ u u'} : Sort.is_prop u -> Sort.is_prop u' -> is_closed_context Γ -> Σ ;;; Γ ⊢ tSort u = tSort u'. Proof using Type. @@ -119,7 +131,7 @@ Proof using Type. red. red. constructor. Qed. -Lemma sprop_sort_eq {Σ Γ u u'} : Universe.is_sprop u -> Universe.is_sprop u' -> +Lemma sprop_sort_eq {Σ Γ u u'} : Sort.is_sprop u -> Sort.is_sprop u' -> is_closed_context Γ -> Σ ;;; Γ ⊢ tSort u = tSort u'. Proof using Type. @@ -131,7 +143,7 @@ Qed. Lemma conv_sort_inv {Σ : global_env_ext} {wfΣ : wf Σ} Γ s s' : Σ ;;; Γ ⊢ tSort s = tSort s' -> - eq_universe (global_ext_constraints Σ) s s'. + eq_sort (global_ext_constraints Σ) s s'. Proof using Type. intros H. eapply ws_cumul_pb_alt_closed in H as [v [v' [redv redv' eqvv']]]. @@ -140,34 +152,37 @@ Proof using Type. now depelim eqvv'. Qed. -Lemma is_prop_superE {l} : Universe.is_prop (Universe.super l) -> False. +Lemma is_prop_superE {l} : Sort.is_prop (Sort.super l) -> False. Proof using Type. destruct l => //. Qed. -Lemma is_sprop_superE {l} : Universe.is_sprop (Universe.super l) -> False. +Lemma is_sprop_superE {l} : Sort.is_sprop (Sort.super l) -> False. Proof using Type. destruct l => //. Qed. -Lemma is_prop_prod {s s'} : Universe.is_prop s' -> Universe.is_prop (Universe.sort_of_product s s'). +Lemma is_prop_prod {s s'} : Sort.is_prop s' -> Sort.is_prop (Sort.sort_of_product s s'). Proof using Type. - intros isp. - unfold Universe.sort_of_product. rewrite isp. auto. + destruct s' => //. Qed. -Lemma is_sprop_prod {s s'} : Universe.is_sprop s' -> Universe.is_sprop (Universe.sort_of_product s s'). +Lemma is_sprop_prod {s s'} : Sort.is_sprop s' -> Sort.is_sprop (Sort.sort_of_product s s'). Proof using Type. - intros isp. - unfold Universe.sort_of_product. rewrite isp orb_true_r. auto. + destruct s' => //. Qed. -Definition eq_univ_prop (u v : Universe.t) := - (Universe.is_prop u <-> Universe.is_prop v) /\ - (Universe.is_sprop u <-> Universe.is_sprop v). +Definition eq_univ_prop (u v : sort) := + match Sort.to_family u, Sort.to_family v with + | Sort.fSProp, Sort.fSProp => true + | Sort.fProp, Sort.fProp => true + | Sort.fType, Sort.fType => true + | Sort.fType, Sort.fProp | Sort.fProp, Sort.fType => prop_sub_type + | _, _ => false + end. Definition eq_term_prop (Σ : global_env) napp := - PCUICEquality.eq_term_upto_univ_napp Σ eq_univ_prop eq_univ_prop napp. + PCUICEquality.eq_term_upto_univ_napp Σ (fun _ _ _ => True) (fun _ => eq_univ_prop) Conv napp. Reserved Notation " Σ ;;; Γ |- t ~~ u " (at level 50, Γ, t, u at next level). @@ -192,92 +207,38 @@ Inductive cumul_prop `{checker_flags} (Σ : global_env_ext) (Γ : context) : ter where " Σ ;;; Γ |- t ~~ u " := (cumul_prop Σ Γ t u) : type_scope. -Lemma eq_term_prop_impl Σ Re Rle t u : - forall n, - PCUICEquality.eq_term_upto_univ_napp Σ.1 Re Rle n t u -> - subrelation Re eq_univ_prop -> - subrelation Rle eq_univ_prop -> - eq_term_prop Σ n t u. +Lemma eq_term_prop_impl Σ cmp_universe cmp_sort pb napp t u : + RelationClasses.subrelation (cmp_sort Conv) eq_univ_prop -> + RelationClasses.subrelation (cmp_sort pb) eq_univ_prop -> + PCUICEquality.eq_term_upto_univ_napp Σ.1 cmp_universe cmp_sort pb napp t u -> + eq_term_prop Σ napp t u. Proof using Type. - intros n eq. - intros. - eapply PCUICEquality.eq_term_upto_univ_impl in eq. eauto. + intros hsub_conv hsub_pb. + eapply PCUICEquality.eq_term_upto_univ_impl. all:auto. + all: now intros ??. Qed. -Lemma leq_universe_prop_spec φ u1 u2 : - leq_universe φ u1 u2 -> - match u1, u2 with - | Universe.lProp, Universe.lProp => True - | Universe.lSProp, Universe.lSProp => True - | Universe.lProp, Universe.lSProp => False - | Universe.lSProp, Universe.lProp => False - | Universe.lProp, Universe.lType _ => prop_sub_type - | Universe.lSProp, Universe.lType _ => False - | Universe.lType l, Universe.lType l' => True - | Universe.lType _, _ => False - end. +#[global] +Instance subrelation_compare_sort_eq_prop φ pb : + RelationClasses.subrelation (compare_sort φ pb) eq_univ_prop. Proof using Type. - intros leq. - apply (leq_universe_props _ _ _ leq). -Qed. - -Lemma subrelation_eq_universe_eq_prop Σ : - subrelation (eq_universe Σ) eq_univ_prop. -Proof using Hcf. - intros x y eq'. red. - split; intros. - eapply eq_universe_leq_universe in eq'. - eapply leq_universe_prop_spec in eq'; auto. - destruct x, y; simpl in *; auto; cong. - eapply eq_universe_leq_universe in eq'. - eapply leq_universe_prop_spec in eq'; auto. - destruct x, y; simpl in *; auto; cong. -Qed. - -Lemma subrelation_leq_universe_eq_prop Σ : - subrelation (leq_universe Σ) eq_univ_prop. -Proof using Hcf. - intros x y eq'. red. - split; intros; - eapply leq_universe_prop_spec in eq'; auto; - destruct x, y; simpl in *; auto; cong. + intros s s'. + destruct pb, s, s' => //=. Qed. -Lemma eq_term_eq_term_prop_impl Σ t u : - forall n, - PCUICEquality.eq_term_upto_univ_napp Σ.1 (eq_universe Σ) (eq_universe Σ) n t u -> - eq_term_prop Σ n t u. -Proof using Hcf. - intros n eq. eapply eq_term_prop_impl; eauto. - now apply subrelation_eq_universe_eq_prop. - now apply subrelation_eq_universe_eq_prop. -Qed. - -Lemma leq_term_eq_term_prop_impl Σ t u : - forall n, - PCUICEquality.eq_term_upto_univ_napp Σ.1 (eq_universe Σ) (leq_universe Σ) n t u -> - eq_term_prop Σ n t u. -Proof using Hcf. - intros n eq. eapply eq_term_prop_impl; eauto. - now apply subrelation_eq_universe_eq_prop. - now apply subrelation_leq_universe_eq_prop. -Qed. - -Lemma cumul_cumul_prop Σ Γ A B : - Σ ;;; Γ ⊢ A ≤ B -> - Σ ;;; Γ |- A ~~ B. -Proof using Hcf. - induction 1. - - constructor => //. now apply leq_term_eq_term_prop_impl in c. - - econstructor 2; eauto. - - econstructor 3; eauto. +Lemma eq_term_eq_term_prop_impl Σ φ pb napp t u : + compare_term_napp Σ φ pb napp t u -> + eq_term_prop Σ napp t u. +Proof using Type. + eapply eq_term_prop_impl. + all: apply subrelation_compare_sort_eq_prop. Qed. -Lemma conv_cumul_prop Σ Γ A B : - Σ ;;; Γ ⊢ A = B -> +Lemma cumul_pb_cumul_prop Σ Γ pb A B : + Σ ;;; Γ ⊢ A ≤[pb] B -> Σ ;;; Γ |- A ~~ B. -Proof using Hcf. +Proof using Type. induction 1. - constructor => //. now apply eq_term_eq_term_prop_impl in c. - econstructor 2; eauto. @@ -314,46 +275,81 @@ Proof using Type. econstructor 2; eauto. Qed. -Lemma cumul_prop_props {Σ Γ u u'} {wfΣ : wf Σ}: - Universe.is_prop u -> - Σ ;;; Γ |- tSort u ~~ tSort u' -> - Universe.is_prop u'. -Proof using Type. - intros isp equiv. +Lemma cumul_prop_sort {Σ Γ s s'} {wfΣ : wf Σ} : + Σ ;;; Γ |- tSort s ~~ tSort s' -> + eq_univ_prop s s'. +Proof. + intros equiv. eapply cumul_prop_alt in equiv as [nf [nf' [redl redr eq]]]. eapply invert_red_sort in redl. apply invert_red_sort in redr. subst. - depelim eq. red in e. intuition auto. + now depelim eq. +Qed. + +Lemma cumul_prop_props {Σ Γ u u'} {wfΣ : wf Σ}: + Sort.is_prop u -> + Σ ;;; Γ |- tSort u ~~ tSort u' -> + Sort.is_prop u'. +Proof using Hcf. + move => isp /cumul_prop_sort. move: isp. + destruct u, u' => //=. cbn. rewrite Hcf //. Qed. Lemma cumul_sprop_props {Σ Γ u u'} {wfΣ : wf Σ} : - Universe.is_sprop u -> + Sort.is_sprop u -> Σ ;;; Γ |- tSort u ~~ tSort u' -> - Universe.is_sprop u'. + Sort.is_sprop u'. Proof using Type. - intros isp equiv. - eapply cumul_prop_alt in equiv as [nf [nf' [redl redr eq]]]. - eapply invert_red_sort in redl. apply invert_red_sort in redr. - subst. - depelim eq. red in e. intuition auto. + move => isp /cumul_prop_sort. move: isp. + destruct u, u' => //. Qed. Instance refl_eq_univ_prop : RelationClasses.Reflexive eq_univ_prop. Proof using Type. - intros x. red. intuition. + now intros []. Qed. Instance sym_eq_univ_prop : RelationClasses.Symmetric eq_univ_prop. Proof using Type. - intros x y; unfold eq_univ_prop; intuition. + now intros [] []. Qed. Instance trans_eq_univ_prop : RelationClasses.Transitive eq_univ_prop. Proof using Type. - intros x y; unfold eq_univ_prop; intuition. + now intros [] [] []. +Qed. + +#[global] +Instance equiv_eq_univ_prop : RelationClasses.Equivalence eq_univ_prop. +Proof using Type. + split; exact _. +Qed. + +#[global] +Instance equiv_True {T} : @RelationClasses.Equivalence T (fun _ _ => True). +Proof using Type. + split; auto. Qed. -Lemma LevelExprSet_For_all (P : LevelExpr.t -> Prop) (u : LevelAlgExpr.t) : +#[global] +Instance subrel_R_True {T} R : @RelationClasses.subrelation T R (fun _ _ => True). +Proof. + now intros ??. +Qed. + +#[global] +Instance substu_f_True {T} `{UnivSubst T} f : SubstUnivPreserving f (fun _ _ => True). +Proof using Type. + now intros ???. +Qed. + +#[global] +Instance substu_True_eq_univ_prop : SubstUnivPreserving (fun _ _ => True) eq_univ_prop. +Proof using Type. + now intros []???. +Qed. + +Lemma LevelExprSet_For_all (P : LevelExpr.t -> Prop) (u : Universe.t) : LevelExprSet.For_all P u <-> Forall P (LevelExprSet.elements u). Proof using Type. @@ -416,11 +412,6 @@ Proof using Type. apply univ_exprs_map_all. Qed. -Lemma univ_is_prop_make x : Universe.is_prop (Universe.make x) = false. -Proof using Type. - destruct x; simpl; auto. -Qed. - (* Lemma is_prop_subst_level_expr u1 u2 s : Forall2 (fun x y : Level.t => eq_univ_prop (Universe.make x) (Universe.make y)) u1 u2 -> LevelExpr.is_prop (subst_instance_level_expr u1 s) = LevelExpr.is_prop (subst_instance_level_expr u2 s). @@ -437,15 +428,6 @@ Proof. now rewrite hu. Qed. *) -Instance substuniv_eq_univ_prop : SubstUnivPreserving eq_univ_prop. -Proof using Type. - intros s u1 u2 hu. - red in hu. - eapply Forall2_map_inv in hu. - rewrite /subst_instance_univ. - destruct s; red; simpl; auto; try intuition reflexivity. -Qed. - Lemma cumul_prop_sym Σ Γ T U : wf Σ.1 -> Σ ;;; Γ |- T ~~ U -> @@ -482,45 +464,24 @@ Qed. Global Instance cumul_prop_transitive Σ Γ : wf Σ -> CRelationClasses.Transitive (cumul_prop Σ Γ). Proof using Type. intros. red. intros. now eapply cumul_prop_trans. Qed. -Lemma cumul_prop_cum_l {Σ Γ A T B} {wfΣ : wf_ext Σ} : - Σ ;;; Γ |- A ~~ T -> - Σ ;;; Γ ⊢ A ≤ B -> - Σ ;;; Γ |- B ~~ T. -Proof using Hcf. - intros HT cum. - eapply cumul_cumul_prop in cum; auto. - eapply CRelationClasses.transitivity ; eauto. - eapply cumul_prop_sym; eauto. -Qed. - -Lemma cumul_prop_cum_r {Σ Γ A T B} {wfΣ : wf_ext Σ} : +Lemma cumul_prop_cumul_pb_l {Σ Γ pb A T B} {wfΣ : wf_ext Σ} : Σ ;;; Γ |- A ~~ T -> - Σ ;;; Γ ⊢ B ≤ A -> + Σ ;;; Γ ⊢ A ≤[pb] B -> Σ ;;; Γ |- B ~~ T. -Proof using Hcf. - intros HT cum. - eapply cumul_cumul_prop in cum; auto. - eapply CRelationClasses.transitivity ; eauto. -Qed. - -Lemma cumul_prop_conv_l {Σ Γ A T B} {wfΣ : wf_ext Σ} : - Σ ;;; Γ |- A ~~ T -> - Σ ;;; Γ ⊢ A = B -> - Σ ;;; Γ |- B ~~ T. -Proof using Hcf. +Proof using Type. intros HT cum. - eapply conv_cumul_prop in cum; auto. - eapply CRelationClasses.transitivity ; eauto. + eapply cumul_pb_cumul_prop in cum; auto. + etransitivity ; eauto. eapply cumul_prop_sym; eauto. Qed. -Lemma cumul_prop_conv_r {Σ Γ A T B} {wfΣ : wf_ext Σ} : +Lemma cumul_prop_cum_pb_r {Σ Γ pb A T B} {wfΣ : wf_ext Σ} : Σ ;;; Γ |- A ~~ T -> - Σ ;;; Γ ⊢ B = A -> + Σ ;;; Γ ⊢ B ≤[pb] A -> Σ ;;; Γ |- B ~~ T. -Proof using Hcf. +Proof using Type. intros HT cum. - eapply conv_cumul_prop in cum; auto. + eapply cumul_pb_cumul_prop in cum; auto. eapply CRelationClasses.transitivity ; eauto. Qed. @@ -700,9 +661,9 @@ Qed. Lemma red_conv_prop {Σ Γ T U} {wfΣ : wf_ext Σ} : Σ ;;; Γ ⊢ T ⇝ U -> Σ ;;; Γ |- T ~~ U. -Proof using Hcf. +Proof using Type. move/(red_ws_cumul_pb (pb:=Conv)). - now apply conv_cumul_prop. + now apply cumul_pb_cumul_prop. Qed. Lemma substitution_red_terms_conv_prop {Σ Γ Δ Γ' s s' M} {wfΣ : wf_ext Σ} : @@ -711,7 +672,7 @@ Lemma substitution_red_terms_conv_prop {Σ Γ Δ Γ' s s' M} {wfΣ : wf_ext Σ} untyped_subslet Γ s Δ -> red_terms Σ Γ s s' -> Σ ;;; (Γ ,,, subst_context s 0 Γ') |- (subst s #|Γ'| M) ~~ (subst s' #|Γ'| M). -Proof using Hcf. +Proof using Type. intros. apply red_conv_prop. eapply closed_red_red_subst; tea. @@ -721,7 +682,7 @@ Lemma context_conversion_cumul_prop {Σ Γ Δ M N} {wfΣ : wf_ext Σ} : Σ ;;; Γ |- M ~~ N -> Σ ⊢ Γ = Δ -> Σ ;;; Δ |- M ~~ N. -Proof using Hcf. +Proof using Type. induction 1; intros. - constructor => //. eauto with fvs. now rewrite -(All2_fold_length X). now rewrite -(All2_fold_length X). @@ -732,7 +693,7 @@ Proof using Hcf. eapply conv_red_conv in X1. 2:exact X0. 3:{ eapply ws_cumul_pb_refl. fvs. now rewrite (All2_fold_length X0). } 2:{ eapply closed_red_refl. fvs. now rewrite (All2_fold_length X0). } - symmetry in X1. now eapply conv_cumul_prop. + symmetry in X1. now eapply cumul_pb_cumul_prop. - specialize (IHX X0). transitivity v => //. eapply red1_red in r. assert (Σ ;;; Γ ⊢ u ⇝ v) by (now apply into_closed_red). @@ -740,7 +701,7 @@ Proof using Hcf. eapply conv_red_conv in X1. 2:exact X0. 3:{ eapply ws_cumul_pb_refl. fvs. now rewrite (All2_fold_length X0). } 2:{ eapply closed_red_refl. fvs. now rewrite (All2_fold_length X0). } - symmetry in X1. now eapply conv_cumul_prop. + symmetry in X1. now eapply cumul_pb_cumul_prop. Qed. (** Note: a more general version involving substitution in an extended context Γ ,,, Δ would be @@ -755,7 +716,7 @@ Lemma substitution_untyped_cumul_prop_cumul {Σ Γ Δ Δ' s s' M} {wfΣ : wf_ext untyped_subslet Γ s' Δ' -> All2 (cumul_prop Σ Γ) s s' -> Σ ;;; Γ |- subst0 s M ~~ subst0 s' M. -Proof using Hcf. +Proof using Type. intros clctx clctx' clM subs subs' Heq. assert (lens' := All2_length Heq). destruct (cumul_prop_args Heq) as (nf & nf' & [redl redr eq]) => //. @@ -787,50 +748,15 @@ Proof using Type. repeat constructor. Qed. -Lemma is_prop_subst_instance_level u l - : Universe.is_prop (Universe.make (subst_instance_level u l)) = Universe.is_prop (Universe.make l). -Proof using Type. - destruct l; simpl; auto. -Qed. - -Lemma R_opt_variance_impl Re Rle v x y : - subrelation Re Rle -> - R_universe_instance Re x y -> - R_opt_variance Re Rle v x y. -Proof using Type. - intros sub. - destruct v; simpl; auto. - intros H. eapply Forall2_map_inv in H. - induction H in l |- *; simpl; auto. - destruct l. auto. - split. destruct t; simpl; auto. - eauto. -Qed. - -Lemma cumul_prop_subst_instance_level Σ univs u u' (l : Level.t) : +Lemma cmp_True_subst_instance Σ univs u u' (i : Instance.t) : wf Σ.1 -> consistent_instance_ext Σ univs u -> consistent_instance_ext Σ univs u' -> - eq_univ_prop (subst_instance u (Universe.make l)) - (subst_instance u' (Universe.make l)). + cmp_universe_instance (fun _ _ => True) (subst_instance u i) (subst_instance u' i). Proof using Type. intros wfΣ cu cu'. red. - unfold subst_instance; cbn. intuition. -Qed. - -Lemma cumul_prop_subst_instance_instance Σ univs u u' (i : Instance.t) : - wf Σ.1 -> - consistent_instance_ext Σ univs u -> - consistent_instance_ext Σ univs u' -> - R_universe_instance eq_univ_prop (subst_instance u i) - (subst_instance u' i). -Proof using Type. - intros wfΣ cu cu'. red. - eapply All2_Forall2, All2_map. - unfold subst_instance. - eapply All2_map. eapply All2_refl. - intros x. red. - rewrite !is_prop_subst_instance_level /=. split; reflexivity. + eapply All2_Forall2, All2_map, All2_refl => ui. + unfold on_rel. auto. Qed. Lemma cumul_prop_subst_instance {Σ Γ univs u u' T} {wfΣ : wf Σ} : @@ -853,41 +779,41 @@ Proof using Type. - constructor. eapply PCUICEquality.eq_term_upto_univ_impl in IHT1; eauto. all:try typeclasses eauto. apply IHT2. - - constructor. now eapply cumul_prop_subst_instance_instance. - - constructor. red. apply R_opt_variance_impl. intros x y; auto. - now eapply cumul_prop_subst_instance_instance. - - constructor. red. apply R_opt_variance_impl. intros x y; auto. - now eapply cumul_prop_subst_instance_instance. + - constructor. now eapply cmp_True_subst_instance. + - constructor. now eapply cmp_instance_opt_variance, cmp_True_subst_instance. + - constructor. now eapply cmp_instance_opt_variance, cmp_True_subst_instance. - cbn. constructor. splits; simpl; solve_all. - eapply cumul_prop_subst_instance_instance; tea. reflexivity. + eapply cmp_True_subst_instance; tea. reflexivity. apply IHT. eapply All2_map. - eapply All_All2; tea. cbn. + eapply All_All2; tea. cbn. unfold eq_branch. intuition auto. rewrite /id. reflexivity. + - constructor. unfold eq_mfixpoint. + eapply All2_map. eapply All_All2; tea. + cbn. intros d []. + intuition eauto. + - constructor. unfold eq_mfixpoint. + eapply All2_map. eapply All_All2; tea. + cbn. intros d []. + intuition eauto. - cbn. constructor; splits; simpl. destruct p as [? []]; constructor; cbn in *; intuition eauto. - unshelve eapply cumul_prop_subst_instance_level; tea. exact (array_level a). solve_all. Qed. -Lemma R_eq_univ_prop_consistent_instances Σ univs u u' : +Lemma cmp_True_instance Σ univs u u' : wf Σ.1 -> consistent_instance_ext Σ univs u -> consistent_instance_ext Σ univs u' -> - R_universe_instance eq_univ_prop u u'. + cmp_universe_instance (fun _ _ => True) u u'. Proof using Type. intros wfΣ cu cu'. destruct univs; simpl in *. - - destruct u, u' => /=; [|done..]. red. - simpl. constructor. - - intuition. - eapply Forall2_map. - eapply All2_Forall2. - solve_all. - eapply All2_impl. - eapply All_All_All2; eauto. lia. - simpl; intros. - intuition auto with *. + - destruct u, u' => //=. + - apply Forall2_triv. + destruct cu as (_ & ? & _). + destruct cu' as (_ & ? & _). + congruence. Qed. Lemma untyped_subslet_inds Γ ind u u' mdecl : @@ -914,7 +840,7 @@ Lemma cumul_prop_tProd {Σ : global_env_ext} {Γ na t ty na' t' ty'} {wfΣ : wf_ eq_term Σ.1 Σ t t' -> Σ ;;; Γ ,, vass na t |- ty ~~ ty' -> Σ ;;; Γ |- tProd na t ty ~~ tProd na' t' ty'. -Proof using Hcf. +Proof using Type. intros eqann eq cum. eapply cumul_prop_alt in cum as (nf & nf' & [redl redr eq']). eapply cumul_prop_alt. eexists (tProd na t nf), (tProd na' t' nf'); split; eauto. @@ -929,7 +855,7 @@ Proof using Hcf. now rewrite on_free_vars_ctx_snoc /= onΓ. repeat (constructor; auto). - repeat (constructor; auto). - eapply eq_term_eq_term_prop_impl; auto. + eapply eq_term_eq_term_prop_impl; eauto. Qed. Lemma cumul_prop_tLetIn (Σ : global_env_ext) {Γ na t d ty na' t' d' ty'} {wfΣ : wf_ext Σ} : @@ -938,11 +864,11 @@ Lemma cumul_prop_tLetIn (Σ : global_env_ext) {Γ na t d ty na' t' d' ty'} {wfΣ eq_term Σ.1 Σ d d' -> Σ ;;; Γ ,, vdef na d t |- ty ~~ ty' -> Σ ;;; Γ |- tLetIn na d t ty ~~ tLetIn na' d' t' ty'. -Proof using Hcf. +Proof using Type. intros eqann eq eq' cum. eapply cumul_prop_alt in cum as (nf & nf' & [redl redr eq'']). eapply cumul_prop_alt. - assert(eq_context_upto Σ (eq_universe Σ) (eq_universe Σ) (Γ ,, vdef na d t) (Γ ,, vdef na' d' t')). + assert(eq_context Σ Σ (Γ ,, vdef na d t) (Γ ,, vdef na' d' t')). { repeat constructor; pcuic. eapply eq_context_upto_refl; typeclasses eauto. } eapply (closed_red_eq_context_upto_l (pb:=Conv)) in redr; eauto. 2:{ eapply clrel_ctx in redl. rewrite !on_free_vars_ctx_snoc in redl |- *. @@ -955,9 +881,9 @@ Proof using Hcf. eexists (tLetIn na d t nf), (tLetIn na' d' t' v'); split. - now eapply closed_red_letin_body. - now eapply closed_red_letin_body. - - constructor; eauto using eq_term_eq_term_prop_impl. - apply eq_term_eq_term_prop_impl; auto. - apply eq_term_eq_term_prop_impl; auto. + - constructor; eauto. + eapply eq_term_eq_term_prop_impl; eauto. + eapply eq_term_eq_term_prop_impl; eauto. transitivity nf'. auto. now eapply eq_term_eq_term_prop_impl. Qed. @@ -968,7 +894,7 @@ Lemma cumul_prop_mkApps {Σ Γ f args f' args'} {wfΣ : wf_ext Σ} : eq_term Σ.1 Σ f f' -> All2 (cumul_prop Σ Γ) args args' -> Σ ;;; Γ |- mkApps f args ~~ mkApps f' args'. -Proof using Hcf. +Proof using Type. intros clΓ clf clf' eq eq'. eapply cumul_prop_alt. eapply cumul_prop_args in eq' as (nf & nf' & [redl redr eq']). @@ -977,8 +903,9 @@ Proof using Hcf. - eapply closed_red_mkApps; auto. - eapply eq_term_upto_univ_mkApps. eapply eq_term_upto_univ_impl. - 5:eapply eq. all:auto. 4:lia. - all:now eapply subrelation_eq_universe_eq_prop. + 6:eapply eq. 5: lia. + all: tc. + auto. Qed. Hint Resolve closed_red_open_right : fvs. @@ -1033,17 +960,10 @@ Proof using Type. Qed. Notation eq_term_napp Σ n x y := - (eq_term_upto_univ_napp Σ (eq_universe Σ) (eq_universe Σ) n x y). + (eq_term_upto_univ_napp Σ (eq_sort Σ) (eq_sort Σ) n x y). Notation leq_term_napp Σ n x y := - (eq_term_upto_univ_napp Σ (eq_universe Σ) (leq_universe Σ) n x y). - -Lemma eq_term_upto_univ_napp_leq {Σ : global_env_ext} {n x y} : - eq_term_napp Σ n x y -> - leq_term_napp Σ n x y. -Proof using Type. - eapply eq_term_upto_univ_impl; auto; typeclasses eauto. -Qed. + (eq_term_upto_univ_napp Σ (eq_sort Σ) (leq_sort Σ) n x y). Lemma cumul_prop_is_open {Σ Γ T U} : Σ ;;; Γ |- T ~~ U -> @@ -1061,21 +981,6 @@ Proof using Type. eapply on_free_vars_ctx_impl. discriminate. Qed. -Lemma eq_context_upto_map2_set_binder_name Σ eqterm leterm eq le pctx pctx' Γ Δ : - eq_context_gen eqterm leterm pctx pctx' -> - eq_context_upto Σ eq le Γ Δ -> - eq_context_upto Σ eq le - (map2 set_binder_name (forget_types pctx) Γ) - (map2 set_binder_name (forget_types pctx') Δ). -Proof using Type. -intros eqp. -induction 1 in pctx, pctx', eqp |- *. -- induction eqp; cbn; constructor. -- depelim eqp. simpl. constructor. - simpl. constructor; auto. - destruct c, p; constructor; auto. -Qed. - (** Well-typed terms in the leq_term relation live in the same sort hierarchy. *) Lemma typing_leq_term_prop_gen : env_prop @@ -1083,16 +988,16 @@ Lemma typing_leq_term_prop_gen : forall t' T' : term, on_udecl Σ.1 Σ.2 -> Σ ;;; Γ |- t' : T' -> - forall n, leq_term_napp Σ n t' t -> + forall pb n, compare_term_napp Σ Σ pb n t' t -> Σ ;;; Γ |- T ~~ T')%type (fun Σ Γ j => on_udecl Σ.1 Σ.2 -> lift_typing0 (fun t T => forall t' T' : term, Σ ;;; Γ |- t' : T' -> - forall n, leq_term_napp Σ n t' t -> + forall pb n, compare_term_napp Σ Σ pb n t' t -> Σ ;;; Γ |- T ~~ T') j) (fun Σ Γ => wf_local Σ Γ). -Proof using Hcf. +Proof using Type. eapply typing_ind_env. { intros ???? H ?. apply lift_typing_impl with (1 := H) => ?? [] ?? ?? //. eauto. } 1: now auto. @@ -1100,17 +1005,17 @@ Proof using Hcf. all: intros Σ wfΣ Γ wfΓ; intros. 1-13:match goal with - [ H : leq_term_napp _ _ _ _ |- _ ] => depelim H + [ H : compare_term_napp _ _ _ _ _ _ |- _ ] => depelim H end; assert (wf_ext Σ) by (split; assumption). - 15:{ assert (wf_ext Σ) by (split; assumption). specialize (X1 _ _ H X5 _ X6). - eapply cumul_prop_cum_l; tea. + 15:{ assert (wf_ext Σ) by (split; assumption). specialize (X1 _ _ H X5 _ _ X6). + eapply cumul_prop_cumul_pb_l; tea. eapply cumulSpec_cumulAlgo_curry in X4; tea; fvs. } 6:{ eapply inversion_App in X6 as (na' & A' & B' & hf & ha & cum); auto. - specialize (X3 _ _ H hf _ X7_1). - specialize (X5 _ _ H ha _ (eq_term_upto_univ_napp_leq X7_2)). - eapply cumul_cumul_prop in cum; auto. + specialize (X3 _ _ H hf _ _ X7_1). + specialize (X5 _ _ H ha _ _ X7_2). + eapply cumul_pb_cumul_prop in cum; auto. transitivity (B' {0 := u0}) => //. eapply cumul_prop_prod_inv in X3 => //. transitivity (B' {0 := u}). @@ -1122,58 +1027,56 @@ Proof using Hcf. rewrite shiftnP_add. now eapply cumul_prop_is_open in X3 as []. eapply eq_term_eq_term_prop_impl => //. eapply PCUICEquality.eq_term_upto_univ_substs. - all:try typeclasses eauto. - eapply PCUICEquality.eq_term_upto_univ_refl. all:try typeclasses eauto. + all: try reflexivity. constructor. 2:constructor. now symmetry. } - eapply inversion_Rel in X0 as [decl' [wfΓ' [Hnth Hcum]]]; auto. - rewrite Hnth in H; noconf H. now eapply cumul_cumul_prop in Hcum. + rewrite Hnth in H; noconf H. now eapply cumul_pb_cumul_prop in Hcum. - eapply inversion_Sort in X0 as [wf [wfs Hs]]; auto. - apply subrelation_leq_universe_eq_prop in x => //. - apply cumul_cumul_prop in Hs => //. + apply subrelation_compare_sort_eq_prop in c => //. + apply cumul_pb_cumul_prop in Hs => //. eapply cumul_prop_trans; eauto. destruct (cumul_prop_is_open Hs) as []. - constructor => //. constructor. symmetry. - split; split; intros H'. 1,2:now eapply is_prop_superE in H'. - 1,2:now eapply is_sprop_superE in H'. + constructor => //. constructor. rewrite /eq_univ_prop !Sort.sType_super //. - eapply inversion_Prod in X4 as [s1' [s2' [Ha [Hb Hs]]]]; auto. + specialize (X1 H). apply unlift_TypUniv in X1, Ha. + specialize (X1 _ _ Ha _ _ X5_1). eapply context_conversion in Hb. 3:{ constructor. apply conv_ctx_refl. constructor. eassumption. constructor. eauto. } 2:{ pcuic. } - specialize (X3 _ _ H Hb _ X5_2). - eapply cumul_cumul_prop in Hs => //. + specialize (X3 _ _ H Hb _ _ X5_2). + eapply cumul_pb_cumul_prop in Hs => //. eapply cumul_prop_trans; eauto. constructor; fvs. constructor. - split. - * split; intros Hs'; apply is_prop_sort_prod in Hs'; eapply is_prop_prod; eapply cumul_prop_props; eauto. - now eapply cumul_prop_sym; eauto. - * split; intros Hs'; apply is_sprop_sort_prod in Hs'; eapply is_sprop_prod; eapply cumul_sprop_props; eauto. - now eapply cumul_prop_sym; eauto. + apply cumul_prop_sort in X1, X3. move: X1 X3. clear. + unfold eq_univ_prop. + destruct s2, s2' => //=. + all: destruct s1, s1' => //=. - - eapply inversion_Lambda in X4 as (B & dom & bod & cum). + - eapply inversion_Lambda in X4 as (B & dom & bod & cum); tas. specialize (X3 t0 B H). assert(conv_context cumulAlgo_gen Σ (Γ ,, vass na0 ty) (Γ ,, vass na t)). { repeat constructor; pcuic. } forward X3 by eapply context_conversion; eauto; pcuic. - specialize (X3 _ X5_2). eapply cumul_cumul_prop in cum; eauto. + specialize (X3 _ _ X5_2). eapply cumul_pb_cumul_prop in cum; eauto. eapply cumul_prop_trans; eauto. - eapply cumul_prop_tProd; eauto. now symmetry. now symmetry. auto. + eapply cumul_prop_tProd; eauto. now symmetry. now symmetry. - eapply inversion_LetIn in X4 as (A & dombod & codom & cum); auto. assert(conv_context cumulAlgo_gen Σ (Γ ,, vdef na0 t ty) (Γ ,, vdef na b b_ty)). { repeat constructor; pcuic. } specialize (X3 u A H). forward X3 by eapply context_conversion; eauto; pcuic. - specialize (X3 _ X5_3). - eapply cumul_cumul_prop in cum; eauto. + specialize (X3 _ _ X5_3). + eapply cumul_pb_cumul_prop in cum; eauto. eapply cumul_prop_trans; eauto. eapply cumul_prop_tLetIn; auto; now symmetry. - eapply inversion_Const in X1 as [decl' [wf [declc [cu cum]]]]; auto. - eapply cumul_cumul_prop in cum; eauto. + eapply cumul_pb_cumul_prop in cum; eauto. eapply cumul_prop_trans; eauto. unshelve eapply declared_constant_to_gen in H, declc; eauto. pose proof (declared_constant_inj _ _ H declc); subst decl'. @@ -1184,7 +1087,7 @@ Proof using Hcf. - eapply inversion_Ind in X1 as [decl' [idecl' [wf [declc [cu cum]]]]]; auto. unshelve eapply declared_inductive_to_gen in isdecl, declc; eauto. pose proof (declared_inductive_inj isdecl declc) as [-> ->]. - eapply cumul_cumul_prop in cum; eauto. + eapply cumul_pb_cumul_prop in cum; eauto. eapply cumul_prop_trans; eauto. eapply cumul_prop_subst_instance; tea. fvs. destruct (cumul_prop_is_open cum) as []. @@ -1194,7 +1097,7 @@ Proof using Hcf. unshelve eapply declared_constructor_to_gen in declc; eauto. unshelve epose proof (isdecl' := declared_constructor_to_gen isdecl); eauto. pose proof (declared_constructor_inj isdecl' declc) as [-> [-> ->]]. - eapply cumul_cumul_prop in cum; eauto. + eapply cumul_pb_cumul_prop in cum; eauto. eapply cumul_prop_trans; eauto. unfold type_of_constructor. have clars : is_closed_context (arities_context (ind_bodies mdecl))@[u]. @@ -1215,10 +1118,9 @@ Proof using Hcf. len. len in clty. * len. * len. - * generalize (ind_bodies mdecl). - induction l; simpl; constructor; auto. - constructor. simpl. eapply R_opt_variance_impl. now intros x. - eapply R_eq_univ_prop_consistent_instances; eauto. + * induction (ind_bodies mdecl) in |- *; simpl; constructor; auto. + constructor. simpl. eapply cmp_instance_opt_variance. + eapply cmp_True_instance; eauto. * simpl. eapply (@substitution_untyped_cumul_prop _ Γ (subst_instance u0 (arities_context mdecl.(ind_bodies))) []) => //. eapply on_free_vars_terms_inds. @@ -1228,13 +1130,13 @@ Proof using Hcf. len in clty; len. - eapply inversion_Case in X9 as (mdecl' & idecl' & isdecl' & indices' & data & cum); auto. - eapply cumul_cumul_prop in cum; eauto. + eapply cumul_pb_cumul_prop in cum; eauto. eapply cumul_prop_trans; eauto. simpl. clear X8. unshelve eapply declared_inductive_to_gen in isdecl, isdecl'; eauto. destruct (declared_inductive_inj isdecl isdecl'). subst. destruct data. - specialize (X7 _ _ H5 scrut_ty _ (eq_term_upto_univ_napp_leq X10)). + specialize (X7 _ _ H5 scrut_ty _ _ X10). eapply cumul_prop_sym => //. destruct e as [eqpars [eqinst [eqpctx eqpret]]]. rewrite /ptm. @@ -1247,24 +1149,23 @@ Proof using Hcf. rewrite /predctx. rewrite /case_predicate_context /case_predicate_context_gen. rewrite /pre_case_predicate_context_gen /inst_case_context. - eapply eq_context_upto_map2_set_binder_name; tea. - eapply eq_context_upto_subst_context; tea. tc. + eapply eq_context_upto_names_map2_set_binder_name; tea. + eapply eq_context_upto_subst_context; tea. 1,2: tc. eapply eq_context_upto_univ_subst_instance; try tc. tas. now eapply All2_rev. } - eapply All2_app. 2:(repeat constructor; auto using eq_term_eq_term_prop_impl). + eapply All2_app. 2:(repeat constructor; eauto using eq_term_eq_term_prop_impl). eapply cumul_prop_mkApps_Ind_inv in X7 => //. eapply All2_app_inv_l in X7 as (?&?&?&?&?). eapply All2_symP => //. typeclasses eauto. eapply app_inj in e as [eql ->] => //. move: (All2_length eqpars). - move: (All2_length a0). lia. fvs. now eapply subject_is_open_term in scrut_ty. + move: (All2_length a). lia. fvs. now eapply subject_is_open_term in scrut_ty. now apply subject_is_open_term in X6. - eapply inversion_Proj in X3 as (u' & mdecl' & idecl' & cdecl' & pdecl' & args' & inv); auto. intuition auto. - specialize (X2 _ _ H0 a0 _ (eq_term_upto_univ_napp_leq X4)). - eapply eq_term_upto_univ_napp_leq in X4. - eapply cumul_cumul_prop in b; eauto. + specialize (X2 _ _ H0 a0 _ _ X4). + eapply cumul_pb_cumul_prop in b; eauto. eapply cumul_prop_trans; eauto. eapply cumul_prop_mkApps_Ind_inv in X2 => //. unshelve epose proof (a' := declared_projection_to_gen a); eauto. @@ -1289,7 +1190,7 @@ Proof using Hcf. * epose proof (projection_subslet Σ _ _ _ _ _ _ _ _ _ a wfΣ a0 (validity a0)). now eapply subslet_untyped_subslet. * constructor => //. symmetry; constructor => //; fvs. - { now eapply leq_term_eq_term_prop_impl. } + { now eapply eq_term_eq_term_prop_impl. } { now eapply All2_rev. } * eapply (@substitution_cumul_prop Σ Γ (projection_context p.(proj_ind) mdecl' idecl' u') []) => //. { apply (projection_subslet Σ _ _ _ _ _ _ _ _ _ a wfΣ a0 (validity a0)). } @@ -1301,10 +1202,10 @@ Proof using Hcf. rewrite closedn_on_free_vars //. eapply closed_upwards; tea. lia. - eapply inversion_Fix in X4 as (decl' & fixguard' & Hnth & types' & bodies & wffix & cum); auto. - eapply cumul_cumul_prop in cum; eauto. + eapply cumul_pb_cumul_prop in cum; eauto. eapply cumul_prop_trans; eauto. - eapply All2_nth_error in a; eauto. - destruct a as [[[a _] _] _]. + eapply All2_nth_error in e; eauto. + destruct e as (a & _). constructor; [fvs|..]. { eapply nth_error_all in X0; tea. now apply isType_is_open_term in X0. } @@ -1313,10 +1214,10 @@ Proof using Hcf. now symmetry in a. - eapply inversion_CoFix in X4 as (decl' & fixguard' & Hnth & types' & bodies & wfcofix & cum); auto. - eapply cumul_cumul_prop in cum; eauto. + eapply cumul_pb_cumul_prop in cum; eauto. eapply cumul_prop_trans; eauto. - eapply All2_nth_error in a; eauto. - destruct a as [[[a _] _] _]. + eapply All2_nth_error in e; eauto. + destruct e as (a & _). constructor; [fvs|..]. { eapply nth_error_all in X0; tea. now apply isType_is_open_term in X0. } @@ -1326,9 +1227,9 @@ Proof using Hcf. - depelim X3. eapply inversion_Prim in X2 as [prim_ty' [cdecl' []]]; tea. depelim o. - 1-2:rewrite H in e; noconf e; eapply cumul_cumul_prop; eauto; pcuic. + 1-2:rewrite H in e; noconf e; eapply cumul_pb_cumul_prop; eauto; pcuic. depelim X1. - cbn in H, e2. rewrite H in e2. noconf e2. eapply cumul_cumul_prop; eauto; pcuic. + cbn in H, e2. rewrite H in e2. noconf e2. eapply cumul_pb_cumul_prop; eauto; pcuic. move: w; simp prim_type. intro. etransitivity; tea. constructor; fvs. cbn. depelim X0. fvs. eapply eq_term_leq_term. symmetry; repeat constructor; eauto. Qed. @@ -1338,11 +1239,23 @@ Lemma typing_leq_term_prop (Σ : global_env_ext) Γ t t' T T' : Σ ;;; Γ |- t : T -> on_udecl Σ.1 Σ.2 -> Σ ;;; Γ |- t' : T' -> - forall n, leq_term_napp Σ n t' t -> + forall pb n, compare_term_napp Σ Σ pb n t' t -> Σ ;;; Γ |- T ~~ T'. -Proof using Hcf. +Proof using Type. intros. now eapply (env_prop_typing typing_leq_term_prop_gen). Qed. +Lemma typing_cumul_term_prop {Σ : global_env_ext} {wfΣ : wf_ext Σ} pb Γ t t' T T' : + Σ ;;; Γ |- t : T -> + Σ ;;; Γ |- t' : T' -> + Σ ;;; Γ |- t' <=[pb] t -> + Σ ;;; Γ |- T ~~ T'. +Proof using Type. + intros. + apply cumul_alt in X1 as (v & v' & r & r' & leq). + eapply typing_leq_term_prop. 5: eassumption. 1,3: apply wfΣ. + all: eapply subject_reduction; [ auto | | eassumption]; assumption. +Qed. + End no_prop_leq_type. diff --git a/pcuic/theories/PCUICCumulativity.v b/pcuic/theories/PCUICCumulativity.v index c6b5bcbb7..318be8f28 100644 --- a/pcuic/theories/PCUICCumulativity.v +++ b/pcuic/theories/PCUICCumulativity.v @@ -14,9 +14,7 @@ Set Default Goal Selector "!". Reserved Notation " Σ ;;; Γ |- t <=[ pb ] u" (at level 50, Γ, t, u at next level, format "Σ ;;; Γ |- t <=[ pb ] u"). -Definition leq_term_ext `{checker_flags} (Σ : global_env_ext) Rle t u := eq_term_upto_univ Σ (eq_universe Σ) Rle t u. - -Notation " Σ ⊢ t <===[ pb ] u" := (compare_term pb Σ Σ t u) (at level 50, t, u at next level). +Notation " Σ ⊢ t <===[ pb ] u" := (compare_term Σ Σ pb t u) (at level 50, t, u at next level). (** ** Cumulativity *) @@ -53,18 +51,17 @@ Instance conv_decls_refl {cf:checker_flags} Σ Γ Γ' : Reflexive (conv_decls cu #[global] Instance cumul_decls_refl {cf:checker_flags} Σ Γ Γ' : Reflexive (cumul_decls cumulAlgo_gen Σ Γ Γ') := _. -Lemma cumul_alt `{cf : checker_flags} Σ Γ t u : - Σ ;;; Γ |- t <= u <~> { v & { v' & (red Σ Γ t v * red Σ Γ u v' * - leq_term_ext Σ (leq_universe Σ) v v')%type } }. +Lemma cumul_alt `{cf : checker_flags} Σ Γ pb t u : + Σ ;;; Γ |- t <=[pb] u <~> ∑ v v', red Σ Γ t v × red Σ Γ u v' × Σ ⊢ v <===[ pb ] v'. Proof. split. - induction 1. + exists t, u. intuition auto. - + destruct IHX as (v' & v'' & (redv & redv') & leqv). + + destruct IHX as (v' & v'' & redv & redv' & leqv). exists v', v''. intuition auto. now eapply red_step. - + destruct IHX as (v' & v'' & (redv & redv') & leqv). + + destruct IHX as (v' & v'' & redv & redv' & leqv). exists v', v''. intuition auto. now eapply red_step. - - intros [v [v' [[redv redv'] Hleq]]]. + - intros (v & v' & redv & redv' & Hleq). apply clos_rt_rt1n in redv. apply clos_rt_rt1n in redv'. induction redv. @@ -83,7 +80,7 @@ Qed. #[global] Instance conv_refl' {cf:checker_flags} Σ Γ : Reflexive (convAlgo Σ Γ). Proof. - intro; constructor. unfold leq_term_ext. reflexivity. + intro; constructor. reflexivity. Qed. Lemma red_cumul `{cf : checker_flags} {Σ : global_env_ext} {Γ t u} : @@ -170,18 +167,18 @@ Qed. Lemma eq_term_eq_term_napp {cf:checker_flags} Σ ϕ napp t t' : eq_term Σ ϕ t t' -> - eq_term_upto_univ_napp Σ (eq_universe ϕ) (eq_universe ϕ) napp t t'. + eq_term_upto_univ_napp Σ (compare_universe ϕ) (compare_sort ϕ) Conv napp t t'. Proof. - intros. eapply eq_term_upto_univ_impl. 5:eauto. - 4:auto with arith. all:typeclasses eauto. + intros. eapply eq_term_upto_univ_impl. 6:eauto. + 5:auto with arith. all:typeclasses eauto. Qed. Lemma leq_term_leq_term_napp {cf:checker_flags} Σ ϕ napp t t' : leq_term Σ ϕ t t' -> - eq_term_upto_univ_napp Σ (eq_universe ϕ) (leq_universe ϕ) napp t t'. + eq_term_upto_univ_napp Σ (compare_universe ϕ) (compare_sort ϕ) Cumul napp t t'. Proof. - intros. eapply eq_term_upto_univ_impl. 5:eauto. - 4:auto with arith. all:typeclasses eauto. + intros. eapply eq_term_upto_univ_impl. 6:eauto. + 5:auto with arith. all:typeclasses eauto. Qed. Lemma eq_term_mkApps `{checker_flags} Σ φ f l f' l' : @@ -249,35 +246,19 @@ Proof. + eauto. Qed. -Lemma conv_alt_red {cf : checker_flags} {Σ : global_env_ext} {Γ : context} {t u : term} : - Σ;;; Γ |- t = u <~> (∑ v v' : term, (red Σ Γ t v × red Σ Γ u v') × - eq_term Σ (global_ext_constraints Σ) v v'). -Proof. - split. - - induction 1. - * exists t, u; intuition auto. - * destruct IHX as [? [? [? ?]]]. - exists x, x0; intuition auto. eapply red_step; eauto. - * destruct IHX as [? [? [? ?]]]. - exists x, x0; intuition auto. eapply red_step; eauto. - - destruct 1 as [? [? [[? ?] ?]]]. - eapply red_conv_conv; eauto. - eapply red_conv_conv_inv; eauto. now constructor. -Qed. - -Definition eq_termp_napp {cf:checker_flags} (pb: conv_pb) (Σ : global_env_ext) napp := - compare_term_napp pb Σ Σ napp. +Definition eq_termp_napp {cf:checker_flags} (Σ : global_env_ext) (pb: conv_pb) napp := + compare_term_napp Σ Σ pb napp. -Notation eq_termp pb Σ := (compare_term pb Σ Σ). +Notation eq_termp Σ pb := (compare_term Σ Σ pb). Lemma eq_term_eq_termp {cf:checker_flags} pb (Σ : global_env_ext) x y : eq_term Σ Σ x y -> - eq_termp pb Σ x y. + eq_termp Σ pb x y. Proof. destruct pb; [easy|]. cbn. apply eq_term_upto_univ_leq; auto. - typeclasses eauto. + all: typeclasses eauto. Qed. Lemma cumul_App_l {cf:checker_flags} : diff --git a/pcuic/theories/PCUICCumulativitySpec.v b/pcuic/theories/PCUICCumulativitySpec.v index 431eb9dc3..10164a8e6 100644 --- a/pcuic/theories/PCUICCumulativitySpec.v +++ b/pcuic/theories/PCUICCumulativitySpec.v @@ -10,38 +10,53 @@ Set Default Goal Selector "!". Implicit Types (cf : checker_flags). -Definition cumul_predicate (cumul : context -> term -> term -> Type) Γ Re p p' := - All2 (cumul Γ) p.(pparams) p'.(pparams) * - (R_universe_instance Re p.(puinst) p'.(puinst) * - ((eq_context_gen eq eq p.(pcontext) p'.(pcontext)) * - cumul (Γ ,,, inst_case_predicate_context p) p.(preturn) p'.(preturn))). - -Definition cumul_predicate_dep {cumul Γ Re p p'} - (H : cumul_predicate cumul Γ Re p p') +Definition cumul_predicate (cumul : context -> term -> term -> Type) cumul_universe Γ p p' := + All2 (cumul Γ) p.(pparams) p'.(pparams) × + cmp_universe_instance cumul_universe p.(puinst) p'.(puinst) × + eq_context_upto_names p.(pcontext) p'.(pcontext) × + cumul (Γ ,,, inst_case_predicate_context p) p.(preturn) p'.(preturn). + +Definition cumul_predicate_dep {cumul cumul_universe Γ p p'} + (H : cumul_predicate cumul cumul_universe Γ p p') (cumul' : forall Γ p p', cumul Γ p p' -> Type) - Re' + cumul_universe' := let '(Hparams, (Huinst, (Heq, Hcumul))) := H in - All2_dep (cumul' Γ) Hparams * - (R_universe_instance_dep Re Re' Huinst - * cumul' _ _ _ Hcumul). + All2_dep (cumul' Γ) Hparams × + cmp_universe_instance_dep cumul_universe cumul_universe' Huinst × + cumul' _ _ _ Hcumul. -Lemma cumul_predicate_undep {cumul Γ Re p p' H cumul' Re'} - : @cumul_predicate cumul' Γ Re' p p' <~> @cumul_predicate_dep cumul Γ Re p p' H (fun Γ p p' _ => cumul' Γ p p') (fun x y _ => Re' x y). +Lemma cumul_predicate_undep {cumul cumul_universe Γ p p' H cumul' cumul_universe'} : + @cumul_predicate cumul' cumul_universe' Γ p p' <~> + @cumul_predicate_dep cumul cumul_universe Γ p p' H (fun Γ p p' _ => cumul' Γ p p') (fun x y _ => on_rel cumul_universe' Universe.make' x y). Proof. - cbv [cumul_predicate cumul_predicate_dep R_universe_instance R_universe_instance_dep] in *. + cbv [cumul_predicate cumul_predicate_dep cmp_universe_instance cmp_universe_instance_dep] in *. split; intro; repeat destruct ?; subst; rdest; try assumption. all: repeat first [ assumption | toAll ]. Qed. +Definition cumul_branch (cumul_term : context -> term -> term -> Type) Γ p br br' := + eq_context_upto_names br.(bcontext) br'.(bcontext) × + cumul_term (Γ ,,, inst_case_branch_context p br) br.(bbody) br'.(bbody). + +Definition cumul_branches cumul_term Γ p brs brs' := All2 (cumul_branch cumul_term Γ p) brs brs'. + +Definition cumul_mfixpoint (cumul_term : context -> term -> term -> Type) Γ mfix mfix' := + All2 (fun d d' => + cumul_term Γ d.(dtype) d'.(dtype) × + cumul_term (Γ ,,, fix_context mfix) d.(dbody) d'.(dbody) × + d.(rarg) = d'.(rarg) × + eq_binder_annot d.(dname) d'.(dname) + ) mfix mfix'. + Reserved Notation " Σ ;;; Γ ⊢ t ≤s[ pb ] u" (at level 50, Γ, t, u at next level, format "Σ ;;; Γ ⊢ t ≤s[ pb ] u"). Definition cumul_Ind_univ {cf} (Σ : global_env_ext) pb i napp := - R_global_instance Σ (eq_universe Σ) (compare_universe pb Σ) (IndRef i) napp. + cmp_global_instance Σ (compare_universe Σ) pb (IndRef i) napp. Definition cumul_Construct_univ {cf} (Σ : global_env_ext) pb i k napp := - R_global_instance Σ (eq_universe Σ) (compare_universe pb Σ) (ConstructRef i k) napp. + cmp_global_instance Σ (compare_universe Σ) pb (ConstructRef i k) napp. (** * Definition of cumulativity and conversion relations *) Local Unset Elimination Schemes. @@ -79,11 +94,11 @@ Inductive cumulSpec0 {cf : checker_flags} (Σ : global_env_ext) Γ (pb : conv_pb Σ ;;; Γ ⊢ mkApps (tConstruct i k u) args ≤s[pb] mkApps (tConstruct i k u') args' | cumul_Sort : forall s s', - compare_universe pb Σ s s' -> + compare_sort Σ pb s s' -> Σ ;;; Γ ⊢ tSort s ≤s[pb] tSort s' | cumul_Const : forall c u u', - R_universe_instance (compare_universe Conv Σ) u u' -> + cmp_universe_instance (compare_universe Σ Conv) u u' -> Σ ;;; Γ ⊢ tConst c u ≤s[pb] tConst c u' (* congruence rules *) @@ -117,12 +132,9 @@ Inductive cumulSpec0 {cf : checker_flags} (Σ : global_env_ext) Γ (pb : conv_pb Σ ;;; Γ ⊢ tLetIn na t ty u ≤s[pb] tLetIn na' t' ty' u' | cumul_Case indn : forall p p' c c' brs brs', - cumul_predicate (fun Γ t u => Σ ;;; Γ ⊢ t ≤s[Conv] u) Γ (compare_universe Conv Σ) p p' -> + cumul_predicate (fun Γ t u => Σ ;;; Γ ⊢ t ≤s[Conv] u) (compare_universe Σ Conv) Γ p p' -> Σ ;;; Γ ⊢ c ≤s[Conv] c' -> - All2 (fun br br' => - eq_context_gen eq eq (bcontext br) (bcontext br') × - Σ ;;; Γ ,,, inst_case_branch_context p br ⊢ bbody br ≤s[Conv] bbody br' - ) brs brs' -> + cumul_branches (fun Γ t u => Σ ;;; Γ ⊢ t ≤s[Conv] u) Γ p brs brs' -> Σ ;;; Γ ⊢ tCase indn p c brs ≤s[pb] tCase indn p' c' brs' | cumul_Proj : forall p c c', @@ -130,25 +142,15 @@ Inductive cumulSpec0 {cf : checker_flags} (Σ : global_env_ext) Γ (pb : conv_pb Σ ;;; Γ ⊢ tProj p c ≤s[pb] tProj p c' | cumul_Fix : forall mfix mfix' idx, - All2 (fun x y => - Σ ;;; Γ ⊢ x.(dtype) ≤s[Conv] y.(dtype) × - Σ ;;; Γ ,,, fix_context mfix ⊢ x.(dbody) ≤s[Conv] y.(dbody) × - (x.(rarg) = y.(rarg)) × - eq_binder_annot x.(dname) y.(dname) - ) mfix mfix' -> + cumul_mfixpoint (fun Γ t u => Σ ;;; Γ ⊢ t ≤s[Conv] u) Γ mfix mfix' -> Σ ;;; Γ ⊢ tFix mfix idx ≤s[pb] tFix mfix' idx | cumul_CoFix : forall mfix mfix' idx, - All2 (fun x y => - Σ ;;; Γ ⊢ x.(dtype) ≤s[Conv] y.(dtype) × - Σ ;;; Γ ,,, fix_context mfix ⊢ x.(dbody) ≤s[Conv] y.(dbody) × - (x.(rarg) = y.(rarg)) × - eq_binder_annot x.(dname) y.(dname) - ) mfix mfix' -> + cumul_mfixpoint (fun Γ t u => Σ ;;; Γ ⊢ t ≤s[Conv] u) Γ mfix mfix' -> Σ ;;; Γ ⊢ tCoFix mfix idx ≤s[pb] tCoFix mfix' idx | cumul_Prim p p' : - onPrims (fun x y => Σ ;;; Γ ⊢ x ≤s[Conv] y) (compare_universe Conv Σ) p p' -> + onPrims (fun x y => Σ ;;; Γ ⊢ x ≤s[Conv] y) (compare_universe Σ Conv) p p' -> Σ ;;; Γ ⊢ tPrim p ≤s[pb] tPrim p' (** Reductions *) @@ -377,15 +379,10 @@ Lemma cumulSpec0_rect : (forall (Γ : context) (pb : conv_pb) (indn : case_info) (p p' : predicate term) (c c' : term) (brs brs' : list (branch term)) - (Hp : cumul_predicate (fun Γ => cumulSpec0 Σ Γ Conv) Γ (compare_universe Conv Σ) p p') - (_ : cumul_predicate_dep Hp (fun Γ => P cf Σ Γ Conv) (fun _ _ _ => True)) + (Hp : cumul_predicate (fun Γ => cumulSpec0 Σ Γ Conv) (compare_universe Σ Conv) Γ p p') + (_ : cumul_predicate_dep Hp (fun Γ => P cf Σ Γ Conv) (fun l l' _ => on_rel (fun _ _ => True) Universe.make' l l')) (Hc : cumulSpec0 Σ Γ Conv c c') (_ : P cf Σ Γ Conv c c' Hc) - (Hbody : All2 - (fun br br' : branch term => - eq_context_gen eq eq (bcontext br) (bcontext br') * - cumulSpec0 Σ (Γ,,, inst_case_branch_context p br) Conv - (bbody br) (bbody br')) - brs brs') + (Hbody : cumul_branches (fun Γ => cumulSpec0 Σ Γ Conv) Γ p brs brs') (_ : All2_dep (fun br br' Hc => P cf Σ (Γ,,, inst_case_branch_context p br) Conv (bbody br) (bbody br') (snd Hc)) Hbody), P cf Σ Γ pb (tCase indn p c brs) (tCase indn p' c' brs') @@ -437,7 +434,7 @@ Lemma cumulSpec0_rect : (forall (Γ : context) (pb : conv_pb) (i : inductive) (u u' : list Level.t) (args args' : list term) - (Hu : R_global_instance Σ (eq_universe Σ) (compare_universe pb Σ) (IndRef i) #|args| u u') + (Hu : cumul_Ind_univ Σ pb i #|args| u u') (Hargs : All2 (cumulSpec0 Σ Γ Conv) args args') (_ : All2_dep (P cf Σ Γ Conv) Hargs), P cf Σ Γ pb (mkApps (tInd i u) args) (mkApps (tInd i u') args') @@ -445,19 +442,19 @@ Lemma cumulSpec0_rect : (forall (Γ : context) (pb : conv_pb) (i : inductive) (k : nat) (u u' : list Level.t) (args args' : list term) - (Hu : R_global_instance Σ (eq_universe Σ) (compare_universe pb Σ) (ConstructRef i k) #|args| u u') + (Hu : cumul_Construct_univ Σ pb i k #|args| u u') (Hargs : All2 (cumulSpec0 Σ Γ Conv) args args') (_ : All2_dep (P cf Σ Γ Conv) Hargs), P cf Σ Γ pb (mkApps (tConstruct i k u) args) (mkApps (tConstruct i k u') args') (cumul_Construct _ _ _ _ _ _ _ _ _ Hu Hargs)) -> - (forall (Γ : context) (pb : conv_pb) (s s' : Universe.t) - (Hs : compare_universe pb Σ s s'), + (forall (Γ : context) (pb : conv_pb) (s s' : sort) + (Hs : compare_sort Σ pb s s'), P cf Σ Γ pb (tSort s) (tSort s') (cumul_Sort _ _ _ _ _ Hs)) -> (forall (Γ : context) (pb : conv_pb) (c : kername) (u u' : list Level.t) - (Hu : R_universe_instance (compare_universe Conv Σ) u u'), + (Hu : cmp_universe_instance (compare_universe Σ Conv) u u'), P cf Σ Γ pb (tConst c u) (tConst c u') (cumul_Const _ _ _ _ _ _ Hu)) -> @@ -492,23 +489,23 @@ Proof. * revert c0. generalize (pparams p), (pparams p'). fix aux' 3; destruct c0; constructor; auto. * apply Forall2_dep_from_nth_error; intros; exact I. - + revert brs brs' a. - fix aux' 3; destruct a; constructor; intuition auto. + + revert brs brs' c1. + fix aux' 3; destruct c1; constructor; intuition auto. - eapply X17 ; eauto. - eapply X18 ; eauto. - revert a. + revert c. unfold cumul_mfixpoint. set (mfixAbs_context := fix_context mfix). clearbody mfixAbs_context. revert mfix mfix'. - fix aux' 3; destruct a; constructor. + fix aux' 3; destruct c; constructor. + intuition auto. + auto. - eapply X19 ; eauto. - revert a. + revert c. unfold cumul_mfixpoint. set (mfixAbs_context := fix_context mfix). clearbody mfixAbs_context. revert mfix mfix'. - fix aux' 3; destruct a; constructor. + fix aux' 3; destruct c; constructor. + intuition auto. + auto. - eapply X20; eauto. @@ -656,15 +653,10 @@ Lemma convSpec0_ind_all : (forall (Γ : context) (indn : case_info) (p p' : predicate term) (c c' : term) (brs brs' : list (branch term)) - (Hp : cumul_predicate (fun Γ => cumulSpec0 Σ Γ Conv) Γ (compare_universe Conv Σ) p p') - (_ : cumul_predicate_dep Hp (fun Γ => P cf Σ Γ Conv) (fun _ _ _ => True)) + (Hp : cumul_predicate (fun Γ => cumulSpec0 Σ Γ Conv) (compare_universe Σ Conv) Γ p p') + (_ : cumul_predicate_dep Hp (fun Γ => P cf Σ Γ Conv) (fun l l' _ => on_rel (fun _ _ => True) Universe.make' l l')) (Hc : cumulSpec0 Σ Γ Conv c c') (_ : P cf Σ Γ Conv c c' Hc) - (Hbody : All2 - (fun br br' : branch term => - eq_context_gen eq eq (bcontext br) (bcontext br') * - cumulSpec0 Σ (Γ,,, inst_case_branch_context p br) Conv - (bbody br) (bbody br')) - brs brs') + (Hbody : cumul_branches (fun Γ => cumulSpec0 Σ Γ Conv) Γ p brs brs') (_ : All2_dep (fun br br' Hc => P cf Σ (Γ,,, inst_case_branch_context p br) Conv (bbody br) (bbody br') (snd Hc)) Hbody), P cf Σ Γ Conv (tCase indn p c brs) (tCase indn p' c' brs') @@ -678,13 +670,7 @@ Lemma convSpec0_ind_all : (forall (Γ : context) (mfix : mfixpoint term) (mfix' : list (def term)) (idx : nat) - (H : All2 - (fun x y : def term => - (cumulSpec0 Σ Γ Conv (dtype x) (dtype y)) - * ((cumulSpec0 Σ (Γ,,, fix_context mfix) Conv (dbody x) (dbody y)) - × (rarg x = rarg y) - × eq_binder_annot (dname x) (dname y))) - mfix mfix') + (H : cumul_mfixpoint (fun Γ => cumulSpec0 Σ Γ Conv) Γ mfix mfix') (_ : All2_dep (fun x y H => P cf Σ Γ Conv (dtype x) (dtype y) (fst H) × P cf Σ (Γ,,, fix_context mfix) Conv (dbody x) (dbody y) (fst (snd H))) @@ -694,13 +680,7 @@ Lemma convSpec0_ind_all : (forall (Γ : context) (mfix : mfixpoint term) (mfix' : list (def term)) (idx : nat) - (H : All2 - (fun x y : def term => - (cumulSpec0 Σ Γ Conv (dtype x) (dtype y)) - × ((cumulSpec0 Σ (Γ,,, fix_context mfix) Conv (dbody x) (dbody y)) - × (rarg x = rarg y) - × (eq_binder_annot (dname x) (dname y)))) - mfix mfix') + (H : cumul_mfixpoint (fun Γ => cumulSpec0 Σ Γ Conv) Γ mfix mfix') (_ : All2_dep (fun x y H => P cf Σ Γ Conv (dtype x) (dtype y) (fst H) × P cf Σ (Γ,,, fix_context mfix) Conv (dbody x) (dbody y) (fst (snd H))) @@ -716,7 +696,7 @@ Lemma convSpec0_ind_all : (forall (Γ : context) (i : inductive) (u u' : list Level.t) (args args' : list term) - (Hu : R_global_instance Σ (eq_universe Σ) (compare_universe Conv Σ) (IndRef i) #|args| u u') + (Hu : cumul_Ind_univ Σ Conv i #|args| u u') (Hargs : All2 (cumulSpec0 Σ Γ Conv) args args') (_ : All2_dep (P cf Σ Γ Conv) Hargs), P cf Σ Γ Conv (mkApps (tInd i u) args) (mkApps (tInd i u') args') @@ -724,19 +704,19 @@ Lemma convSpec0_ind_all : (forall (Γ : context) (i : inductive) (k : nat) (u u' : list Level.t) (args args' : list term) - (Hu : R_global_instance Σ (eq_universe Σ) (compare_universe Conv Σ) (ConstructRef i k) #|args| u u') + (Hu : cumul_Construct_univ Σ Conv i k #|args| u u') (Hargs : All2 (cumulSpec0 Σ Γ Conv) args args') (_ : All2_dep (P cf Σ Γ Conv) Hargs), P cf Σ Γ Conv (mkApps (tConstruct i k u) args) (mkApps (tConstruct i k u') args') (cumul_Construct _ _ _ _ _ _ _ _ _ Hu Hargs)) -> - (forall (Γ : context) (s s' : Universe.t) - (Hs : compare_universe Conv Σ s s'), + (forall (Γ : context) (s s' : sort) + (Hs : compare_sort Σ Conv s s'), P cf Σ Γ Conv (tSort s) (tSort s') (cumul_Sort _ _ _ _ _ Hs)) -> (forall (Γ : context) (c : kername) (u u' : list Level.t) - (Hu : R_universe_instance (compare_universe Conv Σ) u u'), + (Hu : cmp_universe_instance (compare_universe Σ Conv) u u'), P cf Σ Γ Conv (tConst c u) (tConst c u') (cumul_Const _ _ _ _ _ _ Hu)) -> diff --git a/pcuic/theories/PCUICElimination.v b/pcuic/theories/PCUICElimination.v index 18c7d9592..b5341a278 100644 --- a/pcuic/theories/PCUICElimination.v +++ b/pcuic/theories/PCUICElimination.v @@ -19,8 +19,7 @@ Require Import ssreflect. Implicit Types (cf : checker_flags) (Σ : global_env_ext). -Definition Is_proof `{cf : checker_flags} Σ Γ t := ∑ T u, Σ ;;; Γ |- t : T × Σ ;;; Γ |- T : tSort u × - (Universe.is_prop u || Universe.is_sprop u). +Definition Is_proof `{cf : checker_flags} Σ Γ t := ∑ T u, Σ ;;; Γ |- t : T × Σ ;;; Γ |- T : tSort u × Sort.is_propositional u. (* TODO: Figure out whether [SingletonProp], [Computational], and [Subsingleton] should use [strictly_extends_decls] or [extends]. -Jason Gross *) Definition SingletonProp `{cf : checker_flags} (Σ : global_env_ext) (ind : inductive) := @@ -59,7 +58,7 @@ Lemma typing_spine_case_predicate {cf: checker_flags} {Σ : global_env_ext} {wf wf_local Σ Γ -> declared_inductive Σ ci mdecl idecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> - wf_universe Σ ps -> + wf_sort Σ ps -> spine_subst Σ Γ params (List.rev params) (smash_context [] (subst_instance u (ind_params mdecl))) -> spine_subst Σ Γ indices (List.rev indices) @@ -85,7 +84,7 @@ Lemma pre_case_predicate_context_gen_eq {cf: checker_flags} {Σ : global_env_ext wf_local Σ Γ -> declared_inductive Σ ci mdecl idecl -> consistent_instance_ext Σ (ind_universes mdecl) (puinst p) -> - wf_universe Σ ps -> + wf_sort Σ ps -> spine_subst Σ Γ (pparams p) (List.rev (pparams p)) (smash_context [] (ind_params mdecl)@[puinst p]) -> Σ ⊢ Γ ,,, pre_case_predicate_context_gen ci mdecl idecl (pparams p) (puinst p) = @@ -97,7 +96,7 @@ Proof. rewrite /pre_case_predicate_context_gen /inst_case_context /ind_predicate_context. rewrite /case_predicate_context' /=. cbn. rewrite subst_context_snoc; len. - constructor. constructor; cbn. reflexivity. + constructor. unfold subst_decl, map_decl; cbn. relativize (subst _ _ _). 1: constructor. reflexivity. symmetry. rewrite subst_instance_mkApps subst_mkApps. f_equal. cbn. now rewrite [subst_instance_instance _ _](subst_instance_id_mdecl _ _ _ cu). rewrite [to_extended_list _]to_extended_list_k_app; len; rewrite !map_app. @@ -134,10 +133,10 @@ Proof. unshelve epose proof (H_ := declared_inductive_to_gen H); eauto. unshelve epose proof (isdecl'_ := declared_inductive_to_gen isdecl'); eauto. eapply declared_inductive_inj in isdecl'_ as []. 2:exact H_. subst. - enough (~ (Universe.is_prop ps \/ Universe.is_sprop ps)). + enough (~ (Sort.is_propositional ps)). { clear -wfΣ allowed_elim H1. apply wf_ext_consistent in wfΣ as (val&sat). - unfold is_allowed_elimination, is_lSet, eq_universe, eq_levelalg in *. + unfold is_allowed_elimination, is_lSet in *. destruct (ind_kelim idecl); auto; destruct ps; cbn in *; try discriminate; intuition congruence. } intros Huf. apply H0. @@ -152,7 +151,7 @@ Proof. pose proof (PCUICInductiveInversion.isType_mkApps_Ind_smash H (validity scrut_ty)). forward X1. apply (wf_predicate_length_pars wf_pred). simpl in X1. destruct X1 as [sppars [spargs cu']]. - assert (eqctx' : All2 (PCUICEquality.compare_decls eq eq) + assert (eqctx' : eq_context_upto_names (Γ,,, case_predicate_context' ci mdecl idecl p) (Γ,,, predctx)). { eapply All2_app. 2:eapply All2_refl; reflexivity. @@ -163,10 +162,10 @@ Proof. { transitivity (Γ ,,, case_predicate_context' ci mdecl idecl p); revgoals. * symmetry. eapply alpha_eq_context_ws_cumul_ctx_pb => //; fvs. now symmetry. * eapply pre_case_predicate_context_gen_eq; tea. pcuic. - now eapply PCUICWfUniverses.typing_wf_universe in pret_ty. } + now eapply PCUICWfUniverses.typing_wf_sort in pret_ty. } unshelve epose proof (typing_spine_case_predicate (ps:=ps) _ H cons _ sppars). 1-2:shelve. * pcuic. - * now eapply PCUICWfUniverses.typing_wf_universe in pret_ty. + * now eapply PCUICWfUniverses.typing_wf_sort in pret_ty. * rewrite -smash_context_subst_context_let_expand in X2. specialize (X2 spargs scrut_ty). eapply typing_spine_strengthen; tea; revgoals. @@ -176,11 +175,9 @@ Proof. apply ws_cumul_pb_refl; fvs. + eapply validity in pret_ty. eapply isType_it_mkProd_or_LetIn; tea. - * destruct Huf as [Huf|Huf]; rewrite Huf // orb_true_r //. Qed. -Lemma elim_sort_intype {cf:checker_flags} Σ mdecl ind idecl ind_indices ind_sort cdecls : - Universe.is_prop ind_sort -> +Lemma elim_sort_intype {cf:checker_flags} Σ mdecl ind idecl ind_indices cdecls : elim_sort_prop_ind cdecls = IntoAny -> on_constructors cumulSpec0 (lift_typing typing) (Σ, ind_universes mdecl) mdecl @@ -190,11 +187,11 @@ Lemma elim_sort_intype {cf:checker_flags} Σ mdecl ind idecl ind_indices ind_sor (∑ cdecl cdecl_sorts, (ind_ctors idecl = [cdecl]) * (cdecls = [cdecl_sorts]) * - (Forall is_propositional cdecl_sorts) * + (Forall Sort.is_propositional cdecl_sorts) * (on_constructor cumulSpec0 (lift_typing typing) (Σ, ind_universes mdecl) mdecl (inductive_ind ind) idecl ind_indices cdecl cdecl_sorts))%type. Proof. - intros uf lein onc. + intros lein onc. induction onc; simpl in *. left; auto. destruct l' as [|c cs]. @@ -209,7 +206,7 @@ Qed. Lemma typing_spine_it_mkProd_or_LetIn_full_inv {cf:checker_flags} Σ Γ Δ s args s' : wf Σ.1 -> typing_spine Σ Γ (it_mkProd_or_LetIn Δ (tSort s)) args (tSort s') -> - leq_universe (global_ext_constraints Σ) s s'. + leq_sort (global_ext_constraints Σ) s s'. Proof. intros wfΣ. induction Δ using PCUICInduction.ctx_length_rev_ind in args |- *. @@ -279,12 +276,12 @@ Proof. move=> wfe; apply wfe. Qed. Hint Resolve wf_ext_wf : core. Lemma is_propositional_subst_instance u s : - is_propositional (subst_instance_univ u s) = is_propositional s. + Sort.is_propositional (subst_instance_sort u s) = Sort.is_propositional s. Proof. destruct s => //. Qed. -Lemma leq_universe_propositional_l {cf:checker_flags} ϕ u1 u2 : +Lemma leq_sort_propositional_l {cf:checker_flags} ϕ u1 u2 : prop_sub_type = false -> - leq_universe ϕ u1 u2 -> is_propositional u1 -> u1 = u2. + leq_sort ϕ u1 u2 -> Sort.is_propositional u1 -> u1 = u2. Proof. destruct u1 => //=. 1: intros ->. @@ -307,15 +304,15 @@ Lemma typing_spine_proofs {cf:checker_flags} Σ Γ Δ ind u args' args T' s : Σ ;;; Γ |- T' : tSort s -> typing_spine Σ Γ (it_mkProd_or_LetIn Δ (mkApps (tInd ind u) args')) args T' -> ((All_local_assum (fun Γ' t => - (∑ s, (Σ ;;; Γ ,,, Γ' |- t : tSort s) * is_propositional s)%type) Δ -> + (∑ s, (Σ ;;; Γ ,,, Γ' |- t : tSort s) * Sort.is_propositional s)%type) Δ -> ∥ All (Is_proof Σ Γ) args ∥) * (forall mdecl idecl (Hdecl : declared_inductive Σ.1 ind mdecl idecl), consistent_instance_ext Σ (ind_universes mdecl) u -> - ((is_propositional s -> s = subst_instance_univ u idecl.(ind_sort)) /\ + ((Sort.is_propositional s -> s = subst_instance_sort u idecl.(ind_sort)) /\ (prop_sub_type = false -> - is_propositional (subst_instance_univ u idecl.(ind_sort)) -> - s = subst_instance_univ u idecl.(ind_sort)))))%type. + Sort.is_propositional (subst_instance_sort u idecl.(ind_sort)) -> + s = subst_instance_sort u idecl.(ind_sort)))))%type. Proof. intros wfΣ Ht. pose wfΣ' := wfΣ.1. induction Δ using PCUICInduction.ctx_length_rev_ind in Γ, args', args, T', Ht |- *; simpl; intros sp. @@ -341,7 +338,7 @@ Proof. destruct s => //=; destruct ind_sort => //. intros propsub props. rewrite is_propositional_subst_instance in props. - apply leq_universe_propositional_l in sp; eauto. subst s. + apply leq_sort_propositional_l in sp; eauto. subst s. now destruct (ind_sort idecl). now destruct (ind_sort idecl). now eapply declared_inductive_valid_type. @@ -380,13 +377,13 @@ Proof. eapply ws_cumul_pb_Prod_l_inv in e as [na' [dom' [codom' [red eqann conv cum]]]]; auto. eapply subject_reduction_closed in Ht; eauto. intros. - pose proof (PCUICWfUniverses.typing_wf_universe wfΣ Ht). + pose proof (PCUICWfUniverses.typing_wf_sort wfΣ Ht). eapply inversion_Prod in Ht as [s1 [s2 [dom [codom cum']]]]; auto. specialize (H Γ0 ltac:(reflexivity) (Γ ,, vass na' dom') args' []). eapply (type_Cumul _ _ _ _ (tSort s)) in codom; cycle 1; eauto. { econstructor; pcuic. } { eapply ws_cumul_pb_Sort_inv in cum'. - eapply cumul_Sort. etransitivity; eauto. eapply leq_universe_product. } + eapply cumul_Sort. etransitivity; eauto. eapply leq_sort_product. } specialize (H _ codom). have eqctx : Σ ⊢ Γ ,, vass na ty = Γ ,, vass na' dom'. { constructor. apply ws_cumul_ctx_pb_refl. fvs. constructor; auto. } @@ -437,15 +434,15 @@ Lemma check_ind_sorts_is_propositional {cf:checker_flags} (Σ : global_env_ext) (onib : on_ind_body cumulSpec0 (lift_typing typing) (Σ.1, ind_universes mdecl) (inductive_mind ind) mdecl (inductive_ind ind) idecl) : (ind_kelim idecl <> IntoPropSProp /\ ind_kelim idecl <> IntoSProp) -> - is_propositional (ind_sort idecl) -> + Sort.is_propositional (ind_sort idecl) -> check_ind_sorts (lift_typing typing) (Σ.1, ind_universes mdecl) (PCUICEnvironment.ind_params mdecl) (PCUICEnvironment.ind_kelim idecl) (ind_indices idecl) (ind_cunivs onib) (ind_sort idecl) -> - (#|ind_cunivs onib| <= 1) * All (fun cs => All is_propositional cs) (ind_cunivs onib). + (#|ind_cunivs onib| <= 1) * All (fun cs => All Sort.is_propositional cs) (ind_cunivs onib). Proof. intros kelim isp. - unfold check_ind_sorts. simpl. - destruct Universe.is_prop eqn:isp'. + unfold check_ind_sorts. + destruct ind_sort => //=. + induction (ind_cunivs onib); simpl; auto; try discriminate. destruct l; simpl. intros; split; eauto. constructor; [|constructor]. destruct forallb eqn:fo. eapply forallb_All in fo. @@ -453,11 +450,8 @@ Proof. destruct (ind_kelim idecl); intuition cbn in H; try congruence. intros leb. destruct (ind_kelim idecl); simpl in *; intuition congruence. - + destruct Universe.is_sprop eqn:issp. - induction (ind_cunivs onib); simpl; auto; try discriminate. + + induction (ind_cunivs onib); simpl; auto; try discriminate. destruct (ind_kelim idecl); simpl in *; intuition congruence. - unfold is_propositional in isp. - now rewrite isp' issp in isp. Qed. Lemma sorts_local_ctx_All_local_assum_impl {cf:checker_flags} Σ @@ -537,8 +531,8 @@ pose proof (declared_inductive_inj decli_ declc_) as [-> ->]. pose proof (onc.(on_cargs)). pose proof (onib.(ind_sorts)). - assert (Universe.is_prop (ind_sort idecl) || Universe.is_sprop (ind_sort idecl)). - { rewrite -(is_prop_subst_instance_univ u) -(is_sprop_subst_instance_univ u) => //. now subst tycs. } + assert (Sort.is_propositional (ind_sort idecl)). + { rewrite -(is_propositional_subst_instance_univ u) => //. now subst tycs. } apply check_ind_sorts_is_propositional in X1 as [nctors X1]; eauto. assert(#|ind_cunivs onib| = #|ind_ctors idecl|). clear X. clear -onib. pose proof (onib.(onConstructors)). @@ -566,7 +560,7 @@ pose proof (declared_inductive_inj decli_ declc_) as [-> ->]. autorewrite with len in X0. eapply (sorts_local_ctx_All_local_assum_impl Σ (fun Γ Γ' t => - ∑ s0 : Universe.t, Σ;;; Γ ,,, Γ' |- t : tSort s0 × is_propositional s0)). + ∑ s0 : sort, Σ;;; Γ ,,, Γ' |- t : tSort s0 × Sort.is_propositional s0)). 2:eauto. intros. exists s0. intuition auto. eapply In_map in H1 as [cs' [ins ->]]. @@ -667,76 +661,57 @@ Section no_prop_leq_type. Context `{cf : checker_flags}. Variable Hcf : prop_sub_type = false. -Lemma leq_term_prop_sorted_l {Σ Γ v v' u u'} : - wf_ext Σ -> - PCUICEquality.leq_term Σ (global_ext_constraints Σ) v v' -> - Σ;;; Γ |- v : tSort u -> - Σ;;; Γ |- v' : tSort u' -> Universe.is_prop u -> - leq_universe (global_ext_constraints Σ) u' u. +Lemma eq_univ_prop_compare_sort_propositional Σ pb (s s' : sort) : + Sort.is_propositional s' -> + eq_univ_prop s s' -> + compare_sort Σ pb s s'. Proof using Hcf. - intros wfΣ leq hv hv' isp. - eapply typing_leq_term_prop in leq; eauto. - apply leq_prop_prop; intuition auto. - eapply cumul_prop_sym in leq. - eapply cumul_prop_props in leq; eauto. auto. apply wfΣ. + destruct s' => //. + all: unfold eq_univ_prop, compare_sort. + all: destruct s, pb => //=. + all: now rewrite Hcf. Qed. -Lemma leq_term_prop_sorted_r {Σ Γ v v' u u'} : - wf_ext Σ -> - PCUICEquality.leq_term Σ (global_ext_constraints Σ) v v' -> - Σ;;; Γ |- v : tSort u -> - Σ;;; Γ |- v' : tSort u' -> Universe.is_prop u' -> - leq_universe (global_ext_constraints Σ) u u'. +Lemma eq_univ_prop_compare_sort_propositional_r Σ pb (s s' : sort) : + Sort.is_propositional s -> + eq_univ_prop s s' -> + compare_sort Σ pb s s'. Proof using Hcf. - intros wfΣ leq hv hv' isp. - eapply typing_leq_term_prop in leq; eauto. - apply leq_prop_prop; intuition auto. - apply cumul_prop_props in leq; auto. apply wfΣ. + destruct s => //. + all: unfold eq_univ_prop, compare_sort. + all: destruct s', pb => //=. + all: now rewrite Hcf. Qed. -Lemma leq_term_sprop_sorted_l {Σ Γ v v' u u'} : - wf_ext Σ -> - PCUICEquality.leq_term Σ (global_ext_constraints Σ) v v' -> - Σ;;; Γ |- v : tSort u -> - Σ;;; Γ |- v' : tSort u' -> Universe.is_sprop u -> - leq_universe (global_ext_constraints Σ) u' u. -Proof using Hcf. - intros wfΣ leq hv hv' isp. - eapply typing_leq_term_prop in leq; eauto. - apply leq_sprop_sprop; intuition auto. - eapply cumul_prop_sym in leq. - eapply cumul_sprop_props in leq; auto. eauto. auto. apply wfΣ. -Qed. - -Lemma leq_term_propositional_sorted_l {Σ Γ v v' u u'} : +Lemma leq_term_prop_sorted_l {Σ Γ v v' u u'} : wf_ext Σ -> PCUICEquality.leq_term Σ (global_ext_constraints Σ) v v' -> Σ;;; Γ |- v : tSort u -> - Σ;;; Γ |- v' : tSort u' -> is_propositional u -> - leq_universe (global_ext_constraints Σ) u' u. + Σ;;; Γ |- v' : tSort u' -> Sort.is_propositional u -> + leq_sort (global_ext_constraints Σ) u' u. Proof using Hcf. intros wfΣ leq hv hv' isp. - eapply orb_true_iff in isp as [isp | isp]. - - eapply leq_term_prop_sorted_l; eauto. - - eapply leq_term_sprop_sorted_l; eauto. + eapply typing_leq_term_prop in leq; eauto. 2: apply wfΣ. + apply cumul_prop_sort in leq. + now eapply eq_univ_prop_compare_sort_propositional with (pb := Cumul). Qed. -Lemma leq_term_sprop_sorted_r {Σ Γ v v' u u'} : +Lemma leq_term_prop_sorted_r {Σ Γ v v' u u'} : wf_ext Σ -> PCUICEquality.leq_term Σ (global_ext_constraints Σ) v v' -> Σ;;; Γ |- v : tSort u -> - Σ;;; Γ |- v' : tSort u' -> Universe.is_sprop u' -> - leq_universe (global_ext_constraints Σ) u u'. + Σ;;; Γ |- v' : tSort u' -> Sort.is_propositional u' -> + leq_sort (global_ext_constraints Σ) u u'. Proof using Hcf. intros wfΣ leq hv hv' isp. - eapply typing_leq_term_prop in leq; eauto. - apply leq_sprop_sprop; intuition auto. - apply cumul_sprop_props in leq; auto. apply wfΣ. + eapply typing_leq_term_prop in leq; eauto. 2: apply wfΣ. + apply cumul_prop_sort in leq. + now eapply eq_univ_prop_compare_sort_propositional with (pb := Cumul). Qed. Lemma cumul_prop_inv (Σ : global_env_ext) Γ A B u u' : wf_ext Σ -> - Universe.is_prop u -> + Sort.is_propositional u -> (((Σ ;;; Γ |- A : tSort u) * (Σ ;;; Γ |- B : tSort u')) + ((Σ ;;; Γ |- B : tSort u) * (Σ ;;; Γ |- A : tSort u')))%type -> Σ ;;; Γ |- A <= B -> @@ -744,10 +719,10 @@ Lemma cumul_prop_inv (Σ : global_env_ext) Γ A B u u' : Proof using Hcf. intros wfΣ propu. intros [[HA HB]|[HB HA]] cum; split; auto; - apply cumul_alt in cum as [v [v' [[redv redv'] leq]]]. + apply cumul_alt in cum as [v [v' (redv & redv' & leq)]]. - eapply type_Cumul' with (tSort u'); eauto. eapply PCUICArities.isType_Sort. - now eapply PCUICWfUniverses.typing_wf_universe in HA. + now eapply PCUICWfUniverses.typing_wf_sort in HA. pcuic. eapply cumul_Sort. eapply subject_reduction in redv; eauto. eapply subject_reduction in redv'; eauto. @@ -757,129 +732,92 @@ Proof using Hcf. eapply leq_term_prop_sorted_r in leq; eauto. eapply type_Cumul' with (tSort u'); eauto. eapply PCUICArities.isType_Sort. - now eapply PCUICWfUniverses.typing_wf_universe in HB. + now eapply PCUICWfUniverses.typing_wf_sort in HB. pcuic. eapply cumul_Sort; auto. Qed. -Lemma cumul_sprop_inv (Σ : global_env_ext) Γ A B u u' : +Lemma unique_sorting_family {pb} {Σ : global_env_ext} {Γ T U s s'} : wf_ext Σ -> - Universe.is_sprop u -> - (((Σ ;;; Γ |- A : tSort u) * (Σ ;;; Γ |- B : tSort u')) + - ((Σ ;;; Γ |- B : tSort u) * (Σ ;;; Γ |- A : tSort u')))%type -> - Σ ;;; Γ |- A <= B -> - ((Σ ;;; Γ |- A : tSort u) * (Σ ;;; Γ |- B : tSort u))%type. + Σ ;;; Γ |- T : tSort s -> + Σ ;;; Γ |- U : tSort s' -> + Σ ;;; Γ ⊢ T ≤[pb] U -> + Sort.to_family s = Sort.to_family s'. Proof using Hcf. - intros wfΣ propu. - intros [[HA HB]|[HB HA]] cum; split; auto; - apply cumul_alt in cum as [v [v' [[redv redv'] leq]]]. - - eapply type_Cumul' with (tSort u'); eauto. - eapply isType_Sort. - 1: now destruct u. - 1: pcuic. - eapply cumul_Sort. - eapply subject_reduction in redv; eauto. - eapply subject_reduction in redv'; eauto. - eapply leq_term_sprop_sorted_l; eauto. - - eapply subject_reduction in redv; eauto. - eapply subject_reduction in redv'; eauto. - eapply leq_term_sprop_sorted_r in leq; eauto. - eapply type_Cumul' with (tSort u'); eauto. - eapply PCUICArities.isType_Sort. - 1: now destruct u. - 1: now pcuic. - now eapply cumul_Sort. + intros wfΣ HT HU cum. + apply ws_cumul_pb_forget in cum. + eapply typing_cumul_term_prop in cum; tea. + apply cumul_prop_sort in cum. + move: cum. + destruct s, s' => //=; cbn. + all: now rewrite Hcf //. Qed. -Lemma unique_sorting_equality_prop_l {pb} {Σ : global_env_ext} {Γ T U s s'} : +Lemma unique_sorting_equality_prop {pb} {Σ : global_env_ext} {Γ T U s s'} : wf_ext Σ -> Σ ;;; Γ |- T : tSort s -> Σ ;;; Γ |- U : tSort s' -> Σ ;;; Γ ⊢ T ≤[pb] U -> - Universe.is_prop s -> Universe.is_prop s'. + Sort.is_prop s = Sort.is_prop s'. Proof using Hcf. - intros wfΣ HT HU cum isp. - eapply PCUICSpine.ws_cumul_pb_le_le in cum. - eapply ws_cumul_pb_alt_closed in cum as [v [v' [eqv]]]. - eapply subject_reduction_closed in HT; tea. - eapply subject_reduction_closed in HU; tea. - eapply leq_term_prop_sorted_l in c0; tea. all:eauto with pcuic. - eapply leq_universe_prop_r; tea; eauto with pcuic. + intros wfΣ HT HU cum. + eapply unique_sorting_family in cum; tea. + now destruct s, s'. Qed. -Lemma unique_sorting_equality_prop_r {pb} {Σ : global_env_ext} {Γ T U s s'} : +Lemma unique_sorting_equality_prop_l {pb} {Σ : global_env_ext} {Γ T U s s'} : wf_ext Σ -> Σ ;;; Γ |- T : tSort s -> Σ ;;; Γ |- U : tSort s' -> Σ ;;; Γ ⊢ T ≤[pb] U -> - Universe.is_prop s' -> Universe.is_prop s. + Sort.is_prop s -> Sort.is_prop s'. Proof using Hcf. - intros wfΣ HT HU cum isp. - eapply PCUICSpine.ws_cumul_pb_le_le in cum. - eapply ws_cumul_pb_alt_closed in cum as [v [v' [eqv]]]. - eapply subject_reduction_closed in HT; tea. - eapply subject_reduction_closed in HU; tea. - eapply leq_term_prop_sorted_r in c0; tea. all:eauto with pcuic. - eapply leq_universe_prop_r; tea; eauto with pcuic. + intros. + erewrite <- unique_sorting_equality_prop; eassumption. Qed. -Lemma unique_sorting_equality_prop {pb} {Σ : global_env_ext} {Γ T U s s'} : +Lemma unique_sorting_equality_prop_r {pb} {Σ : global_env_ext} {Γ T U s s'} : wf_ext Σ -> Σ ;;; Γ |- T : tSort s -> Σ ;;; Γ |- U : tSort s' -> Σ ;;; Γ ⊢ T ≤[pb] U -> - Universe.is_prop s = Universe.is_prop s'. + Sort.is_prop s' -> Sort.is_prop s. Proof using Hcf. - intros wfΣ HT HU cum. - apply iff_is_true_eq_bool. - split. - now eapply unique_sorting_equality_prop_l; tea. - now eapply unique_sorting_equality_prop_r; tea. + intros. + erewrite unique_sorting_equality_prop; eassumption. Qed. -Lemma unique_sorting_equality_sprop_l {pb} {Σ : global_env_ext} {Γ T U s s'} : +Lemma unique_sorting_equality_sprop {pb} {Σ : global_env_ext} {Γ T U s s'} : wf_ext Σ -> Σ ;;; Γ |- T : tSort s -> Σ ;;; Γ |- U : tSort s' -> Σ ;;; Γ ⊢ T ≤[pb] U -> - Universe.is_sprop s -> Universe.is_sprop s'. + Sort.is_sprop s = Sort.is_sprop s'. Proof using Hcf. - intros wfΣ HT HU cum isp. - eapply PCUICSpine.ws_cumul_pb_le_le in cum. - eapply ws_cumul_pb_alt_closed in cum as [v [v' [eqv]]]. - eapply subject_reduction_closed in HT; tea. - eapply subject_reduction_closed in HU; tea. - eapply leq_term_sprop_sorted_l in c0; tea. all:eauto with pcuic. - eapply leq_universe_sprop_r; tea; eauto with pcuic. + intros wfΣ HT HU cum. + eapply unique_sorting_family in cum; tea. + now destruct s, s'. Qed. -Lemma unique_sorting_equality_sprop_r {pb} {Σ : global_env_ext} {Γ T U s s'} : +Lemma unique_sorting_equality_sprop_l {pb} {Σ : global_env_ext} {Γ T U s s'} : wf_ext Σ -> Σ ;;; Γ |- T : tSort s -> Σ ;;; Γ |- U : tSort s' -> Σ ;;; Γ ⊢ T ≤[pb] U -> - Universe.is_sprop s' -> Universe.is_sprop s. + Sort.is_sprop s -> Sort.is_sprop s'. Proof using Hcf. - intros wfΣ HT HU cum isp. - eapply PCUICSpine.ws_cumul_pb_le_le in cum. - eapply ws_cumul_pb_alt_closed in cum as [v [v' [eqv]]]. - eapply subject_reduction_closed in HT; tea. - eapply subject_reduction_closed in HU; tea. - eapply leq_term_sprop_sorted_r in c0; tea. all:eauto with pcuic. - eapply leq_universe_sprop_r; tea; eauto with pcuic. + intros. + erewrite <- unique_sorting_equality_sprop; eassumption. Qed. -Lemma unique_sorting_equality_sprop {pb} {Σ : global_env_ext} {Γ T U s s'} : +Lemma unique_sorting_equality_sprop_r {pb} {Σ : global_env_ext} {Γ T U s s'} : wf_ext Σ -> Σ ;;; Γ |- T : tSort s -> Σ ;;; Γ |- U : tSort s' -> Σ ;;; Γ ⊢ T ≤[pb] U -> - Universe.is_sprop s = Universe.is_sprop s'. + Sort.is_sprop s' -> Sort.is_sprop s. Proof using Hcf. - intros wfΣ HT HU cum. - apply iff_is_true_eq_bool. - split. - now eapply unique_sorting_equality_sprop_l; tea. - now eapply unique_sorting_equality_sprop_r; tea. + intros. + erewrite unique_sorting_equality_sprop; eassumption. Qed. Lemma unique_sorting_equality_propositional {pb} {Σ : global_env_ext} {Γ T U s s'} : @@ -887,24 +825,16 @@ Lemma unique_sorting_equality_propositional {pb} {Σ : global_env_ext} {Γ T U s Σ ;;; Γ |- T : tSort s -> Σ ;;; Γ |- U : tSort s' -> Σ ;;; Γ ⊢ T ≤[pb] U -> - is_propositional s = is_propositional s'. + Sort.is_propositional s = Sort.is_propositional s'. Proof using Hcf. intros wfΣ HT HU cum. - unfold is_propositional. - destruct (Universe.is_prop s) eqn:isp => /=. symmetry. - - apply orb_true_intro; left. - now rewrite (unique_sorting_equality_prop wfΣ HT HU cum) in isp. - - destruct (Universe.is_sprop s) eqn:isp' => /=. symmetry. - apply orb_true_intro; right. - now rewrite (unique_sorting_equality_sprop wfΣ HT HU cum) in isp'. - rewrite (unique_sorting_equality_prop wfΣ HT HU cum) in isp. - rewrite (unique_sorting_equality_sprop wfΣ HT HU cum) in isp'. - rewrite isp isp' //. + eapply unique_sorting_family in cum; tea. + now destruct s, s'. Qed. Lemma cumul_prop1 (Σ : global_env_ext) Γ A B u : wf_ext Σ -> - Universe.is_prop u -> + Sort.is_prop u -> isType Σ Γ A -> Σ ;;; Γ |- B : tSort u -> Σ ;;; Γ |- A <= B -> @@ -912,13 +842,13 @@ Lemma cumul_prop1 (Σ : global_env_ext) Γ A B u : Proof using Hcf. intros. destruct X0 as (_ & s & Hs & _). - eapply cumul_prop_inv in H. 4:eauto. pcuicfo. auto. - right; eauto. + eapply cumul_prop_inv in X2 as []; eauto. + now apply Sort.is_prop_propositional. Qed. Lemma cumul_prop2 (Σ : global_env_ext) Γ A B u : wf_ext Σ -> - Universe.is_prop u -> + Sort.is_prop u -> isType Σ Γ B -> Σ ;;; Γ |- A <= B -> Σ ;;; Γ |- A : tSort u -> @@ -926,13 +856,13 @@ Lemma cumul_prop2 (Σ : global_env_ext) Γ A B u : Proof using Hcf. intros. destruct X0 as (_ & s & Hs & _). - eapply cumul_prop_inv in H. 4:eauto. pcuicfo. auto. - left; eauto. + eapply cumul_prop_inv in X1 as []; eauto. + now apply Sort.is_prop_propositional. Qed. Lemma cumul_sprop1 (Σ : global_env_ext) Γ A B u : wf_ext Σ -> - Universe.is_sprop u -> + Sort.is_sprop u -> isType Σ Γ A -> Σ ;;; Γ |- B : tSort u -> Σ ;;; Γ |- A <= B -> @@ -940,13 +870,13 @@ Lemma cumul_sprop1 (Σ : global_env_ext) Γ A B u : Proof using Hcf. intros. destruct X0 as (_ & s & Hs & _). - eapply cumul_sprop_inv in H. 4:eauto. pcuicfo. auto. - right; eauto. + eapply cumul_prop_inv in X2 as []; eauto. + now apply Sort.is_sprop_propositional. Qed. Lemma cumul_sprop2 (Σ : global_env_ext) Γ A B u : wf_ext Σ -> - Universe.is_sprop u -> + Sort.is_sprop u -> isType Σ Γ B -> Σ ;;; Γ |- A <= B -> Σ ;;; Γ |- A : tSort u -> @@ -954,8 +884,8 @@ Lemma cumul_sprop2 (Σ : global_env_ext) Γ A B u : Proof using Hcf. intros. destruct X0 as (_ & s & Hs & _). - eapply cumul_sprop_inv in H. 4:eauto. pcuicfo. auto. - left; eauto. + eapply cumul_prop_inv in X1 as []; eauto. + now apply Sort.is_sprop_propositional. Qed. End no_prop_leq_type. diff --git a/pcuic/theories/PCUICEquality.v b/pcuic/theories/PCUICEquality.v index b9db09530..494aa21b5 100644 --- a/pcuic/theories/PCUICEquality.v +++ b/pcuic/theories/PCUICEquality.v @@ -20,11 +20,11 @@ Instance All2_fold_len {A} P (Γ Δ : list A) : HasLen (All2_fold P Γ Δ) #|Γ| Implicit Types (cf : checker_flags). -Definition R_universe_instance R := - fun u u' => Forall2 R (List.map Universe.make u) (List.map Universe.make u'). +Definition cmp_universe_instance (cmp_univ : Universe.t -> Universe.t -> Prop) : Instance.t -> Instance.t -> Prop := + Forall2 (on_rel cmp_univ Universe.make'). -Definition R_universe_instance_dep R R' := - fun {u u'} (H : R_universe_instance R u u') => Forall2_dep R' H. +Definition cmp_universe_instance_dep cmp_univ P' := + fun {u u'} (H : cmp_universe_instance cmp_univ u u') => Forall2_dep P' H. (** Cumulative inductive types: @@ -33,26 +33,15 @@ Definition R_universe_instance_dep R R' := even on ill-formed terms. It corresponds to the right notion on well-formed terms. *) -Definition R_universe_variance (Re Rle : Universe.t -> Universe.t -> Prop) v u u' := +Definition cmp_universe_variance (cmp_univ : conv_pb -> Universe.t -> Universe.t -> Prop) pb v u u' := match v with | Variance.Irrelevant => True - | Variance.Covariant => Rle (Universe.make u) (Universe.make u') - | Variance.Invariant => Re (Universe.make u) (Universe.make u') + | Variance.Covariant => on_rel (cmp_univ pb) Universe.make' u u' + | Variance.Invariant => on_rel (cmp_univ Conv) Universe.make' u u' end. -Fixpoint R_universe_instance_variance Re Rle v u u' := - match u, u' return Prop with - | u :: us, u' :: us' => - match v with - | [] => R_universe_instance_variance Re Rle v us us' - (* Missing variance stands for irrelevance, we still check that the instances have - the same length. *) - | v :: vs => R_universe_variance Re Rle v u u' /\ - R_universe_instance_variance Re Rle vs us us' - end - | [], [] => True - | _, _ => False - end. +Definition cmp_universe_instance_variance cmp_univ pb v u u' := + Forall3 (cmp_universe_variance cmp_univ pb) v u u'. Definition global_variance_gen lookup gr napp := match gr with @@ -60,164 +49,274 @@ Definition global_variance_gen lookup gr napp := match lookup_inductive_gen lookup ind with | Some (mdecl, idecl) => match destArity [] idecl.(ind_type) with - | Some (ctx, _) => if (context_assumptions ctx) <=? napp then mdecl.(ind_variance) - else None - | None => None + | Some (ctx, _) => if (context_assumptions ctx) <=? napp then + match mdecl.(ind_variance) with + | Some var => Variance var + | None => AllEqual + end + else AllEqual + | None => AllEqual end - | None => None + | None => AllEqual end | ConstructRef ind k => match lookup_constructor_gen lookup ind k with | Some (mdecl, idecl, cdecl) => if (cdecl.(cstr_arity) + mdecl.(ind_npars))%nat <=? napp then (** Fully applied constructors are always compared at the same supertype, - which implies that no universe ws_cumul_pb needs to be checked here. *) - Some [] - else None - | _ => None + which implies that no universe ws_cumul_pb needs to be checked here. + We will still check that the instances have the same length. *) + AllIrrelevant + else AllEqual + | _ => AllEqual end - | _ => None + | _ => AllEqual end. Notation global_variance Σ := (global_variance_gen (lookup_env Σ)). -Definition R_opt_variance Re Rle v := +Definition cmp_opt_variance cmp_univ pb v := match v with - | Some v => R_universe_instance_variance Re Rle v - | None => R_universe_instance Re + | AllEqual => cmp_universe_instance (cmp_univ Conv) + | AllIrrelevant => fun l l' => #|l| = #|l'| + | Variance v => fun u u' => cmp_universe_instance (cmp_univ Conv) u u' \/ cmp_universe_instance_variance cmp_univ pb v u u' end. -Definition R_global_instance_gen Σ Re Rle gr napp := - R_opt_variance Re Rle (global_variance_gen Σ gr napp). +Lemma cmp_universe_universe_variance (cmp_univ : conv_pb -> Universe.t -> Universe.t -> Prop) pb v u u' : + RelationClasses.subrelation (cmp_univ Conv) (cmp_univ pb) -> + on_rel (cmp_univ Conv) Universe.make' u u' -> cmp_universe_variance cmp_univ pb v u u'. +Proof. + destruct v => //=. + intros H H1; apply H, H1. +Qed. + +Lemma cmp_instance_variance cmp_univ pb v u u' : + RelationClasses.subrelation (cmp_univ Conv) (cmp_univ pb) -> + #|v| = #|u| -> + cmp_universe_instance (cmp_univ Conv) u u' -> cmp_universe_instance_variance cmp_univ pb v u u'. +Proof. + intros Hsub Hlen Hu. + apply Forall2_triv in Hlen. + eapply Forall2_Forall2_Forall3 in Hu; tea. + apply Forall3_impl with (1 := Hu) => v1 u1 u1' [] _ H1. + now apply cmp_universe_universe_variance. +Qed. + +Lemma cmp_instance_opt_variance cmp_univ pb v : + RelationClasses.subrelation (cmp_opt_variance cmp_univ pb AllEqual) (cmp_opt_variance cmp_univ pb v). +Proof. + intros u u' H. + destruct v as [| |v] => //=. + 1: now apply Forall2_length in H. + now left. +Qed. + +Lemma cmp_opt_variance_var_dec cmp_univ pb v ui ui' : + RelationClasses.subrelation (cmp_univ Conv) (cmp_univ pb) -> + cmp_universe_instance (cmp_univ Conv) ui ui' \/ cmp_universe_instance_variance cmp_univ pb v ui ui' -> + { cmp_universe_instance (cmp_univ Conv) ui ui' } + { cmp_universe_instance_variance cmp_univ pb v ui ui' }. +Proof. + intros subr H. + elim:(eq_dec #|v| #|ui|). + - right. + destruct H as [|]; tas. + now eapply cmp_instance_variance. + - left. + destruct H as [|]; tas. + eapply @Forall3_Forall2_left with (Q := fun _ _ => True) in H => //. + apply Forall2_length in H. + now exfalso. +Qed. + +Lemma cmp_opt_variance_length cmp_univ pb v ui ui' : + cmp_opt_variance cmp_univ pb v ui ui' -> #|ui| = #|ui'|. +Proof. + destruct v => //=. + 1: apply Forall2_length. + move => [|]. + 1: apply Forall2_length. + intro H. + eapply @Forall2_length with (P := fun _ _ => True). + now eapply Forall3_Forall2_right => //. +Qed. + +Lemma cmp_opt_variance_or_impl cmp_universe1 cmp_universe2 cmp_universe3 pb1 pb2 pb3 v u1 u1' u2 u2' u3 u3' : + RelationClasses.subrelation (cmp_universe1 Conv) (cmp_universe1 pb1) -> + RelationClasses.subrelation (cmp_universe2 Conv) (cmp_universe2 pb2) -> + (cmp_universe_instance (cmp_universe1 Conv) u1 u1' -> cmp_universe_instance (cmp_universe2 Conv) u2 u2' -> cmp_universe_instance (cmp_universe3 Conv) u3 u3') -> + (cmp_universe_instance_variance cmp_universe1 pb1 v u1 u1' -> cmp_universe_instance_variance cmp_universe2 pb2 v u2 u2' -> cmp_universe_instance_variance cmp_universe3 pb3 v u3 u3') -> + (#|u1| = #|u1'| -> #|u2| = #|u2'| -> #|u1| = #|u2|) -> + cmp_universe_instance (cmp_universe1 Conv) u1 u1' \/ cmp_universe_instance_variance cmp_universe1 pb1 v u1 u1' -> + cmp_universe_instance (cmp_universe2 Conv) u2 u2' \/ cmp_universe_instance_variance cmp_universe2 pb2 v u2 u2' -> + cmp_universe_instance (cmp_universe3 Conv) u3 u3' \/ cmp_universe_instance_variance cmp_universe3 pb3 v u3 u3'. +Proof. + intros Hsub1 Hsub2 Hl Hr e [H|H] [H'|H']; [left; apply Hl| right; apply Hr ..]; auto. + all: apply cmp_instance_variance; tas. + - rewrite e. + all: eapply Forall2_length; tea. + + eapply @Forall3_Forall2_right with (Q := fun _ _ => True); eauto. + + eapply @Forall3_Forall2_left with (Q := fun _ _ => True); eauto. + - rewrite -e. + all: eapply Forall2_length; tea. + + eapply @Forall3_Forall2_right with (Q := fun _ _ => True); eauto. + + eapply @Forall3_Forall2_left with (Q := fun _ _ => True); eauto. +Qed. + +Definition cmp_global_instance_gen Σ cmp_universe pb gr napp := + cmp_opt_variance cmp_universe pb (global_variance_gen Σ gr napp). -Notation R_global_instance Σ := (R_global_instance_gen (lookup_env Σ)). +Notation cmp_global_instance Σ := (cmp_global_instance_gen (lookup_env Σ)). -Definition R_ind_universes {cf:checker_flags} (Σ : global_env_ext) ind n i i' := - R_global_instance Σ (eq_universe (global_ext_constraints Σ)) - (leq_universe (global_ext_constraints Σ)) (IndRef ind) n i i'. +Definition cmp_ind_universes {cf:checker_flags} (Σ : global_env_ext) ind n i i' := + cmp_global_instance Σ (compare_universe (global_ext_constraints Σ)) Cumul (IndRef ind) n i i'. -Lemma R_universe_instance_impl R R' : +Lemma cmp_universe_instance_impl R R' : RelationClasses.subrelation R R' -> - RelationClasses.subrelation (R_universe_instance R) (R_universe_instance R'). + RelationClasses.subrelation (cmp_universe_instance R) (cmp_universe_instance R'). Proof. - intros H x y xy. eapply Forall2_impl ; tea. + intros H x y xy. eapply Forall2_impl; tea; unfold on_rel; auto. Qed. -Lemma R_universe_instance_impl' R R' : +Lemma cmp_universe_instance_impl' R R' : RelationClasses.subrelation R R' -> - forall u u', R_universe_instance R u u' -> R_universe_instance R' u u'. + forall u u', cmp_universe_instance R u u' -> cmp_universe_instance R' u u'. Proof. - intros H x y xy. eapply Forall2_impl ; tea. + intros H x y xy. eapply Forall2_impl; tea; unfold on_rel; auto. Qed. -Section compare_decls. - (* leq_term compares types, eq_term bodies: - - For conversion they are both equality - - For cumulativity only the type are compared using leq. - *) - Context {eq_term leq_term : term -> term -> Type}. - Inductive compare_decls : context_decl -> context_decl -> Type := - | compare_vass {na T na' T'} : - eq_binder_annot na na' -> - leq_term T T' -> - compare_decls (vass na T) (vass na' T') - | compare_vdef {na b T na' b' T'} : - eq_binder_annot na na' -> - eq_term b b' -> - leq_term T T' -> - compare_decls (vdef na b T) (vdef na' b' T'). +Lemma cmp_universe_variance_impl R R' pb pb' v : + RelationClasses.subrelation (R Conv) (R' Conv) -> + RelationClasses.subrelation (R pb) (R' pb') -> + RelationClasses.subrelation (cmp_universe_variance R pb v) (cmp_universe_variance R' pb' v). +Proof. + intros HConv Hpb x y. + destruct v => //=. + all: unfold on_rel; now auto. +Qed. + +Lemma cmp_universe_instance_variance_impl R R' pb pb' v : + RelationClasses.subrelation (R Conv) (R' Conv) -> + RelationClasses.subrelation (R pb) (R' pb') -> + RelationClasses.subrelation (cmp_universe_instance_variance R pb v) (cmp_universe_instance_variance R' pb' v). +Proof. + intros HConv Hpb x y xy. + eapply Forall3_impl; tea. + intros ???. + now apply cmp_universe_variance_impl. +Qed. - Derive Signature NoConfusion for compare_decls. -End compare_decls. -Arguments compare_decls : clear implicits. +Inductive eq_decl_upto_names : context_decl -> context_decl -> Type := + | compare_vass {na na' T} : + eq_binder_annot na na' -> eq_decl_upto_names (vass na T) (vass na' T) + | compare_vdef {na na' b T} : + eq_binder_annot na na' -> eq_decl_upto_names (vdef na b T) (vdef na' b T). +Derive Signature NoConfusion for eq_decl_upto_names. +#[global] Hint Constructors eq_decl_upto_names : pcuic. -Notation eq_context_upto_names := (All2 (compare_decls eq eq)). +Definition compare_decls cmp_term pb := PCUICConversion.All_decls_alpha_pb pb cmp_term. -Notation eq_context_gen eq_term leq_term := - (All2_fold (fun _ _ => compare_decls eq_term leq_term)). +Notation eq_context_upto_names := (All2 eq_decl_upto_names). -Lemma eq_context_upto_names_gen Γ Γ' : eq_context_upto_names Γ Γ' <~> eq_context_gen eq eq Γ Γ'. +Notation eq_context_gen cmp_term pb := + (All2_fold (fun _ _ => compare_decls cmp_term pb)). + +Lemma eq_decl_upto_names_gen decl decl' pb : eq_decl_upto_names decl decl' <~> compare_decls (fun _ => eq) pb decl decl'. +Proof. + split; intros e; depind e; subst; constructor; auto. +Qed. + +Lemma eq_context_upto_names_gen Γ Γ' pb : eq_context_upto_names Γ Γ' <~> eq_context_gen (fun _ => eq) pb Γ Γ'. Proof. - split; intros e; depind e; constructor; auto. + split; intros e; depind e; constructor; tas; now eapply eq_decl_upto_names_gen. Qed. -Lemma compare_decls_impl eq_term leq_term eq_term' leq_term' : - subrelation eq_term eq_term' -> - subrelation leq_term leq_term' -> - subrelation (compare_decls eq_term leq_term) - (compare_decls eq_term' leq_term'). +Lemma compare_decls_impl cmp_term cmp_term' pb pb' : + subrelation (cmp_term Conv) (cmp_term' Conv) -> + subrelation (cmp_term pb) (cmp_term' pb') -> + subrelation (compare_decls cmp_term pb) (compare_decls cmp_term' pb'). Proof. intros he hle x y []; constructor; auto. Qed. -Lemma eq_context_gen_impl eq_term leq_term eq_term' leq_term' : - subrelation eq_term eq_term' -> - subrelation leq_term leq_term' -> - subrelation (eq_context_gen eq_term leq_term) (eq_context_gen eq_term' leq_term'). +Lemma eq_context_gen_impl cmp_term cmp_term' pb pb' : + subrelation (cmp_term Conv) (cmp_term' Conv) -> + subrelation (cmp_term pb) (cmp_term' pb') -> + subrelation (eq_context_gen cmp_term pb) (eq_context_gen cmp_term' pb'). Proof. intros he hle x y eq. eapply All2_fold_impl; tea => /=. intros; eapply compare_decls_impl; tea. Qed. -Lemma compare_decl_impl_ondecl P eq_term leq_term eq_term' leq_term' d d' : +Lemma compare_decl_impl_ondecl P cmp_term cmp_term' pb pb' d d' : ondecl P d -> - (forall x y, P x -> eq_term x y -> eq_term' x y) -> - (forall x y, P x -> leq_term x y -> leq_term' x y) -> - compare_decls eq_term leq_term d d' -> - compare_decls eq_term' leq_term' d d'. + (forall x y, P x -> cmp_term Conv x y -> cmp_term' Conv x y) -> + (forall x y, P x -> cmp_term pb x y -> cmp_term' pb' x y) -> + compare_decls cmp_term pb d d' -> + compare_decls cmp_term' pb' d d'. Proof. intros ond he hle cd; depelim cd; depelim ond; constructor => //; eauto. Qed. -Lemma compare_decl_map eq_term leq_term f g d d' : - compare_decls (fun x y => eq_term (f x) (g y)) - (fun x y => leq_term (f x) (g y)) d d' -> - compare_decls eq_term leq_term (map_decl f d) (map_decl g d'). +Lemma compare_decl_map cmp_term pb f g d d' : + compare_decls (fun pb x y => cmp_term pb (f x) (g y)) pb d d' -> + compare_decls cmp_term pb (map_decl f d) (map_decl g d'). Proof. intros h; depelim h; constructor; intuition auto. Qed. -Definition bcompare_decls (eq_term leq_term : term -> term -> bool) (d d' : context_decl) : bool := - match d, d' with - | {| decl_name := na; decl_body := None; decl_type := T |}, - {| decl_name := na'; decl_body := None; decl_type := T' |} => - eqb_binder_annot na na' && leq_term T T' - | {| decl_name := na; decl_body := Some b; decl_type := T |}, - {| decl_name := na'; decl_body := Some b'; decl_type := T' |} => - eqb_binder_annot na na' && eq_term b b' && leq_term T T' - | _, _ => false - end. - #[global] -Polymorphic Instance compare_decl_refl eq_term leq_term : - CRelationClasses.Reflexive eq_term -> - CRelationClasses.Reflexive leq_term -> - CRelationClasses.Reflexive (compare_decls eq_term leq_term). +Polymorphic Instance compare_decl_refl cmp_term pb : + CRelationClasses.Reflexive (cmp_term Conv) -> + CRelationClasses.Reflexive (cmp_term pb) -> + CRelationClasses.Reflexive (compare_decls cmp_term pb). Proof. intros heq hle d. destruct d as [na [b|] ty]; constructor; auto; reflexivity. Qed. #[global] -Polymorphic Instance compare_decl_sym eq_term leq_term : - CRelationClasses.Symmetric eq_term -> - CRelationClasses.Symmetric leq_term -> - CRelationClasses.Symmetric (compare_decls eq_term leq_term). +Polymorphic Instance compare_decl_sym cmp_term pb : + CRelationClasses.Symmetric (cmp_term Conv) -> + CRelationClasses.Symmetric (cmp_term pb) -> + CRelationClasses.Symmetric (compare_decls cmp_term pb). Proof. intros heq hle d d' []; constructor; auto; now symmetry. Qed. #[global] -Polymorphic Instance compare_decl_trans eq_term leq_term : - CRelationClasses.Transitive eq_term -> - CRelationClasses.Transitive leq_term -> - CRelationClasses.Transitive (compare_decls eq_term leq_term). +Polymorphic Instance compare_decl_trans cmp_term pb : + CRelationClasses.Transitive (cmp_term Conv) -> + CRelationClasses.Transitive (cmp_term pb) -> + CRelationClasses.Transitive (compare_decls cmp_term pb). Proof. intros hle hre x y z h h'; depelim h; depelim h'; constructor; auto; etransitivity; eauto. Qed. +#[global] +Polymorphic Instance eq_decl_upto_names_refl : + CRelationClasses.Reflexive eq_decl_upto_names. +Proof. + intros d. + destruct d as [na [b|] ty]; constructor; auto; reflexivity. +Qed. + +#[global] +Polymorphic Instance eq_decl_upto_names_sym : + CRelationClasses.Symmetric eq_decl_upto_names. +Proof. + intros d d' []; constructor; auto; now symmetry. +Qed. + +#[global] +Polymorphic Instance eq_decl_upto_names_trans : + CRelationClasses.Transitive eq_decl_upto_names. +Proof. + intros x y z h h'; depelim h; depelim h'; constructor; auto; + etransitivity; eauto. +Qed. + #[global] Instance alpha_eq_reflexive : CRelationClasses.Reflexive eq_context_upto_names. Proof. @@ -237,10 +336,10 @@ Proof. Qed. #[global] -Polymorphic Instance eq_context_refl eq_term leq_term : - CRelationClasses.Reflexive eq_term -> - CRelationClasses.Reflexive leq_term -> - CRelationClasses.Reflexive (eq_context_gen eq_term leq_term). +Polymorphic Instance eq_context_refl cmp_term pb : + CRelationClasses.Reflexive (cmp_term Conv) -> + CRelationClasses.Reflexive (cmp_term pb) -> + CRelationClasses.Reflexive (eq_context_gen cmp_term pb). Proof. intros heq hle x. eapply All2_fold_refl. @@ -248,10 +347,10 @@ Proof. Qed. #[global] -Polymorphic Instance eq_context_sym eq_term leq_term : - CRelationClasses.Symmetric eq_term -> - CRelationClasses.Symmetric leq_term -> - CRelationClasses.Symmetric (eq_context_gen eq_term leq_term). +Polymorphic Instance eq_context_sym cmp_term pb : + CRelationClasses.Symmetric (cmp_term Conv) -> + CRelationClasses.Symmetric (cmp_term pb) -> + CRelationClasses.Symmetric (eq_context_gen cmp_term pb). Proof. intros heq hle x. eapply All2_fold_sym. @@ -259,21 +358,36 @@ Proof. Qed. #[global] -Polymorphic Instance eq_context_trans eq_term leq_term : - CRelationClasses.Transitive eq_term -> - CRelationClasses.Transitive leq_term -> - CRelationClasses.Transitive (eq_context_gen eq_term leq_term). +Polymorphic Instance eq_context_trans cmp_term pb : + CRelationClasses.Transitive (cmp_term Conv) -> + CRelationClasses.Transitive (cmp_term pb) -> + CRelationClasses.Transitive (eq_context_gen cmp_term pb). Proof. intros hr x y z. eapply All2_fold_trans; intros. now transitivity y0. Qed. -Definition eq_predicate (eq_term : term -> term -> Type) Re p p' := - All2 eq_term p.(pparams) p'.(pparams) * - (R_universe_instance Re p.(puinst) p'.(puinst) * - ((eq_context_gen eq eq p.(pcontext) p'.(pcontext)) * - eq_term p.(preturn) p'.(preturn))). +Definition eq_predicate (eq_term : term -> term -> Type) eq_universe p p' := + All2 eq_term p.(pparams) p'.(pparams) × + cmp_universe_instance eq_universe p.(puinst) p'.(puinst) × + eq_context_upto_names p.(pcontext) p'.(pcontext) × + eq_term p.(preturn) p'.(preturn). + +Definition eq_branch (eq_term : term -> term -> Type) br br' := + eq_context_upto_names br.(bcontext) br'.(bcontext) × + eq_term br.(bbody) br'.(bbody). + +Definition eq_branches eq_term brs brs' := All2 (eq_branch eq_term) brs brs'. + +Definition eq_mfixpoint (eq_term : term -> term -> Type) mfix mfix' := + All2 (fun d d' => + eq_term d.(dtype) d'.(dtype) × + eq_term d.(dbody) d'.(dbody) × + d.(rarg) = d'.(rarg) × + eq_binder_annot d.(dname) d'.(dname) + ) mfix mfix'. + (** ** Syntactic ws_cumul_pb up-to universes We don't look at printing annotations *) @@ -285,146 +399,235 @@ Definition eq_predicate (eq_term : term -> term -> Type) Re p p' := Reserved Notation " Σ ⊢ t <==[ Rle , napp ] u" (at level 50, t, u at next level, format "Σ ⊢ t <==[ Rle , napp ] u"). -Inductive eq_term_upto_univ_napp Σ (Re Rle : Universe.t -> Universe.t -> Prop) (napp : nat) : term -> term -> Type := +Inductive eq_term_upto_univ_napp Σ + (cmp_universe : conv_pb -> Universe.t -> Universe.t -> Prop) + (cmp_sort : conv_pb -> sort -> sort -> Prop) + (pb : conv_pb) (napp : nat) : term -> term -> Type := | eq_Rel : forall n, - Σ ⊢ tRel n <==[ Rle , napp ] tRel n + Σ ⊢ tRel n <==[ pb , napp ] tRel n | eq_Evar : forall e args args', - All2 (eq_term_upto_univ_napp Σ Re Re 0) args args' -> - Σ ⊢ tEvar e args <==[ Rle , napp ] tEvar e args' + All2 (fun arg arg' => (Σ ⊢ arg <==[ Conv , 0 ] arg')) args args' -> + Σ ⊢ tEvar e args <==[ pb , napp ] tEvar e args' | eq_Var : forall id, - Σ ⊢ tVar id <==[ Rle , napp ] tVar id + Σ ⊢ tVar id <==[ pb , napp ] tVar id | eq_Sort : forall s s', - Rle s s' -> - Σ ⊢ tSort s <==[ Rle , napp ] tSort s' + cmp_sort pb s s' -> + Σ ⊢ tSort s <==[ pb , napp ] tSort s' | eq_App : forall t t' u u', - Σ ⊢ t <==[ Rle , S napp ] t' -> - Σ ⊢ u <==[ Re , 0 ] u' -> - Σ ⊢ tApp t u <==[ Rle , napp ] tApp t' u' + Σ ⊢ t <==[ pb , S napp ] t' -> + Σ ⊢ u <==[ Conv , 0 ] u' -> + Σ ⊢ tApp t u <==[ pb , napp ] tApp t' u' | eq_Const : forall c u u', - R_universe_instance Re u u' -> - Σ ⊢ tConst c u <==[ Rle , napp ] tConst c u' + cmp_universe_instance (cmp_universe Conv) u u' -> + Σ ⊢ tConst c u <==[ pb , napp ] tConst c u' | eq_Ind : forall i u u', - R_global_instance Σ Re Rle (IndRef i) napp u u' -> - Σ ⊢ tInd i u <==[ Rle , napp ] tInd i u' + cmp_global_instance Σ cmp_universe pb (IndRef i) napp u u' -> + Σ ⊢ tInd i u <==[ pb , napp ] tInd i u' | eq_Construct : forall i k u u', - R_global_instance Σ Re Rle (ConstructRef i k) napp u u' -> - Σ ⊢ tConstruct i k u <==[ Rle , napp ] tConstruct i k u' + cmp_global_instance Σ cmp_universe pb (ConstructRef i k) napp u u' -> + Σ ⊢ tConstruct i k u <==[ pb , napp ] tConstruct i k u' | eq_Lambda : forall na na' ty ty' t t', eq_binder_annot na na' -> - Σ ⊢ ty <==[ Re , 0 ] ty' -> - Σ ⊢ t <==[ Rle , 0 ] t' -> - Σ ⊢ tLambda na ty t <==[ Rle , napp ] tLambda na' ty' t' + Σ ⊢ ty <==[ Conv , 0 ] ty' -> + Σ ⊢ t <==[ pb , 0 ] t' -> + Σ ⊢ tLambda na ty t <==[ pb , napp ] tLambda na' ty' t' | eq_Prod : forall na na' a a' b b', eq_binder_annot na na' -> - Σ ⊢ a <==[ Re , 0 ] a' -> - Σ ⊢ b <==[ Rle , 0 ] b' -> - Σ ⊢ tProd na a b <==[ Rle , napp ] tProd na' a' b' + Σ ⊢ a <==[ Conv , 0 ] a' -> + Σ ⊢ b <==[ pb , 0 ] b' -> + Σ ⊢ tProd na a b <==[ pb , napp ] tProd na' a' b' | eq_LetIn : forall na na' t t' ty ty' u u', eq_binder_annot na na' -> - Σ ⊢ t <==[ Re , 0 ] t' -> - Σ ⊢ ty <==[ Re , 0 ] ty' -> - Σ ⊢ u <==[ Rle , 0 ] u' -> - Σ ⊢ tLetIn na t ty u <==[ Rle , napp ] tLetIn na' t' ty' u' + Σ ⊢ t <==[ Conv , 0 ] t' -> + Σ ⊢ ty <==[ Conv , 0 ] ty' -> + Σ ⊢ u <==[ pb , 0 ] u' -> + Σ ⊢ tLetIn na t ty u <==[ pb , napp ] tLetIn na' t' ty' u' | eq_Case : forall indn p p' c c' brs brs', - eq_predicate (eq_term_upto_univ_napp Σ Re Re 0) Re p p' -> - Σ ⊢ c <==[ Re , 0 ] c' -> - All2 (fun x y => - eq_context_gen eq eq (bcontext x) (bcontext y) * - (Σ ⊢ x.(bbody) <==[ Re , 0 ] y.(bbody)) - ) brs brs' -> - Σ ⊢ tCase indn p c brs <==[ Rle , napp ] tCase indn p' c' brs' + eq_predicate (fun t t' => Σ ⊢ t <==[ Conv , 0 ] t') (cmp_universe Conv) p p' -> + Σ ⊢ c <==[ Conv , 0 ] c' -> + eq_branches (fun t t' => Σ ⊢ t <==[ Conv , 0 ] t') brs brs' -> + Σ ⊢ tCase indn p c brs <==[ pb , napp ] tCase indn p' c' brs' | eq_Proj : forall p c c', - Σ ⊢ c <==[ Re , 0 ] c' -> - Σ ⊢ tProj p c <==[ Rle , napp ] tProj p c' + Σ ⊢ c <==[ Conv , 0 ] c' -> + Σ ⊢ tProj p c <==[ pb , napp ] tProj p c' | eq_Fix : forall mfix mfix' idx, - All2 (fun x y => - (Σ ⊢ x.(dtype) <==[ Re , 0 ] y.(dtype)) * - (Σ ⊢ x.(dbody) <==[ Re , 0 ] y.(dbody)) * - (x.(rarg) = y.(rarg)) * - eq_binder_annot x.(dname) y.(dname) - )%type mfix mfix' -> - Σ ⊢ tFix mfix idx <==[ Rle , napp ] tFix mfix' idx + eq_mfixpoint (fun t t' => Σ ⊢ t <==[ Conv , 0 ] t') mfix mfix' -> + Σ ⊢ tFix mfix idx <==[ pb , napp ] tFix mfix' idx | eq_CoFix : forall mfix mfix' idx, - All2 (fun x y => - (Σ ⊢ x.(dtype) <==[ Re , 0 ] y.(dtype)) * - (Σ ⊢ x.(dbody) <==[ Re , 0 ] y.(dbody)) * - (x.(rarg) = y.(rarg)) * - eq_binder_annot x.(dname) y.(dname) - ) mfix mfix' -> - Σ ⊢ tCoFix mfix idx <==[ Rle , napp ] tCoFix mfix' idx + eq_mfixpoint (fun t t' => Σ ⊢ t <==[ Conv , 0 ] t') mfix mfix' -> + Σ ⊢ tCoFix mfix idx <==[ pb , napp ] tCoFix mfix' idx | eq_Prim i i' : - onPrims (eq_term_upto_univ_napp Σ Re Re 0) Re i i' -> - eq_term_upto_univ_napp Σ Re Rle napp (tPrim i) (tPrim i') -where " Σ ⊢ t <==[ Rle , napp ] u " := (eq_term_upto_univ_napp Σ _ Rle napp t u) : type_scope. + onPrims (fun t t' => Σ ⊢ t <==[ Conv , 0 ] t') (cmp_universe Conv) i i' -> + Σ ⊢ tPrim i <==[ pb , napp ] tPrim i' +where " Σ ⊢ t <==[ pb , napp ] u " := (eq_term_upto_univ_napp Σ _ _ pb napp t u) : type_scope. -Notation eq_term_upto_univ Σ Re Rle := (eq_term_upto_univ_napp Σ Re Rle 0). +Notation eq_term_upto_univ Σ cmp_universe cmp_sort pb := (eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb 0) (only parsing). (* ** Syntactic conparison up-to universes *) -Definition compare_term_napp `{checker_flags} (pb : conv_pb) Σ φ napp (t u : term) := - eq_term_upto_univ_napp Σ (eq_universe φ) (compare_universe pb φ) napp t u. +Definition compare_term_napp `{checker_flags} Σ φ (pb : conv_pb) napp (t u : term) := + eq_term_upto_univ_napp Σ (compare_universe φ) (compare_sort φ) pb napp t u. -Definition compare_term `{checker_flags} (pb : conv_pb) Σ φ (t u : term) := - eq_term_upto_univ Σ (eq_universe φ) (compare_universe pb φ) t u. +Definition compare_term `{checker_flags} Σ φ (pb : conv_pb) (t u : term) := + eq_term_upto_univ Σ (compare_universe φ) (compare_sort φ) pb t u. (* ** Syntactic conversion up-to universes *) -Notation eq_term := (compare_term Conv). +Notation eq_term Σ φ := (compare_term Σ φ Conv). (* ** Syntactic cumulativity up-to universes *) -Notation leq_term := (compare_term Cumul). +Notation leq_term Σ φ := (compare_term Σ φ Cumul). Definition compare_opt_term `{checker_flags} (pb : conv_pb) Σ φ (t u : option term) := match t, u with - | Some t, Some u => compare_term pb Σ φ t u + | Some t, Some u => compare_term Σ φ pb t u | None, None => True | _, _ => False end. -Definition compare_decl `{checker_flags} pb Σ φ (d d' : context_decl) := - compare_decls (compare_term Conv Σ φ) (compare_term pb Σ φ) d d'. +Definition compare_decl `{checker_flags} Σ φ pb (d d' : context_decl) := + compare_decls (compare_term Σ φ) pb d d'. + +Notation eq_decl Σ φ := (compare_decl Σ φ Conv). +Notation leq_decl Σ φ := (compare_decl Σ φ Cumul). + +Definition compare_context `{checker_flags} Σ φ pb (Γ Δ : context) := + eq_context_gen (compare_term Σ φ) pb Γ Δ. + +Notation eq_context Σ φ := (compare_context Σ φ Conv). +Notation leq_context Σ φ := (compare_context Σ φ Cumul). -Notation eq_decl := (compare_decl Conv). -Notation leq_decl := (compare_decl Cumul). +Notation eq_context_upto Σ cmp_universe cmp_sort pb := + (eq_context_gen (fun pb0 => eq_term_upto_univ Σ cmp_universe cmp_sort pb0) pb). -Definition compare_context `{checker_flags} pb Σ φ (Γ Δ : context) := - eq_context_gen (compare_term Conv Σ φ) (compare_term pb Σ φ) Γ Δ. +(* TODO MOVE *) +#[global] +Existing Instance All2_symP. + +(* TODO MOVE *) +#[global] +Existing Instance Forall2_symP. + +#[global] +Instance cmp_universe_instance_refl cmp_universe : + RelationClasses.Reflexive cmp_universe -> + RelationClasses.Reflexive (cmp_universe_instance cmp_universe). +Proof. + intros refl_univ u. + apply Forall2_same; reflexivity. +Qed. + +#[global] +Instance cmp_universe_instance_sym cmp_universe : + RelationClasses.Symmetric cmp_universe -> + RelationClasses.Symmetric (cmp_universe_instance cmp_universe). +Proof. intros tRe x y. now eapply Forall2_symP. Qed. + +#[global] +Instance cmp_universe_instance_trans cmp_universe : + RelationClasses.Transitive cmp_universe -> + RelationClasses.Transitive (cmp_universe_instance cmp_universe). +Proof. intros tRe x y z. eapply Forall2_trans. tc. Qed. -Notation eq_context := (compare_context Conv). -Notation leq_context := (compare_context Cumul). +#[global] +Instance cmp_universe_variance_sym cmp_universe pb v : + RelationClasses.Symmetric (cmp_universe Conv) -> + RelationClasses.Symmetric (cmp_universe pb) -> + RelationClasses.Symmetric (cmp_universe_variance cmp_universe pb v). +Proof. + intros univ_sym univ_sym' u u' u''. + destruct v as [| |] => //=. + all: now symmetry. +Qed. + +#[global] +Instance cmp_universe_variance_trans cmp_universe pb v : + RelationClasses.Transitive (cmp_universe Conv) -> + RelationClasses.Transitive (cmp_universe pb) -> + RelationClasses.Transitive (cmp_universe_variance cmp_universe pb v). +Proof. + intros univ_trans univ_trans' u u' u''. + destruct v as [| |] => //=. + all: now etransitivity. +Qed. -Notation eq_context_upto Σ Re Rle := - (eq_context_gen (eq_term_upto_univ Σ Re Re) (eq_term_upto_univ Σ Re Rle)). +#[global] +Instance cmp_universe_instance_variance_sym cmp_universe pb v : + RelationClasses.Symmetric (cmp_universe Conv) -> + RelationClasses.Symmetric (cmp_universe pb) -> + RelationClasses.Symmetric (cmp_universe_instance_variance cmp_universe pb v). +Proof. + intros univ_sym univ_sym' u u'. + apply Forall3_symP. tc. +Qed. -Lemma R_global_instance_refl Σ Re Rle gr napp u : - RelationClasses.Reflexive Re -> - RelationClasses.Reflexive Rle -> - R_global_instance Σ Re Rle gr napp u u. +#[global] +Instance cmp_universe_instance_variance_trans cmp_universe pb v : + RelationClasses.Transitive (cmp_universe Conv) -> + RelationClasses.Transitive (cmp_universe pb) -> + RelationClasses.Transitive (cmp_universe_instance_variance cmp_universe pb v). +Proof. + intros univ_trans univ_trans' u u' u''. + apply Forall3_transP. tc. +Qed. + +#[global] +Instance cmp_global_instance_refl Σ cmp_universe pb gr napp : + RelationClasses.Reflexive (cmp_universe Conv) -> + RelationClasses.Reflexive (cmp_universe pb) -> + RelationClasses.Reflexive (cmp_global_instance Σ cmp_universe pb gr napp). Proof. intros rRE rRle. - unfold R_global_instance_gen. - destruct global_variance_gen as [v|] eqn:lookup. - - induction u in v |- *; simpl; auto; - unfold R_opt_variance in IHu; destruct v; simpl; auto. - split; auto. - destruct t; simpl; auto. - - apply Forall2_same; eauto. + unfold cmp_global_instance_gen. + destruct global_variance_gen as [| |v] => //= u. + - now apply cmp_universe_instance_refl. + - left. now apply cmp_universe_instance_refl. +Qed. + +#[global] +Instance cmp_global_instance_sym Σ cmp_universe pb gr napp : + RelationClasses.Symmetric (cmp_universe Conv) -> + RelationClasses.Symmetric (cmp_universe pb) -> + RelationClasses.Symmetric (cmp_global_instance Σ cmp_universe pb gr napp). +Proof. + intros univ_sym univ_sym'. + unfold cmp_global_instance_gen. + destruct global_variance_gen as [| |v] => //= u u'. + - now symmetry. + - intros [H | H]; [left|right]. + all: now symmetry. +Qed. + +#[global] +Instance cmp_global_instance_trans Σ cmp_universe pb gr napp : + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe pb) -> + RelationClasses.Transitive (cmp_universe Conv) -> + RelationClasses.Transitive (cmp_universe pb) -> + RelationClasses.Transitive (cmp_global_instance Σ cmp_universe pb gr napp). +Proof. + intros univ_sub univ_trans univ_trans'. + unfold cmp_global_instance_gen. + destruct global_variance_gen as [| |v] => //= u u' u''. + 1,2: now etransitivity. + + apply cmp_opt_variance_or_impl; tas. + all: now etransitivity. Qed. #[global] @@ -443,49 +646,19 @@ Proof. reflexivity. Qed. #[global] Hint Resolve eq_binder_annot_refl : core. -(* TODO MOVE *) -#[global] -Existing Instance All2_symP. - -(* TODO MOVE *) -#[global] -Instance Forall2_symP : - forall A (P : A -> A -> Prop), - RelationClasses.Symmetric P -> - Symmetric (Forall2 P). -Proof. - intros A P h l l' hl. - induction hl. all: auto. -Qed. Lemma eq_binder_relevances_refl (x : list aname) : All2 (on_rel eq binder_relevance) x x. Proof. now eapply All_All2_refl, All_refl. Qed. #[global] Hint Resolve eq_binder_relevances_refl : core. -#[global] -Instance R_universe_instance_refl Re : RelationClasses.Reflexive Re -> - RelationClasses.Reflexive (R_universe_instance Re). -Proof. intros tRe x. eapply Forall2_map. - induction x; constructor; auto. -Qed. - -#[global] -Instance R_universe_instance_sym Re : RelationClasses.Symmetric Re -> - RelationClasses.Symmetric (R_universe_instance Re). -Proof. intros tRe x y. now eapply Forall2_symP. Qed. - -#[global] -Instance R_universe_instance_trans Re : RelationClasses.Transitive Re -> - RelationClasses.Transitive (R_universe_instance Re). -Proof. intros tRe x y z. now eapply Forall2_trans. Qed. - -Lemma onctx_eq_ctx P ctx eq_term : +Lemma onctx_eq_ctx P ctx cmp_term pb : onctx P ctx -> - (forall x, P x -> eq_term x x) -> - All2_fold (fun _ _ => compare_decls eq_term eq_term) ctx ctx. + (forall x, P x -> cmp_term Conv x x) -> + (forall x, P x -> cmp_term pb x x) -> + eq_context_gen cmp_term pb ctx ctx. Proof. - intros onc HP. + intros onc HP HP'. induction onc. - constructor; auto. - constructor; auto; simpl. @@ -509,26 +682,46 @@ Proof. Qed. #[global] -Polymorphic Instance eq_term_upto_univ_refl Σ Re Rle napp : - RelationClasses.Reflexive Re -> - RelationClasses.Reflexive Rle -> - Reflexive (eq_term_upto_univ_napp Σ Re Rle napp). +Polymorphic Instance eq_branches_refl Re : + CRelationClasses.Reflexive Re -> + CRelationClasses.Reflexive (eq_branches Re). Proof. - intros hRe hRle t. - induction t in napp, Rle, hRle |- * using term_forall_list_ind. + intros hre. + intros brs. unfold eq_branches, eq_branch. + apply All2_same. intuition auto; try reflexivity. +Qed. + +#[global] +Polymorphic Instance eq_mfixpoint_refl Re : + CRelationClasses.Reflexive Re -> + CRelationClasses.Reflexive (eq_mfixpoint Re). +Proof. + intros hre. + intros mfix. + apply All2_same. intuition auto; try reflexivity. +Qed. + + +#[global] +Polymorphic Instance eq_term_upto_univ_refl Σ cmp_universe cmp_sort pb napp : + RelationClasses.Reflexive (cmp_universe Conv) -> + RelationClasses.Reflexive (cmp_universe pb) -> + RelationClasses.Reflexive (cmp_sort Conv) -> + RelationClasses.Reflexive (cmp_sort pb) -> + Reflexive (eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp). +Proof. + intros refl_univ refl_univ' refl_sort refl_sort' t. + induction t in napp, pb, refl_univ', refl_sort' |- * using term_forall_list_ind. all: simpl. all: try constructor. all: eauto. + all: try reflexivity. all: try solve [eapply All_All2 ; eauto]. - all: try solve [eapply Forall2_same ; eauto]. - all: try solve [unfold eq_predicate; solve_all; eapply All_All2; eauto]. - - apply R_global_instance_refl; auto. - - apply R_global_instance_refl; auto. - - destruct X as [? [? ?]]. - unfold eq_predicate; solve_all. - eapply All_All2; eauto. reflexivity. - eapply onctx_eq_ctx in a0; eauto. - - eapply All_All2; eauto; simpl; intuition eauto. - eapply onctx_eq_ctx in a; eauto. + - unfold eq_predicate. solve_all. + 2,3: reflexivity. + eapply All_All2; eauto. + - unfold eq_branches, eq_branch. + eapply All_All2; eauto. + intros br [_ ?]; split; eauto. reflexivity. - eapply All_All2; eauto; simpl; intuition eauto. - eapply All_All2; eauto; simpl; intuition eauto. - destruct p as [? []]; constructor; cbn in X; intuition eauto. @@ -536,81 +729,59 @@ Proof. Qed. #[global] -Instance compare_term_refl {cf} pb {Σ : global_env} φ : Reflexive (compare_term pb Σ φ). +Polymorphic Instance All2_eq_refl Σ cmp_universe cmp_sort : + RelationClasses.Reflexive (cmp_universe Conv) -> + RelationClasses.Reflexive (cmp_sort Conv) -> + CRelationClasses.Reflexive (All2 (eq_term_upto_univ Σ cmp_universe cmp_sort Conv)). +Proof using Type. + intros h h' x. apply All2_same. reflexivity. +Qed. + +#[global] +Instance compare_term_refl {cf} pb {Σ : global_env} φ : Reflexive (compare_term Σ φ pb). Proof. eapply eq_term_upto_univ_refl; tc. Qed. Derive Signature for eq_term_upto_univ_napp. -Lemma R_global_instance_sym Σ Re Rle gr napp u u' : - RelationClasses.Symmetric Re -> - RelationClasses.Symmetric Rle -> - R_global_instance Σ Re Rle gr napp u' u -> - R_global_instance Σ Re Rle gr napp u u'. -Proof. - intros rRE rRle. - unfold R_global_instance_gen. - destruct global_variance_gen as [v|] eqn:lookup. - - induction u in u', v |- *; destruct u'; simpl; auto; - destruct v as [|v vs]; unfold R_opt_variance in IHu; simpl; auto. - intros [Ra Ru']. split. - destruct v; simpl; auto. - apply IHu; auto. - - apply Forall2_symP; eauto. -Qed. - -Lemma onctx_eq_ctx_sym P ctx ctx' eq_term : +Lemma onctx_eq_ctx_sym P ctx ctx' cmp_term pb : onctx P ctx -> - (forall x, P x -> forall y, eq_term x y -> eq_term y x) -> - All2_fold (fun _ _ => compare_decls eq_term eq_term) ctx ctx' -> - All2_fold (fun _ _ => compare_decls eq_term eq_term) ctx' ctx. + (forall x, P x -> forall y, cmp_term Conv x y -> cmp_term Conv y x) -> + (forall x, P x -> forall y, cmp_term pb x y -> cmp_term pb y x) -> + eq_context_gen cmp_term pb ctx ctx' -> + eq_context_gen cmp_term pb ctx' ctx. Proof. - intros onc HP H1. + intros onc HP HP' H1. induction H1; depelim onc; constructor; intuition auto; simpl in *. - depelim p; depelim o; constructor; auto; try now symmetry. + destruct p; depelim o; constructor; eauto; now symmetry. Qed. #[global] -Polymorphic Instance eq_term_upto_univ_sym Σ Re Rle napp : - RelationClasses.Symmetric Re -> - RelationClasses.Symmetric Rle -> - Symmetric (eq_term_upto_univ_napp Σ Re Rle napp). -Proof. - intros he hle u v e. +Polymorphic Instance eq_term_upto_univ_sym Σ cmp_universe cmp_sort pb napp : + RelationClasses.Symmetric (cmp_universe Conv) -> + RelationClasses.Symmetric (cmp_universe pb) -> + RelationClasses.Symmetric (cmp_sort Conv) -> + RelationClasses.Symmetric (cmp_sort pb) -> + Symmetric (eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp). +Proof. + intros sym_univ sym_univ' sym_sort sym_sort' u v e. pose proof (@RelationClasses.symmetry _ (@eq_binder_annot name name) _). - induction u in Rle, hle, v, napp, e |- * using term_forall_list_ind. + induction u in napp, pb, sym_univ', sym_sort', v, e |- * using term_forall_list_ind. all: dependent destruction e. all: try solve [ - econstructor ; eauto using R_global_instance_sym ; - try eapply Forall2_symP ; eauto + econstructor ; eauto ; + try eapply Forall2_symP ; eauto ; easy ]. - econstructor. - eapply All2_All_mix_left in X as h; eauto. - clear a X. - induction h. - + constructor. - + destruct r as [h1 h2]. eapply h1 in h2 ; auto. + apply All2_sym. solve_all. - solve_all. destruct e as (r & ? & eq & ?). - econstructor; rewrite ?e; unfold eq_predicate in *; solve_all; eauto. - eapply All2_sym; solve_all. - unfold R_universe_instance in r |- *. - eapply Forall2_symP; eauto. - eapply onctx_eq_ctx_sym in a1; eauto. - eapply All2_sym; solve_all. - eapply onctx_eq_ctx_sym in a0; eauto. - - econstructor. - eapply All2_All_mix_left in X as h; eauto. - clear a X. - induction h. - + constructor. - + destruct r as [[h1 h2] [[[h3 h4] h5] h6]]. - eapply h1 in h3; auto. constructor; auto. - - econstructor. - eapply All2_All_mix_left in X as h; eauto. - clear a X. - induction h. - + constructor. - + destruct r as [[h1 h2] [[[h3 h4] h5] h6]]. eapply h1 in h3 ; auto. - constructor; auto. + econstructor; rewrite ?e; unfold eq_predicate, eq_branches, eq_branch in *; repeat split; eauto. + 2,3: now symmetry. + all: eapply All2_sym; solve_all. + apply All2_symP; solve_all. tc. + - econstructor. unfold eq_mfixpoint in *. + apply All2_sym. solve_all. + - econstructor. unfold eq_mfixpoint in *. + apply All2_sym. solve_all. - econstructor. depelim o; cbn in X; constructor; intuition eauto. eapply All2_All_mix_left in a0 as h; eauto. cbn in h. @@ -628,38 +799,20 @@ Proof. Qed. #[global] -Instance compare_term_sym {cf} Σ φ : Symmetric (compare_term Conv Σ φ). +Instance compare_term_sym {cf} Σ φ : Symmetric (compare_term Σ φ Conv). Proof. now intros t u; unfold compare_term; cbn; symmetry. Qed. -#[global] -Instance R_global_instance_trans Σ Re Rle gr napp : - RelationClasses.Transitive Re -> - RelationClasses.Transitive Rle -> - RelationClasses.Transitive (R_global_instance Σ Re Rle gr napp). -Proof. - intros he hle x y z. - unfold R_global_instance_gen, R_opt_variance. - destruct global_variance_gen as [v|]. - clear -he hle. - induction x in y, z, v |- *; destruct y, z, v; simpl; auto => //. eauto. - intros [Ra Rxy] [Rt Ryz]. - split; eauto. - destruct t1; simpl in *; auto. - now etransitivity; eauto. - now etransitivity; eauto. - eapply Forall2_trans; auto. -Qed. - -Lemma onctx_eq_ctx_trans P ctx ctx' ctx'' eq_term : +Lemma onctx_eq_ctx_trans P ctx ctx' ctx'' cmp_term pb : onctx P ctx -> - (forall x, P x -> forall y z, eq_term x y -> eq_term y z -> eq_term x z) -> - All2_fold (fun _ _ => compare_decls eq_term eq_term) ctx ctx' -> - All2_fold (fun _ _ => compare_decls eq_term eq_term) ctx' ctx'' -> - All2_fold (fun _ _ => compare_decls eq_term eq_term) ctx ctx''. + (forall x, P x -> forall y z, cmp_term Conv x y -> cmp_term Conv y z -> cmp_term Conv x z) -> + (forall x, P x -> forall y z, cmp_term pb x y -> cmp_term pb y z -> cmp_term pb x z) -> + eq_context_gen cmp_term pb ctx ctx' -> + eq_context_gen cmp_term pb ctx' ctx'' -> + eq_context_gen cmp_term pb ctx ctx''. Proof. - intros onc HP H1; revert ctx''. + intros onc HP HP' H1; revert ctx''. induction H1; depelim onc; intros ctx'' H; depelim H; constructor; intuition auto; simpl in *. depelim o. depelim p0. - depelim c; constructor; [now etransitivity|eauto]. @@ -679,104 +832,76 @@ Proof. Qed. #[global] -Polymorphic Instance eq_term_upto_univ_trans Σ Re Rle napp : - RelationClasses.Transitive Re -> - RelationClasses.Transitive Rle -> - Transitive (eq_term_upto_univ_napp Σ Re Rle napp). -Proof. - intros he hle u v w e1 e2. +Polymorphic Instance eq_term_upto_univ_trans Σ cmp_universe cmp_sort pb napp : + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe pb) -> + RelationClasses.Transitive (cmp_universe Conv) -> + RelationClasses.Transitive (cmp_universe pb) -> + RelationClasses.Transitive (cmp_sort Conv) -> + RelationClasses.Transitive (cmp_sort pb) -> + Transitive (eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp). +Proof. + intros sub_univ trans_univ trans_univ' trans_sort trans_sort' u v w e1 e2. pose proof (@RelationClasses.transitivity _ (@eq_binder_annot name name) _). - induction u in Rle, hle, v, w, napp, e1, e2 |- * using term_forall_list_ind. + assert (RelationClasses.subrelation (cmp_universe Conv) (cmp_universe Conv)) by reflexivity. + induction u in napp, pb, sub_univ, trans_univ', trans_sort', v, w, e1, e2 |- * using term_forall_list_ind. all: dependent destruction e1. all: try solve [ eauto ]. all: try solve [ - dependent destruction e2 ; econstructor ; eauto; - try eapply Forall2_trans ; eauto + dependent destruction e2 ; econstructor ; eauto ; + try now etransitivity ]. - dependent destruction e2. econstructor. eapply All2_All_mix_left in X as h; eauto. - clear a X. - induction h in a0, args'0 |- *. - + assumption. - + dependent destruction a0. constructor ; eauto. - destruct r as [h1 h2]. eauto. - - dependent destruction e2. - constructor. - eapply R_global_instance_trans; eauto. + eapply All2_trans'; tea. + intros u v w [[IH]]. now eapply IH. - dependent destruction e2. - constructor. - eapply R_global_instance_trans; eauto. - - dependent destruction e2. - unfold eq_predicate in *. + unfold eq_predicate, eq_branches, eq_branch in *. !!solve_all. - econstructor; unfold eq_predicate in *; solve_all; eauto. - * clear -he hh1 hh2. - revert hh1 hh2. generalize (pparams p), p'.(pparams), p'0.(pparams). - intros l l' l''. - induction 1 in l'' |- *; auto. intros H; depelim H. constructor; auto. - eapply r; eauto. apply r. - * etransitivity; eauto. - * eapply onctx_eq_ctx_trans in hh; eauto. - intros ???? -> ->; eauto. - * clear -H he a a0. - induction a in a0, brs'0 |- *. - + assumption. - + depelim a0. destruct p. constructor; auto. - destruct r as [[h1 h1'] [h2 h3]]. - split. - eapply onctx_eq_ctx_trans in h1; eauto. - intros ???? -> ->;reflexivity. - eapply h1'; eauto. + econstructor; unfold eq_predicate, eq_branches, eq_branch in *; solve_all; eauto. + 2: now etransitivity. + all: eapply All2_trans'; tea; intros ??? [[IH]]; repeat split; eauto. + * etransitivity; eassumption. + * destruct p0, p1; etransitivity; eassumption. + * destruct IH, p0, p1; eauto. - dependent destruction e2. - econstructor. + econstructor. unfold eq_mfixpoint in *. eapply All2_All_mix_left in X as h; eauto. - clear a X. - induction h in a0, mfix'0 |- *. - + assumption. - + dependent destruction a0. constructor ; eauto. - intuition eauto. - transitivity (rarg y); auto. + eapply All2_trans'; tea. + intros u v w [[[IHt IHb] (?&?&?&?)] (?&?&?&?)]. repeat split; eauto. now etransitivity. - dependent destruction e2. - econstructor. + econstructor. unfold eq_mfixpoint in *. eapply All2_All_mix_left in X as h; eauto. - clear a X. - induction h in a0, mfix'0 |- *. - + assumption. - + dependent destruction a0. constructor ; eauto. - intuition eauto. - transitivity (rarg y); auto. + eapply All2_trans'; tea. + intros u v w [[[IHt IHb] (?&?&?&?)] (?&?&?&?)]. repeat split; eauto. now etransitivity. - dependent destruction e2; constructor. - depelim o; intuition eauto. depelim o0; constructor; cbn in X; intuition eauto. - eapply All2_All_mix_left in b0 as h; eauto. - clear b0 a0. clear -he hle a2 h. revert h a2. - generalize (array_value a) (array_value a') (array_value a'0). clear -he hle. - intros l l0 l1. - induction 1 in l1 |- *; intros. - + assumption. - + dependent destruction a2. constructor ; eauto. - destruct r as [h1 h2]. eauto. + depelim o; tas. depelim o0. constructor; destruct X as (hty & hdef & harr); eauto. + eapply All2_All_mix_left in harr as h; eauto. + eapply All2_trans'; tea. + intros ??? [[IH]]; repeat split; eauto. Qed. #[global] -Instance compare_term_trans {cf} pb Σ φ : Transitive (compare_term pb Σ φ). +Instance compare_term_trans {cf} pb Σ φ : Transitive (compare_term Σ φ pb). Proof. apply eq_term_upto_univ_trans; tc. Qed. #[global] -Polymorphic Instance eq_term_upto_univ_equiv Σ Re (hRe : RelationClasses.Equivalence Re) - : Equivalence (eq_term_upto_univ Σ Re Re). +Polymorphic Instance eq_term_upto_univ_equiv Σ cmp_universe cmp_sort : + RelationClasses.Equivalence (cmp_universe Conv) -> + RelationClasses.Equivalence (cmp_sort Conv) -> + Equivalence (eq_term_upto_univ Σ cmp_universe cmp_sort Conv). Proof. constructor. all: exact _. Defined. #[global] -Polymorphic Instance eq_context_equiv {cf} Σ φ : Equivalence (eq_context_gen (eq_term Σ φ) (eq_term Σ φ)). +Polymorphic Instance eq_context_equiv {cf} Σ φ : Equivalence (eq_context_gen (compare_term Σ φ) Conv). Proof. constructor; try exact _. Qed. #[global] -Polymorphic Instance leq_context_preord {cf} Σ φ : PreOrder (eq_context_gen (eq_term Σ φ) (leq_term Σ φ)). +Polymorphic Instance leq_context_preord {cf} Σ φ : PreOrder (eq_context_gen (compare_term Σ φ) Cumul). Proof. constructor; try exact _. Qed. @@ -790,18 +915,18 @@ Polymorphic Instance leq_term_preorder {cf:checker_flags} Σ φ : PreOrder (leq_ Proof. split; tc. Qed. #[global] -Instance R_universe_instance_equiv R (hR : RelationClasses.Equivalence R) - : RelationClasses.Equivalence (R_universe_instance R). +Instance cmp_universe_instance_equiv R (hR : RelationClasses.Equivalence R) + : RelationClasses.Equivalence (cmp_universe_instance R). Proof. split. - intro. apply Forall2_same. reflexivity. - intros x y xy. eapply Forall2_sym, Forall2_impl; tea. now symmetry. - - intros x y z xy yz. eapply Forall2_trans; tea. apply hR. + - intros x y z xy yz. eapply Forall2_trans; tea. apply on_rel_trans. apply hR. Qed. -Lemma R_universe_instance_antisym Re Rle (hRe : RelationClasses.Equivalence Re) : - RelationClasses.Antisymmetric _ Re Rle -> - RelationClasses.Antisymmetric _ (R_universe_instance Re) (R_universe_instance Rle). +Lemma cmp_universe_instance_antisym cmp_universe pb (hE : RelationClasses.Equivalence (cmp_universe Conv)) : + RelationClasses.Antisymmetric _ (cmp_universe Conv) (cmp_universe pb) -> + RelationClasses.Antisymmetric _ (cmp_universe_instance (cmp_universe Conv)) (cmp_universe_instance (cmp_universe pb)). Proof. intros H x y H1 H2. eapply Forall2_sym in H2. @@ -810,33 +935,59 @@ Proof. Qed. #[global] -Instance R_global_instance_equiv Σ R (hR : RelationClasses.Equivalence R) gr napp - : RelationClasses.Equivalence (R_global_instance Σ R R gr napp). +Instance cmp_global_instance_equiv Σ cmp_universe (hE : RelationClasses.Equivalence (cmp_universe Conv)) gr napp + : RelationClasses.Equivalence (cmp_global_instance Σ cmp_universe Conv gr napp). Proof. split. - - intro. apply R_global_instance_refl; typeclasses eauto. - - intros x y xy. eapply R_global_instance_sym; auto; typeclasses eauto. - - intros x y z xy yz. eapply R_global_instance_trans; eauto; typeclasses eauto. + - intro. apply cmp_global_instance_refl; typeclasses eauto. + - intros x y xy. eapply cmp_global_instance_sym; auto; typeclasses eauto. + - intros x y z xy yz. eapply cmp_global_instance_trans; eauto; typeclasses eauto. +Qed. + +Lemma cmp_universe_variance_antisym cmp_universe pb (hRe : RelationClasses.Equivalence (cmp_universe Conv)) v u u' : + RelationClasses.Antisymmetric _ (cmp_universe Conv) (cmp_universe pb) -> + cmp_universe_variance cmp_universe pb v u u' -> + cmp_universe_variance cmp_universe pb v u' u -> + cmp_universe_variance cmp_universe Conv v u u'. +Proof. + intro hAntisym. + destruct v => //=. + apply hAntisym. +Qed. + +Lemma cmp_universe_instance_variance_antisym cmp_universe pb (hRe : RelationClasses.Equivalence (cmp_universe Conv)) l u v : + RelationClasses.Antisymmetric _ (cmp_universe Conv) (cmp_universe pb) -> + cmp_universe_instance_variance cmp_universe pb l u v -> + cmp_universe_instance_variance cmp_universe pb l v u -> + cmp_universe_instance_variance cmp_universe Conv l u v. +Proof. + intro hAntisym. + apply Forall3_antisymP. intros ???. + now eapply cmp_universe_variance_antisym. Qed. #[global] -Instance R_global_instance_antisym Σ Re Rle (hRe : RelationClasses.Equivalence Re) gr napp : - RelationClasses.Antisymmetric _ Re Rle -> - RelationClasses.Antisymmetric _ (R_global_instance Σ Re Re gr napp) (R_global_instance Σ Re Rle gr napp). +Instance cmp_global_instance_antisym Σ cmp_universe pb (hRe : RelationClasses.Equivalence (cmp_universe Conv)) gr napp : + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe pb) -> + RelationClasses.Antisymmetric _ (cmp_universe Conv) (cmp_universe pb) -> + RelationClasses.Antisymmetric _ (cmp_global_instance Σ cmp_universe Conv gr napp) (cmp_global_instance Σ cmp_universe pb gr napp). Proof. - intros hR u v. - unfold R_global_instance_gen, R_opt_variance. + intros hsub hR u v. + unfold cmp_global_instance_gen, cmp_opt_variance. destruct global_variance_gen; auto. - induction u in l, v |- *; destruct v, l; simpl; auto. - intros [at' uv] [ta vu]. split; auto. - destruct t0; simpl in *; auto. + apply cmp_opt_variance_or_impl; auto. + eapply cmp_universe_instance_variance_antisym; tea. Qed. -Lemma eq_term_upto_univ_antisym Σ Re Rle (hRe : RelationClasses.Equivalence Re) : - RelationClasses.Antisymmetric _ Re Rle -> - Antisymmetric (eq_term_upto_univ Σ Re Re) (eq_term_upto_univ Σ Re Rle). +Lemma eq_term_upto_univ_antisym Σ cmp_universe cmp_sort pb + (univ_equi : RelationClasses.Equivalence (cmp_universe Conv)) + (sort_equi : RelationClasses.Equivalence (cmp_sort Conv)) : + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe pb) -> + RelationClasses.Antisymmetric _ (cmp_universe Conv) (cmp_universe pb) -> + RelationClasses.Antisymmetric _ (cmp_sort Conv) (cmp_sort pb) -> + Antisymmetric (eq_term_upto_univ Σ cmp_universe cmp_sort Conv) (eq_term_upto_univ Σ cmp_universe cmp_sort pb). Proof. - intros hR u v. generalize 0; intros n h h'. + intros univ_sub univ_anisym sort_antisym u v. generalize 0; intros n h h'. induction u in v, n, h, h' |- * using term_forall_list_ind. all: simpl ; inversion h ; subst; inversion h' ; subst ; try constructor ; auto. @@ -850,61 +1001,63 @@ Proof. eapply eq_term_upto_univ_antisym; exact _. Qed. -Lemma global_variance_napp_mon {Σ gr napp napp' v} : +Lemma global_variance_napp_mon Σ gr {napp napp'} : napp <= napp' -> - global_variance Σ gr napp = Some v -> - global_variance Σ gr napp' = Some v. + match global_variance Σ gr napp with + | Variance v => global_variance Σ gr napp' = Variance v + | AllEqual => True + | AllIrrelevant => global_variance Σ gr napp' = AllIrrelevant + end. Proof. intros hnapp. rewrite /global_variance_gen. - destruct gr; try congruence. - - destruct lookup_inductive_gen as [[mdecl idec]|] => //. - destruct destArity as [[ctx s]|] => //. - elim: Nat.leb_spec => // cass indv. + destruct gr => //=. + - destruct lookup_inductive_gen as [[mdecl idec]|] => //=. + destruct destArity as [[ctx s]|] => //=. + elim: Nat.leb_spec => // cass. + destruct ind_variance => //=. elim: Nat.leb_spec => //. lia. - - destruct lookup_constructor_gen as [[[mdecl idecl] cdecl]|] => //. - elim: Nat.leb_spec => // cass indv. + - destruct lookup_constructor_gen as [[[mdecl idecl] cdecl]|] => //=. + elim: Nat.leb_spec => // cass. elim: Nat.leb_spec => //. lia. Qed. #[global] -Instance R_global_instance_impl_same_napp Σ Re Re' Rle Rle' gr napp : - RelationClasses.subrelation Re Re' -> - RelationClasses.subrelation Rle Rle' -> - subrelation (R_global_instance Σ Re Rle gr napp) (R_global_instance Σ Re' Rle' gr napp). +Instance cmp_global_instance_impl_same_napp Σ cmp_universe cmp_universe' pb pb' gr napp : + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe' Conv) -> + RelationClasses.subrelation (cmp_universe pb) (cmp_universe' pb') -> + subrelation (cmp_global_instance Σ cmp_universe pb gr napp) (cmp_global_instance Σ cmp_universe' pb' gr napp). Proof. - intros he hle t t'. - unfold R_global_instance_gen, R_opt_variance. - destruct global_variance_gen as [v|] eqn:glob. - induction t in v, t' |- *; destruct v, t'; simpl; auto. - intros []; split; auto. - destruct t0; simpl; auto. - now eapply R_universe_instance_impl'. + intros sub_conv sub_pb u u'. + unfold cmp_global_instance_gen, cmp_opt_variance. + destruct global_variance_gen as [| |v] => //. + 1: now apply cmp_universe_instance_impl. + + intros [H | H]; [left | right]. + 1: eapply cmp_universe_instance_impl; tea. + eapply cmp_universe_instance_variance_impl; eassumption. Qed. #[global] -Instance R_global_instance_impl Σ Re Re' Rle Rle' gr napp napp' : - RelationClasses.subrelation Re Re' -> - RelationClasses.subrelation Re Rle' -> - RelationClasses.subrelation Rle Rle' -> +Instance cmp_global_instance_impl Σ cmp_universe cmp_universe' pb pb' gr napp napp' : + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe' Conv) -> + RelationClasses.subrelation (cmp_universe pb) (cmp_universe' pb') -> napp <= napp' -> - subrelation (R_global_instance Σ Re Rle gr napp) (R_global_instance Σ Re' Rle' gr napp'). + subrelation (cmp_global_instance Σ cmp_universe pb gr napp) (cmp_global_instance Σ cmp_universe' pb' gr napp'). Proof. - intros he hle hele hnapp t t'. - unfold R_global_instance_gen, R_opt_variance. - destruct global_variance_gen as [v|] eqn:glob. - rewrite (global_variance_napp_mon hnapp glob). - induction t in v, t' |- *; destruct v, t'; simpl; auto. - intros []; split; auto. - destruct t0; simpl; auto. - destruct (global_variance _ _ napp') as [v|] eqn:glob'; eauto using R_universe_instance_impl'. - induction t in v, t' |- *; destruct v, t'; simpl; auto; intros H; inv H. - eauto. - split; auto. - destruct t0; simpl; auto. + intros sub_conv sub_pb lenapp u u'. + unfold cmp_global_instance_gen. + move: (global_variance_napp_mon Σ gr lenapp). + destruct global_variance_gen as [| |v] => //. + all: [> intros _ | intros ->; cbn ..]; auto. + 1: intro H; apply: cmp_instance_opt_variance; move: H => /=. + - now apply cmp_universe_instance_impl. + - intros [H | H]; [left | right]. + 1: eapply cmp_universe_instance_impl; tea. + eapply cmp_universe_instance_variance_impl; eassumption. Qed. -Lemma global_variance_empty gr napp env : env.(declarations) = [] -> global_variance env gr napp = None. +Lemma global_variance_empty gr napp env : env.(declarations) = [] -> global_variance env gr napp = AllEqual. Proof. destruct env; cbn => ->. destruct gr; auto. Qed. @@ -912,106 +1065,104 @@ Qed. (** Pure syntactic equality, without cumulative inductive types subtyping *) #[global] -Instance R_global_instance_empty_impl Σ Re Re' Rle Rle' gr napp napp' : - RelationClasses.subrelation Re Re' -> - RelationClasses.subrelation Rle Rle' -> - RelationClasses.subrelation Re Rle' -> - subrelation (R_global_instance empty_global_env Re Rle gr napp) (R_global_instance Σ Re' Rle' gr napp'). +Instance cmp_global_instance_empty_impl Σ cmp_universe cmp_universe' pb pb' gr napp napp' : + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe' Conv) -> + subrelation (cmp_global_instance empty_global_env cmp_universe pb gr napp) (cmp_global_instance Σ cmp_universe' pb' gr napp'). Proof. - intros he hle hele t t'. - unfold R_global_instance_gen, R_opt_variance. + intros he t t'. + unfold cmp_global_instance_gen. rewrite global_variance_empty //. - destruct global_variance_gen as [v|]; eauto using R_universe_instance_impl'. - induction t in v, t' |- *; destruct v, t'; simpl; intros H; inv H; auto. - simpl. - split; auto. - destruct t0; simpl; auto. + intro H; apply: cmp_instance_opt_variance; move: H => /=. + now apply cmp_universe_instance_impl. Qed. -Lemma onctx_eq_ctx_impl P ctx ctx' eq_term eq_term' : +Lemma onctx_eq_ctx_impl P ctx ctx' cmp_term cmp_term' pb pb' : onctx P ctx -> - (forall x, P x -> forall y, eq_term x y -> eq_term' x y) -> - eq_context_gen eq_term eq_term ctx ctx' -> - eq_context_gen eq_term' eq_term' ctx ctx'. + (forall x, P x -> forall y, cmp_term Conv x y -> cmp_term' Conv x y) -> + (forall x, P x -> forall y, cmp_term pb x y -> cmp_term' pb' x y) -> + eq_context_gen cmp_term pb ctx ctx' -> + eq_context_gen cmp_term' pb' ctx ctx'. Proof. - intros onc HP H1. + intros onc HP HP' H1. induction H1; depelim onc; constructor; eauto; intuition auto; simpl in *. destruct o; depelim p; constructor; auto. Qed. #[global] -Instance eq_term_upto_univ_impl Σ Re Re' Rle Rle' napp napp' : - RelationClasses.subrelation Re Re' -> - RelationClasses.subrelation Rle Rle' -> - RelationClasses.subrelation Re Rle' -> +Instance eq_term_upto_univ_impl Σ cmp_universe cmp_universe' cmp_sort cmp_sort' pb pb' napp napp' : + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe' Conv) -> + RelationClasses.subrelation (cmp_universe pb) (cmp_universe' pb') -> + RelationClasses.subrelation (cmp_sort Conv) (cmp_sort' Conv) -> + RelationClasses.subrelation (cmp_sort pb) (cmp_sort' pb') -> napp <= napp' -> - subrelation (eq_term_upto_univ_napp Σ Re Rle napp) (eq_term_upto_univ_napp Σ Re' Rle' napp'). + subrelation (eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp) (eq_term_upto_univ_napp Σ cmp_universe' cmp_sort' pb' napp'). Proof. - intros he hle hele hnapp t t'. - induction t in napp, napp', hnapp, t', Rle, Rle', hle, hele |- * using term_forall_list_ind; + intros univ_sub_conv univ_sub_pb sort_sub_conv sort_sub_pb hnapp t t'. + induction t in napp, napp', hnapp, pb, pb', univ_sub_pb, sort_sub_pb, t' |- * using term_forall_list_ind; try (inversion 1; subst; constructor; - eauto using R_universe_instance_impl'; fail). + eauto using cmp_universe_instance_impl'; fail). - inversion 1; subst; constructor. eapply All2_impl'; tea. eapply All_impl; eauto. - inversion 1; subst; constructor. eapply IHt1. 4:eauto. all:auto with arith. eauto. - inversion 1; subst; constructor. - eapply R_global_instance_impl. 5:eauto. all:auto. + eapply cmp_global_instance_impl. 4:eauto. all:auto. - inversion 1; subst; constructor. - eapply R_global_instance_impl. 5:eauto. all:eauto. - - inversion 1; subst; constructor; unfold eq_predicate in *; eauto; solve_all. - * eapply R_universe_instance_impl'; eauto. + eapply cmp_global_instance_impl. 4:eauto. all:eauto. + - inversion 1; subst; constructor; unfold eq_predicate, eq_branches, eq_branch in *; eauto; solve_all. + * eapply cmp_universe_instance_impl'; eauto. - inversion 1; subst; constructor. eapply All2_impl'; tea. eapply All_impl; eauto. - cbn. intros x [? ?] y [[[? ?] ?] ?]. repeat split; eauto. + cbn. intros x [? ?] y (?&?&?&?). repeat split; eauto. - inversion 1; subst; constructor. eapply All2_impl'; tea. eapply All_impl; eauto. - cbn. intros x [? ?] y [[[? ?] ?] ?]. repeat split; eauto. + cbn. intros x [? ?] y (?&?&?&?). repeat split; eauto. - intros h; depelim h. depelim o; constructor; cbn in X; constructor; intuition eauto. solve_all. Qed. #[global] -Instance eq_term_upto_univ_empty_impl Σ Re Re' Rle Rle' napp napp' : - RelationClasses.subrelation Re Re' -> - RelationClasses.subrelation Rle Rle' -> - RelationClasses.subrelation Re Rle' -> - subrelation (eq_term_upto_univ_napp empty_global_env Re Rle napp) (eq_term_upto_univ_napp Σ Re' Rle' napp'). -Proof. - intros he hle hele t t'. - induction t in napp, napp', t', Rle, Rle', hle, hele |- * using term_forall_list_ind; +Instance eq_term_upto_univ_empty_impl Σ cmp_universe cmp_universe' cmp_sort cmp_sort' pb pb' napp napp' : + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe' Conv) -> + RelationClasses.subrelation (cmp_universe pb) (cmp_universe' pb') -> + RelationClasses.subrelation (cmp_sort Conv) (cmp_sort' Conv) -> + RelationClasses.subrelation (cmp_sort pb) (cmp_sort' pb') -> + subrelation (eq_term_upto_univ_napp empty_global_env cmp_universe cmp_sort pb napp) (eq_term_upto_univ_napp Σ cmp_universe' cmp_sort' pb' napp'). +Proof. + intros univ_sub_conv univ_sub_pb sort_sub_conv sort_sub_pb t t'. + induction t in napp, napp', pb, pb', univ_sub_pb, sort_sub_pb, t' |- * using term_forall_list_ind; try (inversion 1; subst; constructor; - eauto using R_universe_instance_impl'; fail). + eauto using cmp_universe_instance_impl'; fail). - inversion 1; subst; constructor. eapply All2_impl'; tea. eapply All_impl; eauto. - inversion 1; subst; constructor. - (* eapply shelf bug... fixed in unifall *) - eapply R_global_instance_empty_impl. 4:eauto. all:eauto. + eapply cmp_global_instance_empty_impl. 2:eauto. all:auto. - inversion 1; subst; constructor. - eapply R_global_instance_empty_impl. 4:eauto. all:eauto. - - inversion 1; subst; constructor; unfold eq_predicate in *; solve_all. - * eapply R_universe_instance_impl'; eauto. + eapply cmp_global_instance_empty_impl. 2:eauto. all:eauto. + - inversion 1; subst; constructor; unfold eq_predicate, eq_branches, eq_branch in *; eauto; solve_all. + * eapply cmp_universe_instance_impl'; eauto. - inversion 1; subst; constructor. eapply All2_impl'; tea. eapply All_impl; eauto. - cbn. intros x [? ?] y [[[? ?] ?] ?]. repeat split; eauto. + cbn. intros x [? ?] y (?&?&?&?). repeat split; eauto. - inversion 1; subst; constructor. eapply All2_impl'; tea. eapply All_impl; eauto. - cbn. intros x [? ?] y [[[? ?] ?] ?]. repeat split; eauto. - - intros h; depelim h. constructor. depelim o; cbn in X; constructor; intuition eauto. + cbn. intros x [? ?] y (?&?&?&?). repeat split; eauto. + - inversion 1; subst; constructor. depelim X1; cbn in X; constructor; intuition eauto. solve_all. Qed. #[global] -Instance eq_term_upto_univ_leq Σ Re Rle napp napp' : - RelationClasses.subrelation Re Rle -> +Instance eq_term_upto_univ_leq Σ cmp_universe cmp_sort pb napp napp' : + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe pb) -> + RelationClasses.subrelation (cmp_sort Conv) (cmp_sort pb) -> napp <= napp' -> - subrelation (eq_term_upto_univ_napp Σ Re Re napp) (eq_term_upto_univ_napp Σ Re Rle napp'). + subrelation (eq_term_upto_univ_napp Σ cmp_universe cmp_sort Conv napp) (eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp'). Proof. intros H. eapply eq_term_upto_univ_impl; exact _. Qed. @@ -1033,39 +1184,56 @@ Proof. Qed. #[global] -Hint Constructors compare_decls : pcuic. +Hint Constructors PCUICConversion.All_decls_alpha_pb : pcuic. Local Ltac lih := lazymatch goal with - | ih : forall Rle v n k, eq_term_upto_univ_napp _ _ _ ?u _ -> _ - |- eq_term_upto_univ _ _ (lift _ _ ?u) _ => + | ih : forall Rle v n k, eq_term_upto_univ_napp _ _ _ _ ?u _ -> _ + |- eq_term_upto_univ _ _ _ (lift _ _ ?u) _ => eapply ih end. -Lemma eq_term_upto_univ_lift Σ Re Rle n n' k : - Proper (eq_term_upto_univ_napp Σ Re Rle n' ==> eq_term_upto_univ_napp Σ Re Rle n') (lift n k). +Lemma eq_term_upto_univ_lift Σ cmp_universe cmp_sort pb n n' k : + Proper (eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb n' ==> eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb n') (lift n k). Proof. intros u v e. - induction u in n', v, n, k, e, Rle |- * using term_forall_list_ind. + induction u in n', v, n, k, e, pb |- * using term_forall_list_ind. all: dependent destruction e. all: try solve [cbn ; constructor ; try lih ; try assumption; solve_all]. - cbn. destruct e as (? & ? & e & ?). - constructor; unfold eq_predicate in *; simpl; !!solve_all. - * rewrite -?(All2_fold_length e). - eapply hh0; eauto. - * rewrite (All2_fold_length a). now eapply hh4. + constructor; unfold eq_predicate, eq_branches, eq_branch in *; simpl; !!solve_all. + * rewrite -?(All2_length e). + eapply hh; eauto. + * rewrite (All2_length hh3). now eapply hh2. - cbn. constructor. - pose proof (All2_length a). + pose proof (All2_length e). unfold eq_mfixpoint in *. solve_all. rewrite H. eauto. - cbn. constructor. - pose proof (All2_length a). + pose proof (All2_length e). unfold eq_mfixpoint in *. solve_all. rewrite H. eauto. - cbn. constructor. depelim o; cbn in X; try constructor; cbn; intuition eauto. solve_all. Qed. -Lemma lift_compare_term `{checker_flags} pb Σ ϕ n k t t' : - compare_term pb Σ ϕ t t' -> compare_term pb Σ ϕ (lift n k t) (lift n k t'). +Lemma compare_decls_lift_decl Σ cmp_universe cmp_sort pb n k : + Proper (compare_decls (fun pb => eq_term_upto_univ Σ cmp_universe cmp_sort pb) pb ==> compare_decls (fun pb => eq_term_upto_univ Σ cmp_universe cmp_sort pb) pb) (lift_decl n k). +Proof. + intros d d' []; constructor; cbn; auto. + all: now eapply eq_term_upto_univ_lift. +Qed. + +Lemma eq_context_upto_lift_context Σ cmp_universe cmp_sort pb n k : + Proper (eq_context_upto Σ cmp_universe cmp_sort pb ==> eq_context_upto Σ cmp_universe cmp_sort pb) (lift_context n k). +Proof. + intros Γ Δ. + induction 1; rewrite -> ?lift_context_snoc0. constructor. + constructor; auto. + rewrite -(All2_fold_length X). + now eapply compare_decls_lift_decl. +Qed. + +Lemma lift_compare_term `{checker_flags} Σ ϕ pb n k t t' : + compare_term Σ ϕ pb t t' -> compare_term Σ ϕ pb (lift n k t) (lift n k t'). Proof. now apply eq_term_upto_univ_lift. Qed. @@ -1073,18 +1241,14 @@ Qed. Lemma lift_compare_decls `{checker_flags} pb Σ ϕ n k d d' : compare_decl pb Σ ϕ d d' -> compare_decl pb Σ ϕ (lift_decl n k d) (lift_decl n k d'). Proof. - intros []; constructor; cbn; intuition auto using lift_compare_term. + now apply compare_decls_lift_decl. Qed. Lemma lift_compare_context `{checker_flags} pb Σ φ l l' n k : compare_context pb Σ φ l l' -> compare_context pb Σ φ (lift_context n k l) (lift_context n k l'). Proof. - unfold compare_context. - induction 1; rewrite -> ?lift_context_snoc0. constructor. - constructor; auto. - eapply lift_compare_decls in p. - now rewrite (All2_fold_length X). + now apply eq_context_upto_lift_context. Qed. Lemma lift_eq_term {cf:checker_flags} Σ φ n k T U : @@ -1101,19 +1265,20 @@ Qed. Local Ltac sih := lazymatch goal with - | ih : forall Rle v n x y, _ -> eq_term_upto_univ _ _ ?u _ -> _ -> _ - |- eq_term_upto_univ _ _ (subst _ _ ?u) _ => eapply ih + | ih : forall Rle v n x y, _ -> eq_term_upto_univ _ _ _ ?u _ -> _ -> _ + |- eq_term_upto_univ _ _ _ (subst _ _ ?u) _ => eapply ih end. -Lemma eq_term_upto_univ_substs Σ Re Rle napp : - RelationClasses.subrelation Re Rle -> +Lemma eq_term_upto_univ_substs Σ cmp_universe cmp_sort pb napp : + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe pb) -> + RelationClasses.subrelation (cmp_sort Conv) (cmp_sort pb) -> forall u v n l l', - eq_term_upto_univ_napp Σ Re Rle napp u v -> - All2 (eq_term_upto_univ Σ Re Re) l l' -> - eq_term_upto_univ_napp Σ Re Rle napp (subst l n u) (subst l' n v). + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp u v -> + All2 (eq_term_upto_univ Σ cmp_universe cmp_sort Conv) l l' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (subst l n u) (subst l' n v). Proof. - unfold RelationClasses.subrelation; intros hR u v n l l' hu hl. - induction u in napp, v, n, l, l', hu, hl, Rle, hR |- * using term_forall_list_ind. + unfold RelationClasses.subrelation; intros hsub hsub' u v n l l' hu hl. + induction u in napp, v, n, l, l', hu, hl, pb, hsub, hsub' |- * using term_forall_list_ind. all: dependent destruction hu. all: try solve [ cbn ; constructor ; try sih ; eauto ]. - cbn. destruct (Nat.leb_spec0 n n0). @@ -1122,7 +1287,7 @@ Proof. destruct h as [t' [e' h]]. rewrite e'. eapply eq_term_upto_univ_lift. - eapply eq_term_upto_univ_leq. 3:eauto. all:auto with arith. + eapply eq_term_upto_univ_leq. 4:eauto. all:auto with arith. * intros h. eapply All2_nth_error_None in h as hh ; eauto. rewrite hh. apply All2_length in hl as e. rewrite <- e. @@ -1131,27 +1296,28 @@ Proof. - cbn. constructor. solve_all. - cbn. destruct e as (? & ? & e & ?). - constructor ; unfold eq_predicate; simpl; try sih ; solve_all. - * rewrite -(All2_fold_length e). eapply e1; eauto. - * rewrite (All2_fold_length a). now eapply b0. + constructor ; unfold eq_predicate, eq_branches, eq_branch in *; simpl; try sih ; solve_all. + * rewrite -(All2_length e). eapply e2; eauto. + * rewrite (All2_length a0). now eapply b0. - cbn. constructor ; try sih ; eauto. - pose proof (All2_length a). + pose proof (All2_length e). unfold eq_mfixpoint in *. solve_all. now rewrite H. - cbn. constructor ; try sih ; eauto. - pose proof (All2_length a). + pose proof (All2_length e). unfold eq_mfixpoint in *. solve_all. now rewrite H. - cbn; constructor. depelim o; cbn in X |- *; constructor; cbn; intuition eauto. solve_all. Qed. -Lemma eq_term_upto_univ_subst Σ Re Rle : - RelationClasses.subrelation Re Rle -> +Lemma eq_term_upto_univ_subst Σ cmp_universe cmp_sort pb : + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe pb) -> + RelationClasses.subrelation (cmp_sort Conv) (cmp_sort pb) -> forall u v n x y, - eq_term_upto_univ Σ Re Rle u v -> - eq_term_upto_univ Σ Re Re x y -> - eq_term_upto_univ Σ Re Rle (u{n := x}) (v{n := y}). + eq_term_upto_univ Σ cmp_universe cmp_sort pb u v -> + eq_term_upto_univ Σ cmp_universe cmp_sort Conv x y -> + eq_term_upto_univ Σ cmp_universe cmp_sort pb (u{n := x}) (v{n := y}). Proof. - intros hR u v n x y e1 e2. + intros hsub hsub' u v n x y e1 e2. eapply eq_term_upto_univ_substs; eauto. Qed. @@ -1161,7 +1327,6 @@ Lemma subst_eq_term {cf:checker_flags} Σ φ l k T U : Proof. intros Hleq. eapply eq_term_upto_univ_substs; try easy. - now eapply All2_same. Qed. Lemma subst_leq_term {cf:checker_flags} Σ φ l k T U : @@ -1170,34 +1335,32 @@ Lemma subst_leq_term {cf:checker_flags} Σ φ l k T U : Proof. intros Hleq. eapply eq_term_upto_univ_substs; try easy. - intro; apply eq_universe_leq_universe. - now eapply All2_same. + - intro; apply eq_leq_universe. + - intro; apply eq_leq_sort. Qed. (** ** Behavior on mkApps and it_mkLambda_or_LetIn ** *) -Lemma eq_term_eq_term_napp Σ Re Rle napp t t' : - RelationClasses.subrelation Re Rle -> - eq_term_upto_univ Σ Re Rle t t' -> - eq_term_upto_univ_napp Σ Re Rle napp t t'. +Lemma eq_term_eq_term_napp Σ cmp_universe cmp_sort pb napp t t' : + eq_term_upto_univ Σ cmp_universe cmp_sort pb t t' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp t t'. Proof. - intros. eapply eq_term_upto_univ_impl. 5:eauto. - 4:auto with arith. all:typeclasses eauto. + intros. eapply eq_term_upto_univ_impl. 6:eauto. + 5:auto with arith. all:typeclasses eauto. Qed. -Lemma leq_term_leq_term_napp Σ Re Rle napp t t' : - RelationClasses.subrelation Re Rle -> - eq_term_upto_univ Σ Re Rle t t' -> - eq_term_upto_univ_napp Σ Re Rle napp t t'. +Lemma leq_term_leq_term_napp Σ cmp_universe cmp_sort pb napp t t' : + eq_term_upto_univ Σ cmp_universe cmp_sort pb t t' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp t t'. Proof. - intros. eapply eq_term_upto_univ_impl. 5:eauto. - 4:auto with arith. all:try typeclasses eauto. + intros. eapply eq_term_upto_univ_impl. 6:eauto. + 5:auto with arith. all:try typeclasses eauto. Qed. -Lemma eq_term_upto_univ_napp_mkApps Σ Re Rle u1 l1 u2 l2 napp : - eq_term_upto_univ_napp Σ Re Rle (#|l1| + napp) u1 u2 -> - All2 (eq_term_upto_univ Σ Re Re) l1 l2 -> - eq_term_upto_univ_napp Σ Re Rle napp (mkApps u1 l1) (mkApps u2 l2). +Lemma eq_term_upto_univ_napp_mkApps Σ cmp_universe cmp_sort pb u1 l1 u2 l2 napp : + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb (#|l1| + napp) u1 u2 -> + All2 (eq_term_upto_univ Σ cmp_universe cmp_sort Conv) l1 l2 -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (mkApps u1 l1) (mkApps u2 l2). Proof. intros hu hl. induction l1 in napp, u1, u2, l2, hu, hl |- *. - inversion hl. subst. assumption. @@ -1207,14 +1370,14 @@ Proof. + assumption. Qed. -Lemma eq_term_upto_univ_napp_mkApps_l_inv Σ Re Rle napp u l t : - eq_term_upto_univ_napp Σ Re Rle napp (mkApps u l) t -> +Lemma eq_term_upto_univ_napp_mkApps_l_inv Σ cmp_universe cmp_sort pb napp u l t : + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (mkApps u l) t -> ∑ u' l', - eq_term_upto_univ_napp Σ Re Rle (#|l| + napp) u u' * - All2 (eq_term_upto_univ Σ Re Re) l l' * + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb (#|l| + napp) u u' * + All2 (eq_term_upto_univ Σ cmp_universe cmp_sort Conv) l l' * (t = mkApps u' l'). Proof. - intros h. induction l in napp, u, t, h, Rle |- *. + intros h. induction l in napp, u, t, h, pb |- *. - cbn in h. exists t, []. split ; auto. - cbn in h. apply IHl in h as [u' [l' [[h1 h2] h3]]]. dependent destruction h1. subst. @@ -1226,14 +1389,14 @@ Proof. + cbn. reflexivity. Qed. -Lemma eq_term_upto_univ_napp_mkApps_r_inv Σ Re Rle napp u l t : - eq_term_upto_univ_napp Σ Re Rle napp t (mkApps u l) -> +Lemma eq_term_upto_univ_napp_mkApps_r_inv Σ cmp_universe cmp_sort pb napp u l t : + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp t (mkApps u l) -> ∑ u' l', - eq_term_upto_univ_napp Σ Re Rle (#|l| + napp) u' u * - All2 (eq_term_upto_univ Σ Re Re) l' l * + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb (#|l| + napp) u' u * + All2 (eq_term_upto_univ Σ cmp_universe cmp_sort Conv) l' l * (t = mkApps u' l'). Proof. - intros h. induction l in napp, u, t, h, Rle |- *. + intros h. induction l in napp, u, t, h, pb |- *. - cbn in h. exists t, []. split ; auto. - cbn in h. apply IHl in h as [u' [l' [[h1 h2] h3]]]. dependent destruction h1. subst. @@ -1245,40 +1408,42 @@ Proof. + cbn. reflexivity. Qed. -Lemma eq_term_upto_univ_mkApps Σ Re Rle u1 l1 u2 l2 : - eq_term_upto_univ_napp Σ Re Rle #|l1| u1 u2 -> - All2 (eq_term_upto_univ Σ Re Re) l1 l2 -> - eq_term_upto_univ Σ Re Rle (mkApps u1 l1) (mkApps u2 l2). +Lemma eq_term_upto_univ_mkApps Σ cmp_universe cmp_sort pb u1 l1 u2 l2 : + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb #|l1| u1 u2 -> + All2 (eq_term_upto_univ Σ cmp_universe cmp_sort Conv) l1 l2 -> + eq_term_upto_univ Σ cmp_universe cmp_sort pb (mkApps u1 l1) (mkApps u2 l2). Proof. intros; apply eq_term_upto_univ_napp_mkApps; rewrite ?Nat.add_0_r; auto. Qed. -Lemma eq_term_upto_univ_mkApps_l_inv Σ Re Rle u l t : - eq_term_upto_univ Σ Re Rle (mkApps u l) t -> +Lemma eq_term_upto_univ_mkApps_l_inv Σ cmp_universe cmp_sort pb u l t : + eq_term_upto_univ Σ cmp_universe cmp_sort pb (mkApps u l) t -> ∑ u' l', - eq_term_upto_univ_napp Σ Re Rle #|l| u u' * - All2 (eq_term_upto_univ Σ Re Re) l l' * + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb #|l| u u' * + All2 (eq_term_upto_univ Σ cmp_universe cmp_sort Conv) l l' * (t = mkApps u' l'). Proof. intros H; apply eq_term_upto_univ_napp_mkApps_l_inv in H; rewrite ?Nat.add_0_r in H; auto. Qed. -Lemma eq_term_upto_univ_mkApps_r_inv Σ Re Rle u l t : - eq_term_upto_univ Σ Re Rle t (mkApps u l) -> +Lemma eq_term_upto_univ_mkApps_r_inv Σ cmp_universe cmp_sort pb u l t : + eq_term_upto_univ Σ cmp_universe cmp_sort pb t (mkApps u l) -> ∑ u' l', - eq_term_upto_univ_napp Σ Re Rle #|l| u' u * - All2 (eq_term_upto_univ Σ Re Re) l' l * + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb #|l| u' u * + All2 (eq_term_upto_univ Σ cmp_universe cmp_sort Conv) l' l * (t = mkApps u' l'). Proof. intros H; apply eq_term_upto_univ_napp_mkApps_r_inv in H; rewrite Nat.add_0_r in H; auto. Qed. -Lemma R_universe_instance_eq {u u'} : R_universe_instance eq u u' -> u = u'. +Lemma cmp_universe_instance_eq {u u'} : cmp_universe_instance eq u u' -> u = u'. Proof. intros H. + unfold cmp_universe_instance, on_rel in H. + apply Forall2_map in H. apply Forall2_eq in H. apply map_inj in H ; revgoals. - { apply Universe.make_inj. } + { intros ?? e. now inv e. } subst. constructor ; auto. Qed. @@ -1288,23 +1453,25 @@ Proof. red. destruct check_univs => //. Qed. -Lemma upto_eq_impl Σ Re Rle : - RelationClasses.Reflexive Re -> - RelationClasses.Reflexive Rle -> - subrelation (eq_term_upto_univ Σ eq eq) (eq_term_upto_univ Σ Re Rle). +Lemma upto_eq_impl Σ cmp_universe cmp_sort pb0 pb : + RelationClasses.Reflexive (cmp_universe Conv) -> + RelationClasses.Reflexive (cmp_universe pb) -> + RelationClasses.Reflexive (cmp_sort Conv) -> + RelationClasses.Reflexive (cmp_sort pb) -> + subrelation (eq_term_upto_univ Σ (fun _ => eq) (fun _ => eq) pb0) (eq_term_upto_univ Σ cmp_universe cmp_sort pb). Proof. - intros he hle. eapply eq_term_upto_univ_impl. 4:auto. + intros univ_refl univ_refl' sort_refl sort_refl'. eapply eq_term_upto_univ_impl. 5:auto. all: intros ? ? []; eauto. Qed. (** ** Syntactic ws_cumul_pb up to printing anotations ** *) -Definition upto_names := eq_term_upto_univ empty_global_env eq eq. +Definition upto_names := eq_term_upto_univ empty_global_env (fun _ => eq) (fun _ => eq) Conv. Infix "≡" := upto_names (at level 70). -Infix "≡'" := (eq_term_upto_univ empty_global_env eq eq) (at level 70). -Notation upto_names' := (eq_term_upto_univ empty_global_env eq eq). +Infix "≡'" := (eq_term_upto_univ empty_global_env (fun _ => eq) (fun _ => eq) Conv) (at level 70). +Notation upto_names' := (eq_term_upto_univ empty_global_env (fun _ => eq) (fun _ => eq) Conv). #[global] Instance upto_names_ref : Reflexive upto_names. @@ -1335,12 +1502,15 @@ Qed. (* all: intros u u'; eapply reflect_reflectT, eqb_spec. *) (* Qed. *) -Lemma upto_names_impl Σ Re Rle : - RelationClasses.Reflexive Re -> - RelationClasses.Reflexive Rle -> - subrelation upto_names (eq_term_upto_univ Σ Re Rle). +Lemma upto_names_impl Σ cmp_universe cmp_sort pb napp : + RelationClasses.Reflexive (cmp_universe Conv) -> + RelationClasses.Reflexive (cmp_universe pb) -> + RelationClasses.Reflexive (cmp_sort Conv) -> + RelationClasses.Reflexive (cmp_sort pb) -> + subrelation upto_names (eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp). Proof. - intros he hle. eapply eq_term_upto_univ_empty_impl; auto. + intros univ_refl univ_refl' sort_refl sort_refl'. + eapply eq_term_upto_univ_empty_impl; auto. all: intros ? ? []; eauto. Qed. @@ -1356,8 +1526,8 @@ Proof. eapply upto_names_impl ; exact _. Qed. -Lemma eq_term_upto_univ_isApp Σ Re Rle napp u v : - eq_term_upto_univ_napp Σ Re Rle napp u v -> +Lemma eq_term_upto_univ_isApp Σ cmp_universe cmp_sort pb napp u v : + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp u v -> isApp u = isApp v. Proof. induction 1. @@ -1372,14 +1542,14 @@ Inductive rel_option {A B} (R : A -> B -> Type) : option A -> option B -> Type : Derive Signature NoConfusion for rel_option. -Definition eq_decl_upto_gen Σ Re Rle d d' : Type := +Definition eq_decl_upto_gen Σ cmp_universe cmp_sort pb d d' : Type := eq_binder_annot d.(decl_name) d'.(decl_name) * - rel_option (eq_term_upto_univ Σ Re Re) d.(decl_body) d'.(decl_body) * - eq_term_upto_univ Σ Re Rle d.(decl_type) d'.(decl_type). + rel_option (eq_term_upto_univ Σ cmp_universe cmp_sort Conv) d.(decl_body) d'.(decl_body) * + eq_term_upto_univ Σ cmp_universe cmp_sort pb d.(decl_type) d'.(decl_type). (* TODO perhaps should be def *) -Lemma All2_eq_context_upto Σ Re Rle : - subrelation (All2 (eq_decl_upto_gen Σ Re Rle)) (eq_context_upto Σ Re Rle). +Lemma All2_eq_context_upto Σ cmp_universe cmp_sort pb : + subrelation (All2 (eq_decl_upto_gen Σ cmp_universe cmp_sort pb)) (eq_context_upto Σ cmp_universe cmp_sort pb). Proof. intros Γ Δ h. induction h. @@ -1392,27 +1562,45 @@ Proof. + constructor ; eauto. constructor; auto. Qed. -Lemma eq_context_upto_refl Σ Re Rle : - RelationClasses.Reflexive Re -> - RelationClasses.Reflexive Rle -> - Reflexive (eq_context_upto Σ Re Rle). + +Lemma eq_context_upto_impl Σ cmp_universe cmp_universe' cmp_sort cmp_sort' pb pb' : + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe' Conv) -> + RelationClasses.subrelation (cmp_universe pb) (cmp_universe' pb') -> + RelationClasses.subrelation (cmp_sort Conv) (cmp_sort' Conv) -> + RelationClasses.subrelation (cmp_sort pb) (cmp_sort' pb') -> + subrelation (eq_context_upto Σ cmp_universe cmp_sort pb) (eq_context_upto Σ cmp_universe' cmp_sort' pb'). +Proof. + intros. + apply eq_context_gen_impl. + all: apply eq_term_upto_univ_impl; tc. + all: auto. +Qed. + +Lemma eq_context_upto_refl Σ cmp_universe cmp_sort pb : + RelationClasses.Reflexive (cmp_universe Conv) -> + RelationClasses.Reflexive (cmp_universe pb) -> + RelationClasses.Reflexive (cmp_sort Conv) -> + RelationClasses.Reflexive (cmp_sort pb) -> + Reflexive (eq_context_upto Σ cmp_universe cmp_sort pb). Proof. exact _. Qed. -Lemma eq_context_upto_sym Σ Re Rle : - RelationClasses.Symmetric Re -> - RelationClasses.Symmetric Rle -> - Symmetric (eq_context_upto Σ Re Rle). +Lemma eq_context_upto_sym Σ cmp_universe cmp_sort pb : + RelationClasses.Symmetric (cmp_universe Conv) -> + RelationClasses.Symmetric (cmp_universe pb) -> + RelationClasses.Symmetric (cmp_sort Conv) -> + RelationClasses.Symmetric (cmp_sort pb) -> + Symmetric (eq_context_upto Σ cmp_universe cmp_sort pb). Proof. exact _. Qed. -Lemma eq_context_upto_cat Σ Re Rle Γ Δ Γ' Δ' : - eq_context_upto Σ Re Rle Γ Γ' -> - eq_context_upto Σ Re Rle Δ Δ' -> - eq_context_upto Σ Re Rle (Γ ,,, Δ) (Γ' ,,, Δ'). +Lemma eq_context_upto_cat Σ cmp_universe cmp_sort pb Γ Δ Γ' Δ' : + eq_context_upto Σ cmp_universe cmp_sort pb Γ Γ' -> + eq_context_upto Σ cmp_universe cmp_sort pb Δ Δ' -> + eq_context_upto Σ cmp_universe cmp_sort pb (Γ ,,, Δ) (Γ' ,,, Δ'). Proof. intros. eapply All2_fold_app; eauto. Qed. -Lemma eq_context_upto_rev Σ Re Rle Γ Δ : - eq_context_upto Σ Re Rle Γ Δ -> - eq_context_upto Σ Re Rle (rev Γ) (rev Δ). +Lemma eq_context_upto_rev Σ cmp_universe cmp_sort pb Γ Δ : + eq_context_upto Σ cmp_universe cmp_sort pb Γ Δ -> + eq_context_upto Σ cmp_universe cmp_sort pb (rev Γ) (rev Δ). Proof. induction 1. - constructor. @@ -1421,11 +1609,11 @@ Proof. Qed. Lemma eq_context_upto_rev' : - forall Σ Γ Δ Re Rle, - eq_context_upto Σ Re Rle Γ Δ -> - eq_context_upto Σ Re Rle (List.rev Γ) (List.rev Δ). + forall Σ Γ Δ cmp_universe cmp_sort pb, + eq_context_upto Σ cmp_universe cmp_sort pb Γ Δ -> + eq_context_upto Σ cmp_universe cmp_sort pb (List.rev Γ) (List.rev Δ). Proof. - intros Σ Γ Δ Re Rle h. + intros Σ Γ Δ cmp_universe cmp_sort pb h. induction h. - constructor. - simpl. eapply eq_context_upto_cat. @@ -1433,21 +1621,20 @@ Proof. + assumption. Qed. -Lemma eq_context_upto_length : - forall {Σ Re Rle Γ Δ}, - eq_context_upto Σ Re Rle Γ Δ -> +Lemma eq_context_upto_length {Σ cmp_universe cmp_sort pb Γ Δ} : + eq_context_upto Σ cmp_universe cmp_sort pb Γ Δ -> #|Γ| = #|Δ|. Proof. - intros Σ Re Rle Γ Δ h. - induction h. all: simpl ; auto. + apply All2_fold_length. Qed. -Lemma eq_context_upto_subst_context Σ Re Rle : - RelationClasses.subrelation Re Rle -> +Lemma eq_context_upto_subst_context Σ cmp_universe cmp_sort pb : + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe pb) -> + RelationClasses.subrelation (cmp_sort Conv) (cmp_sort pb) -> forall u v n l l', - eq_context_upto Σ Re Rle u v -> - All2 (eq_term_upto_univ Σ Re Re) l l' -> - eq_context_upto Σ Re Rle (subst_context l n u) (subst_context l' n v). + eq_context_upto Σ cmp_universe cmp_sort pb u v -> + All2 (eq_term_upto_univ Σ cmp_universe cmp_sort Conv) l l' -> + eq_context_upto Σ cmp_universe cmp_sort pb (subst_context l n u) (subst_context l' n v). Proof. intros re u v n l l'. induction 1; intros Hl. @@ -1455,27 +1642,27 @@ Proof. - rewrite !subst_context_snoc; constructor; eauto. depelim p; constructor; simpl; intuition auto; rewrite -(length_of X); - apply eq_term_upto_univ_substs; auto. reflexivity. + apply eq_term_upto_univ_substs; auto. all: reflexivity. Qed. #[global] Hint Resolve All2_fold_nil : pcuic. -Lemma eq_context_upto_smash_context Σ ctx ctx' x y : - eq_context_upto Σ eq eq ctx ctx' -> eq_context_upto Σ eq eq x y -> - eq_context_upto Σ eq eq (smash_context ctx x) (smash_context ctx' y). +Lemma eq_context_upto_smash_context Σ ctx ctx' x y pb : + eq_context_upto Σ (fun _ => eq) (fun _ => eq) pb ctx ctx' -> eq_context_upto Σ (fun _ => eq) (fun _ => eq) pb x y -> + eq_context_upto Σ (fun _ => eq) (fun _ => eq) pb (smash_context ctx x) (smash_context ctx' y). Proof. induction x in ctx, ctx', y |- *; intros eqctx eqt; inv eqt; simpl; try split; auto; try constructor; auto. depelim X0 => /=. - apply IHx; auto. apply eq_context_upto_cat; auto. constructor; pcuic. - apply IHx; auto. eapply eq_context_upto_subst_context; eauto. - typeclasses eauto. + all: reflexivity. Qed. -Lemma eq_context_upto_nth_error Σ Re Rle ctx ctx' n : - eq_context_upto Σ Re Rle ctx ctx' -> - rel_option (eq_decl_upto_gen Σ Re Rle) (nth_error ctx n) (nth_error ctx' n). +Lemma eq_context_upto_nth_error Σ cmp_universe cmp_sort pb ctx ctx' n : + eq_context_upto Σ cmp_universe cmp_sort pb ctx ctx' -> + rel_option (eq_decl_upto_gen Σ cmp_universe cmp_sort pb) (nth_error ctx n) (nth_error ctx' n). Proof. induction 1 in n |- *. - rewrite nth_error_nil. constructor. @@ -1485,38 +1672,38 @@ Proof. Qed. Lemma eq_context_impl : - forall Σ Re Re' Rle Rle', - RelationClasses.subrelation Re Re' -> - RelationClasses.subrelation Rle Rle' -> - RelationClasses.subrelation Re' Rle' -> - subrelation (eq_context_upto Σ Re Rle) (eq_context_upto Σ Re' Rle'). -Proof. - intros Σ Re Re' Rle Rle' hR hR' hReRle' Γ Δ h. + forall Σ cmp_universe cmp_universe' cmp_sort cmp_sort' pb pb', + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe' Conv) -> + RelationClasses.subrelation (cmp_universe pb) (cmp_universe' pb') -> + RelationClasses.subrelation (cmp_sort Conv) (cmp_sort' Conv) -> + RelationClasses.subrelation (cmp_sort pb) (cmp_sort' pb') -> + subrelation (eq_context_upto Σ cmp_universe cmp_sort pb) (eq_context_upto Σ cmp_universe' cmp_sort' pb'). +Proof. + intros Σ cmp_universe cmp_universe' cmp_sort cmp_sort' pb pb' univ_sub_conv univ_sub_pb sort_sub_conv sort_sub_pb Γ Δ h. induction h. - constructor. - constructor; auto. depelim p; constructor; auto. - all:eapply eq_term_upto_univ_impl. 5,10,15:tea. all:eauto. - all:now transitivity Re'. + all:eapply eq_term_upto_univ_impl; [ .. | eassumption]; eauto. Qed. -Lemma eq_term_upto_univ_it_mkLambda_or_LetIn Σ Re Rle : - RelationClasses.Reflexive Re -> - Proper (eq_context_upto Σ Re Re ==> eq_term_upto_univ Σ Re Rle ==> eq_term_upto_univ Σ Re Rle) it_mkLambda_or_LetIn. +Lemma eq_term_upto_univ_it_mkLambda_or_LetIn Σ cmp_universe cmp_sort pb : + Proper (eq_context_upto Σ cmp_universe cmp_sort Conv ==> eq_term_upto_univ Σ cmp_universe cmp_sort pb ==> eq_term_upto_univ Σ cmp_universe cmp_sort pb) it_mkLambda_or_LetIn. Proof. - intros he Γ Δ eq u v h. - induction eq in u, v, h, he |- *. + intros Γ Δ eq u v h. + induction eq in u, v, h |- *. - assumption. - simpl. cbn. apply IHeq => //. destruct p; cbn; constructor ; tas; try reflexivity. Qed. -Lemma eq_term_upto_univ_it_mkLambda_or_LetIn_r Σ Re Rle Γ : - RelationClasses.Reflexive Re -> - respectful (eq_term_upto_univ Σ Re Rle) (eq_term_upto_univ Σ Re Rle) +Lemma eq_term_upto_univ_it_mkLambda_or_LetIn_r Σ cmp_universe cmp_sort pb Γ : + RelationClasses.Reflexive (cmp_universe Conv) -> + RelationClasses.Reflexive (cmp_sort Conv) -> + respectful (eq_term_upto_univ Σ cmp_universe cmp_sort pb) (eq_term_upto_univ Σ cmp_universe cmp_sort pb) (it_mkLambda_or_LetIn Γ) (it_mkLambda_or_LetIn Γ). Proof. - intros he u v h. + intros univ_refl sort_refl u v h. induction Γ as [| [na [b|] A] Γ ih ] in u, v, h |- *. - assumption. - simpl. cbn. apply ih. constructor ; try apply eq_term_upto_univ_refl. @@ -1532,12 +1719,13 @@ Proof. apply eq_term_upto_univ_it_mkLambda_or_LetIn_r; exact _. Qed. -Lemma eq_term_upto_univ_it_mkProd_or_LetIn Σ Re Rle Γ : - RelationClasses.Reflexive Re -> - respectful (eq_term_upto_univ Σ Re Rle) (eq_term_upto_univ Σ Re Rle) +Lemma eq_term_upto_univ_it_mkProd_or_LetIn Σ cmp_universe cmp_sort pb Γ : + RelationClasses.Reflexive (cmp_universe Conv) -> + RelationClasses.Reflexive (cmp_sort Conv) -> + respectful (eq_term_upto_univ Σ cmp_universe cmp_sort pb) (eq_term_upto_univ Σ cmp_universe cmp_sort pb) (it_mkProd_or_LetIn Γ) (it_mkProd_or_LetIn Γ). Proof. - intros he u v h. + intros univ_refl sort_refl u v h. induction Γ as [| [na [b|] A] Γ ih ] in u, v, h |- *. - assumption. - simpl. cbn. apply ih. constructor ; try apply eq_term_upto_univ_refl. @@ -1565,11 +1753,11 @@ Proof. assumption. Qed. -Lemma eq_term_upto_univ_mkApps_inv Σ Re Rle u l u' l' : +Lemma eq_term_upto_univ_mkApps_inv Σ cmp_universe cmp_sort pb u l u' l' : isApp u = false -> isApp u' = false -> - eq_term_upto_univ Σ Re Rle (mkApps u l) (mkApps u' l') -> - eq_term_upto_univ_napp Σ Re Rle #|l| u u' * All2 (eq_term_upto_univ Σ Re Re) l l'. + eq_term_upto_univ Σ cmp_universe cmp_sort pb (mkApps u l) (mkApps u' l') -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb #|l| u u' * All2 (eq_term_upto_univ Σ cmp_universe cmp_sort Conv) l l'. Proof. intros hu hu' h. apply eq_term_upto_univ_mkApps_l_inv in h as hh. @@ -1579,9 +1767,9 @@ Proof. destruct h3 as [? ?]. subst. split ; auto. Qed. -Lemma isLambda_eq_term_l Σ Re u v : +Lemma isLambda_eq_term_l Σ cmp_universe cmp_sort pb u v : isLambda u -> - eq_term_upto_univ Σ Re Re u v -> + eq_term_upto_univ Σ cmp_universe cmp_sort pb u v -> isLambda v. Proof. intros h e. @@ -1589,9 +1777,9 @@ Proof. depelim e. auto. Qed. -Lemma isLambda_eq_term_r Σ Re u v : +Lemma isLambda_eq_term_r Σ cmp_universe cmp_sort pb u v : isLambda v -> - eq_term_upto_univ Σ Re Re u v -> + eq_term_upto_univ Σ cmp_universe cmp_sort pb u v -> isLambda u. Proof. intros h e. @@ -1599,9 +1787,9 @@ Proof. depelim e. auto. Qed. -Lemma isConstruct_app_eq_term_l Σ Re u v : +Lemma isConstruct_app_eq_term_l Σ cmp_universe cmp_sort pb u v : isConstruct_app u -> - eq_term_upto_univ Σ Re Re u v -> + eq_term_upto_univ Σ cmp_universe cmp_sort pb u v -> isConstruct_app v. Proof. intros h e. @@ -1621,12 +1809,12 @@ Proof. Qed. Lemma isConstruct_app_eq_term_r : - forall Σ Re u v, + forall Σ cmp_universe cmp_sort pb u v, isConstruct_app v -> - eq_term_upto_univ Σ Re Re u v -> + eq_term_upto_univ Σ cmp_universe cmp_sort pb u v -> isConstruct_app u. Proof. - intros Σ Re u v h e. + intros Σ cmp_universe cmp_sort pb u v h e. case_eq (decompose_app u). intros t1 l1 e1. case_eq (decompose_app v). intros t2 l2 e2. unfold isConstruct_app in *. @@ -1642,85 +1830,119 @@ Proof. - reflexivity. Qed. -Lemma R_global_instance_flip Σ gr napp - (Re Rle Rle' : Universe.t -> Universe.t -> Prop) u v: - RelationClasses.Reflexive Re -> - RelationClasses.Reflexive Rle -> - RelationClasses.Symmetric Re -> - RelationClasses.Transitive Re -> - RelationClasses.Transitive Rle -> - RelationClasses.subrelation Re Rle -> - (forall x y, Rle x y -> Rle' y x) -> - R_global_instance Σ Re Rle gr napp u v -> - R_global_instance Σ Re Rle' gr napp v u. -Proof. - intros Rerefl Rlerefl Resym Retrans Rletrans incl incl'. - unfold R_global_instance_gen, R_opt_variance. - destruct global_variance_gen as [vs|] eqn:var. - - induction u in vs, v |- *; destruct v; simpl; auto; - destruct vs as [|v' vs]; simpl; auto. - intros [Ra Ru']. split. - destruct v'; simpl; auto. - apply IHu; auto. - - apply Forall2_symP; eauto. -Qed. - -Lemma eq_term_upto_univ_napp_flip Σ (Re Rle Rle' : Universe.t -> Universe.t -> Prop) napp u v : - RelationClasses.Reflexive Re -> - RelationClasses.Reflexive Rle -> - RelationClasses.Symmetric Re -> - RelationClasses.Transitive Re -> - RelationClasses.Transitive Rle -> - RelationClasses.subrelation Re Rle -> - (forall x y, Rle x y -> Rle' y x) -> - eq_term_upto_univ_napp Σ Re Rle napp u v -> - eq_term_upto_univ_napp Σ Re Rle' napp v u. -Proof. - intros Rerefl Rlerefl Resym Retrans Rletrans incl incl' H. - assert (Resub : RelationClasses.subrelation Re Re). - { typeclasses eauto. } - revert Rerefl Rlerefl Resym Retrans Rletrans incl incl' Resub. - revert Re Rle u v H Rle'. - induction 1; intros; constructor; intuition auto. - all:try solve [now symmetry]. - all:eauto using R_global_instance_flip. - - eapply All2_sym. solve_all. - * eapply eq_context_sym; try tc. tas. - * now eapply eq_term_upto_univ_sym. - - eapply All2_sym. solve_all. - now eapply eq_term_upto_univ_sym. - now eapply eq_term_upto_univ_sym. - now symmetry. - - eapply All2_sym. solve_all. - now eapply eq_term_upto_univ_sym. - now eapply eq_term_upto_univ_sym. - now symmetry. - - depelim o; constructor; eauto. - now eapply eq_term_upto_univ_sym. - now eapply eq_term_upto_univ_sym. - eapply All2_sym; solve_all. - now eapply eq_term_upto_univ_sym. +Lemma cmp_universe_variance_flip cmp_universe cmp_universe' pb pb' v u u' : + RelationClasses.subrelation (cmp_universe Conv) (flip (cmp_universe' Conv)) -> + RelationClasses.subrelation (cmp_universe pb) (flip (cmp_universe' pb')) -> + cmp_universe_variance cmp_universe pb v u u' -> + cmp_universe_variance cmp_universe' pb' v u' u. +Proof. + intros conv_sym pb_sym. + destruct v => //=. + all: unfold on_rel, flip in *; now auto. Qed. -Lemma eq_univ_make : - forall u u', - Forall2 eq (map Universe.make u) (map Universe.make u') -> - u = u'. +Lemma cmp_universe_instance_variance_flip cmp_universe cmp_universe' pb pb' v u u' : + RelationClasses.subrelation (cmp_universe Conv) (flip (cmp_universe' Conv)) -> + RelationClasses.subrelation (cmp_universe pb) (flip (cmp_universe' pb')) -> + cmp_universe_instance_variance cmp_universe pb v u u' -> + cmp_universe_instance_variance cmp_universe' pb' v u' u. Proof. - intros u u' H. eapply Forall2_map' in H. - eapply Forall2_eq. eapply Forall2_impl; tea. - clear. intros [] [] H; now inversion H. + intros conv_sym pb_sym H. + induction H; constructor; eauto. + now eapply cmp_universe_variance_flip. +Qed. + + +Lemma cmp_universe_instance_flip eq_universe eq_universe' u u' : + RelationClasses.subrelation eq_universe (flip eq_universe') -> + cmp_universe_instance eq_universe u u' -> + cmp_universe_instance eq_universe' u' u. +Proof. + intros Hsub H. + apply Forall2_sym, Forall2_impl with (1 := H). + intros ??. apply Hsub. +Qed. + +Lemma cmp_global_instance_flip Σ cmp_universe cmp_universe' pb pb' gr napp u u': + RelationClasses.subrelation (cmp_universe Conv) (flip (cmp_universe' Conv)) -> + RelationClasses.subrelation (cmp_universe pb) (flip (cmp_universe' pb')) -> + cmp_global_instance Σ cmp_universe pb gr napp u u' -> + cmp_global_instance Σ cmp_universe' pb' gr napp u' u. +Proof. + intros conv_sym pb_sym. + unfold cmp_global_instance_gen, cmp_opt_variance. + destruct global_variance_gen as [| |v] => //. + 2: intros [H|H]; [left|right]; move:H. + 1,2: apply cmp_universe_instance_flip; tas; reflexivity. + now apply cmp_universe_instance_variance_flip. +Qed. + +Lemma eq_term_upto_univ_napp_flip Σ cmp_universe cmp_universe' cmp_sort cmp_sort' pb pb' napp u v : + RelationClasses.subrelation (cmp_universe Conv) (flip (cmp_universe' Conv)) -> + RelationClasses.subrelation (cmp_universe pb) (flip (cmp_universe' pb')) -> + RelationClasses.subrelation (cmp_sort Conv) (flip (cmp_sort' Conv)) -> + RelationClasses.subrelation (cmp_sort pb) (flip (cmp_sort' pb')) -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp u v -> + eq_term_upto_univ_napp Σ cmp_universe' cmp_sort' pb' napp v u. +Proof. + intros univ_sub_conv univ_sub_pb sort_sub_conv sort_sub_pb. + induction u in napp, pb, pb', univ_sub_pb, sort_sub_pb, v |- * using term_forall_list_ind; + try (inversion 1; subst; constructor; + eauto using cmp_universe_instance_flip; try (symmetry; assumption); fail). + - inversion 1; subst; constructor. + eapply All2_sym, All2_impl'; tea. + eapply All_impl; eauto. + - inversion 1; subst; constructor. now eapply sort_sub_pb. + - inversion 1; subst; constructor. + eapply cmp_global_instance_flip. 3:eauto. all:auto. + - inversion 1; subst; constructor. + eapply cmp_global_instance_flip. 3:eauto. all:eauto. + - inversion 1; subst; constructor; unfold eq_predicate, eq_branches, eq_branch in *; eauto. + solve_all. + * apply All2_sym; solve_all. + * eapply cmp_universe_instance_flip; eauto. + * symmetry. solve_all. + * apply All2_sym. solve_all. symmetry. solve_all. + - inversion 1; subst; constructor. + eapply All2_sym, All2_impl'; tea. + eapply All_impl; eauto. + cbn. intros x [? ?] y (?&?&?&?). repeat split; eauto. now symmetry. + - inversion 1; subst; constructor. + eapply All2_sym, All2_impl'; tea. + eapply All_impl; eauto. + cbn. intros x [? ?] y (?&?&?&?). repeat split; eauto. now symmetry. + - inversion 1; subst; constructor. depelim X1; tas; try now constructor. + destruct X as (hty & hdef & harr). + constructor; eauto. + 1: now eapply univ_sub_conv. + apply All2_sym; solve_all. +Qed. + +Lemma eq_context_upto_flip Σ cmp_universe cmp_universe' cmp_sort cmp_sort' pb pb' Γ Δ : + RelationClasses.subrelation (cmp_universe Conv) (flip (cmp_universe' Conv)) -> + RelationClasses.subrelation (cmp_universe pb) (flip (cmp_universe' pb')) -> + RelationClasses.subrelation (cmp_sort Conv) (flip (cmp_sort' Conv)) -> + RelationClasses.subrelation (cmp_sort pb) (flip (cmp_sort' pb')) -> + eq_context_upto Σ cmp_universe cmp_sort pb Γ Δ -> + eq_context_upto Σ cmp_universe' cmp_sort' pb' Δ Γ. +Proof. + intros univ_sub_conv univ_sub_pb sort_sub_conv sort_sub_pb H. + eapply All2_fold_flip, All2_fold_impl with (1 := H). clear H. + intros _ _ d d' H. + destruct H; constructor. + all: try solve [ eapply eq_term_upto_univ_napp_flip; [ .. | eassumption]; assumption ]. + all: now symmetry. Qed. (** ws_cumul_pb of binder annotations *) Notation eq_annots Γ Δ := (Forall2 (fun na decl => eq_binder_annot na (decl_name decl)) Γ Δ). -Lemma eq_context_gen_binder_annot Γ Δ : - eq_context_gen eq eq Γ Δ -> eq_annots (forget_types Γ) Δ. +Lemma eq_context_upto_names_binder_annot Γ Δ : + eq_context_upto_names Γ Δ -> eq_annots (forget_types Γ) Δ. Proof. induction 1; constructor; auto. - destruct p; auto. + destruct r; auto. Qed. Lemma eq_annots_fold (Γ : list aname) (f : nat -> term -> term) (Δ : context) : @@ -1770,3 +1992,73 @@ Proof. symmetry; eapply (eq_annots_subst_context _ (List.rev pars) 0). reflexivity. Qed. + +Lemma eq_context_gen_map2_set_binder_name cmp_term cmp_term' pb pb' pctx pctx' Γ Δ : + eq_context_gen cmp_term pb pctx pctx' -> + eq_context_gen cmp_term' pb' Γ Δ -> + eq_context_gen cmp_term' pb' + (map2 set_binder_name (forget_types pctx) Γ) + (map2 set_binder_name (forget_types pctx') Δ). +Proof using Type. + intros eqp. + induction 1 in pctx, pctx', eqp |- *. + - destruct eqp; cbn; constructor. + - destruct eqp; simpl; constructor; auto. + destruct c, p; constructor; auto. +Qed. + +Lemma eq_context_upto_names_map2_set_binder_name cmp_term pb pctx pctx' Γ Δ : + eq_context_upto_names pctx pctx' -> + eq_context_gen cmp_term pb Γ Δ -> + eq_context_gen cmp_term pb + (map2 set_binder_name (forget_types pctx) Γ) + (map2 set_binder_name (forget_types pctx') Δ). +Proof using Type. + intro eqctx. + eapply eq_context_gen_map2_set_binder_name with (pb := Conv). + now apply eq_context_upto_names_gen. +Qed. + +Lemma eq_context_upto_names_map2_set_binder_name_eq nas Γ Δ : + eq_context_upto_names Γ Δ -> + map2 PCUICEnvironment.set_binder_name nas Γ = + map2 PCUICEnvironment.set_binder_name nas Δ. +Proof. + induction 1 in nas |- *; cbn; auto. + destruct nas; cbn; auto. + f_equal. destruct r; subst; unfold set_binder_name; f_equal. + apply IHX. +Qed. + +Lemma trans_eq_context_upto_names trans Γ Δ : + eq_context_upto_names Γ Δ -> + eq_context_upto_names (map (map_decl trans) Γ) (map (map_decl trans) Δ). +Proof. + intro. + eapply All2_map. solve_all. + destruct X; cbn; subst; constructor; auto. +Qed. + +Lemma eq_context_upto_names_fold (f : nat -> term -> term) Γ Δ : + eq_context_upto_names Γ Δ -> + eq_context_upto_names (fold_context_k f Γ) (fold_context_k f Δ). +Proof. + induction 1. + - cbn; auto. + - rewrite !fold_context_k_snoc0 /=. + constructor; auto. + rewrite -(All2_length X). + destruct r; now constructor. +Qed. + +Lemma eq_context_upto_names_smash_context {Γ Δ} : + eq_context_upto_names Γ Δ -> + eq_context_upto_names (smash_context [] Γ) (smash_context [] Δ). +Proof. + assert (eq_context_upto_names [] []) as X by constructor. move: X. + set (Γ0 := []) at 1 3. set (Δ0 := []). clearbody Γ0 Δ0. intro X. + induction 1 in Γ0, Δ0, X |- *; cbn; try constructor; tas. + destruct r; cbn; apply IHX0. + - apply All2_app; tas. repeat constructor. assumption. + - now apply eq_context_upto_names_fold. +Qed. diff --git a/pcuic/theories/PCUICEtaExpand.v b/pcuic/theories/PCUICEtaExpand.v index 940990cc7..88f900379 100644 --- a/pcuic/theories/PCUICEtaExpand.v +++ b/pcuic/theories/PCUICEtaExpand.v @@ -73,7 +73,7 @@ Inductive expanded (Γ : list nat) : term -> Prop := | expanded_tRel (n : nat) m args : nth_error Γ n = Some m -> forall Hle : m <= #|args|, Forall (expanded Γ) args -> expanded Γ (mkApps (tRel n) args) | expanded_tVar (id : ident) : expanded Γ (tVar id) | expanded_tEvar (ev : nat) (args : list term) : Forall (expanded Γ) args -> expanded Γ (tEvar ev args) -| expanded_tSort (s : Universe.t) : expanded Γ (tSort s) +| expanded_tSort (s : sort) : expanded Γ (tSort s) | expanded_tProd (na : aname) (ty : term) (body : term) : expanded Γ (tProd na ty body) | expanded_tLambda (na : aname) (ty : term) (body : term) : expanded (0 :: Γ) body -> expanded Γ (tLambda na ty body) | expanded_tLetIn (na : aname) (def : term) (def_ty : term) (body : term) : expanded Γ def -> expanded (0 :: Γ) body -> expanded Γ (tLetIn na def def_ty body) @@ -117,7 +117,7 @@ Lemma expanded_ind : (forall (Γ : list nat) (id : ident), P Γ (tVar id)) -> (forall (Γ : list nat) (ev : nat) (args : list term), Forall (expanded Σ Γ) args -> Forall (P Γ) args -> P Γ (tEvar ev args)) -> - (forall (Γ : list nat) (s : Universe.t), P Γ (tSort s)) -> + (forall (Γ : list nat) (s : sort), P Γ (tSort s)) -> (forall (Γ : list nat) (na : aname) (ty body : term), P Γ (tProd na ty body)) -> (forall (Γ : list nat) (na : aname) (ty body : term), expanded Σ (0 :: Γ) body -> P (0 :: Γ) body -> P Γ (tLambda na ty body)) -> @@ -1449,4 +1449,4 @@ Proof. move/expanded_mkApps_inv' => [expa _]. move: expa; rewrite (arguments_mkApps t [u]). move/Forall_app => [] _ hu; now depelim hu. -Qed. \ No newline at end of file +Qed. diff --git a/pcuic/theories/PCUICExpandLetsCorrectness.v b/pcuic/theories/PCUICExpandLetsCorrectness.v index 92e1e4744..53a7392ff 100644 --- a/pcuic/theories/PCUICExpandLetsCorrectness.v +++ b/pcuic/theories/PCUICExpandLetsCorrectness.v @@ -913,7 +913,7 @@ Section wtsub. [× declared_inductive Σ ci mdecl idecl, consistent_instance_ext Σ (PCUICEnvironment.ind_universes mdecl) (PCUICAst.puinst p), wf_predicate mdecl idecl p, - All2 (PCUICEquality.compare_decls eq eq) (PCUICCases.ind_predicate_context ci mdecl idecl) (PCUICAst.pcontext p), + eq_context_upto_names (PCUICCases.ind_predicate_context ci mdecl idecl) (PCUICAst.pcontext p), wf_local_rel Σ (Γ ,,, smash_context [] (ind_params mdecl)@[p.(puinst)]) p.(pcontext)@[p.(puinst)], PCUICSpine.spine_subst Σ Γ (PCUICAst.pparams p) (List.rev (PCUICAst.pparams p)) (PCUICEnvironment.smash_context [] (PCUICEnvironment.ind_params mdecl)@[PCUICAst.puinst p]), @@ -921,9 +921,9 @@ Section wtsub. wt Γ c & All2i (fun i cdecl br => [× wf_branch cdecl br, - All2 (PCUICEquality.compare_decls eq eq) (bcontext br) (PCUICCases.cstr_branch_context ci mdecl cdecl), + eq_context_upto_names (bcontext br) (PCUICCases.cstr_branch_context ci mdecl cdecl), wf_local_rel Σ (Γ ,,, smash_context [] (ind_params mdecl)@[p.(puinst)]) br.(bcontext)@[p.(puinst)], - All2 (PCUICEquality.compare_decls eq eq) + eq_context_upto_names (Γ ,,, PCUICCases.case_branch_context ci mdecl p (forget_types br.(bcontext)) cdecl) (Γ ,,, inst_case_branch_context p br) & wt (Γ ,,, PCUICCases.case_branch_context ci mdecl p (forget_types br.(bcontext)) cdecl) br.(bbody)]) 0 idecl.(ind_ctors) brs] @@ -1347,14 +1347,12 @@ Proof. Qed. Lemma trans_local_set_binder_name_eq nas Γ Δ : - All2 (PCUICEquality.compare_decls eq eq) Γ Δ -> + eq_context_upto_names Γ Δ -> trans_local (map2 PCUICEnvironment.set_binder_name nas Γ) = trans_local (map2 PCUICEnvironment.set_binder_name nas Δ). Proof. - induction 1 in nas |- *; cbn; auto. - destruct nas; cbn; auto. - f_equal. destruct r; subst; f_equal. - apply IHX. + intro H. + f_equal. now apply eq_context_upto_names_map2_set_binder_name_eq. Qed. Lemma map2_trans l l' : @@ -2220,11 +2218,11 @@ Proof. - cbn; depelim wt. eapply red_primArray_type; cbn; eauto. Qed. -Lemma trans_R_global_instance {Σ : global_env} Re Rle gref napp u u' : - R_global_instance Σ Re Rle gref napp u u' -> - R_global_instance (trans_global_env Σ) Re Rle gref napp u u'. +Lemma trans_cmp_global_instance {Σ : global_env} Re Rle gref napp u u' : + cmp_global_instance Σ Re Rle gref napp u u' -> + cmp_global_instance (trans_global_env Σ) Re Rle gref napp u u'. Proof. - unfold PCUICEquality.R_global_instance, PCUICEquality.global_variance. + unfold PCUICEquality.cmp_global_instance, PCUICEquality.global_variance. destruct gref; simpl; auto. - unfold S.lookup_inductive, S.lookup_minductive. unfold S.lookup_inductive_gen, S.lookup_minductive_gen. @@ -2245,83 +2243,45 @@ Proof. destruct nth_error => /= //. Qed. -Lemma trans_eq_context_gen_eq_binder_annot Γ Δ : - eq_context_gen eq eq Γ Δ -> +Lemma trans_eq_context_upto_names_eq_binder_annot Γ Δ : + eq_context_upto_names Γ Δ -> All2 eq_binder_annot (map decl_name (trans_local Γ)) (map decl_name (trans_local Δ)). Proof. - move/All2_fold_All2. intros; do 2 eapply All2_map. solve_all. destruct X; cbn; auto. Qed. -Lemma trans_eq_context_gen Γ Δ : - eq_context_gen eq eq Γ Δ -> - eq_context_gen eq eq (trans_local Γ) (trans_local Δ). -Proof. - move/All2_fold_All2 => e. apply All2_fold_All2. - eapply All2_map. solve_all. - destruct X; cbn; subst; constructor; auto. -Qed. - -Lemma eq_context_gen_extended_subst {Γ Δ n} : - eq_context_gen eq eq Γ Δ -> - extended_subst Γ n = extended_subst Δ n. -Proof. - induction 1 in n |- *; cbn; auto. - destruct p; subst; cbn. f_equal; auto. - rewrite IHX. - now rewrite (PCUICConfluence.eq_context_gen_context_assumptions X). -Qed. - -Lemma eq_context_gen_smash_context {Γ Δ} : - eq_context_gen eq eq Γ Δ -> - eq_context_gen eq eq (smash_context [] Γ) (smash_context [] Δ). -Proof. - induction 1; try constructor. - rewrite (smash_context_app [] [d]) smash_context_acc. - rewrite (smash_context_app [] [d']) (smash_context_acc Γ'). - cbn. destruct p; subst; cbn. eapply All2_fold_All2. - eapply All2_app. 2:now eapply All2_fold_All2. - rewrite !lift_context_snoc /=. - rewrite (All2_fold_length X). repeat constructor; cbn; auto. - rewrite (eq_context_gen_extended_subst X). - now rewrite (PCUICConfluence.eq_context_gen_context_assumptions X). - eapply All2_fold_app => //. - constructor. -Qed. - -Lemma eq_context_upto_context_assumptions {Σ : global_env} {Re Rle} {Γ Δ} : - eq_context_upto Σ Re Rle Γ Δ -> - context_assumptions Γ = context_assumptions Δ. +Lemma trans_eq_context_upto_names Γ Δ : + eq_context_upto_names Γ Δ -> + eq_context_upto_names (trans_local Γ) (trans_local Δ). Proof. - induction 1; cbn; auto. - destruct p; subst; cbn; auto. f_equal; auto. + apply PCUICEquality.trans_eq_context_upto_names. Qed. -Lemma eq_term_upto_univ_expand_lets {cf} {Σ : global_env} {Re Rle Γ Δ t u napp} : - subrelation Re Rle -> - eq_context_upto Σ Re Rle Γ Δ -> - eq_term_upto_univ_napp Σ Re Rle napp t u -> - eq_term_upto_univ_napp Σ Re Rle napp (expand_lets Γ t) (expand_lets Δ u). +Lemma eq_term_upto_univ_expand_lets {cf} {Σ : global_env} {cmp_universe cmp_sort pb Γ Δ t u napp} : + subrelation (cmp_universe Conv) (cmp_universe pb) -> + subrelation (cmp_sort Conv) (cmp_sort pb) -> + eq_context_upto Σ cmp_universe cmp_sort pb Γ Δ -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp t u -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (expand_lets Γ t) (expand_lets Δ u). Proof. - intros subr eqctx eqt. + intros subr subr' eqctx eqt. rewrite /expand_lets /expand_lets_k. eapply eq_term_upto_univ_substs => //. - rewrite (eq_context_upto_length eqctx). - rewrite (eq_context_upto_context_assumptions eqctx). + rewrite -(eq_context_upto_length eqctx). + rewrite (eq_context_gen_context_assumptions eqctx). now eapply eq_term_upto_univ_lift. apply (PCUICConfluence.eq_context_extended_subst eqctx). Qed. -Lemma trans_eq_term_upto_univ {cf} {Σ : global_env} {Re Rle t u napp} : - Reflexive Re -> Reflexive Rle -> - Transitive Re -> SubstUnivPreserving Re -> - subrelation Re Rle -> - PCUICEquality.eq_term_upto_univ_napp Σ Re Rle napp t u -> - eq_term_upto_univ_napp (trans_global_env Σ) Re Rle napp (trans t) (trans u). +Lemma trans_eq_term_upto_univ {cf} {Σ : global_env} {cmp_universe cmp_sort pb t u napp} : + SubstUnivPreserving (cmp_universe Conv) (cmp_universe Conv) -> + SubstUnivPreserving (cmp_universe Conv) (cmp_sort Conv) -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp t u -> + eq_term_upto_univ_napp (trans_global_env Σ) cmp_universe cmp_sort pb napp (trans t) (trans u). Proof. - intros hre hrle hret hres hsub e. - induction t using term_forall_list_ind in Rle, hrle, hsub, napp, u, e |- *. + intros substu substu' e. + induction t using term_forall_list_ind in pb, napp, u, e |- *. all: invs e; cbn. all: try solve [ constructor ; auto ]. all: try solve [ @@ -2331,50 +2291,40 @@ Proof. eapply ih ; eauto using subrelation_refl end ]. - 1,2,3,4,5,6: try solve [ constructor; solve_all; eauto using subrelation_refl ]. - all: try solve [ constructor; now eapply trans_R_global_instance ]. + 1,2,3,4,5,6: try solve [ constructor; unfold eq_mfixpoint in *; solve_all; eauto using subrelation_refl ]. + all: try solve [ constructor; now eapply trans_cmp_global_instance ]. - destruct X1 as [Hpars [Huinst [Hctx Hret]]]. destruct X as [IHpars [IHctx IHret]]. - constructor; cbn; auto. solve_all. - constructor; cbn. solve_all. - 1,3:eauto using subrelation_refl. - repeat split; eauto using subrelation_refl. - rewrite !map_context_trans. - now eapply trans_eq_context_gen. - red in X0. do 2 apply All2_map. - eapply All2_All_mix_left in X3; tea. - eapply All2_impl; tea; cbv beta. - intuition auto. - rewrite !trans_bcontext. - eapply eq_context_gen_smash_context. - now eapply trans_eq_context_gen in a. - rewrite !trans_bbody. - apply eq_term_upto_univ_expand_lets; eauto; tc. - apply eq_context_upto_subst_context; eauto; tc. - rewrite /id. - eapply PCUICConfluence.eq_context_upto_univ_subst_instance'; tc; auto. - cbn. - now eapply trans_eq_context_gen. - cbn. eapply All2_rev. solve_all. eauto using subrelation_refl. - cbn. eauto using subrelation_refl. - - constructor. solve_all; eauto using subrelation_refl. - - constructor; solve_all; eauto using subrelation_refl. - - constructor; depelim X0; cbn in X; constructor; cbn; intuition eauto. - * eapply a2; eauto using subrelation_refl. - * eapply a1; eauto using subrelation_refl. - * solve_all. eauto using subrelation_refl. + constructor; cbn; auto. + all: unfold eq_predicate, eq_branches in *. + 1: repeat split; cbn; auto. + + cbn. apply All2_map. solve_all. + + now apply trans_eq_context_upto_names. + + cbn. apply All2_map. solve_all. + destruct b; split. + * rewrite !trans_bcontext. + now apply eq_context_upto_names_smash_context, trans_eq_context_upto_names. + * rewrite !trans_bbody. + apply eq_term_upto_univ_expand_lets; eauto; tc. + apply eq_context_upto_subst_context; eauto; tc. + 1: apply eq_context_upto_names_subst_instance; eauto; tc. + 1: now eapply trans_eq_context_upto_names. + eapply All2_rev, All2_map. solve_all. + - constructor; depelim X0; cbn in X; try now constructor. + constructor; cbn; intuition eauto. + solve_all. Qed. Lemma trans_compare_term {cf} {Σ : global_env} {pb ϕ T U} : - compare_term pb Σ ϕ T U -> - compare_term (H:=cf' cf) pb (trans_global_env Σ) ϕ (trans T) (trans U). + compare_term Σ ϕ pb T U -> + compare_term (H:=cf' cf) (trans_global_env Σ) ϕ pb (trans T) (trans U). Proof. eapply trans_eq_term_upto_univ ; eauto; tc. Qed. Lemma trans_leq_term {cf} {Σ : global_env} ϕ T U : PCUICEquality.leq_term Σ ϕ T U -> - @compare_term (cf' cf) Cumul (trans_global_env Σ) ϕ (trans T) (trans U). + @compare_term (cf' cf) (trans_global_env Σ) ϕ Cumul (trans T) (trans U). Proof. eapply trans_eq_term_upto_univ; eauto; tc. Qed. @@ -2399,7 +2349,7 @@ Section wtcumul. Reserved Notation " Σ ;;; Γ |-- t <=[ le ] u " (at level 50, Γ, le, t, u at next level). Inductive wt_cumul_pb (pb : conv_pb) (Σ : global_env_ext) (Γ : context) : term -> term -> Type := - | wt_cumul_refl t u : compare_term pb Σ.1 (global_ext_constraints Σ) t u -> Σ ;;; Γ |-- t <=[pb] u + | wt_cumul_refl t u : compare_term Σ.1 (global_ext_constraints Σ) pb t u -> Σ ;;; Γ |-- t <=[pb] u | wt_cumul_red_l t u v : wt_red1 Σ Γ t v -> Σ ;;; Γ |-- v <=[pb] u -> Σ ;;; Γ |-- t <=[pb] u | wt_cumul_red_r t u v : Σ ;;; Γ |-- t <=[pb] v -> wt_red1 Σ Γ u v -> Σ ;;; Γ |-- t <=[pb] u where " Σ ;;; Γ |-- t <=[ pb ] u " := (wt_cumul_pb pb Σ Γ t u) : type_scope. @@ -3752,10 +3702,9 @@ Proof. have declc : declared_constructor Σ (ci, i) mdecl idecl cdecl. { split; tea. } move: wfbr; rewrite /wf_branch /wf_branch_gen. cbn. - apply compare_decls_eq_context in cd. rewrite /cstr_branch_context in cd. - eapply trans_eq_context_gen in cd. - eapply eq_context_gen_smash_context in cd. + eapply trans_eq_context_upto_names in cd. + eapply eq_context_upto_names_smash_context in cd. intros eqann. eapply (eq_annots_subst_context _ (map trans (inds (inductive_mind ci) (abstract_instance (ind_universes mdecl)) (ind_bodies mdecl))) #|ind_params mdecl|). eapply (eq_annots_expand_lets_ctx _ (trans_local (ind_params mdecl))). @@ -3773,7 +3722,7 @@ Proof. apply (declared_constructor_closed_args declc). } apply (inds_is_open_terms []). rewrite !trans_bcontext. - now eapply eq_context_gen_binder_annot in cd. + now eapply eq_context_upto_names_binder_annot in cd. + eapply All2i_map. eapply All2i_map_right. eapply Forall2_All2 in H4. eapply All2i_nth_hyp in X8. @@ -4400,7 +4349,7 @@ Section wtcumul'. Inductive wt_cumul_pb_hetero (pb : conv_pb) (Σ : global_env_ext) (Γ Γ' : context) : term -> term -> Type := | wt_cumul_refl' t u : wt Σ Γ t -> wt Σ Γ' u -> - compare_term pb Σ.1 (global_ext_constraints Σ) t u -> Σ ;;; Γ | Γ' |-- t <=[pb] u + compare_term Σ.1 (global_ext_constraints Σ) pb t u -> Σ ;;; Γ | Γ' |-- t <=[pb] u | wt_cumul_red_l' t u v : wt_red1 Σ Γ t v -> Σ ;;; Γ | Γ' |-- v <=[pb] u -> Σ ;;; Γ | Γ' |-- t <=[pb] u | wt_cumul_red_r' t u v : Σ ;;; Γ | Γ' |-- t <=[pb] v -> wt_red1 Σ Γ' u v -> Σ ;;; Γ | Γ' |-- t <=[pb] u where " Σ ;;; Γ | Γ' |-- t <=[ le ] u " := (wt_cumul_pb_hetero le Σ Γ Γ' t u) : type_scope. @@ -4616,7 +4565,7 @@ Lemma trans_type_local_ctx {cf} {Σ Γ Δ s} : Proof. intros wf wf'. induction Δ; cbn. - unfold PCUICLookup.wf_universe, wf_universe. + unfold PCUICLookup.wf_sort, wf_sort. destruct s => //. destruct a as [? [?|] ?] => /= //; intuition auto. all: apply lift_typing_f_impl with (1 := b) => //; intros. @@ -5083,8 +5032,7 @@ Proof. } { cbn. move: ind_sorts. rewrite /check_ind_sorts. - destruct Universe.is_prop => //. - destruct Universe.is_sprop => //. + destruct Sort.to_family => //. intuition auto. rewrite /PCUICLookup.global_ext_constraints. destruct indices_matter => //. diff --git a/pcuic/theories/PCUICFirstorder.v b/pcuic/theories/PCUICFirstorder.v index 53c111c7f..e0c4d1bed 100644 --- a/pcuic/theories/PCUICFirstorder.v +++ b/pcuic/theories/PCUICFirstorder.v @@ -56,7 +56,7 @@ Section firstorder. (List.rev (c.(cstr_args) ++ mind.(ind_params)))%list. Definition firstorder_oneind mind (ind : one_inductive_body) := - forallb (firstorder_con mind) ind.(ind_ctors) && negb (Universe.is_level (ind_sort ind)). + forallb (firstorder_con mind) ind.(ind_ctors) && negb (Sort.is_level (ind_sort ind)). Definition firstorder_mutind (mind : mutual_inductive_body) := (* if forallb (fun decl => firstorder_type decl.(decl_type)) mind.(ind_params) then *) @@ -102,7 +102,7 @@ Context {cf : config.checker_flags}. Definition isPropositionalArity ar := match destArity [] ar with - | Some (_, s) => is_propositional s + | Some (_, s) => Sort.is_propositional s | None => false end. @@ -724,7 +724,7 @@ Proof. intros Ha H. induction H in t', Ha |- using firstorder_value_inds. eapply eq_term_upto_univ_napp_mkApps_l_inv in Ha as (? & ? & [] & ->). invs e. repeat f_equal. - - now eapply eq_univ_make. + - now eapply cmp_universe_instance_eq. - revert x0 a. clear - H0. induction H0; intros; invs a; f_equal; eauto. Qed. diff --git a/pcuic/theories/PCUICInductiveInversion.v b/pcuic/theories/PCUICInductiveInversion.v index 31039098f..89d146a61 100644 --- a/pcuic/theories/PCUICInductiveInversion.v +++ b/pcuic/theories/PCUICInductiveInversion.v @@ -470,7 +470,7 @@ Lemma mkApps_ind_typing_spine {cf:checker_flags} Σ Γ Γ' ind i (mkApps (tInd ind' i') args') -> ∑ instsubst, [× make_context_subst (List.rev Γ') inst [] = Some instsubst, - #|inst| = context_assumptions Γ', ind = ind', R_ind_universes Σ ind #|args| i i', + #|inst| = context_assumptions Γ', ind = ind', cmp_ind_universes Σ ind #|args| i i', All2 (fun par par' => Σ ;;; Γ ⊢ par = par') (map (subst0 instsubst) args) args' & subslet Σ Γ instsubst Γ']. Proof. @@ -604,7 +604,7 @@ Lemma Construct_Ind_ind_eq {cf:checker_flags} {Σ} (wfΣ : wf Σ.1): declared_constructor Σ.1 (i, n) mdecl idecl cdecl -> (i = i') * (* Universe instances match *) - R_ind_universes Σ i (context_assumptions (ind_params mdecl) + #|cstr_indices cdecl|) u u' * + cmp_ind_universes Σ i (context_assumptions (ind_params mdecl) + #|cstr_indices cdecl|) u u' * consistent_instance_ext Σ (ind_universes mdecl) u * consistent_instance_ext Σ (ind_universes mdecl) u' * (#|args| = (ind_npars mdecl + context_assumptions cdecl.(cstr_args))%nat) * @@ -715,7 +715,7 @@ Proof. eapply weaken_wf_local => //. rewrite -subst_instance_app_ctx. apply a. - - exists (map (subst_instance_univ u') x). split. + - exists (map (subst_instance_sort u') x). split. * move/onParams: onmind. rewrite /on_context. pose proof (@wf_local_instantiate _ Σ (InductiveDecl mdecl) (ind_params mdecl) u'). move=> H'. eapply X in H'; eauto. @@ -786,7 +786,7 @@ Lemma Construct_Ind_ind_eq' {cf:checker_flags} {Σ} (wfΣ : wf Σ.1): declared_constructor Σ.1 (i, n) mdecl idecl cdecl × (i = i') * (* Universe instances match *) - R_ind_universes Σ i (context_assumptions (ind_params mdecl) + #|cstr_indices cdecl|) u u' * + cmp_ind_universes Σ i (context_assumptions (ind_params mdecl) + #|cstr_indices cdecl|) u u' * consistent_instance_ext Σ (ind_universes mdecl) u * consistent_instance_ext Σ (ind_universes mdecl) u' * (#|args| = (ind_npars mdecl + context_assumptions cdecl.(cstr_args))%nat) * @@ -1386,7 +1386,7 @@ Lemma ws_cumul_pb_mkApps_eq {cf} {Σ} {wfΣ : wf Σ} Γ f f' u u' : is_closed_context Γ -> is_open_term Γ f -> is_open_term Γ f' -> - eq_term_upto_univ_napp Σ (eq_universe Σ) (leq_universe Σ) #|u| f f' -> + compare_term_napp Σ Σ Cumul #|u| f f' -> ws_cumul_pb_terms Σ Γ u u' -> Σ ;;; Γ ⊢ mkApps f u ≤ mkApps f' u'. Proof. @@ -1464,7 +1464,7 @@ Qed. Lemma positive_cstr_arg_subst {cf} {Σ} {wfΣ : wf Σ} {ind mdecl idecl Γ t u u'} : declared_inductive Σ ind mdecl idecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> - R_opt_variance (eq_universe Σ) (leq_universe Σ) (ind_variance mdecl) u u' -> + cmp_opt_variance (compare_universe Σ) Cumul (match ind_variance mdecl with Some var => Variance var | None => AllEqual end) u u' -> closed_ctx (ind_arities mdecl ,,, Γ)@[u] -> Σ ;;; subst_instance u (ind_arities mdecl) ,,, subst_instance u Γ ⊢ (subst_instance u t) ≤ (subst_instance u' t) -> positive_cstr_arg mdecl Γ t -> @@ -1523,7 +1523,7 @@ Proof. rewrite /ind_subst !inds_spec !rev_mapi !nth_error_mapi. unshelve epose proof (declm' := declared_minductive_to_gen declm); eauto. rewrite H2 /=. simpl. constructor. simpl. - unfold R_global_instance, R_global_instance_gen. simpl. + unfold cmp_global_instance, cmp_global_instance_gen. simpl. assert(declared_inductive Σ {| inductive_mind := inductive_mind ind; inductive_ind := Nat.pred #|ind_bodies mdecl| - (k - #|Γ|) |} mdecl i). @@ -1586,7 +1586,7 @@ Lemma positive_cstr_closed_args_subst_arities {cf} {Σ} {wfΣ : wf Σ} {u u' Γ} declared_inductive Σ ind mdecl idecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> on_constructor cumulSpec0 (lift_typing typing) (Σ.1, ind_universes mdecl) mdecl i idecl ind_indices cdecl cs -> - R_opt_variance (eq_universe Σ) (leq_universe Σ) (ind_variance mdecl) u u' -> + cmp_opt_variance (compare_universe Σ) Cumul (match ind_variance mdecl with Some var => Variance var | None => AllEqual end) u u' -> closed_ctx (subst_instance u (ind_params mdecl)) -> wf_local Σ (subst_instance u (ind_arities mdecl ,,, smash_context [] (ind_params mdecl) ,,, Γ)) -> All_local_env (fun Γ j => positive_cstr_arg mdecl ([] ,,, (smash_context [] (ind_params mdecl) ,,, Γ)) (j_typ j)) Γ -> @@ -1636,7 +1636,7 @@ Lemma positive_cstr_closed_args {cf} {Σ} {wfΣ : wf Σ} {u u'} {ind mdecl idecl cdecl} : declared_constructor Σ ind mdecl idecl cdecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> - R_opt_variance (eq_universe Σ) (leq_universe Σ) (ind_variance mdecl) u u' -> + cmp_opt_variance (compare_universe Σ) Cumul (match ind_variance mdecl with Some var => Variance var | None => AllEqual end) u u' -> ws_cumul_ctx_pb_rel Cumul Σ (subst_instance u (ind_arities mdecl) ,,, subst_instance u (smash_context [] (PCUICEnvironment.ind_params mdecl))) @@ -1720,13 +1720,13 @@ Section Betweenu. Definition betweenu_level_expr (s : LevelExpr.t) := betweenu_level (LevelExpr.get_level s). - Definition betweenu_universe0 (u : LevelAlgExpr.t) := + Definition betweenu_universe (u : Universe.t) := LevelExprSet.for_all betweenu_level_expr u. - Definition betweenu_universe (u : Universe.t) := + Definition betweenu_sort (u : sort) := match u with - | Universe.lProp | Universe.lSProp => true - | Universe.lType l => betweenu_universe0 l + | sProp | sSProp => true + | sType u => betweenu_universe u end. Definition betweenu_instance (u : Instance.t) := @@ -2030,7 +2030,7 @@ Proof. rewrite is_closed_context_subst_instance app_context_nil_l //. Qed. -(** Morally, if variance_universes l = v i i' and R_universe_instance_variance l u u' then +(** Morally, if variance_universes l = v i i' and cmp_universe_instance_variance l u u' then i and i' can be substituted respectively by u and u'. The hard part is to show that (Σ.1, v) can also be turned into Σ by instanciating i and i' by u and u'. @@ -2042,7 +2042,7 @@ Lemma ws_cumul_pb_inst_variance {cf} {le} {Σ} {wfΣ : wf Σ} {mdecl l v i i' u variance_universes (PCUICEnvironment.ind_universes mdecl) l = Some (v, i, i') -> consistent_instance_ext Σ (ind_universes mdecl) u -> consistent_instance_ext Σ (ind_universes mdecl) u' -> - R_universe_instance_variance (eq_universe Σ) (leq_universe Σ) l u u' -> + cmp_universe_instance_variance (compare_universe Σ) Cumul l u u' -> forall t t', (Σ.1, v) ;;; Γ@[i] ⊢ t@[i] ≤[le] t'@[i'] -> Σ ;;; Γ@[u] ⊢ t@[u] ≤[le] t'@[u']. @@ -2110,16 +2110,16 @@ Proof. induction l in u, u', Ru, lenu, lenlu |- *. simpl in *. destruct u, u'; intro; rewrite ConstraintSetFact.empty_iff //. destruct u, u' => //; simpl in *. - destruct Ru as [Ra Rl]. - specialize (IHl u u' Rl). do 2 forward IHl by lia. + depelim Ru. rename H into Ra. + specialize (IHl u u' Ru). do 2 forward IHl by lia. destruct a => //; intros x; rewrite ConstraintSetFact.add_iff; intros [<-|inx]; auto. - + do 7 red in Ra; rewrite checku in Ra; + + do 5 red in Ra; rewrite checku in Ra; specialize (Ra _ sat); simpl in Ra. constructor. lia. - + do 6 red in Ra. rewrite checku in Ra. + + do 4 red in Ra. rewrite checku in Ra. specialize (Ra _ sat). - constructor. now rewrite !Universes.LevelAlgExpr.val_make in Ra. + constructor. now rewrite !Universes.Universe.val_make in Ra. Qed. Lemma All2_fold_inst {cf} {le} {Σ} {wfΣ : wf Σ} mdecl l v i i' u u' Γ' Γ : @@ -2128,7 +2128,7 @@ Lemma All2_fold_inst {cf} {le} {Σ} {wfΣ : wf Σ} mdecl l v i i' u u' Γ' Γ : consistent_instance_ext Σ (ind_universes mdecl) u -> consistent_instance_ext Σ (ind_universes mdecl) u' -> variance_universes (PCUICEnvironment.ind_universes mdecl) l = Some (v, i, i') -> - R_universe_instance_variance (eq_universe Σ) (leq_universe Σ) l u u' -> + cmp_universe_instance_variance (compare_universe Σ) Cumul l u u' -> ws_cumul_ctx_pb_rel le (Σ.1, v) (subst_instance i Γ') (subst_instance i Γ) (subst_instance i' Γ) -> ws_cumul_ctx_pb_rel le Σ (subst_instance u Γ') (subst_instance u Γ) (subst_instance u' Γ). Proof. @@ -2310,12 +2310,36 @@ Proof. eapply on_free_vars_ctx_impl => //. Qed. +Lemma cmp_global_instance_ind_inv {cf} {Σ} {wfΣ : wf Σ} cmp_universe pb ind mdecl idecl napp u u' : + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe pb) -> + declared_inductive Σ ind mdecl idecl -> + cmp_global_instance Σ cmp_universe pb (IndRef ind) napp u u' -> + ((context_assumptions (ind_indices idecl) + context_assumptions (ind_params mdecl) <= napp × + ∑ l, ind_variance mdecl = Some l × + cmp_universe_instance_variance cmp_universe pb l u u') + + cmp_universe_instance (cmp_universe Conv) u u')%type. +Proof. + intros Hsub decli. + destruct (on_declared_inductive decli) as [onmind oib]. + unshelve epose proof (decli' := declared_inductive_to_gen decli); eauto. + unfold cmp_global_instance, cmp_global_instance_gen, global_variance. + rewrite (declared_inductive_lookup_gen decli'). + rewrite oib.(ind_arity_eq). + rewrite !destArity_it_mkProd_or_LetIn. simpl. + rewrite app_context_nil_l context_assumptions_app. + elim: leb_spec_Set => // comp. 2: now right. + destruct ind_variance eqn:indv => //. 2: now right. + move/cmp_opt_variance_var_dec => [|H]. 1: now right. + left. + now repeat eexists. +Qed. + Lemma inductive_cumulative_indices {cf} {Σ} {wfΣ : wf Σ} : forall {ind mdecl idecl u u' napp}, declared_inductive Σ ind mdecl idecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> consistent_instance_ext Σ (ind_universes mdecl) u' -> - R_global_instance Σ (eq_universe Σ) (leq_universe Σ) (IndRef ind) napp u u' -> + cmp_ind_universes Σ ind napp u u' -> forall Γ pars pars' parsubst parsubst', spine_subst Σ Γ pars parsubst (subst_instance u (ind_params mdecl)) -> spine_subst Σ Γ pars' parsubst' (subst_instance u' (ind_params mdecl)) -> @@ -2328,11 +2352,11 @@ Lemma inductive_cumulative_indices {cf} {Σ} {wfΣ : wf Σ} : Proof. intros * decli. destruct (on_declared_inductive decli) as [onmind oib]. - intros cu cu' Ru Γ * spu spu' cpars *. move: Ru. + intros cu cu' Ru Γ * spu spu' cpars *. unshelve epose proof (decli' := declared_inductive_to_gen decli); eauto. assert (onu : on_udecl_prop Σ (ind_universes mdecl)). { eapply (weaken_lookup_on_global_env' _ _ _ wfΣ (proj1 decli')). } - unfold R_global_instance, R_global_instance_gen. + unfold cmp_global_instance, cmp_global_instance_gen. assert (closed_ctx (subst_instance u (PCUICEnvironment.ind_params mdecl))) as clpu. @@ -2364,22 +2388,12 @@ Proof. rewrite closedn_ctx_app /=. rewrite (closed_wf_local _ (spine_dom_wf _ _ _ _ _ spu)) /=. eapply closedn_ctx_upwards; tea. lia. } - destruct global_variance_gen eqn:gv. - { move:gv. - simpl. unfold lookup_inductive. - rewrite (declared_inductive_lookup_gen decli'). - rewrite oib.(ind_arity_eq). - rewrite !destArity_it_mkProd_or_LetIn. simpl. - rewrite app_context_nil_l context_assumptions_app. - elim: leb_spec_Set => // comp. - destruct ind_variance eqn:indv => //. - move=> [=] eq. subst l0. - pose proof (oib.(onIndices)) as respv. + eapply cmp_global_instance_ind_inv in Ru as [(comp & l & indv & Ru) | Ru]; tea; tc. + { pose proof (oib.(onIndices)) as respv. rewrite indv in respv. simpl in respv. unfold ind_respects_variance in respv. destruct variance_universes as [[[v i] i']|] eqn:vu => //. - simpl => Ru. pose proof (onVariance onmind) as onvari. rewrite indv in onvari. eapply cumul_ctx_relSpec_Algo in respv. @@ -2545,7 +2559,7 @@ Lemma constructor_cumulative_indices {cf} {Σ} {wfΣ : wf Σ} : declared_constructor Σ c mdecl idecl cdecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> consistent_instance_ext Σ (ind_universes mdecl) u' -> - R_global_instance Σ (eq_universe Σ) (leq_universe Σ) (IndRef c.1) napp u u' -> + cmp_ind_universes Σ c.1 napp u u' -> forall Γ pars pars' parsubst parsubst', spine_subst Σ Γ pars parsubst (subst_instance u (ind_params mdecl)) -> spine_subst Σ Γ pars' parsubst' (subst_instance u' (ind_params mdecl)) -> @@ -2567,13 +2581,12 @@ Lemma constructor_cumulative_indices {cf} {Σ} {wfΣ : wf Σ} : Proof. intros * declc. destruct (on_declared_constructor declc) as [[onmind oib] [cs [hnth onc]]]. - intros cu cu' Ru Γ * spu spu' cpars *. move: Ru. + intros cu cu' Ru Γ * spu spu' cpars *. unshelve epose proof (declc' := declared_constructor_to_gen declc); eauto. assert (onu : on_udecl_prop Σ (ind_universes mdecl)). { eapply (weaken_lookup_on_global_env' _ _ _ wfΣ (proj1 (proj1 declc'))). } have clΓ : is_closed_context Γ. { apply spine_dom_wf in spu; eauto with fvs. } - unfold R_global_instance, R_global_instance_gen. assert (closed_ctx (subst_instance u (PCUICEnvironment.ind_params mdecl))) as clpu. @@ -2592,23 +2605,14 @@ Proof. { apply spine_codom_wf in spu; eauto with fvs. } have clΓparsu' : is_closed_context (Γ ,,, (ind_params mdecl)@[u']). { apply spine_codom_wf in spu'; eauto with fvs. } - destruct global_variance_gen eqn:gv. - { move:gv. - simpl. unfold lookup_inductive. - rewrite (declared_inductive_lookup_gen declc'.p1). - rewrite oib.(ind_arity_eq). - rewrite !destArity_it_mkProd_or_LetIn. simpl. - rewrite app_context_nil_l context_assumptions_app. - elim: leb_spec_Set => // comp. - destruct ind_variance eqn:indv => //. - move=> [=] eq. subst l0. - pose proof (onc.(on_ctype_variance)) as respv. + eapply cmp_global_instance_ind_inv in Ru as [(comp & l & indv & Ru) | Ru]; eauto; tc. + 3: apply declc.p1. + { pose proof (onc.(on_ctype_variance)) as respv. specialize (respv _ indv). simpl in respv. unfold cstr_respects_variance in respv. destruct variance_universes as [[[v i] i']|] eqn:vu => //. destruct respv as [args idx]. - simpl => Ru. pose proof (onVariance onmind) as onvari. rewrite indv in onvari. assert (wf_local Σ @@ -2790,7 +2794,7 @@ Proof. { simpl. assert (wf_local Σ Γ) by apply spu. epose proof (on_constructor_inst declc _ cu) as [wfargs spinst]. - intros Ru; split. + split. { rewrite /pargctx /pargctx' /argctx /argctx'. rewrite !(smash_context_subst []). unshelve eapply (substitution_ws_cumul_ctx_pb_subst_conv (Γ'' := []) _ _ spu spu') => //. @@ -2983,7 +2987,7 @@ Lemma projection_cumulative_indices {cf} {Σ} {wfΣ : wf Σ} : on_udecl_prop Σ (ind_universes mdecl) -> consistent_instance_ext Σ (ind_universes mdecl) u -> consistent_instance_ext Σ (ind_universes mdecl) u' -> - R_global_instance Σ (eq_universe Σ) (leq_universe Σ) (IndRef p.(proj_ind)) (ind_npars mdecl) u u' -> + cmp_ind_universes Σ p.(proj_ind) (ind_npars mdecl) u u' -> Σ ;;; projection_context p.(proj_ind) mdecl idecl u ⊢ subst_instance u pdecl.(proj_type) ≤ subst_instance u' pdecl.(proj_type). Proof. @@ -3007,25 +3011,11 @@ Proof. simpl in *. destruct s as [idecl' [idecl'nth _ _ pty pty']]. rewrite -pty. - unfold R_global_instance, R_global_instance_gen in Ru. - unfold global_variance_gen, lookup_inductive, lookup_minductive in Ru. destruct declp' as [[[? ?] ?] ?]. red in H0. - unfold lookup_inductive_gen, lookup_minductive_gen in Ru. - rewrite H0 H1 in Ru. - rewrite oib.(ind_arity_eq) in Ru. - rewrite !destArity_it_mkProd_or_LetIn /= in Ru. destruct p0 as [p0 _]. - destruct (context_assumptions _ <=? _) eqn:eq. - 2:{ - rewrite app_context_nil_l context_assumptions_app in eq. - eapply Nat.leb_nle in eq. - destruct onps. - apply length_nil in on_projs_noidx. - rewrite on_projs_noidx in eq. simpl in *. - rewrite p0.(onNpars) in eq. lia. } epose proof (declared_projection_closed declp). pose proof (wf_projection_context _ _ declp cu) as wfpctx. - destruct (ind_variance mdecl) eqn:eqv; revgoals. + eapply cmp_global_instance_ind_inv in Ru as [(comp & l & eqv & Ru) | Ru]; eauto; tc; revgoals. { eapply into_ws_cumul_pb; cycle 1. { eauto with fvs. } { rewrite -is_open_term_closed. @@ -3072,7 +3062,7 @@ Proof. rewrite subst_instance_app_ctx in onctx. epose proof (positive_cstr_closed_args declp cu) as hpos. rewrite eqv in hpos; simpl in hpos. - specialize (hpos Ru). + forward hpos. 1: now right. rewrite - !(subst_instance_smash _ _ []) in hpos. rewrite - !(expand_lets_smash_context _ []) in hpos. apply hpos in onctx. clear hpos. @@ -3145,7 +3135,7 @@ Qed. Lemma wt_ind_app_variance {cf} {Σ} {wfΣ : wf Σ} {Γ ind u l}: isType Σ Γ (mkApps (tInd ind u) l) -> ∑ mdecl, (lookup_inductive Σ ind = Some mdecl) * - (global_variance Σ (IndRef ind) #|l| = ind_variance (fst mdecl)). + (global_variance Σ (IndRef ind) #|l| = match ind_variance (fst mdecl) with Some var => Variance var | None => AllEqual end). Proof. intros (_ & s & wat & _). eapply inversion_mkApps in wat as [ty [Hind Hargs]]; auto. @@ -3280,7 +3270,7 @@ Proof. depelim wf. eapply type_Cumul'. econstructor; eauto. eapply isType_Sort; eauto. - now eapply PCUICWfUniverses.typing_wf_universe in Hs. + now eapply PCUICWfUniverses.typing_wf_sort in Hs. eapply convSpec_cumulSpec, red1_cumulSpec. repeat constructor. - intros T (_ & s & Hs & _). @@ -3289,7 +3279,7 @@ Proof. have wf := typing_wf_local Hs. depelim wf. pose proof (lift_sorting_extract l). - eapply has_sort_isType with (s := Universe.sort_of_product _ s). + eapply has_sort_isType with (s := Sort.sort_of_product _ s). econstructor; eauto. Qed. @@ -3308,9 +3298,9 @@ Proof. eapply context_conversion; tea. 1: now eapply All_local_env_app. eapply eq_binder_annots_eq_ctx in ha. - eapply eq_context_upto_univ_conv_context. - eapply eq_context_upto_cat. - 1: reflexivity. + eapply eq_context_upto_names_conv_context. + eapply All2_app. + 2: reflexivity. symmetry; apply ha. Qed. @@ -3319,7 +3309,7 @@ Lemma WfArity_build_case_predicate_type {cf:checker_flags} {Σ Γ ci args mdecl declared_inductive Σ.1 ci.(ci_ind) mdecl idecl -> isType Σ Γ (mkApps (tInd ci p.(puinst)) (pparams p ++ args)) -> let params := firstn (ind_npars mdecl) args in - wf_universe Σ ps -> + wf_sort Σ ps -> wf_predicate mdecl idecl p -> isWfArity Σ Γ (it_mkProd_or_LetIn (case_predicate_context ci mdecl idecl p) (tSort ps)). Proof. @@ -3586,7 +3576,7 @@ Lemma wf_case_predicate_context {cf : checker_flags} {Σ : global_env_ext} {wfΣ Proof. intros isdecl Hc wfp predctx. epose proof (WfArity_build_case_predicate_type wfΣ isdecl Hc - (PCUICWfUniverses.wf_universe_type1 Σ) wfp). + (PCUICWfUniverses.wf_sort_type1 Σ) wfp). destruct X. eapply isType_it_mkProd_or_LetIn_inv in i; tea. now eapply isType_wf_local in i. @@ -3632,7 +3622,8 @@ Proof. rewrite subst_instance_cons. rewrite /= subst_context_snoc /=. constructor. - { constructor. red. simpl. simpl in e. red in e. simpl in e. + { rewrite /= /subst_decl /map_decl /= /set_binder_name /=. relativize (subst _ _ _). + 1: constructor. red. simpl. simpl in e. red in e. simpl in e. rewrite -e. simpl in H. noconf H. reflexivity. simpl. rewrite subst_instance_mkApps subst_mkApps /=. f_equal. f_equal. @@ -3729,7 +3720,7 @@ Lemma wf_case_branch_type {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Proof. intros isdecl Hc wfp bc Hp ptm wfpctx. unshelve epose proof (isdecl' := declared_inductive_to_gen isdecl); eauto. - destruct (WfArity_build_case_predicate_type wfΣ isdecl Hc (PCUICWfUniverses.typing_wf_universe _ Hp) wfp) as [wfty _]. + destruct (WfArity_build_case_predicate_type wfΣ isdecl Hc (PCUICWfUniverses.typing_wf_sort _ Hp) wfp) as [wfty _]. set wfcpc := wf_case_predicate_context isdecl Hc wfp. simpl in wfcpc. clearbody wfcpc. have clipars : closed_ctx (subst_instance (puinst p) (ind_params mdecl)). { rewrite closedn_subst_instance_context. @@ -3986,7 +3977,7 @@ Proof. rewrite (declared_inductive_type isdecl). rewrite subst_instance_it_mkProd_or_LetIn subst_instance_app it_mkProd_or_LetIn_app. - have wfs : wf_universe Σ (subst_instance_univ (puinst p) (ind_sort idecl)). + have wfs : wf_sort Σ (subst_instance_sort (puinst p) (ind_sort idecl)). by eapply (on_inductive_sort_inst isdecl _ cu). have wfparinds : wf_local Σ (Γ,,, subst_instance (puinst p) (ind_params mdecl),,, @@ -4093,7 +4084,7 @@ Lemma wf_case_branch_type' {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Proof. intros isdecl Hc wfp bc Hp ptm wfpctx. unshelve epose proof (isdecl' := declared_inductive_to_gen isdecl); eauto. - destruct (WfArity_build_case_predicate_type wfΣ isdecl Hc (PCUICWfUniverses.typing_wf_universe _ Hp) wfp) as [wfty _]. + destruct (WfArity_build_case_predicate_type wfΣ isdecl Hc (PCUICWfUniverses.typing_wf_sort _ Hp) wfp) as [wfty _]. set wfcpc := wf_case_predicate_context isdecl Hc wfp. simpl in wfcpc. clearbody wfcpc. have clipars : closed_ctx (subst_instance (puinst p) (ind_params mdecl)). { rewrite closedn_subst_instance_context. @@ -4348,7 +4339,7 @@ Proof. rewrite (declared_inductive_type isdecl). rewrite subst_instance_it_mkProd_or_LetIn subst_instance_app it_mkProd_or_LetIn_app. - have wfs : wf_universe Σ (subst_instance_univ (puinst p) (ind_sort idecl)). + have wfs : wf_sort Σ (subst_instance_sort (puinst p) (ind_sort idecl)). by eapply (on_inductive_sort_inst isdecl _ cu). have wfparinds : wf_local Σ (Γ,,, subst_instance (puinst p) (ind_params mdecl),,, @@ -4486,7 +4477,7 @@ Lemma wf_case_branches_types' {cf : checker_flags} {Σ : global_env_ext} {wfΣ : 0 (ind_ctors idecl) brs. Proof. intros isdecl Hc wfp bc Hp ptm wfbrs conv. - destruct (WfArity_build_case_predicate_type wfΣ isdecl Hc (PCUICWfUniverses.typing_wf_universe _ Hp) wfp) as [wfty _]. + destruct (WfArity_build_case_predicate_type wfΣ isdecl Hc (PCUICWfUniverses.typing_wf_sort _ Hp) wfp) as [wfty _]. set wfcpc := wf_case_predicate_context isdecl Hc wfp. simpl in wfcpc. clearbody wfcpc. have clipars : closed_ctx (subst_instance (puinst p) (ind_params mdecl)). { rewrite closedn_subst_instance_context. diff --git a/pcuic/theories/PCUICInductives.v b/pcuic/theories/PCUICInductives.v index 0adf71126..2ed8d9f79 100644 --- a/pcuic/theories/PCUICInductives.v +++ b/pcuic/theories/PCUICInductives.v @@ -282,7 +282,7 @@ Section OnInductives. wf_local Σ Γ -> consistent_instance_ext Σ (ind_universes mdecl) u -> isType Σ Γ (it_mkProd_or_LetIn (subst_instance u (ind_params mdecl ,,, idecl.(ind_indices))) - (tSort (subst_instance_univ u idecl.(ind_sort)))). + (tSort (subst_instance_sort u idecl.(ind_sort)))). Proof using decli wfΣ. move=> wfΓ cext. destruct (on_declared_inductive decli) as [onmind oib]. @@ -315,7 +315,7 @@ Section OnInductives. Local Definition oi := (on_declared_inductive decli).1. Local Definition oib := (on_declared_inductive decli).2. - Lemma on_inductive_sort : wf_universe (Σ.1, ind_universes mdecl) (ind_sort idecl). + Lemma on_inductive_sort : wf_sort (Σ.1, ind_universes mdecl) (ind_sort idecl). Proof using decli wfΣ. pose proof (oib.(onArity)) as ar. rewrite oib.(ind_arity_eq) in ar. @@ -323,16 +323,16 @@ Section OnInductives. eapply typing_wf_universes in ar; auto. move/andP: ar => []. rewrite wf_universes_it_mkProd_or_LetIn => /andP [] _. - now rewrite wf_universes_it_mkProd_or_LetIn => /andP [] _ /= /wf_universe_reflect. + now rewrite wf_universes_it_mkProd_or_LetIn => /andP [] _ /= /wf_sort_reflect. Qed. Lemma on_inductive_sort_inst u : consistent_instance_ext Σ (ind_universes mdecl) u -> - wf_universe Σ (subst_instance u (ind_sort idecl)). + wf_sort Σ (subst_instance u (ind_sort idecl)). Proof using decli wfΣ. generalize on_inductive_sort => wf. destruct Σ. intros cu. - eapply wf_universe_instantiate; eauto. + eapply wf_sort_instantiate; eauto. now eapply consistent_instance_ext_wf. Qed. @@ -1247,7 +1247,7 @@ Proof. simpl in oib. pose proof (onProjs.(on_projs_noidx _ _ _ _ _ _)). destruct (ind_indices idecl); simpl in H; try discriminate. - simpl. rewrite [subst_instance_univ _ _]sortu. + simpl. rewrite [subst_instance_sort _ _]sortu. eapply ws_cumul_pb_compare => //. now eapply wf_local_closed_context in X0. constructor. reflexivity. @@ -1524,8 +1524,8 @@ Proof. Qed. Lemma type_local_ctx_cum {cf:checker_flags} {Σ Γ Δ s s'} : - wf Σ.1 -> wf_universe Σ s' -> - leq_universe (global_ext_constraints Σ) s s' -> + wf Σ.1 -> wf_sort Σ s' -> + leq_sort (global_ext_constraints Σ) s s' -> type_local_ctx (lift_typing typing) Σ Γ Δ s -> type_local_ctx (lift_typing typing) Σ Γ Δ s'. Proof. @@ -1541,7 +1541,7 @@ Qed. Lemma type_local_ctx_wf {cf:checker_flags} {Σ Γ Δ s} : wf Σ.1 -> type_local_ctx (lift_typing typing) Σ Γ Δ s -> - wf_universe Σ s. + wf_sort Σ s. Proof. intros wfΣ. induction Δ as [|[na [b|] ty] Δ]; simpl; intuition auto. @@ -1551,7 +1551,7 @@ Lemma isType_it_mkProd_or_LetIn {cf:checker_flags} Σ Γ Δ s s': wf Σ.1 -> wf_local Σ Γ -> type_local_ctx (lift_typing typing) Σ Γ Δ s -> - wf_universe Σ s' -> + wf_sort Σ s' -> isType Σ Γ (it_mkProd_or_LetIn Δ (tSort s')). Proof. move=> wfΣ wfΓ wfΔ wfs. @@ -1573,7 +1573,7 @@ Proof. induction Δ as [|[na [b|] ty] Δ] using ctx_length_rev_ind; simpl in *; auto; rewrite !it_mkProd_or_LetIn_app /= /mkProd_or_LetIn /=; rewrite smash_context_app; intros Γ u Hu. - simpl. - assert (wfu := typing_wf_universe wfΣ Hu). + assert (wfu := typing_wf_sort wfΣ Hu). eapply inversion_LetIn in Hu as (T & wfty & HT & hlt); auto. eapply substitution_let in HT; auto. rewrite /subst1 subst_it_mkProd_or_LetIn /= in HT. @@ -1584,7 +1584,7 @@ Proof. specialize (X _ _ HT). now rewrite -smash_context_subst /= subst_context_nil. - simpl. rewrite it_mkProd_or_LetIn_app. simpl. - assert (wfu := typing_wf_universe wfΣ Hu). + assert (wfu := typing_wf_sort wfΣ Hu). eapply inversion_Prod in Hu as (s1 & s2 & wfty & Ht & hlt); auto. specialize (X Δ ltac:(reflexivity)). specialize (X _ _ Ht). @@ -1600,7 +1600,7 @@ Lemma typing_spine_to_extended_list {cf:checker_flags} Σ Δ u s : typing_spine Σ (smash_context [] (subst_instance u Δ)) (subst_instance u (it_mkProd_or_LetIn Δ (tSort s))) (to_extended_list (smash_context [] (subst_instance u Δ))) - (tSort (subst_instance_univ u s)). + (tSort (subst_instance_sort u s)). Proof. move=> wfΣ wfΔ. apply wf_arity_spine_typing_spine; auto. @@ -1635,7 +1635,7 @@ Proof. assert(wfsmash : wf_local Σ (smash_context [] (subst_instance u (ind_params mdecl)))). { eapply wf_local_smash_context; auto. } constructor; auto. red. - eapply @has_sort_isType with (s := subst_instance_univ u (ind_sort idecl)). + eapply @has_sort_isType with (s := subst_instance_sort u (ind_sort idecl)). eapply type_mkApps. econstructor; eauto. eapply decli.p1. rewrite (ind_arity_eq oib0). pose proof (on_projs_noidx _ _ _ _ _ _ onps). @@ -2427,7 +2427,7 @@ Lemma isType_case_predicate {cf : checker_flags} {Σ : global_env_ext} {wfΣ : w wf_local Σ Γ -> declared_inductive Σ ci mdecl idecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> - wf_universe Σ ps -> + wf_sort Σ ps -> spine_subst Σ Γ params (List.rev params) (smash_context [] (subst_instance u (ind_params mdecl))) -> isType Σ Γ (it_mkProd_or_LetIn @@ -2449,7 +2449,7 @@ Proof. rewrite subst_let_expand_it_mkProd_or_LetIn in Hs. eapply type_it_mkProd_or_LetIn_inv in Hs as (idxs & inds & [sortsidx sortind leq]). eapply has_sort_isType with (s := sort_of_products (subst_instance u (ind_sort idecl) :: idxs) - (Universe.super ps)). + (Sort.super ps)). set (idxctx := subst_context_let_expand _ _ _) in *. have tyass : Σ ;;; Γ ,,, idxctx |- subst (List.rev params) #|ind_indices idecl| (decl_type iass)@[u] : tSort (ind_sort idecl)@[u]. @@ -2527,7 +2527,7 @@ Lemma arity_spine_case_predicate {cf: checker_flags} {Σ : global_env_ext} {wfΣ wf_local Σ Γ -> declared_inductive Σ ci mdecl idecl -> consistent_instance_ext Σ (ind_universes mdecl) u -> - wf_universe Σ ps -> + wf_sort Σ ps -> spine_subst Σ Γ params (List.rev params) (smash_context [] (subst_instance u (ind_params mdecl))) -> spine_subst Σ Γ indices (List.rev indices) diff --git a/pcuic/theories/PCUICInversion.v b/pcuic/theories/PCUICInversion.v index 26b721b44..ec70dbba1 100644 --- a/pcuic/theories/PCUICInversion.v +++ b/pcuic/theories/PCUICInversion.v @@ -135,8 +135,8 @@ Section Inversion. forall {Γ s T}, Σ ;;; Γ |- tSort s : T -> wf_local Σ Γ × - wf_universe Σ s × - Σ ;;; Γ ⊢ tSort (Universe.super s) ≤ T. + wf_sort Σ s × + Σ ;;; Γ ⊢ tSort (Sort.super s) ≤ T. Proof using wfΣ. intros Γ s T h. invtac h. Qed. @@ -147,7 +147,7 @@ Section Inversion. ∑ s1 s2, lift_typing typing Σ Γ (j_vass_s na A s1) × Σ ;;; Γ ,, vass na A |- B : tSort s2 × - Σ ;;; Γ ⊢ tSort (Universe.sort_of_product s1 s2) ≤ T. + Σ ;;; Γ ⊢ tSort (Sort.sort_of_product s1 s2) ≤ T. Proof using wfΣ. intros Γ na A B T h. invtac h. Qed. @@ -157,7 +157,7 @@ Section Inversion. forall H : Σ ;;; Γ |- tProd na A B : T, ∑ s1 s2 (H1 : lift_typing typing Σ Γ (j_vass_s na A s1)) (H2 : Σ ;;; Γ ,, vass na A |- B : tSort s2), lift_typing_size (@typing_size _ _ _) _ H1 < typing_size H × typing_size H2 < typing_size H × - Σ ;;; Γ ⊢ tSort (Universe.sort_of_product s1 s2) ≤ T. + Σ ;;; Γ ⊢ tSort (Sort.sort_of_product s1 s2) ≤ T. Proof using wfΣ. intros Γ na A B T h. unshelve invtac h; eauto. all: try revert l; try revert l0; simpl; cbn; lia. @@ -246,7 +246,7 @@ Section Inversion. Import PCUICEquality. Variant case_inversion_data Γ ci p c brs mdecl idecl indices := | case_inv - (ps : Universe.t) + (ps : sort) (eq_npars : mdecl.(ind_npars) = ci.(ci_npar)) (predctx := case_predicate_context ci.(ci_ind) mdecl idecl p) (wf_pred : wf_predicate mdecl idecl p) diff --git a/pcuic/theories/PCUICNormal.v b/pcuic/theories/PCUICNormal.v index 43892439e..45b8d09bd 100644 --- a/pcuic/theories/PCUICNormal.v +++ b/pcuic/theories/PCUICNormal.v @@ -1052,7 +1052,7 @@ Proof. eauto. - depelim o. 1-2: reflexivity. eapply red_primArray_congr; eauto. - now eapply Universe.make_inj in e. + now eapply Universe.make'_inj in e. Qed. #[global] @@ -1211,7 +1211,7 @@ Qed. Definition fake_params n : context := unfold n (fun x => {| decl_name := {| binder_name := nAnon; binder_relevance := Relevant |}; decl_body := None; - decl_type := tSort Universe.type0 |}). + decl_type := tSort Sort.type0 |}). Lemma fake_params_length n : #|fake_params n| = n. Proof. @@ -1549,20 +1549,20 @@ Proof. now depelim r. Qed. -Lemma whne_eq_term_upto_univ_napp f Σ Γ t Re Rle napp t' : +Lemma whne_eq_term_upto_univ_napp f Σ Γ t cmp_universe cmp_sort pb napp t' : whne f Σ Γ t -> - eq_term_upto_univ_napp Σ Re Rle napp t t' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp t t' -> whne f Σ Γ t'. Proof. intros wh eq. - induction wh in Re, Rle, napp, t, t', eq, wh |- *; depelim eq; + induction wh in pb, napp, t, t', eq, wh |- *; depelim eq; try solve [eauto using whne; depelim wh; solve_discr; eauto using whne]. - destruct args as [|? ? _] using MCList.rev_ind; [discriminate x|]. rewrite mkApps_app in x; cbn in x; inv x. apply eq_term_upto_univ_napp_mkApps_l_inv in eq1 as (?&?&(eq_hds&?)&->). depelim eq_hds. rewrite <- mkApps_snoc. - assert (All2 (eq_term_upto_univ Σ Re Re) (args ++ [x0]) (x1 ++ [u'])) + assert (All2 (eq_term_upto_univ Σ cmp_universe cmp_sort Conv) (args ++ [x0]) (x1 ++ [u'])) by (now apply All2_app). unfold unfold_fix in *. destruct (nth_error mfix idx) eqn:nth; [|easy]. @@ -1573,18 +1573,18 @@ Proof. destruct e0 as (?&?&?). eapply whne_fixapp. + unfold unfold_fix. - rewrite e1. + rewrite e2. reflexivity. + rewrite <- e. - destruct p. rewrite e3. reflexivity. + destruct p as (?& eqrarg &?). rewrite eqrarg. reflexivity. + eapply IHwh; eauto. - destruct args using MCList.rev_ind; [|rewrite mkApps_app in x; discriminate x]. now rewrite nth_error_nil in e0. Qed. -Lemma whnf_eq_term_upto_univ_napp f Σ Γ t Re Rle napp t' : +Lemma whnf_eq_term_upto_univ_napp f Σ Γ t cmp_universe cmp_sort pb napp t' : whnf f Σ Γ t -> - eq_term_upto_univ_napp Σ Re Rle napp t t' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp t t' -> whnf f Σ Γ t'. Proof. intros wh eq. @@ -1606,11 +1606,11 @@ Proof. - apply eq_term_upto_univ_napp_mkApps_l_inv in eq as (?&?&(?&?)&->). depelim e. apply whnf_fixapp. destruct o as [[? [? ?]] |]. - eapply All2_nth_error_Some in a; eauto. - destruct a as (?&?&((? & ?)&?)&?). + eapply All2_nth_error_Some in e; eauto. + destruct e as (? & e & ? & ? & e2 & ?). rewrite e. left; eexists; split; eauto. rewrite <- e2. eapply All2_nth_error_None; eauto. - apply All2_length in a. + apply All2_length in e. right. apply nth_error_None. apply nth_error_None in H. lia. diff --git a/pcuic/theories/PCUICParallelReductionConfluence.v b/pcuic/theories/PCUICParallelReductionConfluence.v index 8113dfdd1..19af08874 100644 --- a/pcuic/theories/PCUICParallelReductionConfluence.v +++ b/pcuic/theories/PCUICParallelReductionConfluence.v @@ -3198,7 +3198,7 @@ Section Rho. Definition fake_params n : context := unfold n (fun x => {| decl_name := {| binder_name := nAnon; binder_relevance := Relevant |}; decl_body := None; - decl_type := tSort Universe.type0 |}). + decl_type := tSort Sort.type0 |}). Lemma context_assumptions_fake_params n : context_assumptions (fake_params n) = n. diff --git a/pcuic/theories/PCUICPrincipality.v b/pcuic/theories/PCUICPrincipality.v index 0c0cd6d99..4f3da8802 100644 --- a/pcuic/theories/PCUICPrincipality.v +++ b/pcuic/theories/PCUICPrincipality.v @@ -60,7 +60,7 @@ Section Principality. Lemma isWfArity_sort Γ u : wf_local Σ Γ -> - wf_universe Σ u -> + wf_sort Σ u -> isWfArity Σ Γ (tSort u). Proof using Type. move=> wfΓ wfu. @@ -86,7 +86,7 @@ Section Principality. - apply inversion_Evar in hA. destruct hA. - apply inversion_Sort in hA as iA. 2: auto. repeat outsum. repeat outtimes. subst. - exists (tSort (Universe.super s)). + exists (tSort (Sort.super s)). int inversion_Sort. repeat outsum. repeat outtimes. now subst. - apply inversion_Prod in hA as (dom1 & codom1 & t & t0 & w); auto. @@ -97,7 +97,7 @@ Section Principality. eapply ws_cumul_pb_Sort_r_inv in e as [domu [red leq]]. destruct (Hcodom _ t0) as [e e'']. eapply ws_cumul_pb_Sort_r_inv in e as [codomu [cored coleq]]. - exists (tSort (Universe.sort_of_product domu codomu)). + exists (tSort (Sort.sort_of_product domu codomu)). int inversion_Prod. destruct hB as (x & x0 & t1 & t2 & w0). apply unlift_TypUniv in t1. @@ -107,7 +107,7 @@ Section Principality. destruct (Hcodom _ t2) as [le'' u2']. eapply ws_cumul_pb_Sort_r_inv in le'' as [u'' [redu'' leu'']]. constructor => //. fvs. constructor. - apply leq_universe_product_mon; auto. + apply leq_sort_product_mon; auto. pose proof (closed_red_confluence red redu') as [v' [redl redr]]. eapply invert_red_sort in redl. eapply invert_red_sort in redr. subst. now noconf redr. @@ -362,10 +362,8 @@ Lemma principal_type_ind {cf:checker_flags} {Σ Γ c ind u u' args args'} {wfΣ: Σ ;;; Γ |- c : mkApps (tInd ind u) args -> Σ ;;; Γ |- c : mkApps (tInd ind u') args' -> (∑ ui', - PCUICEquality.R_global_instance Σ.1 (eq_universe (global_ext_constraints Σ)) - (leq_universe (global_ext_constraints Σ)) (IndRef ind) #|args| ui' u * - PCUICEquality.R_global_instance Σ.1 (eq_universe (global_ext_constraints Σ)) - (leq_universe (global_ext_constraints Σ)) (IndRef ind) #|args'| ui' u') * + cmp_ind_universes Σ ind #|args| ui' u * + cmp_ind_universes Σ ind #|args'| ui' u') * ws_cumul_pb_terms Σ Γ args args'. Proof. intros h h'. @@ -415,46 +413,25 @@ Proof. eapply eq_term_upto_univ_empty_impl; auto; typeclasses eauto. Qed. -Lemma eq_context_empty_eq_context {cf:checker_flags} {Σ : global_env_ext} {x y} : - eq_context_upto empty_global_env (eq_universe Σ) (eq_universe Σ) x y -> - eq_context_upto Σ (eq_universe Σ) (eq_universe Σ) x y. +Lemma eq_context_empty_eq_context {cf:checker_flags} {Σ : global_env_ext} {cmp_universe cmp_sort pb} {x y} : + eq_context_upto empty_global_env cmp_universe cmp_sort pb x y -> + eq_context_upto Σ cmp_universe cmp_sort pb x y. Proof. intros. eapply All2_fold_impl; tea. - intros ???? []; constructor; eauto using eq_term_empty_eq_term. - all:now apply eq_term_empty_eq_term. -Qed. - -Notation eq_term_napp Σ n x y := - (eq_term_upto_univ_napp Σ (eq_universe Σ) (eq_universe Σ) n x y). - -Notation leq_term_napp Σ n x y := - (eq_term_upto_univ_napp Σ (eq_universe Σ) (leq_universe Σ) n x y). - -Lemma eq_term_upto_univ_napp_leq {cf:checker_flags} {Σ : global_env_ext} {n x y} : - eq_term_napp Σ n x y -> - leq_term_napp Σ n x y. -Proof. - eapply eq_term_upto_univ_impl; auto; typeclasses eauto. -Qed. - -Lemma R_global_instance_empty_universe_instance Re Rle ref napp u u' : - R_global_instance empty_global_env Re Rle ref napp u u' -> - R_universe_instance Re u u'. -Proof. - rewrite /R_global_instance_gen. - now rewrite global_variance_empty. + intros ???? []; constructor; eauto. + all: eapply eq_term_upto_univ_empty_impl; tea; tc. Qed. Lemma eq_context_upto_inst_case_context {cf : checker_flags} {Σ : global_env_ext} pars pars' puinst puinst' ctx : - All2 (eq_term_upto_univ empty_global_env (eq_universe Σ) (eq_universe Σ)) pars pars' -> - R_universe_instance (eq_universe Σ) puinst puinst' -> - eq_context_upto Σ.1 (eq_universe Σ) (eq_universe Σ) (inst_case_context pars puinst ctx) + All2 (eq_term_upto_univ empty_global_env (compare_universe Σ) (compare_sort Σ) Conv) pars pars' -> + cmp_universe_instance (eq_universe Σ) puinst puinst' -> + eq_context_upto Σ.1 (compare_universe Σ) (compare_sort Σ) Conv (inst_case_context pars puinst ctx) (inst_case_context pars' puinst' ctx). Proof. intros onps oninst. rewrite /inst_case_context. - eapply eq_context_upto_subst_context. tc. + eapply eq_context_upto_subst_context. 1,2: tc. eapply eq_context_upto_univ_subst_instance; tc; auto. eapply All2_rev. eapply All2_impl; tea. intros. now eapply eq_term_empty_eq_term. @@ -495,9 +472,9 @@ Proof. all:try solve [econstructor; eauto]. - eapply inversion_Sort in X0 as [wf [wfs cum]]; auto. - eapply type_Cumul' with (tSort (Universe.super s)). + eapply type_Cumul' with (tSort (Sort.super s)). constructor; auto. eapply PCUICArities.isType_Sort; pcuic. - apply cumul_Sort. now apply leq_universe_super. + apply cumul_Sort. now apply leq_sort_super. - eapply inversion_Prod in X4 as [s1' [s2' [Ha [Hb Hs]]]]; auto. apply eq_term_empty_leq_term in X5_1 as X5_1'. @@ -665,7 +642,7 @@ Proof. eapply PCUICEquality.eq_term_upto_univ_it_mkLambda_or_LetIn; tea. tc. rewrite /predctx. rewrite /case_predicate_context /case_predicate_context_gen. - eapply eq_context_upto_map2_set_binder_name. tea. + eapply eq_context_upto_names_map2_set_binder_name. tea. rewrite /pre_case_predicate_context_gen. eapply eq_context_upto_inst_case_context => //. eapply All2_app. 2:constructor; pcuic. @@ -724,8 +701,8 @@ Proof. eapply type_Cumul_alt. econstructor; eauto. now eapply All_nth_error in X0. - eapply All2_nth_error in a; eauto. - destruct a as [[[eqty _] _] _]. + eapply All2_nth_error in e; eauto. + destruct e as (eqty & _). constructor. eapply eq_term_empty_leq_term in eqty. now eapply leq_term_empty_leq_term. @@ -733,8 +710,8 @@ Proof. eapply type_Cumul_alt. econstructor; eauto. now eapply All_nth_error in X0. - eapply All2_nth_error in a; eauto. - destruct a as [[[eqty _] _] _]. + eapply All2_nth_error in e; eauto. + destruct e as (eqty & _). constructor. apply eq_term_empty_leq_term in eqty. now eapply leq_term_empty_leq_term. @@ -750,10 +727,10 @@ Proof. simp prim_type in w |- *. eapply (ws_cumul_pb_Axiom_l_inv (args := [_])) in w as [u' [args' []]]; tea. 2:eapply declared_constant_from_gen, H0. 2:eapply p. eapply cumulAlgo_cumulSpec. etransitivity. now eapply red_ws_cumul_pb. - eapply All2_tip_l in a3 as [y' [-> Heq]]. red in r. eapply Forall2_map_inv in r. - eapply Forall2_tip_l in r. cbn. eapply ws_cumul_pb_eq_le. + eapply All2_tip_l in a3 as [y' [-> Heq]]. red in c0. + eapply Forall2_tip_l in c0. cbn. eapply ws_cumul_pb_eq_le. eapply (ws_cumul_pb_mkApps (args := [_]) (args' := [_])). - * constructor; fvs. constructor. red. eapply Forall2_map. destruct r as [? [-> eq]]. constructor. symmetry. + * constructor; fvs. constructor. red. destruct c0 as [? [-> eq]]. constructor. symmetry. etransitivity; tea. now symmetry. constructor. * constructor; [|constructor]. symmetry. etransitivity; tea. constructor; fvs. symmetry. now eapply eq_term_empty_eq_term. diff --git a/pcuic/theories/PCUICProgress.v b/pcuic/theories/PCUICProgress.v index 2bc317750..3e19bd568 100644 --- a/pcuic/theories/PCUICProgress.v +++ b/pcuic/theories/PCUICProgress.v @@ -141,17 +141,17 @@ forall (P : global_env_ext -> context -> term -> term -> Type) PΓ Σ Γ -> P Σ Γ (tRel n) (lift0 (S n) decl.(decl_type))) -> - (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (u : Universe.t), + (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (u : sort), PΓ Σ Γ -> - wf_universe Σ u -> - P Σ Γ (tSort u) (tSort (Universe.super u))) -> + wf_sort Σ u -> + P Σ Γ (tSort u) (tSort (Sort.super u))) -> - (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (na : aname) (t b : term) (s1 s2 : Universe.t), + (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (na : aname) (t b : term) (s1 s2 : sort), PΓ Σ Γ -> lift_typing typing Σ Γ (j_vass_s na t s1) -> Pj Σ Γ (j_vass_s na t s1) -> Σ ;;; Γ,, vass na t |- b : tSort s2 -> - P Σ (Γ,, vass na t) b (tSort s2) -> P Σ Γ (tProd na t b) (tSort (Universe.sort_of_product s1 s2))) -> + P Σ (Γ,, vass na t) b (tSort s2) -> P Σ Γ (tProd na t b) (tSort (Sort.sort_of_product s1 s2))) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (na : aname) (t b bty : term), PΓ Σ Γ -> @@ -329,17 +329,17 @@ Lemma typing_ind_env `{cf : checker_flags} : PΓ Σ Γ -> P Σ Γ (tRel n) (lift0 (S n) decl.(decl_type))) -> - (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (u : Universe.t), + (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (u : sort), PΓ Σ Γ -> - wf_universe Σ u -> - P Σ Γ (tSort u) (tSort (Universe.super u))) -> + wf_sort Σ u -> + P Σ Γ (tSort u) (tSort (Sort.super u))) -> - (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (na : aname) (t b : term) (s1 s2 : Universe.t), + (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (na : aname) (t b : term) (s1 s2 : sort), PΓ Σ Γ -> lift_typing typing Σ Γ (j_vass_s na t s1) -> Pj Σ Γ (j_vass_s na t s1) -> Σ ;;; Γ,, vass na t |- b : tSort s2 -> - P Σ (Γ,, vass na t) b (tSort s2) -> P Σ Γ (tProd na t b) (tSort (Universe.sort_of_product s1 s2))) -> + P Σ (Γ,, vass na t) b (tSort s2) -> P Σ Γ (tProd na t b) (tSort (Sort.sort_of_product s1 s2))) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (na : aname) (t b bty : term), PΓ Σ Γ -> diff --git a/pcuic/theories/PCUICSN.v b/pcuic/theories/PCUICSN.v index fbd8706d4..a8a2af995 100644 --- a/pcuic/theories/PCUICSN.v +++ b/pcuic/theories/PCUICSN.v @@ -7,6 +7,7 @@ From MetaCoq.PCUIC Require Import PCUICUnivSubstitutionTyp. Require Import Equations.Prop.DepElim. +Require Import ssreflect. (** We assume normalization of the reduction. We state is as well-foundedness of the reduction. @@ -61,7 +62,7 @@ Section Alpha. Context {cf : checker_flags} {no : normalizing_flags}. Context (Σ : global_env_ext) {normalization : NormalizationIn Σ}. - Notation eqt u v := (∥ upto_names u v ∥). + Notation eqt u v := (∥ eq u v ∥). (* Can be made into alpha-equality, but not using PCUICEquality.eq_term_upto_univ_napp *) Definition cored' Γ u v := exists u' v', cored Σ Γ u' v' /\ eqt u u' /\ eqt v v'. @@ -83,15 +84,9 @@ Section Alpha. + eapply cored_trans'. all: eassumption. Qed. - Local Instance substu_pres_eq : SubstUnivPreserving eq. + Local Instance substu_pres_eq {T} `{UnivSubst T} : SubstUnivPreserving eq (@eq T). Proof using Type. - red. intros s u u'. - unfold R_universe_instance. - intros f. eapply Forall2_map_inv in f. - assert (u = u') as ->. - { induction f; cbn; auto. f_equal; auto. - now eapply Universe.make_inj in H. } - reflexivity. + move => s u u' /cmp_universe_instance_eq -> //. Qed. Lemma cored'_postpone : @@ -103,17 +98,16 @@ Section Alpha. apply cored_alt in r. destruct r as [r]. induction r in u, v, hu, hv. - - eapply red1_eq_term_upto_univ_r in r. 10: eassumption. - all:tc. - destruct r as [u' [r e]]. + - (* eapply red1_eq_alpha in r as [u' [r e]]. *) + subst x. rename y into u'. exists u'. split. * constructor. assumption. * constructor. etransitivity. 1: eauto. now symmetry. - specialize (IHr1 y v). - destruct IHr1 as [y' [h1 [e1]]]; auto. reflexivity. + destruct IHr1 as [y' [h1 [e1]]]; auto. specialize (IHr2 u y'). - destruct IHr2 as [u' [h2 ?]]; auto. now symmetry. + destruct IHr2 as [u' [h2 ?]]; auto. exists u'. split. + eapply cored_trans'. all: eauto. + assumption. @@ -171,7 +165,6 @@ Section Alpha. - constructor; reflexivity. Qed. - (* TODO Maybe switch to eq_context *) Lemma cored_eq_context_upto_names : forall Γ Δ u v, eq_context_upto_names Γ Δ -> @@ -187,102 +180,6 @@ Section Alpha. + eapply IHh1. assumption. Qed. - Lemma cored_eq_term_upto : - forall Σ' Re Rle Γ u v u', - RelationClasses.Reflexive Re -> - SubstUnivPreserving Re -> - RelationClasses.Reflexive Rle -> - SubstUnivPreserving Rle -> - RelationClasses.Symmetric Re -> - RelationClasses.Transitive Re -> - RelationClasses.Transitive Rle -> - RelationClasses.subrelation Re Rle -> - eq_term_upto_univ Σ' Re Rle u u' -> - cored Σ Γ v u -> - exists v', cored Σ Γ v' u' /\ ∥ eq_term_upto_univ Σ' Re Rle v v' ∥. - Proof using Type. - intros Σ' Re Rle Γ u v u' X X0 X1 X2 X3 X4 X5 X6 e h. - apply cored_alt in h as [h]. - induction h in u', e |- *. - - eapply red1_eq_term_upto_univ_l in r. 9: eauto. all: auto. - destruct r as [? [? ?]]. - eexists. split. - + constructor. eassumption. - + constructor. assumption. - - specialize (IHh1 _ e). destruct IHh1 as [y' [r1 [e1]]]. - specialize (IHh2 _ e1). destruct IHh2 as [z' [r2 [e2]]]. - exists z'. split. - + eapply cored_trans'. all: eassumption. - + constructor. assumption. - Qed. - - Lemma cored_eq_context_upto : - forall Σ' Re Γ Δ u v, - RelationClasses.Reflexive Re -> - RelationClasses.Symmetric Re -> - RelationClasses.Transitive Re -> - SubstUnivPreserving Re -> - eq_context_upto Σ' Re Re Γ Δ -> - cored Σ Γ u v -> - exists u', cored Σ Δ u' v /\ ∥ eq_term_upto_univ Σ' Re Re u u' ∥. - Proof using Type. - intros Σ' Re Γ Δ u v hRe1 hRe2 hRe3 hRe4 e h. - apply cored_alt in h as [h]. - induction h. - - eapply red1_eq_context_upto_l in r. all: eauto. 2:tc. - destruct r as [? [? ?]]. - eexists. split. - + constructor. eassumption. - + constructor. assumption. - - destruct IHh1 as [x' [r1 [e1]]]. - destruct IHh2 as [y' [r2 [e2]]]. - eapply cored_eq_term_upto in r2. 10: exact e1. all: auto. - 2:tc. - destruct r2 as [y'' [r2' [e2']]]. - exists y''. split. - * eapply cored_trans'. all: eassumption. - * constructor. eapply eq_term_upto_univ_trans. all: eauto. - Qed. - - (* Lemma eq_context_upto_nlctx : - forall Γ, - eq_context_upto Σ eq eq Γ (nlctx Γ). - Proof. - intros Γ. - induction Γ as [| [na [b|] A] Γ ih ]. - - constructor. - - simpl. constructor; simpl; try apply binder_anonymize; tas. - + constructor; tas; auto. eapply eq_term_upto_univ_tm_nl. - all: auto. - eapply eq_term_upto_univ_tm_nl. - all: auto. - - simpl. constructor; auto. constructor. - + apply binder_anonymize. - + simpl. eapply eq_term_upto_univ_tm_nl. - all: auto. - Qed. - - Lemma cored_cored'_nl : - forall Γ u v, - cored Σ Γ u v -> - cored' (nlctx Γ) (nl u) (nl v). - Proof. - intros Γ u v h. - eapply cored_eq_context_upto in h. - 6: eapply eq_context_upto_nlctx. - all: auto. - - destruct h as [u' [r [e]]]. - eexists _, _. intuition eauto. - + constructor. eapply eq_term_trans. - * eapply eq_term_sym. eapply eq_term_tm_nl. - * eapply eq_term_upto_univ_impl; eauto. all:typeclasses eauto. - + constructor. eapply eq_term_sym. eapply eq_term_tm_nl. - - intros ? ? ? []. auto. - - intros ? ? ? r. apply Forall2_eq in r. apply map_inj in r. - + subst. reflexivity. - + apply Universe.make_inj. - Qed. *) - Lemma cored_cored' : forall Γ u v, cored Σ Γ u v -> diff --git a/pcuic/theories/PCUICSR.v b/pcuic/theories/PCUICSR.v index 80bc0632f..4642b5c6f 100644 --- a/pcuic/theories/PCUICSR.v +++ b/pcuic/theories/PCUICSR.v @@ -26,7 +26,7 @@ Derive Signature for OnOne2_local_env. Ltac rename_hyp h ht ::= my_rename_hyp h ht. Arguments Nat.sub : simpl nomatch. -Arguments Universe.sort_of_product : simpl nomatch. +Arguments Sort.sort_of_product : simpl nomatch. (* Preservation of wf_*fixpoint *) @@ -170,13 +170,8 @@ Qed. #[global] Hint Extern 0 (conv_context _ _ _) => constructor : pcuic. #[global] Hint Extern 0 (cumul_context _ _ _) => constructor : pcuic. -#[global] Hint Extern 4 (∑ s : Universe.t, typing _ _ ?T (tSort s)) => - match goal with - | [ H : isType _ _ T |- _ ] => exact H - end : pcuic. - Ltac unfold_pcuic := - progress (unfold PCUICTypingDef.typing, PCUICLookup.wf_universe in * ). + progress (unfold PCUICTypingDef.typing, PCUICLookup.wf_sort in * ). #[global] Hint Extern 10 => unfold_pcuic : pcuic. #[global] Hint Resolve red_conv red1_red red_cumul : pcuic. @@ -410,22 +405,21 @@ Qed. (** The crucial property on constructors of cumulative inductive types for type preservation: we don't need to compare their instances when fully applied. *) -Lemma R_global_instance_cstr_irrelevant {cf} {Σ} {wfΣ : wf Σ} {ci c} {mdecl idecl cdecl u u'} : +Lemma cmp_global_instance_cstr_irrelevant {cf} {Σ} {wfΣ : wf Σ} {ci c} {mdecl idecl cdecl u u'} : declared_constructor Σ (ci, c) mdecl idecl cdecl -> - R_ind_universes Σ ci (context_assumptions (ind_params mdecl) + #|cstr_indices cdecl|) u u' -> - R_global_instance Σ.1 (eq_universe Σ) (eq_universe Σ) (ConstructRef ci c) + cmp_ind_universes Σ ci (context_assumptions (ind_params mdecl) + #|cstr_indices cdecl|) u u' -> + cmp_global_instance Σ.1 (compare_universe Σ) Conv (ConstructRef ci c) (ind_npars mdecl + context_assumptions (cstr_args cdecl)) u u'. Proof. intros declc. pose proof (on_declared_constructor declc). pose proof (on_declared_constructor declc) as [[onind oib] [ctor_sorts [hnth onc]]]. - intros Hu. pose proof (R_global_instance_length _ _ _ _ _ _ _ Hu). - rewrite /R_global_instance_gen /R_opt_variance /= /lookup_constructor /lookup_constructor_gen. + intros Hu. pose proof (cmp_global_instance_length _ _ _ _ _ _ _ Hu). + rewrite /cmp_global_instance_gen /cmp_opt_variance /= /lookup_constructor /lookup_constructor_gen. unshelve epose proof (declc' := declared_constructor_to_gen declc); eauto. rewrite (declared_inductive_lookup_gen declc'.p1) (proj2 declc'). rewrite -(cstr_args_length onc). - case: leb_spec_Set; try lia. move=> _ /=; cbn. - now apply R_universe_instance_variance_irrelevant. + case: leb_spec_Set; try lia. Qed. Lemma wf_pre_case_branch_context {cf} {Σ} {wfΣ : wf Σ} {Γ ci mdecl idecl p} {br : branch term} {cdecl} : @@ -565,8 +559,8 @@ Proof. { eapply eq_context_upto_ws_cumul_ctx_pb => //. rewrite is_closed_context_set_binder_name //. apply eq_context_upto_cat. reflexivity. - apply eq_context_gen_eq_context_upto; tc. - apply eq_binder_annots_eq_context_gen_ctx => //. } + apply eq_context_upto_names_eq_context_upto; tc. + apply eq_binder_annots_eq => //. } depelim a; cbn in *; constructor; auto; eapply (ws_cumul_pb_ws_cumul_ctx (pb':=Conv)); tea. Qed. @@ -1750,9 +1744,9 @@ Proof. assert(wfparu : wf_local Σ (subst_instance (puinst p) (ind_params mdecl))). { eapply on_minductive_wf_params; eauto. destruct isdecl; eauto. } - assert (wfps : wf_universe Σ ps). + assert (wfps : wf_sort Σ ps). { eapply validity in IHp; auto. eapply PCUICWfUniverses.isType_wf_universes in IHp; tea. - now apply (ssrbool.elimT PCUICWfUniverses.wf_universe_reflect) in IHp. } + move: IHp => /= /PCUICWfUniverses.wf_sort_reflect //. } have lenpars := (wf_predicate_length_pars H0). unfold hidebody in X8. set (ptm := it_mkLambda_or_LetIn _ _). @@ -2081,9 +2075,9 @@ Proof. { rewrite on_free_vars_mkApps /= //. } eapply eq_term_upto_univ_mkApps. 2:reflexivity. - constructor. eapply R_global_instance_sym; tc. + constructor. eapply cmp_global_instance_sym; tc. rewrite eqargs. - now eapply (R_global_instance_cstr_irrelevant declc). + now eapply (cmp_global_instance_cstr_irrelevant declc). - (* Case congruence: on a cofix, impossible *) eapply inversion_mkApps in typec as [? [tcof ?]] => //. @@ -2192,14 +2186,12 @@ Proof. eapply ws_cumul_pb_eq_le. eapply ws_cumul_pb_mkApps; pcuic. eapply All2_app => //. now apply: red_terms_ws_cumul_pb_terms. } set (pctx := (inst_case_predicate_context (set_pparams p params'))) in *. - pose proof (snd (All2_fold_All2 _) X1). symmetry in X9. move:X9. + pose proof X1 as X9. symmetry in X9. move:X9. change (pcontext p) with (pcontext (set_pparams p params')). move/(PCUICAlpha.inst_case_predicate_context_eq wfp') => eqctx. have wfpctx : wf_local Σ (Γ,,, inst_case_predicate_context (set_pparams p params')). { eapply wf_local_alpha; tea; auto. - eapply All2_app => //. - now eapply All2_fold_All2 in eqctx. - eapply All2_refl; reflexivity. } + eapply All2_app => //. reflexivity. } have eqpctx : Σ ⊢ Γ ,,, pctx = Γ ,,, case_predicate_context ci mdecl idecl (set_pparams p params'). { symmetry. rewrite /pctx. @@ -2208,7 +2200,7 @@ Proof. now eapply wf_local_closed_context. eapply upto_names_conv_context. eapply eq_context_upto_cat. apply eq_context_upto_refl; tc. - now apply eq_context_gen_upto. } + now apply eq_context_upto_names_eq_context_alpha. } epose proof (wf_case_branches_types' (p:=set_pparams p params') ps _ brs isdecl isty' wfp'). cbv zeta in X9; forward_keep X9. { eapply closed_context_conversion; tea. } diff --git a/pcuic/theories/PCUICSafeLemmata.v b/pcuic/theories/PCUICSafeLemmata.v index 928418908..7bc9cffb9 100644 --- a/pcuic/theories/PCUICSafeLemmata.v +++ b/pcuic/theories/PCUICSafeLemmata.v @@ -102,24 +102,6 @@ Section Lemmata. Context {cf : checker_flags}. Context (flags : RedFlags.t). - Instance All2_eq_refl Σ Re : - RelationClasses.Reflexive Re -> - CRelationClasses.Reflexive (All2 (eq_term_upto_univ Σ Re Re)). - Proof using Type. - intros h x. apply All2_same. reflexivity. - Qed. - - Instance All2_br_eq_refl Σ Re : - RelationClasses.Reflexive Re -> - CRelationClasses.Reflexive (All2 - (fun x y : branch term => - eq_context_upto Σ Re Re (bcontext x) (bcontext y) * - eq_term_upto_univ Σ Re Re (bbody x) (bbody y))). - Proof using Type. - intros h x. - apply All2_same; split; reflexivity. - Qed. - (* red is the reflexive transitive closure of one-step reduction and thus can't be used as well order. We thus define the transitive closure, but we take the symmetric version. @@ -223,7 +205,7 @@ Section Lemmata. Lemma welltyped_alpha Γ u v : welltyped Σ Γ u -> - eq_term_upto_univ empty_global_env eq eq u v -> + u ≡α v -> welltyped Σ Γ v. Proof using hΣ. intros [A h] e. @@ -342,30 +324,6 @@ Section Lemmata. destruct h; depelim wf; simpl in *. all: destruct l as (Hb & s & Hs & _); cbn in *; econstructor; eauto. Qed. - (* TODO: rename alpha_eq *) - Lemma compare_decls_conv Γ Γ' : - eq_context_upto_names Γ Γ' -> - conv_context cumulAlgo_gen Σ Γ Γ'. - Proof using Type. - intros. - induction X; constructor; auto. - destruct r; constructor; subst; auto; reflexivity. - Qed. - - Lemma compare_decls_eq_context Γ Γ' : - eq_context_upto_names Γ Γ' <~> - eq_context_gen eq eq Γ Γ'. - Proof using Type. - split; induction 1; constructor; auto. - Qed. - - Lemma alpha_eq_inst_case_context Γ Δ pars puinst : - eq_context_upto_names Γ Δ -> - eq_context_upto_names (inst_case_context pars puinst Γ) (inst_case_context pars puinst Δ). - Proof using Type. - intros. rewrite /inst_case_context. - now eapply alpha_eq_subst_context, alpha_eq_subst_instance. - Qed. Lemma welltyped_context : forall Γ t, @@ -453,11 +411,10 @@ Section Lemmata. rewrite /case_predicate_context /= /case_predicate_context_gen. rewrite /pre_case_predicate_context_gen. rewrite /inst_case_context. - apply compare_decls_conv. + apply eq_context_upto_names_conv_context. eapply All2_app. 2:{ reflexivity. } - eapply compare_decls_eq_context. apply (PCUICAlpha.inst_case_predicate_context_eq (ind:=ci) wf_pred). - cbn. apply compare_decls_eq_context. now symmetry. + cbn. now symmetry. - apply inversion_Case in typ as (?&?&?&?&[]&?); auto. econstructor; eauto. @@ -954,7 +911,7 @@ Section Lemmata. inversion e. reflexivity. Qed. - Hint Resolve cumul_refl conv_alt_red : core. + Hint Resolve cumul_refl cumul_alt : core. Hint Resolve cumul_refl : core. Lemma cored_red_cored : diff --git a/pcuic/theories/PCUICSpine.v b/pcuic/theories/PCUICSpine.v index 883a96c07..ad1208051 100644 --- a/pcuic/theories/PCUICSpine.v +++ b/pcuic/theories/PCUICSpine.v @@ -71,29 +71,23 @@ Lemma subslet_eq_context_alpha {cf} {Σ Γ s Δ Δ'} : Proof. intros eq subs. induction subs in Δ', eq |- *; depelim eq; try constructor. - * depelim c; constructor; auto. now subst. - * depelim c; subst; constructor; auto. -Qed. - -Lemma eq_context_alpha_conv {cf} {Σ} {wfΣ : wf Σ} {Γ Γ'} : - eq_context_upto_names Γ Γ' -> conv_context cumulAlgo_gen Σ Γ Γ'. -Proof. - intros a. - eapply eq_context_upto_empty_conv_context. - eapply All2_fold_All2. - eapply (All2_impl a). - intros ?? []; constructor; subst; auto; reflexivity. + * depelim e; constructor; auto. + * depelim e; subst; constructor; auto. Qed. Lemma wf_local_alpha {cf} {Σ} {wfΣ : wf Σ} Γ Γ' : eq_context_upto_names Γ Γ' -> wf_local Σ Γ -> wf_local Σ Γ'. Proof. - induction 1; intros h; depelim h; try constructor; auto. - all:depelim r; constructor; subst; auto. - all: eapply lift_typing_impl; tea; intros t T Hty. - all: eapply context_conversion; eauto. - all: now apply eq_context_alpha_conv. + induction 1; intros h. + 1: constructor. + apply All_local_env_tip in h as (h & hd). + apply All_local_env_snoc; auto. + replace (j_decl y) with (j_decl x : judgment). + 2: now destruct r. + eapply lift_typing_impl; tea; intros t T Hty. + eapply context_conversion; eauto. + now apply eq_context_upto_names_conv_context. Qed. Lemma subslet_eq_context_alpha_dom {cf} {Σ} {wfΣ : wf Σ} {Γ Γ' s Δ} : @@ -106,11 +100,11 @@ Proof. * now apply IHsubs. * eapply context_conversion; tea. eapply wf_local_alpha; tea. eapply typing_wf_local in t0. exact t0. - now eapply eq_context_alpha_conv. + now eapply eq_context_upto_names_conv_context. * now eapply IHsubs. * eapply context_conversion; tea. eapply wf_local_alpha; tea. eapply typing_wf_local in t0. exact t0. - now eapply eq_context_alpha_conv. + now eapply eq_context_upto_names_conv_context. Qed. @@ -441,7 +435,7 @@ Section WfEnv. Lemma arity_typing_spine {Γ Γ' s inst s'} : typing_spine Σ Γ (it_mkProd_or_LetIn Γ' (tSort s)) inst (tSort s') -> - [× (#|inst| = context_assumptions Γ'), leq_universe (global_ext_constraints Σ) s s' & + [× (#|inst| = context_assumptions Γ'), leq_sort (global_ext_constraints Σ) s s' & ∑ instsubst, spine_subst Σ Γ inst instsubst Γ']. Proof using wfΣ. revert s inst s'. @@ -1044,8 +1038,8 @@ Qed.*) Hint Resolve spine_subst_is_closed_context spine_subst_is_closed_context_codom : fvs. Lemma arity_spine_it_mkProd_or_LetIn_Sort {Γ ctx s s' args inst} : - wf_universe Σ s' -> - leq_universe Σ s s' -> + wf_sort Σ s' -> + leq_sort Σ s s' -> spine_subst Σ Γ args inst ctx -> arity_spine Σ Γ (it_mkProd_or_LetIn ctx (tSort s)) args (tSort s'). Proof using wfΣ. @@ -1708,17 +1702,17 @@ Section WfEnv. ∑ Δs ts, [× sorts_local_ctx (lift_typing typing) Σ Γ Δ Δs, Σ ;;; Γ ,,, Δ |- t : tSort ts, - wf_universe Σ s & - leq_universe Σ (sort_of_products Δs ts) s]. + wf_sort Σ s & + leq_sort Σ (sort_of_products Δs ts) s]. Proof using wfΣ. intros h. revert Γ t s h. induction Δ; intros. - - exists [], s; splits. apply h. eauto with pcuic. apply leq_universe_refl. + - exists [], s; splits. apply h. eauto with pcuic. apply leq_sort_refl. - destruct a as [na [b|] ty]; simpl in *; rewrite /mkProd_or_LetIn /= in h. * specialize (IHΔ _ _ _ h) as (Δs & ts & [sorts IHΔ leq]). exists Δs, ts. - pose proof (PCUICWfUniverses.typing_wf_universe _ IHΔ) as wfts. + pose proof (PCUICWfUniverses.typing_wf_sort _ IHΔ) as wfts. eapply inversion_LetIn in IHΔ as (T & wfty & HT & hlt); auto. split; eauto. eapply (type_ws_cumul_pb (pb:=Cumul)). eapply HT. apply isType_Sort; pcuic. @@ -1744,21 +1738,21 @@ Section WfEnv. eapply inversion_Prod in IHΔ as (s1 & s2 & wfty & Ht & hlt); tea. exists (s1 :: Δs), s2. split; tea. split; tas. eapply ws_cumul_pb_Sort_inv in hlt. - transitivity (sort_of_products Δs ts); auto using leq_universe_product. - simpl. eapply leq_universe_sort_of_products_mon. + transitivity (sort_of_products Δs ts); auto using leq_sort_product. + simpl. eapply leq_sort_sort_of_products_mon. eapply Forall2_same. reflexivity. exact: hlt. Qed. - Lemma leq_universe_sort_of_products {u v} : - leq_universe Σ v (sort_of_products u v). + Lemma leq_sort_sort_of_products {u v} : + leq_sort Σ v (sort_of_products u v). Proof using Type. induction u; simpl; auto. - reflexivity. - etransitivity; tea. - eapply leq_universe_sort_of_products_mon => //. + eapply leq_sort_sort_of_products_mon => //. eapply Forall2_same. reflexivity. - eapply leq_universe_product. + eapply leq_sort_product. Qed. Lemma inversion_it_mkProd_or_LetIn {Γ Δ t s} : @@ -1768,8 +1762,8 @@ Section WfEnv. move/type_it_mkProd_or_LetIn_inv => [Δs [ts [hΔ ht hs leq]]]. eapply type_Cumul; tea. eapply type_Sort; pcuic. eapply cumul_Sort. - transitivity (sort_of_products Δs ts); auto using leq_universe_product. - apply leq_universe_sort_of_products. + transitivity (sort_of_products Δs ts); auto using leq_sort_product. + apply leq_sort_sort_of_products. Qed. Lemma isType_it_mkProd_or_LetIn_app {Γ Δ Δ' args T s} : diff --git a/pcuic/theories/PCUICSubstitution.v b/pcuic/theories/PCUICSubstitution.v index 216c08374..a363d8e7a 100644 --- a/pcuic/theories/PCUICSubstitution.v +++ b/pcuic/theories/PCUICSubstitution.v @@ -1223,24 +1223,24 @@ Proof. rewrite -{3}H. now rewrite simpl_subst_k. Qed. -Lemma subst_compare_term {cf:checker_flags} le Σ (φ : ConstraintSet.t) (l : list term) (k : nat) (T U : term) : - compare_term le Σ φ T U -> compare_term le Σ φ (subst l k T) (subst l k U). +Lemma subst_compare_term {cf:checker_flags} Σ (φ : ConstraintSet.t) pb (l : list term) (k : nat) (T U : term) : + compare_term Σ φ pb T U -> compare_term Σ φ pb (subst l k T) (subst l k U). Proof. - destruct le; simpl. + destruct pb; simpl. - apply subst_eq_term. - apply subst_leq_term. Qed. -Lemma subst_compare_decl `{checker_flags} {le Σ ϕ l k d d'} : - compare_decl le Σ ϕ d d' -> compare_decl le Σ ϕ (subst_decl l k d) (subst_decl l k d'). +Lemma subst_compare_decl `{checker_flags} {Σ ϕ pb l k d d'} : + compare_decl Σ ϕ pb d d' -> compare_decl Σ ϕ pb (subst_decl l k d) (subst_decl l k d'). Proof. - intros []; constructor; auto; destruct le; + intros []; constructor; auto; destruct pb; intuition eauto using subst_compare_term, subst_eq_term, subst_leq_term. Qed. -Lemma subst_compare_context `{checker_flags} le Σ φ l l' n k : - compare_context le Σ φ l l' -> - compare_context le Σ φ (subst_context n k l) (subst_context n k l'). +Lemma subst_compare_context `{checker_flags} Σ φ pb l l' n k : + compare_context Σ φ pb l l' -> + compare_context Σ φ pb (subst_context n k l) (subst_context n k l'). Proof. induction 1; rewrite ?subst_context_snoc /=; constructor; auto. erewrite (All2_fold_length X). simpl. @@ -1274,17 +1274,17 @@ Section CtxReduction. Qed. End CtxReduction. -Record wt_cumul_pb {cf} (c : conv_pb) Σ (Γ : context) T U := +Record wt_cumul_pb {cf} (pb : conv_pb) Σ (Γ : context) T U := { wt_cumul_pb_dom : isType Σ Γ T; wt_cumul_pb_codom : isType Σ Γ U; - wt_cumul_pb_eq : cumulAlgo_gen Σ Γ c T U }. + wt_cumul_pb_eq : cumulAlgo_gen Σ Γ pb T U }. -Arguments wt_cumul_pb_dom {cf c Σ Γ T U}. -Arguments wt_cumul_pb_codom {cf c Σ Γ T U}. -Arguments wt_cumul_pb_eq {cf c Σ Γ T U}. +Arguments wt_cumul_pb_dom {cf pb Σ Γ T U}. +Arguments wt_cumul_pb_codom {cf pb Σ Γ T U}. +Arguments wt_cumul_pb_eq {cf pb Σ Γ T U}. -Definition wt_cumul {cf} := wt_cumul_pb Cumul. -Definition wt_conv {cf} := wt_cumul_pb Conv. +Definition wt_cumul {cf} Σ Γ := wt_cumul_pb Cumul Σ Γ. +Definition wt_conv {cf} Σ Γ := wt_cumul_pb Conv Σ Γ. Notation " Σ ;;; Γ |- t <= u ✓" := (wt_cumul Σ Γ t u) (at level 50, Γ, t, u at next level). Notation " Σ ;;; Γ |- t = u ✓" := (wt_conv Σ Γ t u) (at level 50, Γ, t, u at next level). @@ -1313,10 +1313,10 @@ Reserved Notation " Σ ;;; Γ |-[ P ] t <=[ le ] u" (at level 50, Γ, t, u at ne format "Σ ;;; Γ |-[ P ] t <=[ le ] u"). Inductive cumulP {cf} (pb : conv_pb) (Σ : global_env_ext) (P : nat -> bool) (Γ : context) : term -> term -> Type := -| wt_cumul_refl t u : compare_term pb Σ.1 (global_ext_constraints Σ) t u -> Σ ;;; Γ |-[P] t <=[pb] u +| wt_cumul_refl t u : compare_term Σ.1 (global_ext_constraints Σ) pb t u -> Σ ;;; Γ |-[P] t <=[pb] u | wt_cumul_red_l t u v : red1P P Σ Γ t v -> Σ ;;; Γ |-[P] v <=[pb] u -> Σ ;;; Γ |-[P] t <=[pb] u | wt_cumul_red_r t u v : Σ ;;; Γ |-[P] t <=[pb] v -> red1P P Σ Γ u v -> Σ ;;; Γ |-[P] t <=[pb] u -where " Σ ;;; Γ |-[ P ] t <=[ le ] u " := (cumulP le Σ P Γ t u) : type_scope. +where " Σ ;;; Γ |-[ P ] t <=[ pb ] u " := (cumulP pb Σ P Γ t u) : type_scope. Notation " Σ ;;; Γ |-[ P ] t <= u " := (cumulP Cumul Σ P Γ t u) (at level 50, Γ, t, u at next level, format "Σ ;;; Γ |-[ P ] t <= u") : type_scope. @@ -1345,34 +1345,23 @@ Section SubstitutionLemmas. now rewrite shiftnPF_closedPT. Qed. - Lemma wt_cumul_pb_equalityP {le} {Γ : context} {T U} : wt_cumul_pb le Σ Γ T U -> cumulP le Σ (closedP #|Γ| xpredT) Γ T U. + Lemma wt_cumul_pb_equalityP {pb} {Γ : context} {T U} : wt_cumul_pb pb Σ Γ T U -> cumulP pb Σ (closedP #|Γ| xpredT) Γ T U. Proof using wfΣ. move=> [] dom. move: (isType_wf_local dom) => /closed_wf_local clΓ. rewrite closed_ctx_on_ctx_free_vars in clΓ; tea. move/isType_closedPT: dom => clT. move/isType_closedPT => clU cum. - destruct le. - { induction cum. - - constructor; auto. - - econstructor 2. - * econstructor; [|split]; tea. - * eapply IHcum => //. - now eapply red1_on_free_vars in r. - - econstructor 3. - * eapply IHcum => //. - now eapply red1_on_free_vars. - * econstructor; [|split]; tea. } - { induction cum. - - constructor; auto. - - econstructor 2. - * econstructor; [|split]; tea. - * eapply IHcum => //. - now eapply red1_on_free_vars in r. - - econstructor 3. - * eapply IHcum => //. - now eapply red1_on_free_vars. - * econstructor; [|split]; tea. } + induction cum. + - constructor; auto. + - econstructor 2. + * econstructor; [|split]; tea. + * eapply IHcum => //. + now eapply red1_on_free_vars in r. + - econstructor 3. + * eapply IHcum => //. + now eapply red1_on_free_vars. + * econstructor; [|split]; tea. Qed. Lemma substitution_red1 {Γ Γ' Γ'' s M N} : @@ -1859,10 +1848,10 @@ Qed. (** Substitution into a *well-typed* cumulativity/conversion derivation. *) -Lemma substitution_wt_cumul_pb {cf} {Σ} {wfΣ : wf Σ} {le Γ Γ' Γ'' s M N} : +Lemma substitution_wt_cumul_pb {cf} {Σ} {wfΣ : wf Σ} {pb Γ Γ' Γ'' s M N} : subslet Σ Γ s Γ' -> - wt_cumul_pb le Σ (Γ ,,, Γ' ,,, Γ'') M N -> - wt_cumul_pb le Σ (Γ ,,, subst_context s 0 Γ'') (subst s #|Γ''| M) (subst s #|Γ''| N). + wt_cumul_pb pb Σ (Γ ,,, Γ' ,,, Γ'') M N -> + wt_cumul_pb pb Σ (Γ ,,, subst_context s 0 Γ'') (subst s #|Γ''| M) (subst s #|Γ''| N). Proof. move=> Hs wteq; split. + eapply (isType_substitution Hs), wteq. @@ -1871,13 +1860,13 @@ Proof. - intros t u cmp. constructor. now eapply subst_compare_term. - move=> t u v red cum. - destruct le. + destruct pb. * eapply red_conv_conv. eapply substitution_let_red; tea; eauto with wf; apply red. * eapply red_cumul_cumul. eapply substitution_let_red; tea; eauto with wf; apply red. - move=> t u v red cum red'. - destruct le. + destruct pb. * eapply red_conv_conv_inv; tea. eapply substitution_let_red; tea; apply red'. * eapply red_cumul_cumul_inv; tea. diff --git a/pcuic/theories/PCUICTypedAst.v b/pcuic/theories/PCUICTypedAst.v index 92bba0678..c8d97d745 100644 --- a/pcuic/theories/PCUICTypedAst.v +++ b/pcuic/theories/PCUICTypedAst.v @@ -82,7 +82,7 @@ Inductive term {k : nat} : Type := | tRel (f : Fin.t k) | tVar (i : ident) (* For free variables (e.g. in a goal) *) | tEvar (n : nat) (l : list term) -| tSort (u : Universe.t) +| tSort (u : sort) | tProd (na : aname) (A : term) (B : @term Σ (S k)) | tLambda (na : aname) (A : term) (B : @term Σ (S k)) | tLetIn (na : aname) (b B : term) (t : @term Σ (S k)) diff --git a/pcuic/theories/PCUICTyping.v b/pcuic/theories/PCUICTyping.v index a64384466..c951c51f5 100644 --- a/pcuic/theories/PCUICTyping.v +++ b/pcuic/theories/PCUICTyping.v @@ -179,8 +179,8 @@ Variant primitive_typing_hyps `{checker_flags} | prim_int_hyps i : primitive_typing_hyps typing Σ Γ (primInt; primIntModel i) | prim_float_hyps f : primitive_typing_hyps typing Σ Γ (primFloat; primFloatModel f) | prim_array_hyps a - (wfl : wf_universe Σ (Universe.make a.(array_level))) - (hty : typing Σ Γ a.(array_type) (tSort (Universe.make a.(array_level)))) + (wfl : wf_universe Σ (Universe.make' a.(array_level))) + (hty : typing Σ Γ a.(array_type) (tSort (sType (Universe.make' a.(array_level))))) (hdef : typing Σ Γ a.(array_default) a.(array_type)) (hvalue : All (fun x => typing Σ Γ x a.(array_type)) a.(array_value)) : primitive_typing_hyps typing Σ Γ (primArray; primArrayModel a). @@ -200,13 +200,13 @@ Inductive typing `{checker_flags} (Σ : global_env_ext) (Γ : context) : term -> | type_Sort : forall s, wf_local Σ Γ -> - wf_universe Σ s -> - Σ ;;; Γ |- tSort s : tSort (Universe.super s) + wf_sort Σ s -> + Σ ;;; Γ |- tSort s : tSort (Sort.super s) | type_Prod : forall na A B s1 s2, lift_typing typing Σ Γ (j_vass_s na A s1) -> Σ ;;; Γ ,, vass na A |- B : tSort s2 -> - Σ ;;; Γ |- tProd na A B : tSort (Universe.sort_of_product s1 s2) + Σ ;;; Γ |- tProd na A B : tSort (Sort.sort_of_product s1 s2) | type_Lambda : forall na A t B, lift_typing typing Σ Γ (j_vass na A) -> @@ -552,7 +552,7 @@ Lemma env_prop_typing `{checker_flags} {P Pj PΓ} : env_prop P Pj PΓ -> Σ ;;; Γ |- t : T -> P Σ Γ t T. Proof. intros. now apply X. Qed. -Lemma type_Prop_wf `{checker_flags} Σ Γ : wf_local Σ Γ -> Σ ;;; Γ |- tSort Universe.lProp : tSort Universe.type1. +Lemma type_Prop_wf `{checker_flags} Σ Γ : wf_local Σ Γ -> Σ ;;; Γ |- tSort sProp : tSort Sort.type1. Proof. repeat constructor; auto. Defined. @@ -564,7 +564,7 @@ Proof. intros. now destruct (X _ wfΣ _ _ _ t) as [? [? ?]]. Qed. -Lemma type_Prop `{checker_flags} Σ : Σ ;;; [] |- tSort Universe.lProp : tSort Universe.type1. +Lemma type_Prop `{checker_flags} Σ : Σ ;;; [] |- tSort sProp : tSort Sort.type1. repeat constructor. Defined. @@ -662,17 +662,17 @@ Lemma typing_ind_env_app_size `{cf : checker_flags} : PΓ Σ Γ -> P Σ Γ (tRel n) (lift0 (S n) decl.(decl_type))) -> - (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (u : Universe.t), + (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (u : sort), PΓ Σ Γ -> - wf_universe Σ u -> - P Σ Γ (tSort u) (tSort (Universe.super u))) -> + wf_sort Σ u -> + P Σ Γ (tSort u) (tSort (Sort.super u))) -> - (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (na : aname) (t b : term) (s1 s2 : Universe.t), + (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (na : aname) (t b : term) (s1 s2 : sort), PΓ Σ Γ -> lift_typing typing Σ Γ (j_vass_s na t s1) -> Pj Σ Γ (j_vass_s na t s1) -> Σ ;;; Γ,, vass na t |- b : tSort s2 -> - P Σ (Γ,, vass na t) b (tSort s2) -> P Σ Γ (tProd na t b) (tSort (Universe.sort_of_product s1 s2))) -> + P Σ (Γ,, vass na t) b (tSort s2) -> P Σ Γ (tProd na t b) (tSort (Sort.sort_of_product s1 s2))) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (na : aname) (t b bty : term), PΓ Σ Γ -> @@ -839,7 +839,7 @@ Proof. destruct Xg. rename on_global_decl_d into Xg. constructor; auto; try constructor; auto. - * unshelve eset (IH' := IH ((Σ', udecl); (wfΣ; []; (tSort Universe.lProp); _; _))). + * unshelve eset (IH' := IH ((Σ', udecl); (wfΣ; []; (tSort sProp); _; _))). shelve. simpl. apply type_Prop. forward IH'. constructor 1; cbn. lia. apply IH'; auto. @@ -877,8 +877,7 @@ Proof. apply (IH (_; _; _; Hs)). } - pose proof (onProjections Xg); auto. - pose proof (ind_sorts Xg) as Xg'. unfold check_ind_sorts in *. - destruct Universe.is_prop; auto. - destruct Universe.is_sprop; auto. + destruct Sort.to_family; auto. split. apply Xg'. destruct indices_matter; auto. eapply type_local_ctx_impl. eapply Xg'. auto. intros ?? Hj. apply Xj; tas. apply lift_typing_impl with (1 := Hj); intros ?? HT. split; tas. @@ -1122,17 +1121,17 @@ Lemma typing_ind_env `{cf : checker_flags} : PΓ Σ Γ -> P Σ Γ (tRel n) (lift0 (S n) decl.(decl_type))) -> - (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (u : Universe.t), + (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (u : sort), PΓ Σ Γ -> - wf_universe Σ u -> - P Σ Γ (tSort u) (tSort (Universe.super u))) -> + wf_sort Σ u -> + P Σ Γ (tSort u) (tSort (Sort.super u))) -> - (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (na : aname) (t b : term) (s1 s2 : Universe.t), + (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (na : aname) (t b : term) (s1 s2 : sort), PΓ Σ Γ -> lift_typing typing Σ Γ (j_vass_s na t s1) -> Pj Σ Γ (j_vass_s na t s1) -> Σ ;;; Γ,, vass na t |- b : tSort s2 -> - P Σ (Γ,, vass na t) b (tSort s2) -> P Σ Γ (tProd na t b) (tSort (Universe.sort_of_product s1 s2))) -> + P Σ (Γ,, vass na t) b (tSort s2) -> P Σ Γ (tProd na t b) (tSort (Sort.sort_of_product s1 s2))) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (na : aname) (t b bty : term), PΓ Σ Γ -> diff --git a/pcuic/theories/PCUICValidity.v b/pcuic/theories/PCUICValidity.v index ded210af1..ca255c23c 100644 --- a/pcuic/theories/PCUICValidity.v +++ b/pcuic/theories/PCUICValidity.v @@ -45,7 +45,7 @@ Section Validity. eapply weaken_env_prop_typing; cbn; tas. 3: eassumption. all: assumption. Qed. - Lemma isType_Sort_inv {Σ : global_env_ext} {Γ s} : wf Σ -> isType Σ Γ (tSort s) -> wf_universe Σ s. + Lemma isType_Sort_inv {Σ : global_env_ext} {Γ s} : wf Σ -> isType Σ Γ (tSort s) -> wf_sort Σ s. Proof using Type. intros wfΣ (_ & u & Hu & _). now eapply inversion_Sort in Hu as [? [? ?]]. @@ -72,7 +72,7 @@ Section Validity. Proof using Type. destruct Σ as [Σ φ]. intros X X0 [isTy [ctx [s eq]]] X1. split. eapply isType_subst_instance_decl; eauto. - exists (subst_instance u ctx), (subst_instance_univ u s). + exists (subst_instance u ctx), (subst_instance_sort u s). rewrite (subst_instance_destArity []) eq. intuition auto. Qed. @@ -87,7 +87,7 @@ Section Validity. Qed. Notation type_ctx := (type_local_ctx (lift_typing typing)). - Lemma type_ctx_wf_univ Σ Γ Δ s : type_ctx Σ Γ Δ s -> wf_universe Σ s. + Lemma type_ctx_wf_univ Σ Γ Δ s : type_ctx Σ Γ Δ s -> wf_sort Σ s. Proof using Type. induction Δ as [|[na [b|] ty]]; simpl; auto with pcuic. Qed. @@ -95,23 +95,12 @@ Section Validity. Notation liat := ltac:(lia) (only parsing). - Lemma eq_binder_annots_eq_ctx (Σ : global_env_ext) (Δ : context) (nas : list aname) : + Lemma eq_binder_annots_eq_ctx (Δ : context) (nas : list aname) : All2 (fun x y => eq_binder_annot x y.(decl_name)) nas Δ -> - PCUICEquality.eq_context_gen (PCUICEquality.eq_term Σ Σ) (PCUICEquality.eq_term Σ Σ) - (map2 set_binder_name nas Δ) Δ. + PCUICEquality.eq_context_upto_names (map2 set_binder_name nas Δ) Δ. Proof using Type. - induction Δ in nas |- * using PCUICInduction.ctx_length_rev_ind; simpl; intros hlen. - - depelim hlen. simpl. reflexivity. - - destruct nas as [|nas na] using rev_case => //; - pose proof (All2_length hlen) as hlen';len in hlen'; simpl in hlen'; try lia. - eapply All2_app_inv_l in hlen as (l1'&l2'&heq&alnas&allna). - depelim allna. depelim allna. - rewrite map2_app => /= //; try lia. unfold aname. - eapply app_inj_tail in heq as [<- <-]. - simpl. eapply All2_fold_app; auto. - constructor. constructor. - destruct d as [na' [d|] ty]; constructor; cbn in *; auto; - try reflexivity. + induction 1; cbn; constructor; auto. + destruct y as [na [b|] t]; now constructor. Qed. Lemma eq_term_set_binder_name (Σ : global_env_ext) (Δ : context) T U (nas : list aname) : @@ -120,12 +109,12 @@ Section Validity. PCUICEquality.eq_term Σ Σ (it_mkProd_or_LetIn (map2 set_binder_name nas Δ) T) (it_mkProd_or_LetIn Δ U) . Proof using Type. intros a; unshelve eapply eq_binder_annots_eq_ctx in a; tea. - eapply All2_fold_All2 in a. induction a in T, U |- *. - auto. - rewrite /= /mkProd_or_LetIn. destruct r => /=; intros; eapply IHa; constructor; auto. + all: reflexivity. Qed. Lemma All2_eq_binder_subst_context_inst l s k i Δ Γ : @@ -185,7 +174,7 @@ Section Validity. Theorem validity_env : env_prop (fun Σ Γ t T => isType Σ Γ T) - (fun Σ Γ j => lift_sorting (fun _ T => isType Σ Γ T) (fun _ s => wf_universe Σ s) j) + (fun Σ Γ j => lift_sorting (fun _ T => isType Σ Γ T) (fun _ s => wf_sort Σ s) j) (fun Σ Γ => wf_local Σ Γ). Proof using Type. apply typing_ind_env; intros; rename_all_hyps. @@ -202,15 +191,15 @@ Section Validity. now eapply has_sort_isType. - (* Universe *) - eapply has_sort_isType with (s := Universe.super (Universe.super u)). + eapply has_sort_isType with (s := Sort.super (Sort.super u)). constructor; auto. - now apply wf_universe_super. + now apply wf_sort_super. - (* Product *) eapply has_sort_isType. apply unlift_TypUniv in X1; eapply isType_Sort_inv in X3; auto. econstructor; eauto. - now apply wf_universe_product. + now apply wf_sort_product. - (* Lambda *) eapply lift_sorting_ex_it_impl_gen with X3 => // Hs. @@ -225,7 +214,7 @@ Section Validity. - (* Application *) apply lift_sorting_it_impl_gen with X3 => // Hs'. - move: (typing_wf_universe wf Hs') => wfs. + move: (typing_wf_sort wf Hs') => wfs. eapply (substitution0 (n := na) (T := tSort _)); eauto. apply inversion_Prod in Hs' as [na' [s1 [s2 [Hs Hle]]]]; tas. eapply (weakening_ws_cumul_pb (pb:=Cumul) (Γ' := []) (Γ'' := [vass na A])) in Hle; pcuic. @@ -235,7 +224,7 @@ Section Validity. eapply into_ws_cumul_pb => //. all:eauto with fvs. do 2 constructor. - apply leq_universe_product. + apply leq_sort_product. - (* Constant *) eapply declared_constant_inv in wf as Hc; eauto. @@ -287,7 +276,7 @@ Section Validity. eapply has_sort_isType. eapply type_it_mkProd_or_LetIn_sorts; tea. exact X3.2.π2.1. } - have wfps : wf_universe Σ ps. + have wfps : wf_sort Σ ps. { pcuic. } eapply typing_spine_strengthen; tea. 2:{ rewrite /predctx /case_predicate_context /case_predicate_context_gen. @@ -353,12 +342,12 @@ Section Validity. depelim X0; depelim X1; simp prim_type; cbn in *. 1-2:destruct H1 as [hty hbod huniv]; eapply has_sort_isType with (s := _@[[]]); change (tSort ?s@[[]]) with (tSort s)@[[]]; rewrite <- hty; refine (type_Const _ _ _ [] _ wfΓ H0 _); rewrite huniv //. - set (s := (Universe.make (array_level a))). + set (s := sType (Universe.make' (array_level a))). destruct H1 as [hty' hbod huniv]. eapply has_sort_isType with s. eapply (type_App _ _ _ _ _ (tSort s)); tea; cycle 1. + eapply (type_Const _ _ _ [array_level a]) in H0; tea. rewrite hty' in H0. cbn in H0. exact H0. - red. rewrite huniv. simpl. rtoProp; intuition eauto. eapply LevelSet.mem_spec. eapply (wfl (array_level a, 0)). lsets. + red. rewrite huniv. simpl. rtoProp; intuition eauto. eapply LevelSet.mem_spec. eapply (wfl (array_level a, 0)). cbn. lsets. cbn. red. destruct check_univs => //. red. red. intros v H c. csets. + econstructor. 2: econstructor; eauto. repeat (eexists; tea). econstructor; eauto. diff --git a/pcuic/theories/PCUICWeakeningConfig.v b/pcuic/theories/PCUICWeakeningConfig.v index 01ef96862..4c7255807 100644 --- a/pcuic/theories/PCUICWeakeningConfig.v +++ b/pcuic/theories/PCUICWeakeningConfig.v @@ -14,11 +14,11 @@ Set Default Goal Selector "!". (** ** Constraints *) -#[global] Instance subrel_config_impl_cmp cf1 cf2 pb cs : +#[global] Instance subrel_config_impl_cmp cf1 cf2 cs pb : config.impl cf1 cf2 -> - RelationClasses.subrelation (@compare_universe cf1 pb cs) (@compare_universe cf2 pb cs). + RelationClasses.subrelation (@compare_sort cf1 cs pb) (@compare_sort cf2 cs pb). Proof. - cbv [compare_universe eq_universe leq_universe leq_universe_n leq_universe_n_ eq_levelalg leq_levelalg_n eq_universe_ config.impl]. + cbv [compare_sort eq_sort eq_sort_ leq_sort leq_sort_n leq_sort_n_ eq_universe leq_universe_n config.impl]. destruct cf1, cf2; cbn. move => H u1 u2; move: H. repeat match goal with @@ -28,29 +28,29 @@ Proof. reflexivity. Qed. -#[global] Instance subrel_config_impl_eq_pb cf1 cf2 pb cs : +#[global] Instance subrel_config_impl_eq_pb cf1 cf2 cs pb : config.impl cf1 cf2 -> - RelationClasses.subrelation (@eq_universe cf1 cs) (@compare_universe cf2 pb cs). + RelationClasses.subrelation (@eq_sort cf1 cs) (@compare_sort cf2 cs pb). Proof. - change (@eq_universe ?cf) with (@compare_universe cf Conv). + change (@eq_sort ?cf ?φ) with (@compare_sort cf φ Conv). etransitivity; [ now eapply (@subrel_config_impl_cmp cf1 cf2) | ]. tc. Qed. #[global] Instance subrel_config_impl_eq cf1 cf2 u : config.impl cf1 cf2 -> - RelationClasses.subrelation (@eq_universe cf1 u) (@eq_universe cf2 u). -Proof. change (@eq_universe ?cf) with (@compare_universe cf Conv). tc. Qed. + RelationClasses.subrelation (@eq_sort cf1 u) (@eq_sort cf2 u). +Proof. change (@eq_sort ?cf ?φ) with (@compare_sort cf φ Conv). tc. Qed. #[global] Instance subrel_config_impl_le cf1 cf2 u : config.impl cf1 cf2 -> - RelationClasses.subrelation (@leq_universe cf1 u) (@leq_universe cf2 u). -Proof. change (@leq_universe ?cf) with (@compare_universe cf Cumul). tc. Qed. + RelationClasses.subrelation (@leq_sort cf1 u) (@leq_sort cf2 u). +Proof. change (@leq_sort ?cf ?φ) with (@compare_sort cf φ Cumul). tc. Qed. #[global] Instance subrel_config_impl_eq_le cf1 cf2 u : config.impl cf1 cf2 -> - RelationClasses.subrelation (@eq_universe cf1 u) (@leq_universe cf2 u). -Proof. change (@leq_universe ?cf) with (@compare_universe cf Cumul). tc. Qed. + RelationClasses.subrelation (@eq_sort cf1 u) (@leq_sort cf2 u). +Proof. change (@leq_sort ?cf ?φ) with (@compare_sort cf φ Cumul). tc. Qed. Lemma weakening_config_is_allowed_elimination cf1 cf2 cs u allowed : config.impl cf1 cf2 -> diff --git a/pcuic/theories/PCUICWeakeningEnv.v b/pcuic/theories/PCUICWeakeningEnv.v index 8dc5c3788..a7123e36f 100644 --- a/pcuic/theories/PCUICWeakeningEnv.v +++ b/pcuic/theories/PCUICWeakeningEnv.v @@ -67,66 +67,76 @@ Proof. apply global_ext_constraints_app, sub. Qed. -#[global] Instance subrel_extends_cmp {cf} pb (Σ Σ' : global_env) (ϕ : universes_decl) : +#[global] Instance subrel_extends_cmp_universe {cf} pb (Σ Σ' : global_env) (ϕ : universes_decl) : extends Σ Σ' -> - RelationClasses.subrelation (compare_universe pb (global_ext_constraints (Σ, ϕ))) - (compare_universe pb (global_ext_constraints (Σ', ϕ))). + RelationClasses.subrelation (compare_universe (global_ext_constraints (Σ, ϕ)) pb) + (compare_universe (global_ext_constraints (Σ', ϕ)) pb). Proof. intros ext u u'. apply cmp_universe_subset. apply weakening_env_global_ext_constraints, ext. Qed. +#[global] Instance subrel_extends_cmp {cf} pb (Σ Σ' : global_env) (ϕ : universes_decl) : + extends Σ Σ' -> + RelationClasses.subrelation (compare_sort (global_ext_constraints (Σ, ϕ)) pb) + (compare_sort (global_ext_constraints (Σ', ϕ)) pb). +Proof. + intros ext u u'. + apply cmp_sort_subset. + apply weakening_env_global_ext_constraints, ext. +Qed. + #[global] Instance subrel_extends_eq_pb {cf} pb (Σ Σ' : global_env) (ϕ : universes_decl) : extends Σ Σ' -> - RelationClasses.subrelation (eq_universe (global_ext_constraints (Σ, ϕ))) - (compare_universe pb (global_ext_constraints (Σ', ϕ))). + RelationClasses.subrelation (eq_sort (global_ext_constraints (Σ, ϕ))) + (compare_sort (global_ext_constraints (Σ', ϕ)) pb). Proof. - change eq_universe with (compare_universe Conv). + change (eq_sort ?φ) with (compare_sort φ Conv). intros ext. destruct pb. - tc. - - transitivity (compare_universe Conv (global_ext_constraints (Σ', ϕ))); tc. + - transitivity (compare_sort (global_ext_constraints (Σ', ϕ)) Conv); tc. Qed. #[global] Instance subrel_extends_eq {cf} (Σ Σ' : global_env) (ϕ : universes_decl) : extends Σ Σ' -> - RelationClasses.subrelation (eq_universe (global_ext_constraints (Σ, ϕ))) - (eq_universe (global_ext_constraints (Σ', ϕ))). -Proof. change eq_universe with (compare_universe Conv). tc. Qed. + RelationClasses.subrelation (eq_sort (global_ext_constraints (Σ, ϕ))) + (eq_sort (global_ext_constraints (Σ', ϕ))). +Proof. change (eq_sort ?φ) with (compare_sort φ Conv). tc. Qed. #[global] Instance subrel_extends_le {cf} (Σ Σ' : global_env) (ϕ : universes_decl) : extends Σ Σ' -> - RelationClasses.subrelation (leq_universe (global_ext_constraints (Σ, ϕ))) - (leq_universe (global_ext_constraints (Σ', ϕ))). -Proof. change leq_universe with (compare_universe Cumul). tc. Qed. + RelationClasses.subrelation (leq_sort (global_ext_constraints (Σ, ϕ))) + (leq_sort (global_ext_constraints (Σ', ϕ))). +Proof. change (leq_sort ?φ) with (compare_sort φ Cumul). tc. Qed. #[global] Instance subrel_extends_eq_le {cf} (Σ Σ' : global_env) (ϕ : universes_decl) : extends Σ Σ' -> - RelationClasses.subrelation (eq_universe (global_ext_constraints (Σ, ϕ))) - (leq_universe (global_ext_constraints (Σ', ϕ))). -Proof. change leq_universe with (compare_universe Cumul). tc. Qed. + RelationClasses.subrelation (eq_sort (global_ext_constraints (Σ, ϕ))) + (leq_sort (global_ext_constraints (Σ', ϕ))). +Proof. change (leq_sort ?φ) with (compare_sort φ Cumul). tc. Qed. Lemma subrelations_extends {cf} Σ Σ' φ : extends Σ Σ' -> - RelationClasses.subrelation (eq_universe (global_ext_constraints (Σ,φ))) (eq_universe (global_ext_constraints (Σ',φ))). + RelationClasses.subrelation (eq_sort (global_ext_constraints (Σ,φ))) (eq_sort (global_ext_constraints (Σ',φ))). Proof. typeclasses eauto. Qed. Lemma subrelations_leq_extends {cf} Σ Σ' φ : extends Σ Σ' -> - RelationClasses.subrelation (leq_universe (global_ext_constraints (Σ,φ))) (leq_universe (global_ext_constraints (Σ',φ))). + RelationClasses.subrelation (leq_sort (global_ext_constraints (Σ,φ))) (leq_sort (global_ext_constraints (Σ',φ))). Proof. typeclasses eauto. Qed. Lemma subrelations_compare_extends {cf} Σ Σ' pb φ : extends Σ Σ' -> - RelationClasses.subrelation (compare_universe pb (global_ext_constraints (Σ,φ))) - (compare_universe pb (global_ext_constraints (Σ',φ))). + RelationClasses.subrelation (compare_sort (global_ext_constraints (Σ,φ)) pb) + (compare_sort (global_ext_constraints (Σ',φ)) pb). Proof. destruct pb; typeclasses eauto. Qed. Lemma subrelations_eq_compare_extends {cf} Σ Σ' pb φ : extends Σ Σ' -> - RelationClasses.subrelation (eq_universe (global_ext_constraints (Σ,φ))) - (compare_universe pb (global_ext_constraints (Σ',φ))). + RelationClasses.subrelation (eq_sort (global_ext_constraints (Σ,φ))) + (compare_sort (global_ext_constraints (Σ',φ)) pb). Proof. destruct pb; typeclasses eauto. Qed. @@ -184,7 +194,6 @@ Lemma extends_wf_universe {Σ : global_env_ext} Σ' u : extends Σ Σ' -> Proof. destruct Σ as [Σ univ]; cbn. intros [sub _]. - destruct u; simpl; auto. intros Hl. intros l inl; specialize (Hl l inl). cbn. @@ -195,6 +204,13 @@ Proof. - right. eapply global_levels_sub; tea. Qed. +Lemma extends_wf_sort {Σ : global_env_ext} Σ' s : extends Σ Σ' -> + wf_sort Σ s -> wf_sort (Σ', Σ.2) s. +Proof. + destruct s => //=. + apply extends_wf_universe. +Qed. + Definition on_udecl_prop (Σ : global_env) (udecl : universes_decl) := let levels := levels_of_udecl udecl in diff --git a/pcuic/theories/PCUICWellScopedCumulativity.v b/pcuic/theories/PCUICWellScopedCumulativity.v index 231d023d1..24c749098 100644 --- a/pcuic/theories/PCUICWellScopedCumulativity.v +++ b/pcuic/theories/PCUICWellScopedCumulativity.v @@ -37,7 +37,7 @@ Implicit Types (cf : checker_flags) (Σ : global_env_ext). Inductive ws_cumul_pb {cf} (pb : conv_pb) (Σ : global_env_ext) (Γ : context) : term -> term -> Type := | ws_cumul_pb_compare (t u : term) : is_closed_context Γ -> is_open_term Γ t -> is_open_term Γ u -> - compare_term pb Σ.1 (global_ext_constraints Σ) t u -> Σ ;;; Γ ⊢ t ≤[pb] u + compare_term Σ.1 (global_ext_constraints Σ) pb t u -> Σ ;;; Γ ⊢ t ≤[pb] u | ws_cumul_pb_red_l (t u v : term) : is_closed_context Γ -> is_open_term Γ t -> is_open_term Γ u -> is_open_term Γ v -> @@ -125,7 +125,7 @@ Lemma ws_cumul_pb_alt `{cf : checker_flags} {pb} {Σ : global_env_ext} {wfΣ : w Σ ;;; Γ ⊢ t ≤[pb] u <~> ∑ v v', [× is_closed_context Γ, is_open_term Γ t, is_open_term Γ u, - red Σ Γ t v, red Σ Γ u v' & compare_term pb Σ (global_ext_constraints Σ) v v']. + red Σ Γ t v, red Σ Γ u v' & compare_term Σ (global_ext_constraints Σ) pb v v']. Proof. split. - induction 1. @@ -188,9 +188,9 @@ Proof. - now transitivity u'nf. } Qed. -Arguments wt_cumul_pb_dom {cf c Σ Γ T U}. -Arguments wt_cumul_pb_codom {cf c Σ Γ T U}. -Arguments wt_cumul_pb_eq {cf c Σ Γ T U}. +Arguments wt_cumul_pb_dom {cf pb Σ Γ T U}. +Arguments wt_cumul_pb_codom {cf pb Σ Γ T U}. +Arguments wt_cumul_pb_eq {cf pb Σ Γ T U}. Section EqualityLemmas. Context {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ}. @@ -299,7 +299,7 @@ Lemma ws_cumul_pb_alt_closed {cf} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} Γ t Σ ;;; Γ ⊢ t ≤[pb] u <~> ∑ v v', [× closed_red Σ Γ t v, closed_red Σ Γ u v' & - compare_term pb Σ (global_ext_constraints Σ) v v']. + compare_term Σ (global_ext_constraints Σ) pb v v']. Proof. etransitivity. apply ws_cumul_pb_alt. split; intros (v & v' & cl); exists v, v'; intuition. diff --git a/pcuic/theories/PCUICWfUniverses.v b/pcuic/theories/PCUICWfUniverses.v index 1e3c3469c..63624b8ad 100644 --- a/pcuic/theories/PCUICWfUniverses.v +++ b/pcuic/theories/PCUICWfUniverses.v @@ -36,7 +36,7 @@ Qed. Section CheckerFlags. Context {cf:checker_flags}. - Lemma wf_universe_type0 Σ : wf_universe Σ Universe.type0. + Lemma wf_sort_type0 Σ : wf_sort Σ Sort.type0. Proof using Type. simpl. intros l hin%LevelExprSet.singleton_spec. @@ -44,7 +44,7 @@ Section CheckerFlags. apply global_ext_levels_InSet. Qed. - Lemma wf_universe_type1 Σ : wf_universe Σ Universe.type1. + Lemma wf_sort_type1 Σ : wf_sort Σ Sort.type1. Proof using Type. simpl. intros l hin%LevelExprSet.singleton_spec. @@ -52,10 +52,10 @@ Section CheckerFlags. apply global_ext_levels_InSet. Qed. - Lemma wf_universe_super {Σ u} : wf_universe Σ u -> wf_universe Σ (Universe.super u). + Lemma wf_sort_super {Σ u} : wf_sort Σ u -> wf_sort Σ (Sort.super u). Proof using Type. destruct u; cbn. - 1-2:intros _ l hin%LevelExprSet.singleton_spec; subst l; apply wf_universe_type1; + 1-2:intros _ l hin%LevelExprSet.singleton_spec; subst l; apply wf_sort_type1; now apply LevelExprSet.singleton_spec. intros Hl. intros l hin. @@ -63,8 +63,8 @@ Section CheckerFlags. simpl. now specialize (Hl _ int). Qed. - Lemma wf_universe_sup {Σ u u'} : wf_universe Σ u -> wf_universe Σ u' -> - wf_universe Σ (Universe.sup u u'). + Lemma wf_sort_sup {Σ u u'} : wf_sort Σ u -> wf_sort Σ u' -> + wf_sort Σ (Sort.sup u u'). Proof using Type. destruct u, u'; cbn; auto. intros Hu Hu' l [Hl|Hl]%LevelExprSet.union_spec. @@ -72,51 +72,50 @@ Section CheckerFlags. now apply (Hu' _ Hl). Qed. - Lemma wf_universe_product {Σ u u'} : wf_universe Σ u -> wf_universe Σ u' -> - wf_universe Σ (Universe.sort_of_product u u'). + Lemma wf_sort_product {Σ s s'} : wf_sort Σ s -> wf_sort Σ s' -> + wf_sort Σ (Sort.sort_of_product s s'). Proof using Type. - intros Hu Hu'. unfold Universe.sort_of_product. - destruct (Universe.is_prop u' || Universe.is_sprop u'); auto. - now apply wf_universe_sup. + intros Hu Hu'. + destruct s' => //=. + now apply wf_sort_sup. Qed. - Hint Resolve wf_universe_type1 wf_universe_super wf_universe_sup wf_universe_product : pcuic. + Hint Resolve wf_sort_type1 wf_sort_super wf_sort_sup wf_sort_product : pcuic. - Definition wf_universeb_level Σ l := + Definition wf_levelb Σ l := LevelSet.mem l (global_ext_levels Σ). - Definition wf_universe_level Σ l := + Definition wf_level Σ l := LevelSet.In l (global_ext_levels Σ). - Definition wf_universe_instance Σ u := - Forall (wf_universe_level Σ) u. + Definition wf_instance Σ u := + Forall (wf_level Σ) u. - Definition wf_universeb_instance Σ u := - forallb (wf_universeb_level Σ) u. + Definition wf_instanceb Σ u := + forallb (wf_levelb Σ) u. - Lemma wf_universe_levelP {Σ l} : reflect (wf_universe_level Σ l) (wf_universeb_level Σ l). + Lemma wf_levelP {Σ l} : reflect (wf_level Σ l) (wf_levelb Σ l). Proof using Type. - unfold wf_universe_level, wf_universeb_level. + unfold wf_level, wf_levelb. destruct LevelSet.mem eqn:ls; constructor. now apply LevelSet.mem_spec in ls. intros hin. now apply LevelSet.mem_spec in hin. Qed. - Lemma wf_universe_instanceP {Σ u} : reflect (wf_universe_instance Σ u) (wf_universeb_instance Σ u). + Lemma wf_instanceP {Σ u} : reflect (wf_instance Σ u) (wf_instanceb Σ u). Proof using Type. - unfold wf_universe_instance, wf_universeb_instance. - apply forallbP. intros x; apply wf_universe_levelP. + unfold wf_instance, wf_instanceb. + apply forallbP. intros x; apply wf_levelP. Qed. - Lemma wf_universe_subst_instance_univ (Σ : global_env_ext) univs u s : + Lemma wf_universe_subst_instance_univ (Σ : global_env_ext) univs ui u : wf Σ -> - wf_universe Σ s -> - wf_universe_instance (Σ.1, univs) u -> - wf_universe (Σ.1, univs) (subst_instance u s). + wf_universe Σ u -> + wf_instance (Σ.1, univs) ui -> + wf_universe (Σ.1, univs) (subst_instance ui u). Proof using Type. - destruct s as [| |t]; cbnr. intros wfΣ Hl Hu e [[l n] [inl ->]]%In_subst_instance. destruct l as [|s|n']; simpl; auto. - apply global_ext_levels_InSet. @@ -135,22 +134,32 @@ Section CheckerFlags. eapply nth_error_forall in Hu; eauto. apply global_ext_levels_InSet. * unfold subst_instance. simpl. - destruct (nth_error u n') eqn:hnth. + destruct (nth_error ui n') eqn:hnth. 2:{ simpl. rewrite hnth. apply global_ext_levels_InSet. } eapply nth_error_forall in Hu. 2:eauto. - change (nth_error u n') with (nth_error u n') in *. + change (nth_error ui n') with (nth_error ui n') in *. rewrite -> hnth. simpl. apply Hu. + now apply not_var_global_levels in Hl. Qed. - Lemma wf_universe_instantiate Σ univs s u φ : + Lemma wf_sort_subst_instance_sort (Σ : global_env_ext) univs u s : + wf Σ -> + wf_sort Σ s -> + wf_instance (Σ.1, univs) u -> + wf_sort (Σ.1, univs) (subst_instance u s). + Proof using Type. + destruct s as [| |t]; cbnr. + apply wf_universe_subst_instance_univ. + Qed. + + Lemma wf_sort_instantiate Σ univs s u φ : wf Σ -> - wf_universe (Σ, univs) s -> - wf_universe_instance (Σ, φ) u -> - wf_universe (Σ, φ) (subst_instance_univ u s). + wf_sort (Σ, univs) s -> + wf_instance (Σ, φ) u -> + wf_sort (Σ, φ) (subst_instance_sort u s). Proof using Type. intros wfΣ Hs. - apply (wf_universe_subst_instance_univ (Σ, univs) φ); auto. + apply (wf_sort_subst_instance_sort (Σ, univs) φ); auto. Qed. Lemma subst_instance_empty u : @@ -164,10 +173,10 @@ Section CheckerFlags. now destruct a => /= //; auto. Qed. - Lemma wf_universe_level_mono Σ u : + Lemma wf_level_mono Σ u : wf Σ -> on_udecl_prop Σ (Monomorphic_ctx) -> - Forall (wf_universe_level (Σ, Monomorphic_ctx)) u -> + Forall (wf_level (Σ, Monomorphic_ctx)) u -> forallb (fun x => ~~ Level.is_var x) u. Proof using Type. intros wf uprop. @@ -179,9 +188,9 @@ Section CheckerFlags. now pose proof (not_var_global_levels wf _ H). Qed. - Lemma wf_universe_level_sub Σ univs u : - wf_universe_level (Σ, Monomorphic_ctx) u -> - wf_universe_level (Σ, univs) u. + Lemma wf_level_sub Σ univs u : + wf_level (Σ, Monomorphic_ctx) u -> + wf_level (Σ, univs) u. Proof using cf. intros wfx. red in wfx |- *. @@ -190,14 +199,14 @@ Section CheckerFlags. eapply LevelSet.union_spec. now right. Qed. - Lemma wf_universe_instance_sub Σ univs u : - wf_universe_instance (Σ, Monomorphic_ctx) u -> - wf_universe_instance (Σ, univs) u. + Lemma wf_instance_sub Σ univs u : + wf_instance (Σ, Monomorphic_ctx) u -> + wf_instance (Σ, univs) u. Proof using cf. intros wfu. red in wfu |- *. eapply Forall_impl; eauto. - intros. red in H. cbn in H. eapply wf_universe_level_sub; eauto. + intros. red in H. cbn in H. eapply wf_level_sub; eauto. Qed. Lemma In_Level_global_ext_poly s Σ cst : @@ -217,10 +226,10 @@ Section CheckerFlags. intros x' [->|inx]; auto. Qed. - Lemma wf_universe_instance_In {Σ u} : wf_universe_instance Σ u <-> + Lemma wf_instance_In {Σ u} : wf_instance Σ u <-> (forall l, In l u -> LS.In l (global_ext_levels Σ)). Proof using Type. - unfold wf_universe_instance. + unfold wf_instance. split; intros. eapply Forall_In in H; eauto. apply In_Forall. auto. Qed. @@ -236,21 +245,21 @@ Section CheckerFlags. specialize (IHu' H). intuition auto. Qed. - Lemma wf_universe_subst_instance Σ univs u u' φ : + Lemma wf_instance_subst_instance Σ univs u u' φ : wf Σ -> on_udecl_prop Σ univs -> - wf_universe_instance (Σ, univs) u' -> - wf_universe_instance (Σ, φ) u -> - wf_universe_instance (Σ, φ) (subst_instance u u'). + wf_instance (Σ, univs) u' -> + wf_instance (Σ, φ) u -> + wf_instance (Σ, φ) (subst_instance u u'). Proof using Type. intros wfΣ onup Hs cu. destruct univs. - red in Hs |- *. - unshelve epose proof (wf_universe_level_mono _ _ _ _ Hs); eauto. + unshelve epose proof (wf_level_mono _ _ _ _ Hs); eauto. eapply forallb_Forall in H. apply Forall_map. solve_all. destruct x; simpl => //. red. apply global_ext_levels_InSet. - eapply wf_universe_level_sub; eauto. + eapply wf_level_sub; eauto. - clear onup. red in Hs |- *. eapply Forall_map, Forall_impl; eauto. @@ -274,34 +283,30 @@ Section CheckerFlags. Section WfUniverses. Context (Σ : global_env_ext). - Definition wf_universeb (s : Universe.t) : bool := - match s with - | Universe.lType l => LevelExprSet.for_all (fun l => LevelSet.mem (LevelExpr.get_level l) (global_ext_levels Σ)) l - | _ => true - end. + Definition wf_universeb (u : Universe.t) : bool := + LevelExprSet.for_all (fun l => LevelSet.mem (LevelExpr.get_level l) (global_ext_levels Σ)) u. Lemma wf_universe_reflect {u : Universe.t} : reflect (wf_universe Σ u) (wf_universeb u). Proof using Type. - destruct u; simpl; try now constructor. eapply iff_reflect. rewrite LevelExprSet.for_all_spec. split; intros. - intros l Hl; specialize (H l Hl). now eapply LS.mem_spec. - - specialize (H l H0). simpl in H. + - intros l Hl. specialize (H l Hl). now eapply LS.mem_spec in H. Qed. Fixpoint on_universes fu fc t := match t with - | tSort s => fu s + | tSort s => Sort.on_sort fu true s | tApp t u | tProd _ t u | tLambda _ t u => on_universes fu fc t && on_universes fu fc u | tCase _ p c brs => [&& - forallb fu (map Universe.make p.(puinst)) , + forallb fu (map Universe.make' p.(puinst)) , forallb (on_universes fu fc) p.(pparams) , test_context (fc #|p.(puinst)|) p.(pcontext) , on_universes fu fc p.(preturn) , @@ -313,16 +318,24 @@ Section CheckerFlags. | tFix mfix _ | tCoFix mfix _ => forallb (fun d => on_universes fu fc d.(dtype) && on_universes fu fc d.(dbody)) mfix | tConst _ u | tInd _ u | tConstruct _ _ u => - forallb fu (map Universe.make u) + forallb fu (map Universe.make' u) | tEvar _ args => forallb (on_universes fu fc) args - | tPrim p => test_primu (fun x => fu (Universe.make x)) (on_universes fu fc) p + | tPrim p => test_primu (fun x => fu (Universe.make' x)) (on_universes fu fc) p | _ => true end. Definition wf_universes t := on_universes wf_universeb closedu t. + Definition wf_sortb s := Sort.on_sort wf_universeb true s. + + Lemma wf_sort_reflect {s : sort} : + reflect (wf_sort Σ s) (wf_sortb s). + Proof using Type. + destruct s => //=; repeat constructor. + apply wf_universe_reflect. + Qed. Lemma wf_universeb_instance_forall u : - forallb wf_universeb (map Universe.make u) = wf_universeb_instance Σ u. + forallb wf_universeb (map Universe.make' u) = wf_instanceb Σ u. Proof using Type. induction u => //=. rewrite IHu. @@ -430,64 +443,68 @@ Qed. repeat match goal with | [ H: is_true (wf_universeb _ ?x) |- _ ] => apply (elimT (@wf_universe_reflect _ x)) in H | [ |- is_true (wf_universeb _ ?x) ] => apply (introT (@wf_universe_reflect _ x)) + | [ H: is_true (Sort.on_sort (wf_universeb _) _ ?x) |- _ ] => apply (elimT (@wf_sort_reflect _ x)) in H + | [ |- is_true (Sort.on_sort (wf_universeb _) _ ?x) ] => apply (introT (@wf_sort_reflect _ x)) + | [ H: is_true (wf_sortb _ ?x) |- _ ] => apply (elimT (@wf_sort_reflect _ x)) in H + | [ |- is_true (wf_sortb _ ?x) ] => apply (introT (@wf_sort_reflect _ x)) end. Lemma wf_universes_inst {Σ : global_env_ext} univs t u : wf Σ -> on_udecl_prop Σ.1 univs -> - wf_universe_instance Σ u -> + wf_instance Σ u -> wf_universes (Σ.1, univs) t -> wf_universes Σ (subst_instance u t). Proof using Type. intros wfΣ onudecl cu wft. induction t using term_forall_list_ind; simpl in *; auto; try to_prop; - try apply /andP; to_wfu; intuition eauto 4. + try apply /andP; intuition eauto 4. - all:cbn -[Universe.make] in * ; autorewrite with map; repeat (f_equal; solve_all). + all:cbn -[Universe.make'] in * ; to_wfu; autorewrite with map; repeat (f_equal; solve_all). - - to_wfu. destruct Σ as [Σ univs']. simpl in *. - eapply (wf_universe_subst_instance_univ (Σ, univs)); auto. + - destruct Σ as [Σ univs']. simpl in *. + eapply (wf_sort_subst_instance_sort (Σ, univs)); auto. - apply forallb_All. rewrite -forallb_map wf_universeb_instance_forall. apply All_forallb in wft. rewrite -forallb_map wf_universeb_instance_forall in wft. - apply/wf_universe_instanceP. - eapply wf_universe_subst_instance; eauto. + apply/wf_instanceP. + eapply wf_instance_subst_instance; eauto. destruct Σ; simpl in *. - now move/wf_universe_instanceP: wft. + now move/wf_instanceP: wft. - apply forallb_All. rewrite -forallb_map wf_universeb_instance_forall. apply All_forallb in wft. rewrite -forallb_map wf_universeb_instance_forall in wft. - apply/wf_universe_instanceP. - eapply wf_universe_subst_instance; eauto. + apply/wf_instanceP. + eapply wf_instance_subst_instance; eauto. destruct Σ; simpl in *. - now move/wf_universe_instanceP: wft. + now move/wf_instanceP: wft. - apply forallb_All. rewrite -forallb_map wf_universeb_instance_forall. apply All_forallb in wft. rewrite -forallb_map wf_universeb_instance_forall in wft. - apply/wf_universe_instanceP. - eapply wf_universe_subst_instance; eauto. + apply/wf_instanceP. + eapply wf_instance_subst_instance; eauto. destruct Σ; simpl in *. - now move/wf_universe_instanceP: wft. + now move/wf_instanceP: wft. - apply forallb_All. rewrite -forallb_map wf_universeb_instance_forall. apply All_forallb in H. rewrite -forallb_map wf_universeb_instance_forall in H. - apply/wf_universe_instanceP. - eapply wf_universe_subst_instance; eauto. + apply/wf_instanceP. + eapply wf_instance_subst_instance; eauto. destruct Σ ; simpl in *. - now move/wf_universe_instanceP: H. + now move/wf_instanceP: H. - now len. - rewrite /test_branch. rtoProp. move/andP: a => [] tctx wfu. split; auto. simpl. solve_all. now len. - - rewrite -subst_instance_univ_make. to_wfu. + - rewrite -subst_instance_universe_make. to_wfu. eapply (wf_universe_subst_instance_univ (Σ.1, univs)) => //. Qed. @@ -496,19 +513,18 @@ Qed. wf_universe (Σ', Σ.2) t. Proof using Type. intros wfΣ ext. - destruct t; simpl; auto. intros Hl l inl; specialize (Hl l inl). apply LS.union_spec. apply LS.union_spec in Hl as [Hl|Hl]; simpl. left; auto. right. now eapply global_levels_sub; [apply ext|]. Qed. - Lemma weaken_wf_universe_level {Σ : global_env_ext} Σ' t : wf Σ -> wf Σ' -> extends Σ Σ' -> - wf_universe_level Σ t -> - wf_universe_level (Σ', Σ.2) t. + Lemma weaken_wf_level {Σ : global_env_ext} Σ' t : wf Σ -> wf Σ' -> extends Σ Σ' -> + wf_level Σ t -> + wf_level (Σ', Σ.2) t. Proof using Type. intros wfΣ wfΣ' ext. - unfold wf_universe_level. + unfold wf_level. destruct t; simpl; auto using global_ext_levels_InSet; intros; apply LS.union_spec. - eapply LS.union_spec in H as [H|H]. @@ -518,30 +534,30 @@ Qed. - cbn. eapply in_var_global_ext in H; eauto. Qed. - Lemma weaken_wf_universe_instance {Σ : global_env_ext} Σ' t : wf Σ -> wf Σ' -> extends Σ.1 Σ' -> - wf_universe_instance Σ t -> - wf_universe_instance (Σ', Σ.2) t. + Lemma weaken_wf_instance {Σ : global_env_ext} Σ' t : wf Σ -> wf Σ' -> extends Σ.1 Σ' -> + wf_instance Σ t -> + wf_instance (Σ', Σ.2) t. Proof using Type. intros wfΣ wfΣ' ext. - unfold wf_universe_instance. + unfold wf_instance. intros H; eapply Forall_impl; eauto. - intros. now eapply weaken_wf_universe_level. + intros. now eapply weaken_wf_level. Qed. - Arguments Universe.make : simpl never. -Lemma test_primu_test_primu_tPrimProp {P : term -> Type} {pu put} {pu' : Level.t -> bool} {put' : term -> bool} p : - tPrimProp P p -> test_primu pu put p -> - (forall u, pu u -> pu' u) -> - (forall t, P t -> put t -> put' t) -> - test_primu pu' put' p. -Proof. - intros hp ht hf hg. - destruct p as [? []]; cbn => //. - destruct a; destruct hp; cbn in *. - rtoProp. destruct p0. intuition eauto. - eapply forallb_All in H2. eapply All_prod in a; tea. - eapply All_forallb, All_impl; tea. intuition eauto. apply hg; intuition auto. -Qed. + Arguments Universe.make' : simpl never. + Lemma test_primu_test_primu_tPrimProp {P : term -> Type} {pu put} {pu' : Level.t -> bool} {put' : term -> bool} p : + tPrimProp P p -> test_primu pu put p -> + (forall u, pu u -> pu' u) -> + (forall t, P t -> put t -> put' t) -> + test_primu pu' put' p. + Proof. + intros hp ht hf hg. + destruct p as [? []]; cbn => //. + destruct a; destruct hp; cbn in *. + rtoProp. destruct p0. intuition eauto. + eapply forallb_All in H2. eapply All_prod in a; tea. + eapply All_forallb, All_impl; tea. intuition eauto. apply hg; intuition auto. + Qed. Lemma weaken_wf_universes {Σ : global_env_ext} Σ' t : wf Σ -> wf Σ' -> extends Σ.1 Σ' -> wf_universes Σ t -> @@ -552,7 +568,8 @@ Qed. try apply /andP; to_wfu; intuition eauto 4. - solve_all. - - now eapply weaken_wf_universe. + - move: H. destruct s => //=. + now apply weaken_wf_universe. - eapply forallb_impl ; tea. now move => ? _ /wf_universe_reflect /weaken_wf_universe /wf_universe_reflect. - eapply forallb_impl ; tea. @@ -582,7 +599,7 @@ Qed. Lemma wf_universes_weaken : weaken_env_prop cumulSpec0 (lift_typing typing) - (fun Σ _ j => option_default (wf_universes Σ) (j_term j) true && wf_universes Σ (j_typ j) && option_default (wf_universeb Σ) (j_univ j) true). + (fun Σ _ j => option_default (wf_universes Σ) (j_term j) true && wf_universes Σ (j_typ j) && option_default (wf_sortb Σ) (j_univ j) true). Proof using Type. intros Σ Σ' φ wfΣ wfΣ' Hext _ j Hj. pose proof (fun t => @weaken_wf_universes (Σ, φ) Σ' t wfΣ wfΣ' Hext). @@ -592,7 +609,7 @@ Qed. Qed. Lemma wf_universes_inds Σ mind u bodies : - wf_universe_instance Σ u -> + wf_instance Σ u -> All (fun t : term => wf_universes Σ t) (inds mind u bodies). Proof using Type. intros wfu. @@ -602,7 +619,7 @@ Qed. constructor; auto. cbn. rewrite wf_universeb_instance_forall. - now apply /wf_universe_instanceP. + now apply /wf_instanceP. Qed. Lemma wf_universes_mkApps Σ f args : @@ -621,7 +638,7 @@ Qed. Qed. Lemma consistent_instance_ext_wf Σ univs u : consistent_instance_ext Σ univs u -> - wf_universe_instance Σ u. + wf_instance Σ u. Proof using Type. destruct univs; simpl. - destruct u => // /=. @@ -636,10 +653,10 @@ Qed. | [ H : on_udecl _ _, H' : on_udecl _ _ -> _ |- _ ] => specialize (H' H) end. - Local Lemma wf_sorts_local_ctx_smash (Σ : global_env_ext) mdecl args sorts : - sorts_local_ctx (fun Σ _ => lift_wfbu_term (fun t => wf_universes Σ t) (wf_universeb Σ)) + Local Lemma wf_universes_local_ctx_smash (Σ : global_env_ext) mdecl args sorts : + sorts_local_ctx (fun Σ _ => lift_wfbu_term (fun t => wf_universes Σ t) (wf_sortb Σ)) (Σ.1, ind_universes mdecl) (arities_context (ind_bodies mdecl),,, ind_params mdecl) args sorts -> - sorts_local_ctx (fun Σ _ => lift_wfbu_term (fun t => wf_universes Σ t) (wf_universeb Σ)) + sorts_local_ctx (fun Σ _ => lift_wfbu_term (fun t => wf_universes Σ t) (wf_sortb Σ)) (Σ.1, ind_universes mdecl) (arities_context (ind_bodies mdecl),,, ind_params mdecl) (smash_context [] args) sorts. Proof using Type. induction args as [|[na [b|] ty] args] in sorts |- *; simpl; auto. @@ -662,7 +679,7 @@ Qed. - now rewrite wf_universes_lift. Qed. - Lemma wf_sorts_local_ctx_nth_error Σ P Pu Γ Δ s n d : + Lemma wf_universes_local_ctx_nth_error Σ P Pu Γ Δ s n d : sorts_local_ctx (fun Σ _ => lift_wfbu_term (P Σ) (Pu Σ)) Σ Γ Δ s -> nth_error Δ n = Some d -> P Σ (decl_type d). @@ -694,7 +711,7 @@ Qed. Qed. Lemma wf_abstract_instance Σ decl : - wf_universe_instance (Σ, decl) (abstract_instance decl). + wf_instance (Σ, decl) (abstract_instance decl). Proof using Type. destruct decl as [|[u cst]]=> /=. red. constructor. @@ -761,7 +778,7 @@ Qed. Qed. Lemma closedu_compare_decls k Γ Δ : - All2 (PCUICEquality.compare_decls eq eq) Γ Δ -> + PCUICEquality.eq_context_upto_names Γ Δ -> test_context (closedu k) Γ = test_context (closedu k) Δ. Proof using Type. induction 1; cbn; auto. @@ -893,12 +910,12 @@ Qed. apply closedu_smash_context_gen => //. Qed. - Lemma wf_universe_level_closed {Σ : global_env} {wfΣ : wf Σ} univs u : + Lemma wf_level_closed {Σ : global_env} {wfΣ : wf Σ} univs l : on_udecl_prop Σ univs -> - wf_universe_level (Σ, univs) u -> closedu_level #|polymorphic_instance univs| u. + wf_level (Σ, univs) l -> closedu_level #|polymorphic_instance univs| l. Proof using Type. - intros ond Ht; destruct u => //. - cbn in Ht. unfold closedu_universe, closedu_universe_levels. + intros ond Ht; destruct l => //. + cbn in Ht. unfold closedu_level. cbn. red in Ht. eapply in_var_global_ext in Ht => //. cbn in Ht. @@ -915,30 +932,38 @@ Qed. Lemma wf_universe_closed {Σ : global_env} {wfΣ : wf Σ} univs u : on_udecl_prop Σ univs -> - wf_universe (Σ, univs) u -> closedu #|polymorphic_instance univs| (tSort u). + wf_universe (Σ, univs) u -> closedu_universe #|polymorphic_instance univs| u. Proof using Type. - intros ond Ht; destruct u => //. - cbn in Ht. unfold closedu_universe, closedu_universe_levels. + intros ond Ht. + cbn in Ht. unfold closedu_universe. eapply LevelExprSet.for_all_spec. intros x y ?; subst; auto. intros i hi. specialize (Ht i hi). unfold closedu_level_expr. - apply wf_universe_level_closed => //. + apply wf_level_closed => //. + Qed. + + Lemma wf_sort_closed {Σ : global_env} {wfΣ : wf Σ} univs s : + on_udecl_prop Σ univs -> + wf_sort (Σ, univs) s -> closedu_sort #|polymorphic_instance univs| s. + Proof using Type. + destruct s => //=. + apply wf_universe_closed. Qed. - Lemma wf_universe_instance_closed {Σ : global_env} {wfΣ : wf Σ} {univs u} : + Lemma wf_instance_closed {Σ : global_env} {wfΣ : wf Σ} {univs u} : on_udecl_prop Σ univs -> - wf_universe_instance (Σ, univs) u -> + wf_instance (Σ, univs) u -> closedu_instance #|polymorphic_instance univs| u. Proof using Type. intros ond Ht. red in Ht. unfold closedu_instance. solve_all. - now eapply wf_universe_level_closed. + now eapply wf_level_closed. Qed. - Lemma wf_universe_make Σ u : wf_universe Σ (Universe.make u) -> wf_universe_level Σ u. + Lemma wf_universe_make Σ u : wf_universe Σ (Universe.make' u) -> wf_level Σ u. Proof. - rewrite /wf_universe /= => hl; rewrite /wf_universe_level. + rewrite /wf_universe /= => hl; rewrite /wf_level. apply (hl (u, 0)). lsets. Qed. @@ -947,30 +972,31 @@ Qed. wf_universes (Σ, univs) t -> closedu #|polymorphic_instance univs| t. Proof using Type. intros ond. induction t using term_forall_list_ind; cbn => //; solve_all. - - apply wf_universe_closed => //. + - apply wf_sort_closed => //. + destruct s => //=. now move/wf_universe_reflect: H. - - eapply wf_universe_instance_closed => //. + - eapply wf_instance_closed => //. apply All_forallb in H. rewrite -forallb_map wf_universeb_instance_forall in H. - now move/wf_universe_instanceP: H. - - eapply wf_universe_instance_closed => //. + now move/wf_instanceP: H. + - eapply wf_instance_closed => //. apply All_forallb in H. rewrite -forallb_map wf_universeb_instance_forall in H. - now move/wf_universe_instanceP: H. - - eapply wf_universe_instance_closed => //. + now move/wf_instanceP: H. + - eapply wf_instance_closed => //. apply All_forallb in H. rewrite -forallb_map wf_universeb_instance_forall in H. - now move/wf_universe_instanceP: H. + now move/wf_instanceP: H. - unfold test_predicate_ku in *; solve_all. - eapply wf_universe_instance_closed => //. + eapply wf_instance_closed => //. apply All_forallb in H0. rewrite -forallb_map wf_universeb_instance_forall in H0. - now move/wf_universe_instanceP: H0. + now move/wf_instanceP: H0. - unfold test_branch in *; solve_all. - unfold test_def in *; solve_all. - unfold test_def in *; solve_all. - eapply test_primu_test_primu_tPrimProp; tea; cbn; eauto. - intros. to_wfu. eapply wf_universe_level_closed; tea. + intros. to_wfu. eapply wf_level_closed; tea. now apply wf_universe_make. Qed. @@ -1041,7 +1067,7 @@ Qed. Theorem wf_types : env_prop (fun Σ Γ t T => wf_universes Σ t && wf_universes Σ T) - (fun Σ _ j => option_default (wf_universes Σ) (j_term j) true && wf_universes Σ (j_typ j) && option_default (wf_universeb Σ) (j_univ j) true) + (fun Σ _ j => option_default (wf_universes Σ) (j_term j) true && wf_universes Σ (j_typ j) && option_default (wf_sortb Σ) (j_univ j) true) (fun Σ Γ => wf_ctx_universes Σ Γ). Proof using Type. apply typing_ind_env; unfold lift_wfb_term; intros; rename_all_hyps; cbn; rewrite -!/(wf_universes _ _) ; @@ -1071,7 +1097,7 @@ Qed. - apply/andP; split. { rewrite wf_universeb_instance_forall. - apply/wf_universe_instanceP. + apply/wf_instanceP. eapply consistent_instance_ext_wf; eauto. } pose proof (declared_constant_inv _ _ _ _ wf_universes_weaken wf X H0) as [[_ X0]%andb_and _]%andb_and. unshelve eapply declared_constant_to_gen in H0; eauto. @@ -1081,7 +1107,7 @@ Qed. - apply/andP; split. { rewrite wf_universeb_instance_forall. - apply/wf_universe_instanceP. + apply/wf_instanceP. eapply consistent_instance_ext_wf; eauto. } pose proof (declared_inductive_inv wf_universes_weaken wf X isdecl). move/onArity : X0 => /andP[] /andP[] /= _ Hind _. @@ -1092,7 +1118,7 @@ Qed. - apply/andP; split. { rewrite wf_universeb_instance_forall. - apply/wf_universe_instanceP. + apply/wf_instanceP. eapply consistent_instance_ext_wf; eauto. } pose proof (declared_constructor_inv wf_universes_weaken wf X isdecl) as [sc [nthe onc]]. unfold type_of_constructor. @@ -1168,7 +1194,7 @@ Qed. destruct o0 as [_ ->]. rewrite wf_universes_mkApps {1}/wf_universes /= -!/(wf_universes _ _) wf_universeb_instance_forall in H2. - move/andP: H2 => [/wf_universe_instanceP wfu wfargs]. + move/andP: H2 => [/wf_instanceP wfu wfargs]. unshelve eapply declared_projection_to_gen in isdecl; eauto. eapply (wf_universes_inst (ind_universes mdecl)); eauto. exact (weaken_lookup_on_global_env' Σ.1 _ _ wf (proj1 (proj1 (proj1 isdecl)))). @@ -1194,8 +1220,8 @@ Qed. rewrite !wf_universes_it_mkProd_or_LetIn in Hs. now move/andP: Hs => /andP /andP []. rewrite wf_universes_lift. - eapply wf_sorts_local_ctx_smash in s. - eapply wf_sorts_local_ctx_nth_error in s; eauto. + eapply wf_universes_local_ctx_smash in s. + eapply wf_universes_local_ctx_nth_error in s; eauto. - clear X X1. unfold on_def_type, on_def_body in *; cbn in *. apply/andP; split; auto. @@ -1222,9 +1248,9 @@ Qed. exact (env_prop_typing wf_types _ wfΣ _ _ _ Hty). Qed. - Lemma typing_wf_universe {Σ : global_env_ext} {Γ t s} : + Lemma typing_wf_sort {Σ : global_env_ext} {Γ t s} : wf Σ -> - Σ ;;; Γ |- t : tSort s -> wf_universe Σ s. + Σ ;;; Γ |- t : tSort s -> wf_sort Σ s. Proof using Type. intros wfΣ Hty. apply typing_wf_universes in Hty as [_ wfs]%andb_and; auto. @@ -1239,10 +1265,10 @@ Qed. End CheckerFlags. Arguments wf_universe_reflect {Σ u}. -#[global] Hint Resolve wf_universe_type1 wf_universe_super wf_universe_sup wf_universe_product : pcuic. +#[global] Hint Resolve wf_sort_type1 wf_sort_super wf_sort_sup wf_sort_product : pcuic. #[global] -Hint Extern 4 (wf_universe _ ?u) => +Hint Extern 4 (wf_sort _ ?u) => match goal with - [ H : typing _ _ _ (tSort u) |- _ ] => apply (typing_wf_universe _ H) + [ H : typing _ _ _ (tSort u) |- _ ] => apply (typing_wf_sort _ H) end : pcuic. diff --git a/pcuic/theories/Syntax/PCUICOnFreeVars.v b/pcuic/theories/Syntax/PCUICOnFreeVars.v index ac499f54f..011c13580 100644 --- a/pcuic/theories/Syntax/PCUICOnFreeVars.v +++ b/pcuic/theories/Syntax/PCUICOnFreeVars.v @@ -1049,13 +1049,13 @@ Lemma on_free_vars_case_predicate_context {cf} {Σ} {wfΣ : wf Σ} {P ci mdecl i rewrite alli_app; len; rewrite andb_true_r. apply andb_true_iff. split. - rewrite -/(on_free_vars_ctx P _). - rewrite (on_free_vars_ctx_all_term _ _ Universe.type0). + rewrite (on_free_vars_ctx_all_term _ _ Sort.type0). rewrite -(subst_it_mkProd_or_LetIn _ _ _ (tSort _)). apply on_free_vars_subst. { rewrite forallb_rev => //. } rewrite -on_free_vars_ctx_all_term. rewrite on_free_vars_ctx_subst_instance. - rewrite (on_free_vars_ctx_all_term _ _ (Universe.type0)). + rewrite (on_free_vars_ctx_all_term _ _ Sort.type0). rewrite -(expand_lets_it_mkProd_or_LetIn _ _ 0 (tSort _)). eapply on_free_vars_expand_lets_k; len. * rewrite (wf_predicate_length_pars wfp). @@ -1090,7 +1090,7 @@ Lemma on_free_vars_case_predicate_context {cf} {Σ} {wfΣ : wf Σ} {P ci mdecl i Proof. intros brctx decli wfp wfb havp. rewrite /brctx /case_branch_context /case_branch_context_gen. - rewrite (on_free_vars_ctx_all_term _ _ Universe.type0). + rewrite (on_free_vars_ctx_all_term _ _ Sort.type0). rewrite -(subst_it_mkProd_or_LetIn _ _ _ (tSort _)). apply on_free_vars_subst => //. { rewrite forallb_rev //. } @@ -1127,7 +1127,7 @@ Proof. intros hpars hn. rewrite /inst_case_context. rewrite test_context_k_eq. - rewrite (on_free_vars_ctx_all_term _ _ Universe.type0). + rewrite (on_free_vars_ctx_all_term _ _ Sort.type0). rewrite -(subst_it_mkProd_or_LetIn _ _ _ (tSort _)). intros a. apply on_free_vars_subst => //. @@ -1234,7 +1234,7 @@ Lemma on_free_vars_ctx_subst_context P s k ctx : on_free_vars_ctx (shiftnP k P) (subst_context s k ctx). Proof. intros onctx ons. - rewrite (on_free_vars_ctx_all_term _ _ Universe.type0). + rewrite (on_free_vars_ctx_all_term _ _ Sort.type0). rewrite -(subst_it_mkProd_or_LetIn _ _ _ (tSort _)). eapply on_free_vars_impl; revgoals. - eapply on_free_vars_subst_gen => //; tea. @@ -1255,7 +1255,7 @@ Lemma on_free_vars_ctx_lift_context p k n ctx : on_free_vars_ctx p ctx = on_free_vars_ctx (strengthenP k n p) (lift_context n k ctx). Proof. - rewrite !(on_free_vars_ctx_all_term _ _ Universe.type0). + rewrite !(on_free_vars_ctx_all_term _ _ Sort.type0). rewrite -(lift_it_mkProd_or_LetIn _ _ _ (tSort _)). rewrite on_free_vars_lift => //. Qed. @@ -1492,7 +1492,7 @@ Proof. Defined. Lemma alpha_eq_on_free_vars P (Γ Δ : context) : - All2 (PCUICEquality.compare_decls eq eq) Γ Δ -> + PCUICEquality.eq_context_upto_names Γ Δ -> on_free_vars_ctx P Γ -> on_free_vars_ctx P Δ. Proof. induction 1; cbn; auto. diff --git a/pcuic/theories/Syntax/PCUICPosition.v b/pcuic/theories/Syntax/PCUICPosition.v index ee75e7d03..589b0fb60 100644 --- a/pcuic/theories/Syntax/PCUICPosition.v +++ b/pcuic/theories/Syntax/PCUICPosition.v @@ -180,11 +180,11 @@ Definition dlet_ty na b B t (p : pos B) : pos (tLetIn na b B t) := Definition dlet_in na b B t (p : pos t) : pos (tLetIn na b B t) := exist (let_in :: proj1_sig p) (proj2_sig p). -Lemma eq_context_upto_context_choice_term Σ Re Rle Γ Γ' c : - eq_context_upto Σ Re Rle Γ Γ' -> - rel_option (eq_term_upto_univ Σ Re (match c.2 with - | choose_decl_body => Re - | choose_decl_type => Rle +Lemma eq_context_upto_context_choice_term Σ cmp_universe cmp_sort pb Γ Γ' c : + eq_context_upto Σ cmp_universe cmp_sort pb Γ Γ' -> + rel_option (eq_term_upto_univ Σ cmp_universe cmp_sort (match c.2 with + | choose_decl_body => Conv + | choose_decl_type => pb end) ) (context_choice_term Γ c) (context_choice_term Γ' c). @@ -203,13 +203,13 @@ Proof. Qed. Lemma eq_term_upto_valid_pos : - forall {Σ u v p Re Rle napp}, + forall {Σ u v p cmp_universe cmp_sort pb napp}, validpos u p -> - eq_term_upto_univ_napp Σ Re Rle napp u v -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp u v -> validpos v p. Proof. - intros Σ u v p Re Rle napp vp e. - induction p as [| c p ih ] in u, v, Re, Rle, napp, vp, e |- *. + intros Σ u v p cmp_universe cmp_sort pb napp vp e. + induction p as [| c p ih ] in u, v, pb, napp, vp, e |- *. - reflexivity. - destruct c, u. all: try discriminate. all: try solve [ @@ -219,50 +219,38 @@ Proof. + dependent destruction e. simpl in *. destruct (nth_error (pparams p0) n) as [par|] eqn:enth. 2: discriminate. destruct e. - induction a0 in n, par, enth, ih, vp |- *. 1: rewrite enth. 1: assumption. + induction a in n, par, enth, ih, vp |- *. 1: rewrite enth. 1: assumption. destruct n. * simpl in *. apply some_inj in enth. subst. intuition eauto. - * simpl in *. eapply IHa0. all: eauto. + * simpl in *. eapply IHa. all: eauto. + dependent destruction e. simpl in *. eapply ih; eauto. apply e. + dependent destruction e. simpl in *. destruct nth_error eqn:nth; [|congruence]. - eapply All2_nth_error_Some in a; eauto. - destruct a as (?&->&_&eq). + eapply All2_nth_error_Some in e1; eauto. + destruct e1 as (?&->&_&eq). eauto. + dependent destruction e. simpl in *. - destruct (nth_error mfix n) as [[na ty bo ra]|] eqn:e. 2: discriminate. - induction a in n, na, ty, bo, ra, e, ih, vp |- *. - 1:{ rewrite e. assumption. } - destruct n. - * simpl in *. apply some_inj in e. subst. - destruct y as [na' ty' bo' ra']. simpl in *. intuition eauto. - * simpl in *. eapply IHa. all: eauto. + destruct (nth_error mfix n) as [[na ty bo ra]|] eqn:e1. 2: discriminate. + eapply All2_nth_error_Some in e; eauto. + destruct e as (?&->&H&_). + now eapply ih. + dependent destruction e. simpl in *. - destruct (nth_error mfix n) as [[na ty bo ra]|] eqn:e. 2: discriminate. - induction a in n, na, ty, bo, ra, e, ih, vp |- *. - 1:{ rewrite e. assumption. } - destruct n. - * simpl in *. apply some_inj in e. subst. - destruct y as [na' ty' bo' ra']. simpl in *. intuition eauto. - * simpl in *. eapply IHa. all: eauto. + destruct (nth_error mfix n) as [[na ty bo ra]|] eqn:e1. 2: discriminate. + eapply All2_nth_error_Some in e; eauto. + destruct e as (?&->&_&H&_). + now eapply ih. + dependent destruction e. simpl in *. - destruct (nth_error mfix n) as [[na ty bo ra]|] eqn:e. 2: discriminate. - induction a in n, na, ty, bo, ra, e, ih, vp |- *. - 1:{ rewrite e. assumption. } - destruct n. - * simpl in *. apply some_inj in e. subst. - destruct y as [na' ty' bo' ra']. simpl in *. intuition eauto. - * simpl in *. eapply IHa. all: eauto. + destruct (nth_error mfix n) as [[na ty bo ra]|] eqn:e1. 2: discriminate. + eapply All2_nth_error_Some in e; eauto. + destruct e as (?&->&H&_). + now eapply ih. + dependent destruction e. simpl in *. - destruct (nth_error mfix n) as [[na ty bo ra]|] eqn:e. 2: discriminate. - induction a in n, na, ty, bo, ra, e, ih, vp |- *. - 1:{ rewrite e. assumption. } - destruct n. - * simpl in *. apply some_inj in e. subst. - destruct y as [na' ty' bo' ra']. simpl in *. intuition eauto. - * simpl in *. eapply IHa. all: eauto. + destruct (nth_error mfix n) as [[na ty bo ra]|] eqn:e1. 2: discriminate. + eapply All2_nth_error_Some in e; eauto. + destruct e as (?&->&_&H&_). + now eapply ih. + depelim e. depelim o; eauto. + depelim e; depelim o; eauto. + depelim e. depelim o; eauto. diff --git a/pcuic/theories/Syntax/PCUICReflect.v b/pcuic/theories/Syntax/PCUICReflect.v index 47fafc878..15a6b788e 100644 --- a/pcuic/theories/Syntax/PCUICReflect.v +++ b/pcuic/theories/Syntax/PCUICReflect.v @@ -25,7 +25,7 @@ Local Ltac fcase c := Local Ltac term_dec_tac term_dec := repeat match goal with | t : term, u : term |- _ => fcase (term_dec t u) - | u : Universe.t, u' : Universe.t |- _ => fcase (eq_dec u u') + | u : sort, u' : sort |- _ => fcase (eq_dec u u') | x : Instance.t, y : Instance.t |- _ => fcase (eq_dec x y) | x : list Level.t, y : Instance.t |- _ => diff --git a/pcuic/theories/Typing/PCUICContextConversionTyp.v b/pcuic/theories/Typing/PCUICContextConversionTyp.v index b06f7ee3a..c1ac54485 100644 --- a/pcuic/theories/Typing/PCUICContextConversionTyp.v +++ b/pcuic/theories/Typing/PCUICContextConversionTyp.v @@ -146,16 +146,37 @@ Proof. eapply All2_fold_refl. intros ? ?; reflexivity. Qed. -Lemma cumul_context_Algo_Spec {cf:checker_flags} Σ Γ' Γ : - Σ ⊢ Γ' ≤ Γ -> PCUICCumulativitySpec.cumul_context cumulSpec0 Σ Γ' Γ. +Lemma eq_context_cumul_Spec {cf:checker_flags} Σ pb Γ Δ : + compare_context Σ pb Γ Δ -> PCUICCumulativitySpec.cumul_pb_context cumulSpec0 pb Σ Γ Δ. Proof. intros e. eapply All2_fold_impl. 1: tea. cbn; intros. destruct X. - - econstructor 1; eauto. eapply (@cumulAlgo_cumulSpec _ _ Cumul); eauto. + - econstructor 1; eauto. eapply eq_term_upto_univ_cumulSpec; eauto. - econstructor 2; eauto. - + eapply (@cumulAlgo_cumulSpec _ _ Conv); eauto. - + eapply (@cumulAlgo_cumulSpec _ _ Cumul); eauto. + all: eapply eq_term_upto_univ_cumulSpec; eauto. +Defined. + +Lemma eq_context_cumul_Spec_rel {cf:checker_flags} Σ Ξ0 Γ Δ : + compare_context Σ Cumul Γ Δ -> cumul_ctx_rel cumulSpec0 Σ Ξ0 Γ Δ. +Proof. + intros e. + eapply All2_fold_impl. 1: tea. cbn; intros. + destruct X. + - econstructor 1; eauto. eapply eq_term_upto_univ_cumulSpec; eauto. + - econstructor 2; eauto. + all: eapply eq_term_upto_univ_cumulSpec; eauto. +Defined. + +Lemma cumul_context_Algo_Spec {cf:checker_flags} Σ pb Γ' Γ : + Σ ⊢ Γ' ≤[pb] Γ -> PCUICCumulativitySpec.cumul_pb_context cumulSpec0 pb Σ Γ' Γ. +Proof. + intros e. + eapply All2_fold_impl. 1: tea. cbn; intros. + destruct X. + - econstructor 1; eauto. eapply cumulAlgo_cumulSpec; eauto. + - econstructor 2; eauto. + all: eapply cumulAlgo_cumulSpec; eauto. Defined. Lemma context_cumulativity_prop {cf:checker_flags} : @@ -297,7 +318,8 @@ Lemma closed_context_cumulativity {cf:checker_flags} {Σ} {wfΣ : wf Σ.1} Γ {p Proof. intros h hΓ' e. pose proof (ws_cumul_ctx_pb_forget e). - destruct pb; eapply context_cumulativity_prop; eauto. + eapply context_cumulativity_prop; eauto. + destruct pb; tas. eapply conv_cumul_context in e; tea. eapply (ws_cumul_ctx_pb_forget e). Qed. diff --git a/pcuic/theories/Typing/PCUICInstTyp.v b/pcuic/theories/Typing/PCUICInstTyp.v index c085063c1..bc6dc5704 100644 --- a/pcuic/theories/Typing/PCUICInstTyp.v +++ b/pcuic/theories/Typing/PCUICInstTyp.v @@ -187,9 +187,9 @@ Proof. + eapply All2_map. repeat toAll. eapply All2_impl. 1: tea. cbn; intros. destruct_head'_prod; eauto. + unfold preturn. cbn. - unshelve erewrite (All2_fold_length _ : #|pcontext _| = #|pcontext _|); shelve_unifiable; tea. + unshelve erewrite (All2_length _ : #|pcontext _| = #|pcontext _|); shelve_unifiable; tea. exactly_once (idtac; multimatch goal with H : _ |- _ => eapply H end); eauto. - ++ unshelve erewrite <- (All2_fold_length _ : #|pcontext _| = #|pcontext _|); shelve_unifiable; tea. + ++ unshelve erewrite <- (All2_length _ : #|pcontext _| = #|pcontext _|); shelve_unifiable; tea. rewrite <- inst_case_predicate_context_length. rewrite inst_case_predicate_context_inst; eauto. eapply closed_subst_ext. 2: symmetry; apply up_Upn. @@ -209,17 +209,17 @@ Proof. unfold is_open_term. rewrite app_length. rewrite <- shiftnP_add. rewrite inst_case_predicate_context_length. - unshelve erewrite (All2_fold_length _ : #|pcontext _| = #|pcontext _|); shelve_unifiable; tea. + unshelve erewrite (All2_length _ : #|pcontext _| = #|pcontext _|); shelve_unifiable; tea. * eauto. - * rename Hbody into Hbrsbrs'. + * rename Hbody into Hbrsbrs'. unfold cumul_branches, cumul_branch in *. repeat toAll. eapply All2_impl. 1: tea. cbn; intros; destruct_head'_prod. - unshelve erewrite (All2_fold_length _ : #|bcontext _| = #|bcontext _|); shelve_unifiable; tea. + unshelve erewrite (All2_length _ : #|bcontext _| = #|bcontext _|); shelve_unifiable; tea. split; eauto. repeat match goal with H : is_true (andb _ _) |- _ => apply andb_and in H; destruct H end. rewrite -> test_context_k_closed_on_free_vars_ctx in *. exactly_once (idtac; multimatch goal with H : _ |- _ => eapply H end); eauto. - + unshelve erewrite <- (All2_fold_length _ : #|bcontext _| = #|bcontext _|); shelve_unifiable; tea. + + unshelve erewrite <- (All2_length _ : #|bcontext _| = #|bcontext _|); shelve_unifiable; tea. rewrite <- (inst_case_branch_context_length p). rewrite inst_case_branch_context_inst; eauto. eapply closed_subst_ext. 2: symmetry; apply up_Upn. @@ -242,9 +242,9 @@ Proof. unfold is_open_term. rewrite app_length. rewrite <- shiftnP_add. rewrite inst_case_branch_context_length. - unshelve erewrite (All2_fold_length _ : #|bcontext _| = #|bcontext _|); shelve_unifiable; tea. + unshelve erewrite (All2_length _ : #|bcontext _| = #|bcontext _|); shelve_unifiable; tea. - eapply cumul_Proj; try apply X0; eauto. - - cbn. eapply cumul_Fix. cbn in HfreeA, HfreeB. + - cbn. eapply cumul_Fix. cbn in HfreeA, HfreeB. unfold cumul_mfixpoint in *. repeat toAll. eapply All2_impl. 1: tea. cbn; intros. destruct_head'_prod. repeat split; eauto. @@ -285,7 +285,7 @@ Proof. rewrite fix_context_length. rewrite (All2_length X). eauto. - cbn. rewrite (All2_length X). - eapply cumul_CoFix. cbn in HfreeA, HfreeB. + eapply cumul_CoFix. cbn in HfreeA, HfreeB. unfold cumul_mfixpoint in *. repeat toAll. eapply All2_impl. 1: tea. cbn; intros. destruct_head'_prod. diff --git a/pcuic/theories/Typing/PCUICNamelessTyp.v b/pcuic/theories/Typing/PCUICNamelessTyp.v index 9e5d3fcd7..9b60d2709 100644 --- a/pcuic/theories/Typing/PCUICNamelessTyp.v +++ b/pcuic/theories/Typing/PCUICNamelessTyp.v @@ -102,7 +102,7 @@ Proof. now setoid_rewrite <- nl_check_one_cofix. Qed. -Lemma wf_universe_nl Σ u : wf_universe Σ u -> wf_universe (nlg Σ) u. +Lemma wf_sort_nl Σ u : wf_sort Σ u -> wf_sort (nlg Σ) u. Proof. destruct u; simpl; auto. intros. @@ -150,7 +150,7 @@ Proof. constructor. 1: eauto using nlg_wf_local. unfold nlctx. rewrite nth_error_map. now rewrite H. - constructor; eauto using nlg_wf_local. - now apply wf_universe_nl. + now apply wf_sort_nl. - replace (nl (cst_type decl)) with (cst_type (map_constant_body nl decl)); [|destruct decl; reflexivity]. constructor; eauto using nlg_wf_local. diff --git a/pcuic/theories/Typing/PCUICRenameTyp.v b/pcuic/theories/Typing/PCUICRenameTyp.v index 41454abbb..e94c5f32e 100644 --- a/pcuic/theories/Typing/PCUICRenameTyp.v +++ b/pcuic/theories/Typing/PCUICRenameTyp.v @@ -260,11 +260,11 @@ Proof. repeat split; eauto. + eapply All2_map. apply forallb_All in Hp, Hp'. repeat toAll. eapply All2_impl. 1: tea. cbn; intros. destruct X as [[X [X''' X']] X'']. apply X'; eauto. - + unfold preturn. cbn. unshelve erewrite (All2_fold_length _ : #|pcontext _| = #|pcontext _|); shelve_unifiable; tea. + + unfold preturn. cbn. unshelve erewrite (All2_length _ : #|pcontext _| = #|pcontext _|); shelve_unifiable; tea. exactly_once (idtac; multimatch goal with H : _ |- _ => eapply H end); eauto. ++ rewrite app_context_length. eapply urenaming_ext; try apply shiftnP_add; try reflexivity. - unshelve erewrite <- (All2_fold_length _ : #|pcontext _| = #|pcontext _|); shelve_unifiable; tea. + unshelve erewrite <- (All2_length _ : #|pcontext _| = #|pcontext _|); shelve_unifiable; tea. rewrite <- inst_case_predicate_context_length. rewrite test_context_k_closed_on_free_vars_ctx in Hcontext. rewrite inst_case_predicate_context_rename; eauto. @@ -281,25 +281,26 @@ Proof. unfold is_open_term. rewrite app_length. rewrite <- shiftnP_add. rewrite inst_case_predicate_context_length. - unshelve erewrite (All2_fold_length _ : #|pcontext _| = #|pcontext _|); shelve_unifiable; tea. + unshelve erewrite (All2_length _ : #|pcontext _| = #|pcontext _|); shelve_unifiable; tea. ++ rewrite test_context_k_closed_on_free_vars_ctx in Hcontext. unfold inst_case_predicate_context. apply on_free_vars_ctx_inst_case_context; eauto. +++ eapply All_forallb. apply All_map. apply forallb_All in Hp; eapply All_impl. 1: tea. cbn; intros. eapply urename_is_open_term; eauto. +++ unfold pparams. cbn. rewrite map_length. exact Hcontext. * eauto. - * let X2 := match goal with H : All2 _ brs brs' |- _ => H end in + * unfold cumul_branches, cumul_branch in *. + let X2 := match goal with H : All2 _ brs brs' |- _ => H end in rename X2 into Hbrsbrs'. apply forallb_All in Hbrs, Hbrs'. apply (All2_All_mix_left Hbrs) in Hbrsbrs'. clear Hbrs. apply (All2_All_mix_right Hbrs') in Hbrsbrs'. clear Hbrs'. apply All2_map. repeat toAll. eapply All2_impl. 1: tea. cbn; intros; destruct_head'_prod. - unshelve erewrite (All2_fold_length _ : #|bcontext _| = #|bcontext _|); shelve_unifiable; tea. + unshelve erewrite (All2_length _ : #|bcontext _| = #|bcontext _|); shelve_unifiable; tea. split; eauto. repeat match goal with H : is_true (andb _ _) |- _ => apply andb_and in H; destruct H end. exactly_once (idtac; multimatch goal with H : _ |- _ => apply H end); eauto. + rewrite app_context_length. eapply urenaming_ext; try apply shiftnP_add; try reflexivity. - unshelve erewrite <- (All2_fold_length _ : #|bcontext _| = #|bcontext _|); shelve_unifiable; tea. + unshelve erewrite <- (All2_length _ : #|bcontext _| = #|bcontext _|); shelve_unifiable; tea. rewrite <- (inst_case_branch_context_length p). rewrite -> test_context_k_closed_on_free_vars_ctx in *. rewrite inst_case_branch_context_rename; eauto. @@ -317,7 +318,7 @@ Proof. unfold is_open_term. rewrite app_length. rewrite <- shiftnP_add. rewrite inst_case_branch_context_length. - unshelve erewrite (All2_fold_length _ : #|bcontext _| = #|bcontext _|); shelve_unifiable; tea. + unshelve erewrite (All2_length _ : #|bcontext _| = #|bcontext _|); shelve_unifiable; tea. + rewrite test_context_k_closed_on_free_vars_ctx in Hcontext. unfold inst_case_predicate_context. apply on_free_vars_ctx_inst_case_context; eauto. ++ eapply All_forallb. apply All_map. repeat toAll. eapply All_impl. 1: tea. diff --git a/pcuic/theories/Typing/PCUICUnivSubstitutionTyp.v b/pcuic/theories/Typing/PCUICUnivSubstitutionTyp.v index f7cb84c31..f5a3d55c4 100644 --- a/pcuic/theories/Typing/PCUICUnivSubstitutionTyp.v +++ b/pcuic/theories/Typing/PCUICUnivSubstitutionTyp.v @@ -21,17 +21,17 @@ Local Ltac aa := rdest; eauto with univ_subst. Section SubstIdentity. Context `{cf:checker_flags}. -Lemma compare_universe_subst_instance pb {Σ : global_env_ext} univs u : +Lemma compare_sort_subst_instance pb {Σ : global_env_ext} univs u : valid_constraints (global_ext_constraints (Σ.1, univs)) (subst_instance_cstrs u Σ) -> - RelationClasses.subrelation (compare_universe pb Σ) - (fun x y : Universe.t => - compare_universe pb (global_ext_constraints (Σ.1, univs)) (subst_instance_univ u x) - (subst_instance_univ u y)). + RelationClasses.subrelation (compare_sort Σ pb) + (fun x y : sort => + compare_sort (global_ext_constraints (Σ.1, univs)) pb (subst_instance_sort u x) + (subst_instance_sort u y)). Proof using Type. intros v. destruct pb; cbn. - - now apply eq_universe_subst_instance. - - now apply leq_universe_subst_instance. + - now apply eq_sort_subst_instance. + - now apply leq_sort_subst_instance. Qed. Lemma cumulSpec_subst_instance (Σ : global_env_ext) Γ u A B pb univs : @@ -105,12 +105,13 @@ Proof. - eapply cumul_Case; try solve [intuition eauto; eauto]. * cbv [cumul_predicate] in *; destruct_head'_prod. repeat split; eauto; cbn. + apply All2_map. repeat toAll. eapply All2_impl. 1: tea. cbn; intros. destruct_head'_prod; eauto. - + apply precompose_subst_instance. eapply R_universe_instance_impl. + + apply precompose_subst_instance. eapply cmp_universe_instance_impl. 1:now apply eq_universe_subst_instance. eauto. + rewrite -> subst_instance_app, inst_case_predicate_context_subst_instance in *. eauto. - * eapply All2_map. repeat toAll. eapply All2_impl. 1: tea. cbn; intros. + * unfold cumul_branches, cumul_branch in *. + eapply All2_map. repeat toAll. eapply All2_impl. 1: tea. cbn; intros. repeat split; intuition eauto. rewrite -> subst_instance_app, inst_case_branch_context_subst_instance in *; eauto. - eapply cumul_Fix. apply All2_map. repeat toAll. eapply All2_impl. 1: tea. @@ -120,26 +121,26 @@ Proof. cbn; intros; intuition eauto. rewrite -> subst_instance_app, fix_context_subst_instance in *; eauto. - eapply cumul_Prim. depelim e0; depelim X; cbn in H; cbn; noconf H; cbn in H; constructor; cbn -[Universe.make]; eauto. - + rewrite -!subst_instance_univ_make. + + rewrite -!subst_instance_universe_make. eapply eq_universe_subst_instance; tea. + solve_all. - repeat rewrite subst_instance_mkApps. eapply cumul_Ind. * apply precompose_subst_instance_global. - rewrite map_length. eapply R_global_instance_impl_same_napp; try eapply H; eauto. + rewrite map_length. eapply cmp_global_instance_impl_same_napp; try eapply H; eauto. { now apply eq_universe_subst_instance. } { now apply compare_universe_subst_instance. } * eapply All2_map. repeat toAll. eapply All2_impl. 1: tea. cbn; intros. eapply X0.2; eauto. - repeat rewrite subst_instance_mkApps. eapply cumul_Construct. * apply precompose_subst_instance_global. cbn. - rewrite map_length. eapply R_global_instance_impl_same_napp; try eapply H; eauto. + rewrite map_length. eapply cmp_global_instance_impl_same_napp; try eapply H; eauto. { now apply eq_universe_subst_instance. } { now apply compare_universe_subst_instance. } * eapply All2_map. repeat toAll. eapply All2_impl. 1: tea. cbn; intros. eapply X0.2; eauto. - - eapply cumul_Sort. now apply compare_universe_subst_instance. + - eapply cumul_Sort. now apply compare_sort_subst_instance. - eapply cumul_Const. apply precompose_subst_instance. - eapply R_universe_instance_impl; eauto. + eapply cmp_universe_instance_impl; eauto. now apply compare_universe_subst_instance. Defined. @@ -265,7 +266,7 @@ Proof using Type. rewrite subst_instance_univ_super. + econstructor. * aa. - * now apply wf_universe_subst_instance. + * now apply wf_sort_subst_instance. - intros n t0 b s1 s2 X X0 X1 X2 X3 u univs wfΣ' H. rewrite product_subst_instance; aa. econstructor. + eapply lift_typing_mapu with (tm := None) (u := Some _) => //. apply X1; eauto. @@ -307,7 +308,7 @@ Proof using Type. change (map_predicate _ _ _ _ _) with (subst_instance i p). rewrite subst_instance_case_predicate_context. eapply type_Case with (p:=subst_instance i p) - (ps:=subst_instance_univ i u); eauto with pcuic. + (ps:=subst_instance_sort i u); eauto with pcuic. 3,4: constructor; eauto with pcuic. + rewrite -subst_instance_case_predicate_context - !subst_instance_app_ctx. eapply Hpty; eauto. @@ -393,9 +394,10 @@ Proof using Type. + exact H0. + now rewrite subst_instance_prim_val_tag. + destruct p as [? []]; depelim X1; constructor; eauto. - * rewrite -subst_instance_univ_make. eapply wf_universe_subst_instance => //. - * cbn -[Universe.make] in hty. - specialize (hty u univs). rewrite subst_instance_univ_make in hty. now eapply hty. + * rewrite -subst_instance_universe_make. eapply wf_universe_subst_instance => //. + * cbn -[Universe.make'] in hty. + specialize (hty u univs). + rewrite /subst_instance subst_instance_universe_make in hty. now eapply hty. * cbn. solve_all. - intros t0 A B X X0 X1 X2 X3 X4 cum u univs wfΣ' H. @@ -474,7 +476,7 @@ Lemma wf_local_instantiate_poly {Σ ctx Γ u} : wf_local Σ (subst_instance u Γ). Proof using Type. intros wfΣ Huniv wf. - epose proof (type_Sort _ _ Universes.Universe.lProp wf) as ty. forward ty. + epose proof (type_Sort _ _ sProp wf) as ty. forward ty. - now simpl. - eapply typing_subst_instance_ctx in ty; cbn; eauto using typing_wf_local. @@ -490,7 +492,7 @@ Lemma wf_local_instantiate {Σ} {decl : global_decl} {Γ u c} : wf_local Σ (subst_instance u Γ). Proof using Type. intros wfΣ Hdecl Huniv wf. - epose proof (type_Sort _ _ Universes.Universe.lProp wf) as ty. forward ty. + epose proof (type_Sort _ _ sProp wf) as ty. forward ty. - now simpl. - eapply typing_subst_instance_decl in ty; cbn; eauto using typing_wf_local. @@ -554,7 +556,7 @@ Qed. wf Σ -> declared_inductive Σ ind mdecl idecl -> let u := abstract_instance (ind_universes mdecl) in - subst_instance_univ u (ind_sort idecl) = ind_sort idecl. + subst_instance_sort u (ind_sort idecl) = ind_sort idecl. Proof using Type. intros wfΣ decli u. pose proof (on_declared_inductive decli) as [onmind oib]. diff --git a/pcuic/theories/Typing/PCUICWeakeningEnvTyp.v b/pcuic/theories/Typing/PCUICWeakeningEnvTyp.v index 0ccb54e3e..f4cb79137 100644 --- a/pcuic/theories/Typing/PCUICWeakeningEnvTyp.v +++ b/pcuic/theories/Typing/PCUICWeakeningEnvTyp.v @@ -111,7 +111,7 @@ Proof. - apply All_local_env_impl with (1 := X0) => Γ' j Hj. now apply Hj. - econstructor; eauto 2 with extends. - now apply extends_wf_universe. + now apply extends_wf_sort. - econstructor; eauto 2 with extends. all: econstructor; eauto 2 with extends. * revert X5. clear -Σ' wf0 wfΣ' extΣ. induction 1; constructor; try destruct t0; eauto with extends. @@ -149,11 +149,11 @@ Proof. apply on_global_decl_impl_full; eauto. - reflexivity. - intros ?????. eapply weakening_env_cumulSpec0; eauto. - - intro. eapply (extends_wf_universe (Σ:=(Σ,φ)) Σ'); auto. + - intro. eapply (extends_wf_sort (Σ:=(Σ,φ)) Σ'); auto. - unfold check_constructors_smaller. intros ???. eapply Forall_impl; tea; cbn. intros. eapply Forall_impl; tea; simpl; intros. - eapply leq_universe_subset; tea. + eapply leq_sort_subset; tea. apply weakening_env_global_ext_constraints; tea; eauto. - rewrite /on_variance. intros u l. destruct u => //. destruct l => //. diff --git a/pcuic/theories/utils/PCUICPrimitive.v b/pcuic/theories/utils/PCUICPrimitive.v index b9bcae6fa..9807da587 100644 --- a/pcuic/theories/utils/PCUICPrimitive.v +++ b/pcuic/theories/utils/PCUICPrimitive.v @@ -173,7 +173,7 @@ Inductive onPrims {term} (eq_term : term -> term -> Type) Re : prim_val term -> | onPrimsInt i : onPrims eq_term Re (primInt; primIntModel i) (primInt; primIntModel i) | onPrimsFloat f : onPrims eq_term Re (primFloat; primFloatModel f) (primFloat; primFloatModel f) | onPrimsArray a a' : - Re (Universe.make a.(array_level)) (Universe.make a'.(array_level)) -> + Re (Universe.make' a.(array_level)) (Universe.make' a'.(array_level)) -> eq_term a.(array_default) a'.(array_default) -> eq_term a.(array_type) a'.(array_type) -> All2 eq_term a.(array_value) a'.(array_value) -> @@ -192,7 +192,7 @@ Inductive onPrims_dep {term} (eq_term : term -> term -> Type) (Re : Universe.t - | onPrimsInt_dep i : onPrims_dep eq_term Re eq_term_dep Re' (primInt; primIntModel i) (primInt; primIntModel i) (onPrimsInt eq_term Re i) | onPrimsFloat_dep f : onPrims_dep eq_term Re eq_term_dep Re' (primFloat; primFloatModel f) (primFloat; primFloatModel f) (onPrimsFloat _ _ f) | onPrimsArray_dep a a' : - forall (hre : Re (Universe.make a.(array_level)) (Universe.make a'.(array_level))) + forall (hre : Re (Universe.make' a.(array_level)) (Universe.make' a'.(array_level))) (eqdef : eq_term a.(array_default) a'.(array_default)) (eqty : eq_term a.(array_type) a'.(array_type)) (eqt : All2 eq_term a.(array_value) a'.(array_value)), diff --git a/quotation/theories/CommonUtils.v b/quotation/theories/CommonUtils.v index 27f703c07..1364ef661 100644 --- a/quotation/theories/CommonUtils.v +++ b/quotation/theories/CommonUtils.v @@ -178,7 +178,7 @@ Module WithTemplate. end. Section with_monad. - Context {M} {M_monad : Monad M} (in_domain : bool) (U : Universe.t -> M term). + Context {M} {M_monad : Monad M} (in_domain : bool) (U : sort -> M term). #[local] Fixpoint tmRelaxSortsM (t : term) {struct t} : M term @@ -235,20 +235,20 @@ Module WithTemplate. end. End with_monad. - #[local] Definition is_set (s : Universe.t) : bool - := match option_map Level.is_set (Universe.get_is_level s) with + #[local] Definition is_set (s : sort) : bool + := match option_map Level.is_set (Sort.get_is_level s) with | Some true => true | _ => false end. - #[local] Definition is_type (s : Universe.t) : bool - := match Universe.get_is_level s with + #[local] Definition is_type (s : sort) : bool + := match Sort.get_is_level s with | Some _ => true | _ => false end. - #[local] Definition is_only_type (s : Universe.t) : bool - := match option_map Level.is_set (Universe.get_is_level s) with + #[local] Definition is_only_type (s : sort) : bool + := match option_map Level.is_set (Sort.get_is_level s) with | Some false => true | _ => false end. @@ -256,7 +256,7 @@ Module WithTemplate. Definition tmRelaxSet (in_domain : bool) (prefix : string) (t : term) : term := tmRelaxSortsM (M:=fun T => T) in_domain - (fun u => tSort (if is_set u then Universe.of_levels (inr (Level.level (prefix ++ "._Set.0")%bs)) else u)) + (fun u => tSort (if is_set u then Sort.of_levels (inr (Level.level (prefix ++ "._Set.0")%bs)) else u)) t. Module Import PrefixUniverse. @@ -302,21 +302,21 @@ Module WithTemplate. ; t_ne := eq_trans LevelExprSet.is_empty_prefix_with l.(t_ne) |}. End nonEmptyLevelExprSet. - Module LevelAlgExpr := nonEmptyLevelExprSet. + Module Universe := nonEmptyLevelExprSet. - Module Universe. - Definition prefix_with (prefix : string) (u : Universe.t) : Universe.t + Module Sort. + Definition prefix_with (prefix : string) (u : sort) : sort := match u with - | Universe.lProp | Universe.lSProp => u - | Universe.lType u => Universe.lType (LevelAlgExpr.prefix_with prefix u) + | sProp | sSProp => u + | sType u => sType (Universe.prefix_with prefix u) end. - End Universe. + End Sort. End PrefixUniverse. Definition tmRelaxOnlyType (in_domain : bool) (prefix : string) (t : term) : term := tmRelaxSortsM (M:=fun T => T) in_domain - (fun u => tSort (PrefixUniverse.Universe.prefix_with prefix u)) + (fun u => tSort (PrefixUniverse.Sort.prefix_with prefix u)) t. Polymorphic Definition tmRetypeMagicRelaxSetInCodomain@{a b t u} (prefix : string) {A : Type@{a}} (B : Type@{b}) (x : A) : TemplateMonad@{t u} B diff --git a/quotation/theories/ToPCUIC/Common/EnvironmentTyping.v b/quotation/theories/ToPCUIC/Common/EnvironmentTyping.v index b79606213..e138b1418 100644 --- a/quotation/theories/ToPCUIC/Common/EnvironmentTyping.v +++ b/quotation/theories/ToPCUIC/Common/EnvironmentTyping.v @@ -21,8 +21,10 @@ Module QuoteLookup (Import T : Term) (Import E : EnvironmentSig T) (Import L : L End with_refl. #[export] Instance quote_consistent_instance {cf lvs ϕ uctx u} : ground_quotable (@consistent_instance cf lvs ϕ uctx u) := ltac:(cbv [consistent_instance]; exact _). - #[export] Instance quote_wf_universe {Σ s} : ground_quotable (@wf_universe Σ s) - := ground_quotable_of_dec (@wf_universe_dec Σ s). + #[export] Instance quote_wf_universe {Σ u} : ground_quotable (@wf_universe Σ u) + := ground_quotable_of_dec (@wf_universe_dec Σ u). + #[export] Instance quote_wf_sort {Σ s} : ground_quotable (@wf_sort Σ s) + := ground_quotable_of_dec (@wf_sort_dec Σ s). #[export] Instance quote_declared_constant {Σ id decl} : ground_quotable (@declared_constant Σ id decl) := ltac:(cbv [declared_constant]; exact _). #[export] Instance quote_declared_minductive {Σ mind decl} : ground_quotable (@declared_minductive Σ mind decl) := ltac:(cbv [declared_minductive]; exact _). diff --git a/quotation/theories/ToPCUIC/Common/Universes.v b/quotation/theories/ToPCUIC/Common/Universes.v index 01327a51a..3077ec65a 100644 --- a/quotation/theories/ToPCUIC/Common/Universes.v +++ b/quotation/theories/ToPCUIC/Common/Universes.v @@ -58,7 +58,7 @@ End QuoteUniverses1. Export (hints) QuoteUniverses1. #[export] Hint Unfold - LevelAlgExpr.t + Universe.t Instance.t UContext.t AUContext.t @@ -68,34 +68,20 @@ Export (hints) QuoteUniverses1. : quotation. #[export] Typeclasses Transparent - LevelAlgExpr.t + Universe.t Instance.t UContext.t AUContext.t ContextSet.t . -#[export] Instance quote_nonEmptyLevelExprSet : ground_quotable nonEmptyLevelExprSet := ltac:(destruct 1; exact _). - -#[export] Instance quote_concreteUniverses : ground_quotable concreteUniverses := ltac:(destruct 1; exact _). -Import StrongerInstances. -#[export] Instance quote_leq_cuniverse_n {cf n u u'} : ground_quotable (@leq_cuniverse_n cf n u u') := ltac:(cbv [leq_cuniverse_n]; exact _). -#[export] Instance quote_is_uprop {u} : ground_quotable (@is_uprop u) := ltac:(cbv [is_uprop]; exact _). -#[export] Instance quote_is_usprop {u} : ground_quotable (@is_usprop u) := ltac:(cbv [is_usprop]; exact _). -#[export] Instance quote_is_uproplevel {u} : ground_quotable (@is_uproplevel u) := ltac:(cbv [is_uproplevel]; exact _). -#[export] Instance quote_is_uproplevel_or_set {u} : ground_quotable (@is_uproplevel_or_set u) := ltac:(cbv [is_uproplevel_or_set]; exact _). -#[export] Instance quote_is_utype {u} : ground_quotable (@is_utype u) := ltac:(cbv [is_utype]; exact _). - -#[export] Instance quote_allowed_eliminations : ground_quotable allowed_eliminations := ltac:(destruct 1; exact _). -#[export] Instance quote_is_allowed_elimination_cuniv {allowed u} : ground_quotable (is_allowed_elimination_cuniv allowed u) := ltac:(destruct allowed; cbv [is_allowed_elimination_cuniv]; exact _). - Module QuoteUniverses2. Module Import Universe. - #[export] Instance quote_t_ : ground_quotable Universe.t_ := ltac:(destruct 1; exact _). - #[export] Hint Unfold Universe.t : quotation. - #[export] Typeclasses Transparent Universe.t. + #[export] Instance quote_t_ {univ} {quniv : quotation_of univ} {quote_univ : ground_quotable univ} : ground_quotable (Sort.t_ univ) := ltac:(destruct 1; exact _). + #[export] Hint Unfold sort : quotation. + #[export] Typeclasses Transparent sort. #[local] Hint Constructors or eq : typeclass_instances. - #[export] Instance quote_on_sort {P def s} {quoteP : forall l, s = Universe.lType l -> ground_quotable (P l:Prop)} {quote_def : s = Universe.lProp \/ s = Universe.lSProp -> ground_quotable (def:Prop)} : ground_quotable (@Universe.on_sort P def s) := ltac:(cbv [Universe.on_sort]; exact _). + #[export] Instance quote_on_sort {univ P def s} {quniv : quotation_of univ} {quote_univ : ground_quotable univ} {quoteP : forall l, s = sType l -> ground_quotable (P l : Prop)} {quote_def : s = sProp \/ s = sSProp -> ground_quotable (def : Prop)} : ground_quotable (@Sort.on_sort univ Prop P def s) := ltac:(cbv [Sort.on_sort]; exact _). End Universe. Export (hints) Universe. @@ -129,6 +115,14 @@ Module QuoteUniverses2. End QuoteUniverses2. Export (hints) QuoteUniverses2. +#[export] Instance quote_nonEmptyLevelExprSet : ground_quotable nonEmptyLevelExprSet := ltac:(destruct 1; exact _). +#[export] Instance quote_Universe : ground_quotable Universe.t := ltac:(destruct 1; exact _). + +#[export] Instance quote_concrete_sort : ground_quotable concrete_sort := ltac:(destruct 1; exact _). +Import StrongerInstances. + +#[export] Instance quote_allowed_eliminations : ground_quotable allowed_eliminations := ltac:(destruct 1; exact _). + #[export] Instance quote_declared_cstr_levels {levels cstr} : ground_quotable (declared_cstr_levels levels cstr) := ltac:(cbv [declared_cstr_levels]; exact _). #[export] Instance quote_universes_decl : ground_quotable universes_decl := ltac:(destruct 1; exact _). #[export] Instance quote_satisfies0 {v s} {qv : quotation_of v} : ground_quotable (@satisfies0 v s) @@ -139,16 +133,19 @@ Export (hints) QuoteUniverses2. := ground_quotable_of_dec (@consistent_dec ctrs). #[export] Instance quote_consistent_extension_on {cs cstr} : ground_quotable (@consistent_extension_on cs cstr) := ground_quotable_of_dec (@consistent_extension_on_dec cs cstr). -#[export] Instance quote_leq_levelalg_n {cf n ϕ u u'} : ground_quotable (@leq_levelalg_n cf (uGraph.Z_of_bool n) ϕ u u') - := ground_quotable_of_dec (@leq_levelalg_n_dec cf _ ϕ u u'). -#[export] Instance quote_leq_universe_n_ {cf CS leq_levelalg_n n ϕ s s'} {quote_leq_levelalg_n : forall u u', ground_quotable (leq_levelalg_n n ϕ u u':Prop)} : ground_quotable (@leq_universe_n_ cf CS leq_levelalg_n n ϕ s s') := ltac:(cbv [leq_universe_n_]; exact _). -#[export] Instance quote_leq_universe_n {cf n ϕ s s'} : ground_quotable (@leq_universe_n cf (uGraph.Z_of_bool n) ϕ s s') := ltac:(cbv [leq_universe_n]; exact _). +#[export] Instance quote_leq_universe_n {cf n ϕ u u'} : ground_quotable (@leq_universe_n cf (uGraph.Z_of_bool n) ϕ u u') + := ground_quotable_of_dec (@leq_universe_n_dec cf _ ϕ u u'). #[export] Instance quote_leq_universe {cf ϕ s s'} : ground_quotable (@leq_universe cf ϕ s s') := @quote_leq_universe_n cf false ϕ s s'. -#[export] Instance quote_eq_levelalg {cf ϕ u u'} : ground_quotable (@eq_levelalg cf ϕ u u') - := ground_quotable_of_dec (@eq_levelalg_dec cf ϕ u u'). -#[export] Instance quote_eq_universe_ {CS pst eq_levelalg ϕ s s'} {quote_eq_levelalg : forall u u', ground_quotable (eq_levelalg ϕ u u':Prop)} : ground_quotable (@eq_universe_ pst CS eq_levelalg ϕ s s') := ltac:(cbv [eq_universe_]; exact _). -#[export] Instance quote_eq_universe {cf ϕ s s'} : ground_quotable (@eq_universe cf ϕ s s') := ltac:(cbv [eq_universe]; exact _). -#[export] Instance quote_compare_universe {cf pb ϕ u u'} : ground_quotable (@compare_universe cf pb ϕ u u') := ltac:(destruct pb; cbv [compare_universe]; exact _). +#[export] Instance quote_leq_sort_n_ {cf univ leq_universe_n n s s'} {quote_leq_universe_n : forall u u', ground_quotable (leq_universe_n n u u':Prop)} : ground_quotable (@leq_sort_n_ cf univ leq_universe_n n s s') := ltac:(cbv [leq_sort_n_]; exact _). +#[export] Instance quote_leq_csort_n {cf n s s'} : ground_quotable (@leq_csort_n cf n s s') := @quote_leq_sort_n_ cf nat _ n s s' _. +#[export] Instance quote_leq_sort_n {cf n ϕ s s'} : ground_quotable (@leq_sort_n cf (uGraph.Z_of_bool n) ϕ s s') := ltac:(cbv [leq_sort_n]; exact _). +#[export] Instance quote_leq_sort {cf ϕ s s'} : ground_quotable (@leq_sort cf ϕ s s') := @quote_leq_sort_n cf false ϕ s s'. +#[export] Instance quote_eq_universe {cf ϕ u u'} : ground_quotable (@eq_universe cf ϕ u u') + := ground_quotable_of_dec (@eq_universe_dec cf ϕ u u'). +#[export] Instance quote_eq_sort_ {univ eq_universe s s'} {quote_eq_universe : forall u u', ground_quotable (eq_universe u u':Prop)} : ground_quotable (@eq_sort_ univ eq_universe s s') := ltac:(cbv [eq_sort_]; exact _). +#[export] Instance quote_eq_sort {cf ϕ s s'} : ground_quotable (@eq_sort cf ϕ s s') := ltac:(cbv [eq_sort]; exact _). +#[export] Instance quote_compare_universe {cf univ pb u u'} : ground_quotable (@compare_universe cf univ pb u u') := ltac:(destruct pb; cbv [compare_universe]; exact _). +#[export] Instance quote_compare_sort {cf univ pb u u'} : ground_quotable (@compare_sort cf univ pb u u') := ltac:(destruct pb; cbv [compare_sort]; exact _). #[export] Instance quote_valid_constraints0 {ϕ ctrs} : ground_quotable (@valid_constraints0 ϕ ctrs) := ground_quotable_of_dec (@valid_constraints0_dec ϕ ctrs). #[export] Instance quote_valid_constraints {cf ϕ ctrs} : ground_quotable (@valid_constraints cf ϕ ctrs) diff --git a/quotation/theories/ToPCUIC/Coq/Init.v b/quotation/theories/ToPCUIC/Coq/Init.v index 02d39f555..b0a969fa0 100644 --- a/quotation/theories/ToPCUIC/Coq/Init.v +++ b/quotation/theories/ToPCUIC/Coq/Init.v @@ -75,6 +75,12 @@ End Init. #[export] Instance quote_sumbool {A B : Prop} {qA : quotation_of A} {qB : quotation_of B} {quoteA : ground_quotable A} {quoteB : ground_quotable B} : ground_quotable (sumbool A B) := ltac:(destruct 1; exact _). #[export] Instance quote_sumor {A} {B : Prop} {qA : quotation_of A} {qB : quotation_of B} {quoteA : ground_quotable A} {quoteB : ground_quotable B} : ground_quotable (sumor A B) := ltac:(destruct 1; exact _). +Definition quote_or_dec {P Q : Prop} (dec : P \/ Q -> {P} + {Q}) {qP : quotation_of P} {qQ : quotation_of Q} {quoteP : ground_quotable P} {quoteQ : ground_quotable Q} : ground_quotable (or P Q). +Proof. + intro pf. + destruct (dec pf). + all: adjust_quotation_of_by_econstructor_then ltac:(fun _ => destruct pf; first [ eassumption | tauto ]) ltac:(fun _ => exact _). +Defined. Definition quote_or_dec_l {P Q : Prop} (decP : {P} + {~P}) {qP : quotation_of P} {qQ : quotation_of Q} {quoteP : ground_quotable P} {quoteQ : ground_quotable Q} : ground_quotable (or P Q). Proof. destruct decP. diff --git a/quotation/theories/ToPCUIC/PCUIC/PCUICCumulativitySpec.v b/quotation/theories/ToPCUIC/PCUIC/PCUICCumulativitySpec.v index 284810bb3..2522a9241 100644 --- a/quotation/theories/ToPCUIC/PCUIC/PCUICCumulativitySpec.v +++ b/quotation/theories/ToPCUIC/PCUIC/PCUICCumulativitySpec.v @@ -6,10 +6,16 @@ From MetaCoq.Quotation.ToPCUIC.Common Require Import (hints) config BasicAst Uni From MetaCoq.Quotation.ToPCUIC.PCUIC Require Import (hints) PCUICAst PCUICEquality utils.PCUICPrimitive. From MetaCoq.Quotation.ToPCUIC.QuotationOf.Common Require Import EnvironmentTyping.Sig. -#[export] Instance quote_cumul_predicate {cumul Γ Re p p'} {qcumul : quotation_of cumul} {qRe : quotation_of Re} {quote_cumul : forall x y Γ, ground_quotable (cumul Γ x y)} {quote_Re : forall x y, ground_quotable (Re x y:Prop)} : ground_quotable (@cumul_predicate cumul Γ Re p p') +#[export] Instance quote_cumul_predicate {cumul Γ Re p p'} {qcumul : quotation_of cumul} {qRe : quotation_of Re} {quote_cumul : forall x y Γ, ground_quotable (cumul Γ x y)} {quote_Re : forall x y, ground_quotable (Re x y:Prop)} : ground_quotable (@cumul_predicate cumul Re Γ p p') := ltac:(cbv [cumul_predicate]; exact _). -Definition quote_cumul_predicate_via_dep {cumul Γ Re Re' p p'} {c : @cumul_predicate cumul Γ Re p p'} (qc : cumul_predicate_dep c (fun _ _ _ c => quotation_of c) Re') {qcumul : quotation_of cumul} {qRe : quotation_of Re} {quote_Re : forall x y, ground_quotable (Re x y:Prop)} : quotation_of c. +#[export] Instance quote_cumul_branch {cumul Γ p br br'} {qcumul : quotation_of cumul} {quote_cumul : forall x y Γ, ground_quotable (cumul Γ x y)} : ground_quotable (@cumul_branch cumul Γ p br br') +:= ltac:(cbv [cumul_branch]; exact _). + +#[export] Instance quote_cumul_mfixpoint {cumul Γ mfix mfix'} {qcumul : quotation_of cumul} {quote_cumul : forall x y Γ, ground_quotable (cumul Γ x y)} : ground_quotable (@cumul_mfixpoint cumul Γ mfix mfix') +:= ltac:(cbv [cumul_mfixpoint]; exact _). + +Definition quote_cumul_predicate_via_dep {cumul Γ Re Re' p p'} {c : @cumul_predicate cumul Re Γ p p'} (qc : cumul_predicate_dep c (fun _ _ _ c => quotation_of c) Re') {qcumul : quotation_of cumul} {qRe : quotation_of Re} {quote_Re : forall x y, ground_quotable (Re x y:Prop)} : quotation_of c. Proof. cbv [cumul_predicate cumul_predicate_dep] in *. repeat match goal with H : _ * _ |- _ => destruct H end. @@ -17,7 +23,7 @@ Proof. Defined. #[export] Hint Extern 0 (cumul_predicate_dep _ (fun _ _ _ r => quotation_of r) _) => eassumption : typeclass_instances. -#[export] Hint Extern 0 (@quotation_of (@cumul_predicate ?cumul ?Γ ?Re ?p ?p') ?x) +#[export] Hint Extern 0 (@quotation_of (@cumul_predicate ?cumul ?Re ?Γ ?p ?p') ?x) => lazymatch goal with | [ H : cumul_predicate_dep x (fun _ _ _ r => quotation_of r) ?Re' |- _ ] => simple eapply (@quote_cumul_predicate_via_dep cumul Γ Re Re' p p' x H) @@ -42,7 +48,9 @@ Defined. #[export] Instance quote_cumulSpec0 {cf Σ Γ pb t u} : ground_quotable (@cumulSpec0 cf Σ Γ pb t u). Proof. + pose proof (compare_universe_subrel Σ : forall pb, RelationClasses.subrelation (compare_universe Σ Conv) (compare_universe Σ pb)). induction 1. + all: unfold cumul_branches, cumul_branch, cumul_mfixpoint in *. all: lazymatch goal with | [ H : All_Forall.All2_dep ?T ?x |- _ ] => lazymatch T with diff --git a/quotation/theories/ToPCUIC/PCUIC/PCUICEquality.v b/quotation/theories/ToPCUIC/PCUIC/PCUICEquality.v index 904baa88f..ba56223fd 100644 --- a/quotation/theories/ToPCUIC/PCUIC/PCUICEquality.v +++ b/quotation/theories/ToPCUIC/PCUIC/PCUICEquality.v @@ -5,51 +5,61 @@ From MetaCoq.Quotation.ToPCUIC.Utils Require Import (hints) utils All_Forall. From MetaCoq.Quotation.ToPCUIC.Common Require Import (hints) config Reflect Environment Universes BasicAst Kernames. From MetaCoq.Quotation.ToPCUIC.PCUIC Require Import (hints) PCUICAst utils.PCUICPrimitive (*PCUICAstUtils*) (*Induction*). -#[export] Instance quote_R_universe_instance {R u u'} {qR : quotation_of R} {quoteR : forall x y, ground_quotable (R x y:Prop)} : ground_quotable (@R_universe_instance R u u') := ltac:(cbv [R_universe_instance]; exact _). +#[export] Instance quote_on_rel {T T'} {R} {f: T -> T'} {x y : T} {qR : quotation_of R} {quoteR : forall x y, ground_quotable (R x y:Prop)}: ground_quotable (MCRelations.on_rel R f x y) := ltac:(cbv [MCRelations.on_rel]; exact _). + +#[export] Instance quote_cmp_universe_instance {R u u'} {qR : quotation_of R} {quoteR : forall x y, ground_quotable (R x y:Prop)} : ground_quotable (@cmp_universe_instance R u u') := ltac:(cbv [cmp_universe_instance]; exact _). Section with_R. - Context {Re Rle : Universe.t -> Universe.t -> Prop} - {qRe : quotation_of Re} {qRle : quotation_of Rle} - {quoteRe : forall x y, ground_quotable (Re x y)} {quoteRle : forall x y, ground_quotable (Rle x y)}. + Context {cmp_universe : conv_pb -> Universe.t -> Universe.t -> Prop} + {qRe : quotation_of cmp_universe} + {quoteRe : forall pb x y, ground_quotable (cmp_universe pb x y)}. - #[export] Instance quote_R_universe_variance {v u u'} : ground_quotable (@R_universe_variance Re Rle v u u') := ltac:(cbv [R_universe_variance]; exact _). + #[export] Instance quote_cmp_universe_variance {pb v u u'} : ground_quotable (@cmp_universe_variance cmp_universe pb v u u') := ltac:(cbv [cmp_universe_variance]; exact _). - #[export] Instance quote_R_universe_instance_variance {v u u'} : ground_quotable (@R_universe_instance_variance Re Rle v u u') := ltac:(revert v u'; induction u, u'; cbn; exact _). + #[export] Instance quote_cmp_universe_instance_variance {pb v u u'} : ground_quotable (@cmp_universe_instance_variance cmp_universe pb v u u') := ltac:(cbv [cmp_universe_instance_variance]; exact _). - #[export] Instance quote_R_opt_variance {v u u'} : ground_quotable (@R_opt_variance Re Rle v u u') := ltac:(destruct v; cbv [R_opt_variance]; exact _). + #[export] Instance quote_cmp_opt_variance {pb v u u'} (subr : RelationClasses.subrelation (cmp_universe Conv) (cmp_universe pb)) : ground_quotable (@cmp_opt_variance cmp_universe pb v u u'). + Proof using cmp_universe qRe quoteRe. + destruct v; cbv [cmp_opt_variance]; try exact _. + eapply Coq.Init.quote_or_dec; try exact _. + now apply cmp_opt_variance_var_dec. + Defined. - #[export] Instance quote_R_global_instance {Σ gr napp u u'} : ground_quotable (@R_global_instance Σ Re Rle gr napp u u') := ltac:(cbv [R_global_instance]; exact _). + #[export] Instance quote_cmp_global_instance {Σ pb gr napp u u'} (subr : RelationClasses.subrelation (cmp_universe Conv) (cmp_universe pb)) : ground_quotable (@cmp_global_instance Σ cmp_universe pb gr napp u u') := ltac:(cbv [cmp_global_instance]; exact _). End with_R. #[export] Existing Instances - quote_R_universe_variance - quote_R_universe_instance_variance - quote_R_opt_variance - quote_R_global_instance + quote_cmp_universe_variance + quote_cmp_universe_instance_variance + quote_cmp_opt_variance + quote_cmp_global_instance . -#[export] Instance quote_compare_decls {eq_term leq_term u u'} {qeq_term : quotation_of eq_term} {qleq_term : quotation_of leq_term} {quote_eq_term : forall x y, ground_quotable (eq_term x y)} {quote_leq_term : forall x y, ground_quotable (leq_term x y)} : ground_quotable (@compare_decls eq_term leq_term u u') +#[export] Instance quote_compare_decls {d d'} : ground_quotable (@eq_decl_upto_names d d') := ltac:(destruct 1; exact _). #[export] Hint Unfold - eq_predicate + eq_predicate eq_branches eq_branch eq_mfixpoint : quotation. #[export] Typeclasses Transparent - eq_predicate + eq_predicate eq_branches eq_branch eq_mfixpoint . #[export] Instance quote_eq_term_upto_univ_napp - {Re Rle : Universe.t -> Universe.t -> Prop} - {qRe : quotation_of Re} {qRle : quotation_of Rle} - {quoteRe : forall x y, ground_quotable (Re x y)} {quoteRle : forall x y, ground_quotable (Rle x y)} - {Σ napp x y} - : ground_quotable (@eq_term_upto_univ_napp Σ Re Rle napp x y). + {cmp_universe : conv_pb -> Universe.t -> Universe.t -> Prop} + {cmp_sort : conv_pb -> sort -> sort -> Prop} + {qRe : quotation_of cmp_universe} {qRle : quotation_of cmp_sort} + {quoteRe : forall pb x y, ground_quotable (cmp_universe pb x y)} {quoteRle : forall pb x y, ground_quotable (cmp_sort pb x y)} + {Σ pb napp x y} + {subr : RelationClasses.subrelation (cmp_universe Conv) (cmp_universe pb)} + : ground_quotable (@eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp x y). Proof. - unfold ground_quotable; revert Σ Re Rle napp x y qRe qRle quoteRe quoteRle. - fix quote_eq_term_upto_univ_napp 11; intros. + unfold ground_quotable; revert Σ cmp_universe cmp_sort pb napp x y qRe qRle quoteRe quoteRle subr. + fix quote_eq_term_upto_univ_napp 13; intros. lazymatch type of quote_eq_term_upto_univ_napp with - | forall (x1 : ?X1) (x2 : ?X2) (x3 : ?X3) (x4 : ?X4) (x5 : ?X5) (x6 : ?X6) (x7 : ?X7) (x8 : ?X8) (x9 : ?X9) (x10 : ?X10) (t : ?X11), quotation_of t - => change (forall (x1 : X1) (x2 : X2) (x3 : X3) (x4 : X4) (x5 : X5) (x6 : X6) (x7 : X7) (x8 : X8) (x9 : X9) (x10 : X10), ground_quotable X11) in quote_eq_term_upto_univ_napp + | forall (x1 : ?X1) (x2 : ?X2) (x3 : ?X3) (x4 : ?X4) (x5 : ?X5) (x6 : ?X6) (x7 : ?X7) (x8 : ?X8) (x9 : ?X9) (x10 : ?X10) (x11 : ?X11) (x12 : ?X12) (t : ?X13), quotation_of t + => change (forall (x1 : X1) (x2 : X2) (x3 : X3) (x4 : X4) (x5 : X5) (x6 : X6) (x7 : X7) (x8 : X8) (x9 : X9) (x10 : X10) (x11 : X11) (x12 : X12), ground_quotable X13) in quote_eq_term_upto_univ_napp end. destruct t; replace_quotation_of_goal (). Defined. -#[export] Instance quote_compare_term {cf pb Σ ϕ x y} : ground_quotable (@compare_term cf pb Σ ϕ x y) := ltac:(cbv [compare_term]; exact _). +#[export] Instance quote_compare_term {cf pb Σ ϕ x y} : ground_quotable (@compare_term cf Σ ϕ pb x y). +Proof. unshelve eapply quote_eq_term_upto_univ_napp. apply compare_universe_subrel. Defined. diff --git a/quotation/theories/ToPCUIC/QuotationOf/Common/EnvironmentTyping/Sig.v b/quotation/theories/ToPCUIC/QuotationOf/Common/EnvironmentTyping/Sig.v index 91a36a67c..9aed1cc53 100644 --- a/quotation/theories/ToPCUIC/QuotationOf/Common/EnvironmentTyping/Sig.v +++ b/quotation/theories/ToPCUIC/QuotationOf/Common/EnvironmentTyping/Sig.v @@ -14,7 +14,7 @@ Module Type QuoteLookupSig (Import T : Term) (Import E : EnvironmentSig T) (Impo . #[export] Declare Instance quote_consistent_instance {cf lvs ϕ uctx u} : ground_quotable (@consistent_instance cf lvs ϕ uctx u). - #[export] Declare Instance quote_wf_universe {Σ s} : ground_quotable (@wf_universe Σ s). + #[export] Declare Instance quote_wf_sort {Σ s} : ground_quotable (@wf_sort Σ s). #[export] Declare Instance quote_declared_constant {Σ id decl} : ground_quotable (@declared_constant Σ id decl). #[export] Declare Instance quote_declared_minductive {Σ mind decl} : ground_quotable (@declared_minductive Σ mind decl). #[export] Declare Instance quote_declared_inductive {Σ ind mdecl decl} : ground_quotable (@declared_inductive Σ ind mdecl decl). diff --git a/quotation/theories/ToPCUIC/Utils/All_Forall.v b/quotation/theories/ToPCUIC/Utils/All_Forall.v index c46a9e524..0031d0442 100644 --- a/quotation/theories/ToPCUIC/Utils/All_Forall.v +++ b/quotation/theories/ToPCUIC/Utils/All_Forall.v @@ -31,3 +31,9 @@ Definition quote_All2_via_dep {A B R lsA lsB} {a : @All2 A B R lsA lsB} (qa : Al #[export] Instance quote_All2i_len {A B R lsA lsB} {qA : quotation_of A} {qB : quotation_of B} {qR : quotation_of R} {quoteA : ground_quotable A} {quoteB : ground_quotable B} {quoteR : forall n x y, ground_quotable (R n x y)} : ground_quotable (@All2i_len A B R lsA lsB) := ltac:(induction 1; exact _). #[export] Instance quote_All_fold {A P ls} {qA : quotation_of A} {qP : quotation_of P} {quoteA : ground_quotable A} {quoteP : forall x y, ground_quotable (P x y)} : ground_quotable (@All_fold A P ls) := ltac:(induction 1; exact _). #[export] Instance quote_All2_fold {A P ls1 ls2} {qA : quotation_of A} {qP : quotation_of P} {quoteA : ground_quotable A} {quoteP : forall x y z w, ground_quotable (P x y z w)} : ground_quotable (@All2_fold A P ls1 ls2) := ltac:(induction 1; exact _). +#[export] Instance quote_Forall3 {A B C R lsA lsB lsC} {qA : quotation_of A} {qB : quotation_of B} {qC : quotation_of C} {qR : quotation_of R} {quoteA : ground_quotable A} {quoteB : ground_quotable B} {quoteC : ground_quotable C} {quoteR : forall x y z, ground_quotable (R x y z:Prop)} : ground_quotable (@Forall3 A B C R lsA lsB lsC). +Proof. + revert lsB lsC; induction lsA as [|a lsA IH], lsB as [|b lsB], lsC as [|c lsC]. + all: try solve [ intro pf; exfalso; inversion pf ]. + all: adjust_ground_quotable_by_econstructor_inversion (). +Defined. diff --git a/quotation/theories/ToTemplate/Common/EnvironmentTyping.v b/quotation/theories/ToTemplate/Common/EnvironmentTyping.v index ca9448714..bb7dc2708 100644 --- a/quotation/theories/ToTemplate/Common/EnvironmentTyping.v +++ b/quotation/theories/ToTemplate/Common/EnvironmentTyping.v @@ -21,8 +21,10 @@ Module QuoteLookup (Import T : Term) (Import E : EnvironmentSig T) (Import L : L End with_refl. #[export] Instance quote_consistent_instance {cf lvs ϕ uctx u} : ground_quotable (@consistent_instance cf lvs ϕ uctx u) := ltac:(cbv [consistent_instance]; exact _). - #[export] Instance quote_wf_universe {Σ s} : ground_quotable (@wf_universe Σ s) - := ground_quotable_of_dec (@wf_universe_dec Σ s). + #[export] Instance quote_wf_universe {Σ u} : ground_quotable (@wf_universe Σ u) + := ground_quotable_of_dec (@wf_universe_dec Σ u). + #[export] Instance quote_wf_sort {Σ s} : ground_quotable (@wf_sort Σ s) + := ground_quotable_of_dec (@wf_sort_dec Σ s). #[export] Instance quote_declared_constant {Σ id decl} : ground_quotable (@declared_constant Σ id decl) := ltac:(cbv [declared_constant]; exact _). #[export] Instance quote_declared_minductive {Σ mind decl} : ground_quotable (@declared_minductive Σ mind decl) := ltac:(cbv [declared_minductive]; exact _). diff --git a/quotation/theories/ToTemplate/Common/Universes.v b/quotation/theories/ToTemplate/Common/Universes.v index db3f0d759..bf1ad2912 100644 --- a/quotation/theories/ToTemplate/Common/Universes.v +++ b/quotation/theories/ToTemplate/Common/Universes.v @@ -58,7 +58,7 @@ End QuoteUniverses1. Export (hints) QuoteUniverses1. #[export] Hint Unfold - LevelAlgExpr.t + Universe.t Instance.t UContext.t AUContext.t @@ -68,34 +68,20 @@ Export (hints) QuoteUniverses1. : quotation. #[export] Typeclasses Transparent - LevelAlgExpr.t + Universe.t Instance.t UContext.t AUContext.t ContextSet.t . -#[export] Instance quote_nonEmptyLevelExprSet : ground_quotable nonEmptyLevelExprSet := ltac:(destruct 1; exact _). - -#[export] Instance quote_concreteUniverses : ground_quotable concreteUniverses := ltac:(destruct 1; exact _). -Import StrongerInstances. -#[export] Instance quote_leq_cuniverse_n {cf n u u'} : ground_quotable (@leq_cuniverse_n cf n u u') := ltac:(cbv [leq_cuniverse_n]; exact _). -#[export] Instance quote_is_uprop {u} : ground_quotable (@is_uprop u) := ltac:(cbv [is_uprop]; exact _). -#[export] Instance quote_is_usprop {u} : ground_quotable (@is_usprop u) := ltac:(cbv [is_usprop]; exact _). -#[export] Instance quote_is_uproplevel {u} : ground_quotable (@is_uproplevel u) := ltac:(cbv [is_uproplevel]; exact _). -#[export] Instance quote_is_uproplevel_or_set {u} : ground_quotable (@is_uproplevel_or_set u) := ltac:(cbv [is_uproplevel_or_set]; exact _). -#[export] Instance quote_is_utype {u} : ground_quotable (@is_utype u) := ltac:(cbv [is_utype]; exact _). - -#[export] Instance quote_allowed_eliminations : ground_quotable allowed_eliminations := ltac:(destruct 1; exact _). -#[export] Instance quote_is_allowed_elimination_cuniv {allowed u} : ground_quotable (is_allowed_elimination_cuniv allowed u) := ltac:(destruct allowed; cbv [is_allowed_elimination_cuniv]; exact _). - Module QuoteUniverses2. Module Import Universe. - #[export] Instance quote_t_ : ground_quotable Universe.t_ := ltac:(destruct 1; exact _). - #[export] Hint Unfold Universe.t : quotation. - #[export] Typeclasses Transparent Universe.t. + #[export] Instance quote_t_ {univ} {quniv : quotation_of univ} {quote_univ : ground_quotable univ} : ground_quotable (Sort.t_ univ) := ltac:(destruct 1; exact _). + #[export] Hint Unfold sort : quotation. + #[export] Typeclasses Transparent sort. #[local] Hint Constructors or eq : typeclass_instances. - #[export] Instance quote_on_sort {P def s} {quoteP : forall l, s = Universe.lType l -> ground_quotable (P l:Prop)} {quote_def : s = Universe.lProp \/ s = Universe.lSProp -> ground_quotable (def:Prop)} : ground_quotable (@Universe.on_sort P def s) := ltac:(cbv [Universe.on_sort]; exact _). + #[export] Instance quote_on_sort {univ P def s} {quniv : quotation_of univ} {quote_univ : ground_quotable univ} {quoteP : forall l, s = sType l -> ground_quotable (P l : Prop)} {quote_def : s = sProp \/ s = sSProp -> ground_quotable (def : Prop)} : ground_quotable (@Sort.on_sort univ Prop P def s) := ltac:(cbv [Sort.on_sort]; exact _). End Universe. Export (hints) Universe. @@ -129,6 +115,14 @@ Module QuoteUniverses2. End QuoteUniverses2. Export (hints) QuoteUniverses2. +#[export] Instance quote_nonEmptyLevelExprSet : ground_quotable nonEmptyLevelExprSet := ltac:(destruct 1; exact _). +#[export] Instance quote_Universe : ground_quotable Universe.t := ltac:(destruct 1; exact _). + +#[export] Instance quote_concrete_sort : ground_quotable concrete_sort := ltac:(destruct 1; exact _). +Import StrongerInstances. + +#[export] Instance quote_allowed_eliminations : ground_quotable allowed_eliminations := ltac:(destruct 1; exact _). + #[export] Instance quote_declared_cstr_levels {levels cstr} : ground_quotable (declared_cstr_levels levels cstr) := ltac:(cbv [declared_cstr_levels]; exact _). #[export] Instance quote_universes_decl : ground_quotable universes_decl := ltac:(destruct 1; exact _). #[export] Instance quote_satisfies0 {v s} {qv : quotation_of v} : ground_quotable (@satisfies0 v s) @@ -139,16 +133,19 @@ Export (hints) QuoteUniverses2. := ground_quotable_of_dec (@consistent_dec ctrs). #[export] Instance quote_consistent_extension_on {cs cstr} : ground_quotable (@consistent_extension_on cs cstr) := ground_quotable_of_dec (@consistent_extension_on_dec cs cstr). -#[export] Instance quote_leq_levelalg_n {cf n ϕ u u'} : ground_quotable (@leq_levelalg_n cf (uGraph.Z_of_bool n) ϕ u u') - := ground_quotable_of_dec (@leq_levelalg_n_dec cf _ ϕ u u'). -#[export] Instance quote_leq_universe_n_ {cf CS leq_levelalg_n n ϕ s s'} {quote_leq_levelalg_n : forall u u', ground_quotable (leq_levelalg_n n ϕ u u':Prop)} : ground_quotable (@leq_universe_n_ cf CS leq_levelalg_n n ϕ s s') := ltac:(cbv [leq_universe_n_]; exact _). -#[export] Instance quote_leq_universe_n {cf n ϕ s s'} : ground_quotable (@leq_universe_n cf (uGraph.Z_of_bool n) ϕ s s') := ltac:(cbv [leq_universe_n]; exact _). +#[export] Instance quote_leq_universe_n {cf n ϕ u u'} : ground_quotable (@leq_universe_n cf (uGraph.Z_of_bool n) ϕ u u') + := ground_quotable_of_dec (@leq_universe_n_dec cf _ ϕ u u'). #[export] Instance quote_leq_universe {cf ϕ s s'} : ground_quotable (@leq_universe cf ϕ s s') := @quote_leq_universe_n cf false ϕ s s'. -#[export] Instance quote_eq_levelalg {cf ϕ u u'} : ground_quotable (@eq_levelalg cf ϕ u u') - := ground_quotable_of_dec (@eq_levelalg_dec cf ϕ u u'). -#[export] Instance quote_eq_universe_ {CS pst eq_levelalg ϕ s s'} {quote_eq_levelalg : forall u u', ground_quotable (eq_levelalg ϕ u u':Prop)} : ground_quotable (@eq_universe_ CS pst eq_levelalg ϕ s s') := ltac:(cbv [eq_universe_]; exact _). -#[export] Instance quote_eq_universe {cf ϕ s s'} : ground_quotable (@eq_universe cf ϕ s s') := ltac:(cbv [eq_universe]; exact _). -#[export] Instance quote_compare_universe {cf pb ϕ u u'} : ground_quotable (@compare_universe cf pb ϕ u u') := ltac:(destruct pb; cbv [compare_universe]; exact _). +#[export] Instance quote_leq_sort_n_ {cf univ leq_universe_n n s s'} {quote_leq_universe_n : forall u u', ground_quotable (leq_universe_n n u u':Prop)} : ground_quotable (@leq_sort_n_ cf univ leq_universe_n n s s') := ltac:(cbv [leq_sort_n_]; exact _). +#[export] Instance quote_leq_csort_n {cf n s s'} : ground_quotable (@leq_csort_n cf n s s') := @quote_leq_sort_n_ cf nat _ n s s' _. +#[export] Instance quote_leq_sort_n {cf n ϕ s s'} : ground_quotable (@leq_sort_n cf (uGraph.Z_of_bool n) ϕ s s') := ltac:(cbv [leq_sort_n]; exact _). +#[export] Instance quote_leq_sort {cf ϕ s s'} : ground_quotable (@leq_sort cf ϕ s s') := @quote_leq_sort_n cf false ϕ s s'. +#[export] Instance quote_eq_universe {cf ϕ u u'} : ground_quotable (@eq_universe cf ϕ u u') + := ground_quotable_of_dec (@eq_universe_dec cf ϕ u u'). +#[export] Instance quote_eq_sort_ {univ eq_universe s s'} {quote_eq_universe : forall u u', ground_quotable (eq_universe u u':Prop)} : ground_quotable (@eq_sort_ univ eq_universe s s') := ltac:(cbv [eq_sort_]; exact _). +#[export] Instance quote_eq_sort {cf ϕ s s'} : ground_quotable (@eq_sort cf ϕ s s') := ltac:(cbv [eq_sort]; exact _). +#[export] Instance quote_compare_universe {cf univ pb u u'} : ground_quotable (@compare_universe cf univ pb u u') := ltac:(destruct pb; cbv [compare_universe]; exact _). +#[export] Instance quote_compare_sort {cf univ pb u u'} : ground_quotable (@compare_sort cf univ pb u u') := ltac:(destruct pb; cbv [compare_sort]; exact _). #[export] Instance quote_valid_constraints0 {ϕ ctrs} : ground_quotable (@valid_constraints0 ϕ ctrs) := ground_quotable_of_dec (@valid_constraints0_dec ϕ ctrs). #[export] Instance quote_valid_constraints {cf ϕ ctrs} : ground_quotable (@valid_constraints cf ϕ ctrs) diff --git a/quotation/theories/ToTemplate/Coq/Init.v b/quotation/theories/ToTemplate/Coq/Init.v index 826a29845..0151e2ad0 100644 --- a/quotation/theories/ToTemplate/Coq/Init.v +++ b/quotation/theories/ToTemplate/Coq/Init.v @@ -75,6 +75,12 @@ End Init. #[export] Instance quote_sumbool {A B : Prop} {qA : quotation_of A} {qB : quotation_of B} {quoteA : ground_quotable A} {quoteB : ground_quotable B} : ground_quotable (sumbool A B) := ltac:(destruct 1; exact _). #[export] Instance quote_sumor {A} {B : Prop} {qA : quotation_of A} {qB : quotation_of B} {quoteA : ground_quotable A} {quoteB : ground_quotable B} : ground_quotable (sumor A B) := ltac:(destruct 1; exact _). +Definition quote_or_dec {P Q : Prop} (dec : P \/ Q -> {P} + {Q}) {qP : quotation_of P} {qQ : quotation_of Q} {quoteP : ground_quotable P} {quoteQ : ground_quotable Q} : ground_quotable (or P Q). +Proof. + intro pf. + destruct (dec pf). + all: adjust_quotation_of_by_econstructor_then ltac:(fun _ => destruct pf; first [ eassumption | tauto ]) ltac:(fun _ => exact _). +Defined. Definition quote_or_dec_l {P Q : Prop} (decP : {P} + {~P}) {qP : quotation_of P} {qQ : quotation_of Q} {quoteP : ground_quotable P} {quoteQ : ground_quotable Q} : ground_quotable (or P Q). Proof. destruct decP. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/EnvironmentTyping/Sig.v b/quotation/theories/ToTemplate/QuotationOf/Common/EnvironmentTyping/Sig.v index 2b1d2f2c4..b6742d89f 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Common/EnvironmentTyping/Sig.v +++ b/quotation/theories/ToTemplate/QuotationOf/Common/EnvironmentTyping/Sig.v @@ -14,7 +14,7 @@ Module Type QuoteLookupSig (Import T : Term) (Import E : EnvironmentSig T) (Impo . #[export] Declare Instance quote_consistent_instance {cf lvs ϕ uctx u} : ground_quotable (@consistent_instance cf lvs ϕ uctx u). - #[export] Declare Instance quote_wf_universe {Σ s} : ground_quotable (@wf_universe Σ s). + #[export] Declare Instance quote_wf_sort {Σ s} : ground_quotable (@wf_sort Σ s). #[export] Declare Instance quote_declared_constant {Σ id decl} : ground_quotable (@declared_constant Σ id decl). #[export] Declare Instance quote_declared_minductive {Σ mind decl} : ground_quotable (@declared_minductive Σ mind decl). #[export] Declare Instance quote_declared_inductive {Σ ind mdecl decl} : ground_quotable (@declared_inductive Σ ind mdecl decl). diff --git a/quotation/theories/ToTemplate/Template/TermEquality.v b/quotation/theories/ToTemplate/Template/TermEquality.v index eac3907cc..fdbc90d07 100644 --- a/quotation/theories/ToTemplate/Template/TermEquality.v +++ b/quotation/theories/ToTemplate/Template/TermEquality.v @@ -5,44 +5,54 @@ From MetaCoq.Quotation.ToTemplate.Utils Require Import (hints) utils All_Forall. From MetaCoq.Quotation.ToTemplate.Common Require Import (hints) config Reflect Environment Universes BasicAst Kernames. From MetaCoq.Quotation.ToTemplate.Template Require Import (hints) Ast AstUtils Induction. -#[export] Instance quote_R_universe_instance {R u u'} {qR : quotation_of R} {quoteR : forall x y, ground_quotable (R x y:Prop)} : ground_quotable (@R_universe_instance R u u') := ltac:(cbv [R_universe_instance]; exact _). +#[export] Instance quote_on_rel {T T'} {R} {f: T -> T'} {x y : T} {qR : quotation_of R} {quoteR : forall x y, ground_quotable (R x y:Prop)}: ground_quotable (MCRelations.on_rel R f x y) := ltac:(cbv [MCRelations.on_rel]; exact _). + +#[export] Instance quote_cmp_universe_instance {R u u'} {qR : quotation_of R} {quoteR : forall x y, ground_quotable (R x y:Prop)} : ground_quotable (@cmp_universe_instance R u u') := ltac:(cbv [cmp_universe_instance]; exact _). Section with_R. - Context {Re Rle : Universe.t -> Universe.t -> Prop} - {qRe : quotation_of Re} {qRle : quotation_of Rle} - {quoteRe : forall x y, ground_quotable (Re x y)} {quoteRle : forall x y, ground_quotable (Rle x y)}. + Context {cmp_universe : conv_pb -> Universe.t -> Universe.t -> Prop} + {qRe : quotation_of cmp_universe} + {quoteRe : forall pb x y, ground_quotable (cmp_universe pb x y)}. - #[export] Instance quote_R_universe_variance {v u u'} : ground_quotable (@R_universe_variance Re Rle v u u') := ltac:(cbv [R_universe_variance]; exact _). + #[export] Instance quote_cmp_universe_variance {pb v u u'} : ground_quotable (@cmp_universe_variance cmp_universe pb v u u') := ltac:(cbv [cmp_universe_variance]; exact _). - #[export] Instance quote_R_universe_instance_variance {v u u'} : ground_quotable (@R_universe_instance_variance Re Rle v u u') := ltac:(revert v u'; induction u, u'; cbn; exact _). + #[export] Instance quote_cmp_universe_instance_variance {pb v u u'} : ground_quotable (@cmp_universe_instance_variance cmp_universe pb v u u') := ltac:(cbv [cmp_universe_instance_variance]; exact _). - #[export] Instance quote_R_opt_variance {v u u'} : ground_quotable (@R_opt_variance Re Rle v u u') := ltac:(destruct v; cbv [R_opt_variance]; exact _). + #[export] Instance quote_cmp_opt_variance {pb v u u'} (subr : RelationClasses.subrelation (cmp_universe Conv) (cmp_universe pb)) : ground_quotable (@cmp_opt_variance cmp_universe pb v u u'). + Proof using cmp_universe qRe quoteRe. + destruct v; cbv [cmp_opt_variance]; try exact _. + eapply Coq.Init.quote_or_dec; try exact _. + now apply cmp_opt_variance_var_dec. + Defined. - #[export] Instance quote_R_global_instance {Σ gr napp u u'} : ground_quotable (@R_global_instance Σ Re Rle gr napp u u') := ltac:(cbv [R_global_instance]; exact _). + #[export] Instance quote_cmp_global_instance {Σ pb gr napp u u'} (subr : RelationClasses.subrelation (cmp_universe Conv) (cmp_universe pb)) : ground_quotable (@cmp_global_instance Σ cmp_universe pb gr napp u u') := ltac:(cbv [cmp_global_instance]; exact _). End with_R. #[export] Existing Instances - quote_R_universe_variance - quote_R_universe_instance_variance - quote_R_opt_variance - quote_R_global_instance + quote_cmp_universe_variance + quote_cmp_universe_instance_variance + quote_cmp_opt_variance + quote_cmp_global_instance . -#[export] Instance quote_compare_decls {eq_term leq_term u u'} {qeq_term : quotation_of eq_term} {qleq_term : quotation_of leq_term} {quote_eq_term : forall x y, ground_quotable (eq_term x y)} {quote_leq_term : forall x y, ground_quotable (leq_term x y)} : ground_quotable (@compare_decls eq_term leq_term u u') +#[export] Instance quote_compare_decls {d d'} : ground_quotable (@eq_decl_upto_names d d') := ltac:(destruct 1; exact _). #[export] Instance quote_eq_term_upto_univ_napp - {Re Rle : Universe.t -> Universe.t -> Prop} - {qRe : quotation_of Re} {qRle : quotation_of Rle} - {quoteRe : forall x y, ground_quotable (Re x y)} {quoteRle : forall x y, ground_quotable (Rle x y)} - {Σ napp x y} - : ground_quotable (@eq_term_upto_univ_napp Σ Re Rle napp x y). + {cmp_universe : conv_pb -> Universe.t -> Universe.t -> Prop} + {cmp_sort : conv_pb -> sort -> sort -> Prop} + {qRe : quotation_of cmp_universe} {qRle : quotation_of cmp_sort} + {quoteRe : forall pb x y, ground_quotable (cmp_universe pb x y)} {quoteRle : forall pb x y, ground_quotable (cmp_sort pb x y)} + {Σ pb napp x y} + {subr : RelationClasses.subrelation (cmp_universe Conv) (cmp_universe pb)} + : ground_quotable (@eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp x y). Proof. - unfold ground_quotable; revert Σ Re Rle napp x y qRe qRle quoteRe quoteRle. - fix quote_eq_term_upto_univ_napp 11; intros. + unfold ground_quotable; revert Σ cmp_universe cmp_sort pb napp x y qRe qRle quoteRe quoteRle subr. + fix quote_eq_term_upto_univ_napp 13; intros. lazymatch type of quote_eq_term_upto_univ_napp with - | forall (x1 : ?X1) (x2 : ?X2) (x3 : ?X3) (x4 : ?X4) (x5 : ?X5) (x6 : ?X6) (x7 : ?X7) (x8 : ?X8) (x9 : ?X9) (x10 : ?X10) (t : ?X11), quotation_of t - => change (forall (x1 : X1) (x2 : X2) (x3 : X3) (x4 : X4) (x5 : X5) (x6 : X6) (x7 : X7) (x8 : X8) (x9 : X9) (x10 : X10), ground_quotable X11) in quote_eq_term_upto_univ_napp + | forall (x1 : ?X1) (x2 : ?X2) (x3 : ?X3) (x4 : ?X4) (x5 : ?X5) (x6 : ?X6) (x7 : ?X7) (x8 : ?X8) (x9 : ?X9) (x10 : ?X10) (x11 : ?X11) (x12 : ?X12) (t : ?X13), quotation_of t + => change (forall (x1 : X1) (x2 : X2) (x3 : X3) (x4 : X4) (x5 : X5) (x6 : X6) (x7 : X7) (x8 : X8) (x9 : X9) (x10 : X10) (x11 : X11) (x12 : X12), ground_quotable X13) in quote_eq_term_upto_univ_napp end. destruct t; replace_quotation_of_goal (). Defined. -#[export] Instance quote_compare_term {cf pb Σ ϕ x y} : ground_quotable (@compare_term cf pb Σ ϕ x y) := ltac:(cbv [compare_term]; exact _). +#[export] Instance quote_compare_term {cf pb Σ ϕ x y} : ground_quotable (@compare_term cf Σ ϕ pb x y). +Proof. unshelve eapply quote_eq_term_upto_univ_napp. apply compare_universe_subrel. Defined. diff --git a/quotation/theories/ToTemplate/Utils/All_Forall.v b/quotation/theories/ToTemplate/Utils/All_Forall.v index 78f35a215..9fbe15c9f 100644 --- a/quotation/theories/ToTemplate/Utils/All_Forall.v +++ b/quotation/theories/ToTemplate/Utils/All_Forall.v @@ -31,3 +31,9 @@ Definition quote_All2_via_dep {A B R lsA lsB} {a : @All2 A B R lsA lsB} (qa : Al #[export] Instance quote_All2i_len {A B R lsA lsB} {qA : quotation_of A} {qB : quotation_of B} {qR : quotation_of R} {quoteA : ground_quotable A} {quoteB : ground_quotable B} {quoteR : forall n x y, ground_quotable (R n x y)} : ground_quotable (@All2i_len A B R lsA lsB) := ltac:(induction 1; exact _). #[export] Instance quote_All_fold {A P ls} {qA : quotation_of A} {qP : quotation_of P} {quoteA : ground_quotable A} {quoteP : forall x y, ground_quotable (P x y)} : ground_quotable (@All_fold A P ls) := ltac:(induction 1; exact _). #[export] Instance quote_All2_fold {A P ls1 ls2} {qA : quotation_of A} {qP : quotation_of P} {quoteA : ground_quotable A} {quoteP : forall x y z w, ground_quotable (P x y z w)} : ground_quotable (@All2_fold A P ls1 ls2) := ltac:(induction 1; exact _). +#[export] Instance quote_Forall3 {A B C R lsA lsB lsC} {qA : quotation_of A} {qB : quotation_of B} {qC : quotation_of C} {qR : quotation_of R} {quoteA : ground_quotable A} {quoteB : ground_quotable B} {quoteC : ground_quotable C} {quoteR : forall x y z, ground_quotable (R x y z:Prop)} : ground_quotable (@Forall3 A B C R lsA lsB lsC). +Proof. + revert lsB lsC; induction lsA as [|a lsA IH], lsB as [|b lsB], lsC as [|c lsC]. + all: try solve [ intro pf; exfalso; inversion pf ]. + all: adjust_ground_quotable_by_econstructor_inversion (). +Defined. diff --git a/safechecker/theories/PCUICEqualityDec.v b/safechecker/theories/PCUICEqualityDec.v index ba59100fd..80e0e4976 100644 --- a/safechecker/theories/PCUICEqualityDec.v +++ b/safechecker/theories/PCUICEqualityDec.v @@ -16,11 +16,11 @@ Set Default Goal Selector "!". (* TODO move*) -Lemma consistent_instance_wf_universe `{checker_flags} Σ uctx u : +Lemma consistent_instance_wf_sort `{checker_flags} Σ uctx u : consistent_instance_ext Σ uctx u -> - Forall (wf_universe Σ) (map Universe.make u). + Forall (wf_universe Σ) (map Universe.make' u). Proof. - move => /consistent_instance_ext_wf /wf_universe_instanceP. + move => /consistent_instance_ext_wf /wf_instanceP. rewrite -wf_universeb_instance_forall. move => /forallb_Forall ?. eapply Forall_impl ; tea. @@ -39,112 +39,117 @@ Qed. (** ** Boolean of equality ** *) -Definition compare_universe_variance (equ lequ : Universe.t -> Universe.t -> bool) v u u' := +Definition compare_universe_variance (cmpu : conv_pb -> Universe.t -> Universe.t -> bool) pb v u u' := match v with | Variance.Irrelevant => true - | Variance.Covariant => lequ (Universe.make u) (Universe.make u') - | Variance.Invariant => equ (Universe.make u) (Universe.make u') + | Variance.Covariant => cmpu pb (Universe.make' u) (Universe.make' u') + | Variance.Invariant => cmpu Conv (Universe.make' u) (Universe.make' u') end. Definition compare_universe_instance equ u u' := - forallb2 equ (map Universe.make u) (map Universe.make u'). - -Fixpoint compare_universe_instance_variance equ lequ v u u' := - match u, u' with - | u :: us, u' :: us' => - match v with - | [] => compare_universe_instance_variance equ lequ v us us' - (* Missing variance stands for irrelevance *) - | v :: vs => compare_universe_variance equ lequ v u u' && - compare_universe_instance_variance equ lequ vs us us' - end - | [], [] => true - | _, _ => false - end. + forallb2 (fun u u' => equ (Universe.make' u) (Universe.make' u')) u u'. + +Definition compare_universe_instance_variance cmpu pb v u u' := + forallb3 (compare_universe_variance cmpu pb) v u u'. -Definition compare_global_instance lookup equ lequ gr napp := +Definition compare_global_instance lookup cmpu pb gr napp u u' := match global_variance_gen lookup gr napp with - | Some v => compare_universe_instance_variance equ lequ v - | None => compare_universe_instance equ + | AllEqual => compare_universe_instance (cmpu Conv) u u' + | Variance v => + compare_universe_instance_variance cmpu pb v u u' || compare_universe_instance (cmpu Conv) u u' + | AllIrrelevant => #|u| == #|u'| end. Definition eqb_binder_annots (x y : list aname) : bool := forallb2 eqb_binder_annot x y. +Definition eqb_decl_upto_names (d d' : context_decl) : bool := + match d, d' with + | {| decl_name := na; decl_body := None; decl_type := T |}, + {| decl_name := na'; decl_body := None; decl_type := T' |} => + eqb_binder_annot na na' && eqb T T' + | {| decl_name := na; decl_body := Some b; decl_type := T |}, + {| decl_name := na'; decl_body := Some b'; decl_type := T' |} => + eqb_binder_annot na na' && eqb b b' && eqb T T' + | _, _ => false + end. + +Notation eqb_context_upto_names := (forallb2 eqb_decl_upto_names). + Fixpoint eqb_term_upto_univ_napp - (equ lequ : Universe.t -> Universe.t -> bool) - (gen_compare_global_instance : (Universe.t -> Universe.t -> bool) -> global_reference -> nat -> list Level.t -> list Level.t -> bool) - napp (u v : term) : bool := + (cmpu : conv_pb -> Universe.t -> Universe.t -> bool) + (cmps : conv_pb -> sort -> sort -> bool) + (gen_compare_global_instance : conv_pb -> global_reference -> nat -> list Level.t -> list Level.t -> bool) + pb napp (u v : term) : bool := match u, v with | tRel n, tRel m => eqb n m | tEvar e args, tEvar e' args' => eqb e e' && - forallb2 (eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0) args args' + forallb2 (eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance Conv 0) args args' | tVar id, tVar id' => eqb id id' | tSort u, tSort u' => - lequ u u' + cmps pb u u' | tApp u v, tApp u' v' => - eqb_term_upto_univ_napp equ lequ gen_compare_global_instance (S napp) u u' && - eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0 v v' + eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance pb (S napp) u u' && + eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance Conv 0 v v' | tConst c u, tConst c' u' => eqb c c' && - forallb2 equ (map Universe.make u) (map Universe.make u') + compare_universe_instance (cmpu Conv) u u' | tInd i u, tInd i' u' => eqb i i' && - gen_compare_global_instance lequ (IndRef i) napp u u' + gen_compare_global_instance pb (IndRef i) napp u u' | tConstruct i k u, tConstruct i' k' u' => eqb i i' && eqb k k' && - gen_compare_global_instance lequ (ConstructRef i k) napp u u' + gen_compare_global_instance pb (ConstructRef i k) napp u u' | tLambda na A t, tLambda na' A' t' => eqb_binder_annot na na' && - eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0 A A' && - eqb_term_upto_univ_napp equ lequ gen_compare_global_instance 0 t t' + eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance Conv 0 A A' && + eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance pb 0 t t' | tProd na A B, tProd na' A' B' => eqb_binder_annot na na' && - eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0 A A' && - eqb_term_upto_univ_napp equ lequ gen_compare_global_instance 0 B B' + eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance Conv 0 A A' && + eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance pb 0 B B' | tLetIn na B b u, tLetIn na' B' b' u' => eqb_binder_annot na na' && - eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0 B B' && - eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0 b b' && - eqb_term_upto_univ_napp equ lequ gen_compare_global_instance 0 u u' + eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance Conv 0 B B' && + eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance Conv 0 b b' && + eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance pb 0 u u' | tCase indp p c brs, tCase indp' p' c' brs' => eqb indp indp' && eqb_predicate_gen - (fun u u' => forallb2 equ (map Universe.make u) (map Universe.make u')) - (bcompare_decls eqb eqb) - (eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0) p p' && - eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0 c c' && + (compare_universe_instance (cmpu Conv)) + eqb_decl_upto_names + (eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance Conv 0) p p' && + eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance Conv 0 c c' && forallb2 (fun x y => forallb2 - (bcompare_decls eqb eqb) - x.(bcontext) y.(bcontext) && - eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0 (bbody x) (bbody y) + eqb_decl_upto_names x.(bcontext) y.(bcontext) && + eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance Conv 0 (bbody x) (bbody y) ) brs brs' | tProj p c, tProj p' c' => eqb p p' && - eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0 c c' + eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance Conv 0 c c' | tFix mfix idx, tFix mfix' idx' => eqb idx idx' && forallb2 (fun x y => - eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0 x.(dtype) y.(dtype) && - eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0 x.(dbody) y.(dbody) && + eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance Conv 0 x.(dtype) y.(dtype) && + eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance Conv 0 x.(dbody) y.(dbody) && eqb x.(rarg) y.(rarg) && eqb_binder_annot x.(dname) y.(dname) ) mfix mfix' @@ -152,72 +157,131 @@ Fixpoint eqb_term_upto_univ_napp | tCoFix mfix idx, tCoFix mfix' idx' => eqb idx idx' && forallb2 (fun x y => - eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0 x.(dtype) y.(dtype) && - eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0 x.(dbody) y.(dbody) && + eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance Conv 0 x.(dtype) y.(dtype) && + eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance Conv 0 x.(dbody) y.(dbody) && eqb x.(rarg) y.(rarg) && eqb_binder_annot x.(dname) y.(dname) ) mfix mfix' - | tPrim p, tPrim p' => eqb_prim_val (equ := fun l l' => equ (Universe.make l) (Universe.make l')) - (req := eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0) p p' + | tPrim p, tPrim p' => eqb_prim_val (equ := fun l l' => compare_universe_instance (cmpu Conv) [l] [l']) + (req := eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance Conv 0) p p' | _, _ => false end. -Notation eqb_term_upto_univ eq leq gen_compare_global_instance := - (eqb_term_upto_univ_napp eq leq gen_compare_global_instance 0). +Notation eqb_term_upto_univ cmpu cmps gen_compare_global_instance pb := + (eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance pb 0). -Definition conv_pb_relb_gen pb (eq leq : Universe.t -> Universe.t -> bool) := +Definition conv_pb_relb_gen {T} (eq leq : T -> T -> bool) pb := match pb with | Conv => eq | Cumul => leq end. -Definition eqb_termp_napp_gen pb eq leq compare_global_instance_gen napp := - eqb_term_upto_univ_napp eq (conv_pb_relb_gen pb eq leq) - compare_global_instance_gen napp. - +Lemma equiv_reflect P p : + ssrbool.reflect P p <~> + (P <-> p). +Proof. + split. + - destruct 1; split; intro; eauto. + now exfalso. + - destruct p; intros []; constructor; auto. +Qed. -Ltac eqspec := - lazymatch goal with - | |- context [ eqb ?u ?v ] => - destruct (eqb_specT u v) ; nodec ; subst - end. +Lemma reflect_cmp_universe_instance (p : Universe.t -> bool) cmpu cmp_universe ui ui' : + (forall u u', p u -> p u' -> reflect (cmp_universe u u') (cmpu u u')) -> + forallb p (map Universe.make' ui) -> + forallb p (map Universe.make' ui') -> + reflect (cmp_universe_instance cmp_universe ui ui') (compare_universe_instance cmpu ui ui'). +Proof. + intros he hui hui'. + apply equiv_reflect; split. + all: unfold cmp_universe_instance, compare_universe_instance in *. + all: solve_all. + - now apply/he. + - now apply/he. +Qed. -Ltac eqspecs := - repeat eqspec. +Lemma reflect_cmp_universe_instance_variance (p : Universe.t -> bool) cmpu cmp_universe pb v ui ui' : + (forall u u', p u -> p u' -> reflect (cmp_universe Conv u u') (cmpu Conv u u')) -> + (forall u u', p u -> p u' -> reflect (cmp_universe pb u u') (cmpu pb u u')) -> + forallb p (map Universe.make' ui) -> + forallb p (map Universe.make' ui') -> + reflect (cmp_universe_instance_variance cmp_universe pb v ui ui') (compare_universe_instance_variance cmpu pb v ui ui'). +Proof. + intros he hle hui hui'. + apply equiv_reflect; split. + all: unfold cmp_universe_instance_variance, compare_universe_instance_variance in *. + - induction 1 in hui, hui' |- *; cbnr. + cbn in hui, hui'; rtoProp. + split; auto. + destruct x; cbnr. + + now apply/hle. + + now apply/he. + - intro X. apply forallb3_Forall3 in X. + induction X in hui, hui' |- *; cbnr; try solve [ constructor ]. + cbn in hui, hui'; rtoProp. + constructor; auto. + destruct x; cbnr. + + now apply/hle. + + now apply/he. +Qed. -Local Ltac equspec equ h := - repeat lazymatch goal with - | |- context [ equ ?x ?y ] => - destruct (h x y) ; nodec ; subst - end. +Lemma reflect_cmp_global_instance' lookup (p : Universe.t -> bool) cmpu cmp_universe pb gr napp ui ui' : + (forall u u', p u -> p u' -> reflect (cmp_universe Conv u u') (cmpu Conv u u')) -> + (forall u u', p u -> p u' -> reflect (cmp_universe pb u u') (cmpu pb u u')) -> + forallb p (map Universe.make' ui) -> + forallb p (map Universe.make' ui') -> + reflect (cmp_global_instance_gen lookup cmp_universe pb gr napp ui ui') + (compare_global_instance lookup cmpu pb gr napp ui ui'). +Proof. + intros he hle hui hui'. + rewrite /compare_global_instance /cmp_global_instance_gen /cmp_opt_variance. + destruct (global_variance_gen _ gr napp) as [| |v]. + - eapply reflect_cmp_universe_instance; tea. + - apply eqb_specT. + - apply equiv_reflect; split. + + intros [X|X]; apply orb_true_iff; [right|left]. + * now apply/reflect_cmp_universe_instance. + * now apply/reflect_cmp_universe_instance_variance. + + intros [X|X]%orb_true_iff; [right|left]. + * now apply/reflect_cmp_universe_instance_variance. + * now apply/reflect_cmp_universe_instance. +Qed. -Local Ltac ih := - repeat lazymatch goal with - | ih : forall lequ Rle napp hle t' ht ht', reflectT (eq_term_upto_univ_napp _ _ _ napp ?t _) _, - hle : forall u u' hu hu', reflect (?Rle u u') (?lequ u u') , - hcompare : forall R leq H ref n l l' _ _ , _ <-> _ - |- context [ eqb_term_upto_univ _ ?lequ _ ?t ?t' ] => - destruct (ih lequ Rle 0 hle t') - ; nodec ; subst - end. +Lemma reflect_cmp_global_instance Σ lookup (p : Universe.t -> bool) cmpu cmp_universe pb gr napp ui ui' : + (forall u u', p u -> p u' -> reflect (cmp_universe Conv u u') (cmpu Conv u u')) -> + (forall u u', p u -> p u' -> reflect (cmp_universe pb u u') (cmpu pb u u')) -> + (forall kn, lookup_env Σ kn = lookup kn) -> + forallb p (map Universe.make' ui) -> + forallb p (map Universe.make' ui') -> + reflect (cmp_global_instance Σ cmp_universe pb gr napp ui ui') + (compare_global_instance lookup cmpu pb gr napp ui ui'). +Proof. + intros he hleh hlookup hui hui'. + pose proof (Hglobal := reflect_cmp_global_instance' lookup p + cmpu cmp_universe pb gr napp ui ui' he hleh hui hui'). + rewrite /cmp_global_instance_gen /compare_global_instance /cmp_opt_variance. + rewrite /global_variance_gen /lookup_constructor_gen /lookup_inductive_gen /lookup_minductive_gen. + destruct gr; auto; now repeat rewrite hlookup. +Qed. -(* Lemma compare_global_instance_impl (equ lequ : _ -> _ -> bool) Σ Re Rle gr napp : - RelationClasses.subrelation equ Re -> - RelationClasses.subrelation lequ Rle -> - subrelation (compare_global_instance Σ equ lequ gr napp) (R_global_instance Σ Re Rle gr napp). +Lemma forallb_true {A : Type} (l : list A) : forallb xpredT l. Proof. - intros hre hrle x y. - unfold compare_global_instance, R_global_instance, R_opt_variance. - destruct global_variance as [v|]. - - induction x in v, y |- *; destruct v, y; simpl; auto. - rtoProp. intros [Hat Hxy]. split; auto. - destruct t; simpl in *; auto. - - intro. eapply forallb2_Forall2 in H. - eapply Forall2_impl; tea; eauto. -Qed. *) + now induction l. +Qed. +Lemma compare_global_instance_impl Σ lookup cmpu cmp_universe pb gr napp : + (forall u u', reflect (cmp_universe Conv u u') (cmpu Conv u u')) -> + (forall u u', reflect (cmp_universe pb u u') (cmpu pb u u')) -> + (forall kn, lookup_env Σ kn = lookup kn) -> + subrelation (compare_global_instance lookup cmpu pb gr napp) (cmp_global_instance Σ cmp_universe pb gr napp). +Proof. + intros hre hrle hlookup x y. + move/reflect_cmp_global_instance => H. eapply H. + all: intros; eauto. + all: apply forallb_true. +Qed. Lemma Forall2_forallb2: forall (A : Type) (p : A -> A -> bool) (l l' : list A), @@ -261,65 +325,27 @@ Proof. red in H'. unfold eqb_binder_annots in H'. congruence. Qed. -Lemma forallb2_bcompare_decl_All2_fold - (P : term -> term -> bool) Γ Δ : - forallb2 (bcompare_decls P P) Γ Δ -> - All2_fold (fun _ _ => bcompare_decls P P) Γ Δ. +Lemma reflect_eq_decl_upto_names d d' : + reflectT (eq_decl_upto_names d d') (eqb_decl_upto_names d d'). Proof. - induction Γ as [|[na [b|] ty] Γ] in Δ |- *; destruct Δ as [|[na' [b'|] ty'] Δ]; simpl => //; constructor; auto; - now move/andb_and: H => []. + destruct d as [na [b|] ty], d' as [na' [b'|] ty'] => //=. + 2,3: constructor; intro X; inv X. + all: eapply equiv_reflectT; intro X; [inv X|]; rtoProp. + - repeat split; tas. 1: now apply/eqb_annot_reflect. all: apply eqb_refl. + - apply eqb_eq in H0 as <-, H1 as <-. apply eqb_annot_spec in H. + now constructor. + - repeat split; tas. 1: now apply/eqb_annot_reflect. all: apply eqb_refl. + - apply eqb_eq in H0 as <-. apply eqb_annot_spec in H. + now constructor. Qed. -Lemma reflect_eq_context_IH {Σ equ lequ} - {Re Rle : Universe.t -> Universe.t -> Prop} - {gen_compare_global_instance : (Universe.t -> Universe.t -> Prop) -> global_reference -> nat -> list Level.t -> list Level.t -> bool }: - (forall u u', reflect (Re u u') (equ u u')) -> - (forall u u', reflect (Rle u u') (lequ u u')) -> - forall ctx ctx', - onctx - (fun t : term => - forall (lequ : Universe.t -> Universe.t -> bool) - (Rle : Universe.t -> Universe.t -> Prop) - (napp : nat), - (forall u u' : Universe.t, reflect (Rle u u') (lequ u u')) -> - forall t' : term, - reflectT (eq_term_upto_univ_napp Σ Re Rle napp t t') - (eqb_term_upto_univ_napp equ lequ gen_compare_global_instance napp t t')) - ctx -> - reflectT - (eq_context_gen (eq_term_upto_univ Σ Re Re) (eq_term_upto_univ Σ Re Re) ctx ctx') - (forallb2 (bcompare_decls (eqb_term_upto_univ equ equ gen_compare_global_instance) - (eqb_term_upto_univ equ equ gen_compare_global_instance)) ctx ctx'). +Lemma reflect_eq_context_upto_names Γ Δ : + reflectT (eq_context_upto_names Γ Δ) (eqb_context_upto_names Γ Δ). Proof. - intros hRe hRle ctx ctx' onc. - eapply equiv_reflectT. - - intros hcc'. - eapply All2_fold_forallb2, All2_fold_impl_onctx; tea. - unfold ondecl; intuition auto. - depelim X0; cbn in * => //; - intuition auto. - + destruct (eqb_annot_reflect na na') => //. - destruct (b equ Re 0 hRe T') => //. - + destruct (eqb_annot_reflect na na') => //. - destruct (a equ Re 0 hRe b') => //. - destruct (b0 equ Re 0 hRe T') => //. - - intros hcc'. - eapply forallb2_bcompare_decl_All2_fold in hcc'; tea. - eapply All2_fold_impl_onctx in onc; tea; simpl; intuition eauto. - destruct X0. - move: H. - destruct d as [na [bod|] ty], d' as [na' [bod'|] ty']; cbn in * => //. - + destruct (eqb_annot_reflect na na') => //. - destruct (r equ Re 0 hRe ty') => //. - 2: now rewrite andb_false_r. - destruct (o equ Re 0 hRe bod') => //. - now constructor. - + destruct (eqb_annot_reflect na na') => //. - destruct (r equ Re 0 hRe ty') => //. - now constructor. + eapply All2P, reflect_eq_decl_upto_names. Qed. -Definition eqb_univ_reflect : forall u u' : Universe.t, reflectProp (u = u') (eqb u u'). +Definition eqb_univ_reflect : forall u u' : sort, reflectProp (u = u') (eqb u u'). Proof. intros u u'. destruct (eqb_spec u u'); constructor; auto. @@ -332,40 +358,11 @@ Proof. now destruct (Classes.eq_dec x x). Qed. -Lemma reflect_eq_ctx ctx ctx' : - reflectT - (eq_context_gen eq eq ctx ctx') - (forallb2 (bcompare_decls eqb eqb) ctx ctx'). -Proof. - eapply equiv_reflectT. - - intros hcc'. - eapply All2_fold_forallb2; tea. - unfold ondecl; intuition auto. - eapply All2_fold_impl; tea. intros. - destruct X; cbn ; subst. - all: destruct (eqb_annot_reflect na na') => /= //. - 2: apply/andb_and; split. - all: eapply eqb_refl. - - intros hcc'. - eapply forallb2_bcompare_decl_All2_fold in hcc'; tea. - eapply All2_fold_impl in hcc'; tea; simpl; intuition eauto. - move: H. - destruct d as [na [bod|] ty], d' as [na' [bod'|] ty']; cbn in * => //. - + destruct (eqb_annot_reflect na na') => // /=. - repeat case: eqb_specT => //; intros; subst; cbn; auto; constructor; auto. - + destruct (eqb_annot_reflect na na') => //. - repeat case: eqb_specT => //; intros; subst; cbn; auto; constructor; auto. -Qed. - -Lemma forallb_true {A : Type} (l : list A) : forallb xpredT l. -Proof. - now induction l. -Qed. - Lemma on_universes_true (t : term) : on_universes xpredT (fun _ => xpredT) t. Proof. induction t using term_forall_list_ind => //=. - now apply All_forallb. + - now destruct s. - now rewrite IHt1 IHt2. - now rewrite IHt1 IHt2. - now rewrite IHt1 IHt2 IHt3. @@ -401,512 +398,216 @@ Proof. solve_all. Qed. -Definition reflect_eq_predicate {Σ equ lequ} - {gen_compare_global_instance : (Universe.t -> Universe.t -> bool) -> global_reference -> nat -> list Level.t -> list Level.t -> bool} - {Re Rle : Universe.t -> Universe.t -> Prop} - {p : Universe.t -> bool} - {q : nat -> term -> bool} : - (forall u u', p u -> p u' -> reflect (Re u u') (equ u u')) -> - (forall u u', p u -> p u' -> reflect (Rle u u') (lequ u u')) -> - (forall R leq, - (forall u u', p u -> p u' -> reflect (R u u') (leq u u')) -> - forall ref n l l', - forallb p (map Universe.make l) -> - forallb p (map Universe.make l') -> - R_global_instance Σ Re R ref n l l' <-> - gen_compare_global_instance leq ref n l l') -> - forall pr pr', - Forall p (map Universe.make pr.(puinst)) -> - Forall (on_universes p q) pr.(pparams) -> - on_universes p q pr.(preturn) -> - Forall p (map Universe.make pr'.(puinst)) -> - Forall (on_universes p q) pr'.(pparams) -> - on_universes p q pr'.(preturn) -> - tCasePredProp - (fun t : term => - forall (lequ : Universe.t -> Universe.t -> bool) (Rle : Universe.t -> Universe.t -> Prop) (napp : nat), - (forall u u' : Universe.t, p u -> p u' -> reflect (Rle u u') (lequ u u')) -> - forall t' : term, - on_universes p q t -> - on_universes p q t' -> - reflectT (eq_term_upto_univ_napp Σ Re Rle napp t t') (eqb_term_upto_univ_napp equ lequ gen_compare_global_instance napp t t')) - (fun t : term => - forall (lequ : Universe.t -> Universe.t -> bool) (Rle : Universe.t -> Universe.t -> Prop) (napp : nat), - (forall u u' : Universe.t, p u -> p u' -> reflect (Rle u u') (lequ u u')) -> - forall t' : term, - on_universes p q t -> - on_universes p q t' -> - reflectT (eq_term_upto_univ_napp Σ Re Rle napp t t') (eqb_term_upto_univ_napp equ lequ gen_compare_global_instance napp t t')) pr -> - reflectT (eq_predicate (eq_term_upto_univ_napp Σ Re Re 0) Re pr pr') - (eqb_predicate_gen (fun u u' => forallb2 equ (map Universe.make u) (map Universe.make u')) - (bcompare_decls eqb eqb) - (eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0) pr pr'). -Proof. - intros. - solve_all. unfold eq_predicate, eqb_predicate, eqb_predicate_gen. - cbn -[eqb]; apply equiv_reflectT. - - intros Hp; rtoProp. - destruct Hp as [onpars [onuinst [pctx pret]]]. - intuition auto; rtoProp; intuition auto. - * solve_all. destruct (b1 _ Re 0 X y); auto; try contradiction. - * red in onuinst. - solve_all. - eapply All2_impl. - 1: eapply (All2_All_mix_left H0), (All2_All_mix_right H3), All2_map_inv ; - eassumption. - now move=> x y [? []] /X. - * case: (reflect_eq_ctx (pcontext pr) (pcontext pr')) => //. - * now destruct (r equ Re 0 X (preturn pr')) ; nodec ; subst. - - move/andb_and => [/andb_and [/andb_and [ppars pinst] pctx] pret]. - intuition auto. - * solve_all. - now destruct (b1 _ _ 0 X y). - * red. - solve_all. - eapply All2_impl. - 1: eapply (All2_All_mix_left H0), (All2_All_mix_right H3), All2_map_inv; - eassumption. - now move=> x y [? []] /X. - * move: pctx; case: (reflect_eq_ctx (pcontext pr) (pcontext pr')) => //. - * now destruct (r _ _ 0 X (preturn pr')). -Qed. +Ltac eqspec := + lazymatch goal with + | |- context [ eqb ?u ?v ] => + destruct (eqb_specT u v) ; nodec ; subst + end. + +Ltac eqspecs := + repeat eqspec. + +Local Ltac equspec equ pb h := + repeat lazymatch goal with + | |- context [ equ pb ?x ?y ] => + destruct (h x y); tas ; nodec ; subst + end. + +Local Ltac ih := + repeat lazymatch goal with + | ih : forall pb napp hle hspb hglpb t' ht ht', reflectT (eq_term_upto_univ_napp _ _ _ pb napp ?t _) _ + |- context [ eqb_term_upto_univ_napp _ _ _ ?pb ?napp ?t ?t' ] => + destruct (ih pb napp ltac:(assumption) ltac:(assumption) ltac:(assumption) t'); eauto; + nodec ; subst + end. Arguments eqb : simpl never. -Lemma reflect_R_global_instance' lookup equ lequ (p : Universe.t -> bool) - (Re Rle : Universe.t -> Universe.t -> Prop) gr napp ui ui' : - (forall u u', p u -> p u' -> reflect (Re u u') (equ u u')) -> - (forall u u', p u -> p u' -> reflect (Rle u u') (lequ u u')) -> - forallb p (map Universe.make ui) -> - forallb p (map Universe.make ui') -> - reflect (R_global_instance_gen lookup Re Rle gr napp ui ui') - (compare_global_instance lookup equ lequ gr napp ui ui'). +Lemma reflectT_change_left2 P1 P2 R p1 p2 : + CRelationClasses.iffT (P1 × P2) R -> reflectT P1 p1 -> reflectT P2 p2 -> reflectT R (p1 && p2). Proof. - intros he hle hui hui'. - rewrite /compare_global_instance /R_global_instance_gen. - destruct (global_variance_gen _ gr napp) as [v|]. - - induction ui as [|u ui IHui] in ui', v, hui, hui' |- * ; cbn in *. - all: destruct ui' as [|u' ui']. - 1-3: by constructor. - move: hui => /andP [? ?]. - move: hui' => /andP [? ?]. - destruct v as [|hv v]; cbn in *. - 1: now apply IHui. - apply: (iffP andP) => [] [?] /IHui H. - all: split. - 2,4: now apply H. - all: destruct hv => //=. - + apply /hle => //. - + apply /he => //. - + edestruct (hle (Universe.make u) (Universe.make u')) => //. - + edestruct (he (Universe.make u) (Universe.make u')) => //. - - cbn. - unfold R_universe_instance, compare_universe_instance. - apply (iffP idP). - + solve_all. - eapply All2_impl. - 1: eapply (All2_All_mix_left hui), (All2_All_mix_right hui'), All2_map_inv ; - eassumption. - now move => u u' [? []] /he. - + solve_all. - eapply All2_impl. - 1: eapply (All2_All_mix_left hui), (All2_All_mix_right hui'), All2_map_inv ; - eassumption. - now move => u u' [? []] /he. + intros [H H'] [] []; constructor. + 1: apply H; now split. + all: intro HR; destruct (H' HR); now apply f. Qed. -Lemma reflect_R_global_instance Σ lookup equ lequ (p : Universe.t -> bool) - (Re Rle : Universe.t -> Universe.t -> Prop) gr napp ui ui' : - (forall u u', p u -> p u' -> reflect (Re u u') (equ u u')) -> - (forall u u', p u -> p u' -> reflect (Rle u u') (lequ u u')) -> - (forall kn, lookup_env Σ kn = lookup kn) -> - forallb p (map Universe.make ui) -> - forallb p (map Universe.make ui') -> - reflect (R_global_instance Σ Re Rle gr napp ui ui') - (compare_global_instance lookup equ lequ gr napp ui ui'). +Lemma reflectT_change_left3 P1 P2 P3 R p1 p2 p3 : + CRelationClasses.iffT [× P1, P2 & P3] R -> reflectT P1 p1 -> reflectT P2 p2 -> reflectT P3 p3 -> reflectT R (p1 && p2 && p3). Proof. - intros he hleh hlookup hui hui'. - pose proof (Hglobal := reflect_R_global_instance' lookup equ lequ p - Re Rle gr napp ui ui' he hleh hui hui'). - rewrite /R_global_instance_gen /compare_global_instance /R_opt_variance. - rewrite /global_variance_gen /lookup_constructor_gen /lookup_inductive_gen /lookup_minductive_gen. - destruct gr; auto; now repeat rewrite hlookup. + intros [H H'] [] [] []; constructor. + 1: apply H; now split. + all: intro HR; destruct (H' HR); now apply f. +Qed. + +Lemma reflectT_change_left4 P1 P2 P3 P4 R p1 p2 p3 p4 : + CRelationClasses.iffT [× P1, P2, P3 & P4] R -> reflectT P1 p1 -> reflectT P2 p2 -> reflectT P3 p3 -> reflectT P4 p4 -> reflectT R (p1 && p2 && p3 && p4). +Proof. + intros [H H'] [] [] [] []; constructor. + 1: apply H; now split. + all: intro HR; destruct (H' HR); now apply f. Qed. Transparent eqb_prim_val eqb_prim_model. -Lemma reflect_eq_term_upto_univ Σ equ lequ - (p : Universe.t -> bool) (q : nat -> term -> bool) - (Re Rle : Universe.t -> Universe.t -> Prop) - (gen_compare_global_instance : (Universe.t -> Universe.t -> bool) -> global_reference -> nat -> list Level.t -> list Level.t -> bool) - napp : - (forall u u', p u -> p u' -> reflect (Re u u') (equ u u')) -> - (forall u u', p u -> p u' -> reflect (Rle u u') (lequ u u')) -> - (forall R leq, - (forall u u', p u -> p u' -> reflect (R u u') (leq u u')) -> - forall ref n l l' , - forallb p (map Universe.make l) -> - forallb p (map Universe.make l') -> - R_global_instance Σ Re R ref n l l' <-> - gen_compare_global_instance leq ref n l l') -> +Lemma reflect_eq_term_upto_univ Σ (p : Universe.t -> bool) (q : nat -> term -> bool) cmpu cmps cmp_universe cmp_sort + (gen_compare_global_instance : conv_pb -> global_reference -> nat -> list Level.t -> list Level.t -> bool) + pb napp : + (forall u u', p u -> p u' -> reflect (cmp_universe Conv u u') (cmpu Conv u u')) -> + (forall u u', p u -> p u' -> reflect (cmp_universe pb u u') (cmpu pb u u')) -> + (forall s s', Sort.on_sort p true s -> Sort.on_sort p true s' -> reflect (cmp_sort Conv s s') (cmps Conv s s')) -> + (forall s s', Sort.on_sort p true s -> Sort.on_sort p true s' -> reflect (cmp_sort pb s s') (cmps pb s s')) -> + (forall gr napp ui ui', forallb p (map Universe.make' ui) -> forallb p (map Universe.make' ui') -> reflect (cmp_global_instance Σ cmp_universe Conv gr napp ui ui') (gen_compare_global_instance Conv gr napp ui ui')) -> + (forall gr napp ui ui', forallb p (map Universe.make' ui) -> forallb p (map Universe.make' ui') -> reflect (cmp_global_instance Σ cmp_universe pb gr napp ui ui') (gen_compare_global_instance pb gr napp ui ui')) -> forall t t', on_universes p q t -> on_universes p q t' -> - reflectT (eq_term_upto_univ_napp Σ Re Rle napp t t') - (eqb_term_upto_univ_napp equ lequ gen_compare_global_instance napp t t'). + reflectT (eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp t t') + (eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance pb napp t t'). Proof. - intros he hle hcompare t t' ht ht'. - induction t in t', napp, lequ, Rle, hle, ht, ht' |- * using term_forall_list_ind. + intros he hle hs hspb hgl hglpb t t' ht ht'. + induction t in t', pb, napp, hle, hspb, hglpb, ht, ht' |- * using term_forall_list_ind. all: destruct t' ; nodec. all: move: ht => /= ; (repeat move => /andP [?]) ; move => ht. all: move: ht' => /= ; (repeat move => /andP [?]) ; move => ht'. + all: cbn - [eqb]; eqspecs; try solve [ ih => //; constructor; constructor; assumption ]. + all: try solve [ match goal with |- context [eqb_binder_annot ?na ?na'] => + destruct (eqb_annot_reflect na na'); ih => //=; constructor; constructor; assumption end ]. - - cbn - [eqb]. eqspecs. equspec equ he. equspec lequ hle. ih. - constructor. constructor ; assumption. - - cbn - [eqb]. eqspecs. equspec equ he. equspec lequ hle. ih. - constructor. constructor ; assumption. - - cbn - [eqb]. eqspecs. equspec equ he. equspec lequ hle. ih. - cbn. - induction X in l0, ht, ht' |- *. - + destruct l0. - * constructor. constructor. constructor. - * constructor. intro bot. inversion bot. inversion X. - + destruct l0. - * constructor. intro bot. inversion bot. subst. inversion X0. - * move: ht => /= /andP [? ?]. - move: ht' => /= /andP [? ?]. - destruct (p0 _ _ 0 he t) => //. - -- cbn. destruct (IHX l0) => //. - ++ compute. constructor. constructor. constructor ; try assumption. - inversion e0. subst. assumption. - ++ constructor. intro bot. inversion bot. subst. - inversion X0. subst. - apply f. constructor. assumption. - -- constructor. intro bot. apply f. - inversion bot. subst. inversion X0. subst. assumption. - - cbn - [eqb]. equspec lequ hle. - all: auto. - ih. + - eapply reflectT_change_left. { split; intros XE. 1: constructor; now apply XE. now depelim XE. } + eapply All_reflect_reflect_All2. 2: now apply forallb_All. + solve_all. + - equspec cmps pb hspb. constructor. constructor. assumption. - - cbn - [eqb]. eqspecs. equspec equ he. equspec lequ hle. - destruct (eqb_annot_reflect n na); ih => //=. - constructor. constructor; assumption. - - cbn - [eqb]. eqspecs. equspec equ he. equspec lequ hle. - destruct (eqb_annot_reflect n na); ih => //. - constructor. constructor ; assumption. - - cbn - [eqb]. eqspecs. equspec equ he. equspec lequ hle. - destruct (eqb_annot_reflect n na); ih => //. - constructor. constructor ; assumption. - - cbn - [eqb]. eqspecs. equspec equ he. equspec lequ hle. ih => //. - + destruct (IHt1 lequ Rle (S napp) hle t'1) => //. - * constructor. constructor ; assumption. - * constructor. intros H. now inv H. - + destruct (IHt1 lequ Rle (S napp) hle t'1) => //. - * constructor; auto. - intros H; now inv H. - * constructor. intros H; now inv H. - - cbn - [eqb]. - destruct (eqb_specT s k) ; nodec. subst. - induction u in ui, ht, ht' |- *. - + destruct ui. - * constructor. constructor. constructor. - * constructor. intro bot. inversion bot. subst. inversion H0. - + destruct ui. - * constructor. intro bot. inversion bot. subst. inversion H0. - * move: ht => /= /andP [? ?]. - move: ht' => /= /andP [? ?]. - cbn in *. equspec equ he => //=. - -- destruct (IHu ui) => //=. - ++ constructor. constructor. - inversion e. subst. - constructor ; assumption. - ++ constructor. intro bot. apply f. - inversion bot. subst. constructor. inversion H0. - subst. assumption. - -- constructor. intro bot. apply n. - inversion bot. subst. inversion H0. subst. - assumption. - - cbn - [eqb]. eqspecs. - apply equiv_reflectT. - + inversion 1; subst. now eapply hcompare. - + intros H. - constructor. - now rewrite hcompare. - - cbn - [eqb]. eqspecs. - apply equiv_reflectT. - + inversion 1; subst. now eapply hcompare. - + intros H. - constructor. now eapply hcompare. - - cbn - [eqb]. eqspecs => /=. - unshelve epose proof (Hr := (reflect_eq_predicate he hle hcompare p0 p1 _ _ _ _ _ _ X)). - 7: ih. - 1-8: solve_all. - 2:{ rewrite andb_false_r /=. - constructor. intros bot; inv bot; contradiction. - } - case: Hr => e' /=. - 2:{ - constructor. intro bot. inversion bot. subst. - auto. - } - clear X. rename X0 into X. - induction l in brs, X, ht, ht' |- *. - + destruct brs. - * constructor. constructor ; try assumption. - constructor. - * constructor. intro bot. inversion bot. subst. inversion X2. - + destruct brs. - * constructor. intro bot. inversion bot. subst. inversion X2. - * move: ht; rewrite /= /test_branch /= => /andP [] /andP [? ?] ?. - move: ht'; rewrite /= /test_branch /= => /andP [] /andP [? ?] ?. - cbn - [eqb]. inversion X. subst. - destruct a, b. cbn - [eqb eqb_binder_annots]. - destruct X0 as [onc onbod]. - case: (reflect_eq_ctx bcontext bcontext0) => a // /=. - 2:{ constructor. intro bot. inversion bot. subst. - inversion X3. subst. destruct X4. cbn in *. subst. - contradiction. - } - cbn - [eqb]. - pose proof (onbod equ Re 0 he bbody0) as hh. cbn in hh. - case: hh => //= [e1|f]. - 2:{ constructor. intro bot. apply f. inversion bot. subst. - inversion X3. subst. destruct X4. assumption. } - cbn -[eqb eqb_binder_annots] in *. case: (IHl X1 brs) => // [e2|f]. - 2:{ constructor. intro bot. apply f. inversion bot. subst. - inversion X3. subst. constructor; auto. } - constructor. inversion e2. subst. - constructor ; auto. - - - cbn - [eqb]. eqspecs. equspec equ he. equspec lequ hle. ih => //. - constructor. constructor ; assumption. - - - cbn - [eqb]. eqspecs. equspec equ he. equspec lequ hle. ih. - cbn - [eqb]. - induction m in X, mfix, ht, ht' |- *. - + destruct mfix. - * constructor. constructor. constructor. - * constructor. intro bot. inversion bot. subst. inversion X0. - + destruct mfix. - * constructor. intro bot. inversion bot. subst. inversion X0. - * cbn - [eqb]. - move: ht => /= /andP [] /andP [? ?] ?. - move: ht' => /= /andP [] /andP [? ?] ?. - inversion X. subst. - destruct X0 as [h1 h2]. - destruct (h1 equ Re 0 he (dtype d)) => //. - 2:{ constructor. intro bot. apply f. - inversion bot. subst. inversion X0. subst. apply X2. } - destruct (h2 equ Re 0 he (dbody d)) => //. - 2:{ - constructor. intro bot. apply f. - inversion bot. subst. inversion X0. subst. - apply X2. - } - cbn - [eqb]. eqspecs. - 2:{ constructor. intro bot. inversion bot. subst. - apply n. inversion X0. subst. destruct X2 as [[? ?] ?]. - assumption. - } - destruct (eqb_annot_reflect (dname a) (dname d)). - 2:{ constructor. intro bot; inversion bot. subst. - apply n. inversion X0. subst. destruct X2 as [[? ?] ?]. - assumption. - } - cbn - [eqb]. destruct (IHm X1 mfix) => //. - 2:{ constructor. intro bot. apply f. - inversion bot. subst. constructor. - inversion X0. subst. assumption. } - constructor. constructor. constructor ; try easy. - now inversion e3. - - - cbn - [eqb]. eqspecs. equspec equ he. equspec lequ hle. ih. - cbn - [eqb]. - induction m in X, mfix, ht, ht' |- *. - + destruct mfix. - * constructor. constructor. constructor. - * constructor. intro bot. inversion bot. subst. inversion X0. - + destruct mfix. - * constructor. intro bot. inversion bot. subst. inversion X0. - * cbn - [eqb]. - move: ht => /= /andP [] /andP [? ?] ?. - move: ht' => /= /andP [] /andP [? ?] ?. - inversion X. subst. - destruct X0 as [h1 h2]. - destruct (h1 equ Re 0 he (dtype d)) => //. - 2:{ constructor. intro bot. apply f. - inversion bot. subst. inversion X0. subst. apply X2. } - destruct (h2 equ Re 0 he (dbody d)) => //. - 2:{ - constructor. intro bot. apply f. - inversion bot. subst. inversion X0. subst. - apply X2. - } - cbn - [eqb]. eqspecs. - 2:{ constructor. intro bot. inversion bot. subst. - apply n. inversion X0. subst. destruct X2 as [[? ?] ?]. - assumption. - } - destruct (eqb_annot_reflect (dname a) (dname d)). - 2:{ constructor. intro bot; inversion bot. subst. - apply n. inversion X0. subst. destruct X2 as [[? ?] ?]. - assumption. - } - cbn - [eqb]. destruct (IHm X1 mfix) => //. - 2:{ constructor. intro bot. apply f. - inversion bot. subst. constructor. - inversion X0. subst. assumption. } - constructor. constructor. constructor ; try easy. - now inversion e3. - - - destruct p0 as [? []], prim as [? []]; + - eapply reflectT_change_left. { split; intros XE. 1: constructor; now apply XE. now depelim XE. } + apply reflect_reflectT. eapply reflect_cmp_universe_instance; eauto. + - eapply reflectT_change_left. { split; intros XE. 1: constructor; now apply XE. now depelim XE. } + apply reflect_reflectT. now eapply hglpb. + - eapply reflectT_change_left. { split; intros XE. 1: constructor; now apply XE. now depelim XE. } + apply reflect_reflectT. now eapply hglpb. + + - eapply reflectT_change_left3. { split; intros XE. 1: destruct XE as [XE1 XE2 XE3]; constructor; [apply XE1|apply XE2|apply XE3]. now depelim XE. } + + eapply reflectT_change_left4. { split; intros XE. 1: destruct XE as [XE1 XE2 XE3 XE4]; repeat split; [apply XE1|apply XE2|apply XE3|apply XE4]. now depelim XE. } + * eapply All_reflect_reflect_All2. 2: now apply forallb_All. + solve_all. + * apply reflect_reflectT. eapply reflect_cmp_universe_instance; eauto. + * apply reflect_eq_context_upto_names. + * solve_all. + + ih => //=; constructor; assumption. + + eapply All_reflect_reflect_All2. 2: now apply forallb_All. + solve_all. + eapply reflectT_change_left2. { split; intros XE. 1: destruct XE as [XE1 XE2]; constructor; [apply XE1|apply XE2]. now depelim XE. } + 1: apply reflect_eq_context_upto_names. + unfold test_branch in *. rtoProp. + ih => //=. constructor; assumption. + + - eapply reflectT_change_left. { split; intros XE. 1: constructor; now apply XE. now depelim XE. } + eapply All_reflect_reflect_All2. 2: now apply forallb_All. + solve_all. + eapply reflectT_change_left4. { split; intros XE. 1: destruct XE as [XE1 XE2 XE3 XE4]; repeat split; [apply XE1|apply XE2|apply XE3|apply XE4]. now depelim XE. } + 1,2: ih => //; constructor; assumption. + + apply reflect_reflectT, eqb_specT. + + apply reflect_reflectT, eqb_annot_reflect. + + - eapply reflectT_change_left. { split; intros XE. 1: constructor; now apply XE. now depelim XE. } + eapply All_reflect_reflect_All2. 2: now apply forallb_All. + solve_all. + eapply reflectT_change_left4. { split; intros XE. 1: destruct XE as [XE1 XE2 XE3 XE4]; repeat split; [apply XE1|apply XE2|apply XE3|apply XE4]. now depelim XE. } + 1,2: ih => //; constructor; assumption. + + apply reflect_reflectT, eqb_specT. + + apply reflect_reflectT, eqb_annot_reflect. + + - destruct p0 as [? []], prim as [? []]; cbn in X, ht, ht'; rewrite /eqb_prim_val /eqb_prim_model; cbn -[eqb]; try eqspecs; try repeat constructor. 1-8:intros e; depelim e; try depelim o; intuition eauto. - unfold eqb_array. eqspecs; rewrite ?andb_true_r ?andb_false_r. - rtoProp; intuition auto. specialize (a1 equ Re 0 he _ H4 H0). - specialize (a2 equ Re 0 he _ H5 H1). - case: a1; rewrite ?andb_true_r ?andb_false_r; [intros eq|constructor; intros e; depelim e; depelim o]; eauto. - case: a2; rewrite ?andb_true_r ?andb_false_r; [intros eq'|constructor; intros e; depelim e; depelim o]; eauto. - equspec equ he; eauto; cbn. - 2:constructor; intros e; depelim e; depelim o; eauto. - repeat toAll. - revert b0 H2. - destruct a as [l d ty v], a0 as [l' d' ty' v']; cbn in *. - intros a. - induction a in v' |- *; intros. - * depelim H2; cbn; constructor; eauto; try repeat constructor; cbn; eauto. - intros heq; depelim heq; cbn in *; depelim o; eauto. depelim a0. - * intuition auto. depelim H2; cbn; try constructor; eauto. - ++ intros heq; depelim heq; depelim o; eauto. depelim a2. - ++ specialize (IHa _ H2). case: IHa; intros htl. - +++ rewrite andb_true_r. specialize (b equ Re 0 he _ a0 i). - case: b; repeat constructor; eauto; depelim htl; depelim o; eauto. - intros heq; depelim heq; depelim o; cbn in *; eauto. eapply f. now depelim a3. - +++ rewrite andb_false_r; constructor. - intros heq; depelim heq; depelim o; cbn in *; eauto. eapply htl. - repeat constructor; eauto. cbn. now depelim a2. + rtoProp. destruct X as (hty & hdef & harr). + eapply reflectT_change_left. { split; intros XE. 1: constructor; now apply XE. now depelim XE. } + eapply reflectT_change_left4. { split; intros XE. 1: destruct XE as [XE1 XE2 XE3 XE4]; constructor; [apply XE1|apply XE3|apply XE4|apply XE2]. now depelim XE. } + 3,4: ih => //; constructor; assumption. + + rewrite andb_true_r. eapply reflect_reflectT. eauto. + + eapply All_reflect_reflect_All2. 2: now apply forallb_All. + solve_all. Qed. - Lemma eqb_term_upto_univ_impl (equ lequ : _ -> _ -> bool) - (gen_compare_global_instance : (Universe.t -> Universe.t -> bool) -> global_reference -> nat -> list Level.t -> list Level.t -> bool) - (p : Universe.t -> bool) (q : nat -> term -> bool) Σ Re Rle napp: - (forall u u', p u -> p u' -> reflect (Re u u') (equ u u')) -> - (forall u u', p u -> p u' -> reflect (Rle u u') (lequ u u')) -> - (forall R leq, - (forall u u', p u -> p u' -> reflect (R u u') (leq u u')) -> - forall ref n l l' , - forallb p (map Universe.make l) -> - forallb p (map Universe.make l') -> - R_global_instance Σ Re R ref n l l' <-> - gen_compare_global_instance leq ref n l l') -> +Lemma eqb_term_upto_univ_impl Σ (p : Universe.t -> bool) (q : nat -> term -> bool) cmpu cmps cmp_universe cmp_sort + (gen_compare_global_instance : conv_pb -> global_reference -> nat -> list Level.t -> list Level.t -> bool) + pb napp : + (forall u u', p u -> p u' -> reflect (cmp_universe Conv u u') (cmpu Conv u u')) -> + (forall u u', p u -> p u' -> reflect (cmp_universe pb u u') (cmpu pb u u')) -> + (forall s s', Sort.on_sort p true s -> Sort.on_sort p true s' -> reflect (cmp_sort Conv s s') (cmps Conv s s')) -> + (forall s s', Sort.on_sort p true s -> Sort.on_sort p true s' -> reflect (cmp_sort pb s s') (cmps pb s s')) -> + (forall gr napp ui ui', forallb p (map Universe.make' ui) -> forallb p (map Universe.make' ui') -> reflect (cmp_global_instance Σ cmp_universe Conv gr napp ui ui') (gen_compare_global_instance Conv gr napp ui ui')) -> + (forall gr napp ui ui', forallb p (map Universe.make' ui) -> forallb p (map Universe.make' ui') -> reflect (cmp_global_instance Σ cmp_universe pb gr napp ui ui') (gen_compare_global_instance pb gr napp ui ui')) -> forall t t', on_universes p q t -> on_universes p q t' -> - eqb_term_upto_univ_napp equ lequ (gen_compare_global_instance) napp t t' -> - eq_term_upto_univ_napp Σ Re Rle napp t t'. + eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance pb napp t t' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp t t'. Proof. - intros he hle Hcompare t t' ht ht'. - case: (reflect_eq_term_upto_univ Σ equ lequ p q Re Rle) => //; eauto. + intros he hle hs hspb hgl hglpb t t' ht ht'. + eapply elimT, reflect_eq_term_upto_univ. + all: eassumption. Qed. - -Definition compare_global_instance_proper Σ equ equ' eqlu eqlu' : - (forall u u', equ u u' = equ' u u') -> - (forall u u', eqlu u u' = eqlu' u u') -> - forall ref n l l', - compare_global_instance Σ equ eqlu ref n l l' = - compare_global_instance Σ equ' eqlu' ref n l l'. +Definition compare_global_instance_proper lookup cmpu cmpu' : + (forall pb u u', cmpu pb u u' = cmpu' pb u u') -> + forall ref pb n l l', + compare_global_instance lookup cmpu pb ref n l l' = + compare_global_instance lookup cmpu' pb ref n l l'. Proof. - intros Hequ Heqlu ref n l l'. + intros Hequ ref pb n l l'. apply eq_true_iff_eq. etransitivity. - symmetry. eapply reflect_iff. - eapply reflect_R_global_instance' with (p := xpredT); intros; eauto. + eapply reflect_cmp_global_instance' with (p := xpredT) (cmp_universe := cmpu); intros; eauto. 1-2: apply idP. 1-2: apply forallb_true. - eapply reflect_iff. - eapply reflect_R_global_instance' with (p := xpredT); intros; eauto. + eapply reflect_cmp_global_instance' with (p := xpredT); intros; eauto. 3-4: apply forallb_true. - + rewrite Hequ. destruct equ'; constructor; eauto. - + rewrite Heqlu. destruct eqlu'; constructor; eauto. + 1-2: rewrite Hequ; apply idP. Defined. -Definition eqb_term_upto_univ_proper Σ equ equ' eqlu eqlu' -(gen_compare_global_instance gen_compare_global_instance' : (Universe.t -> Universe.t -> bool) -> global_reference -> nat -> list Level.t -> list Level.t -> bool) -napp (t u : term) : -(forall u u', wf_universe Σ u -> wf_universe Σ u' -> equ u u' = equ' u u') -> -(forall u u', wf_universe Σ u -> wf_universe Σ u' -> eqlu u u' = eqlu' u u') -> -(forall leq ref n l l', compare_global_instance (lookup_env Σ) equ leq ref n l l' = - gen_compare_global_instance leq ref n l l') -> -(forall leq ref n l l', gen_compare_global_instance leq ref n l l' = - gen_compare_global_instance' leq ref n l l') -> -wf_universes Σ t -> wf_universes Σ u -> -eqb_term_upto_univ_napp equ eqlu gen_compare_global_instance napp t u = -eqb_term_upto_univ_napp equ' eqlu' gen_compare_global_instance' napp t u. +Definition eqb_term_upto_univ_proper Σ cmpu cmpu' cmps cmps' + (gen_compare_global_instance gen_compare_global_instance' : conv_pb -> global_reference -> nat -> list Level.t -> list Level.t -> bool) + pb napp (t u : term) : + (forall pb u u', wf_universe Σ u -> wf_universe Σ u' -> cmpu pb u u' = cmpu' pb u u') -> + (forall pb s s', wf_sort Σ s -> wf_sort Σ s' -> cmps pb s s' = cmps' pb s s') -> + (forall ref pb n l l', compare_global_instance (lookup_env Σ) cmpu pb ref n l l' = gen_compare_global_instance pb ref n l l') -> + (forall ref pb n l l', gen_compare_global_instance ref pb n l l' = + gen_compare_global_instance' ref pb n l l') -> + wf_universes Σ t -> wf_universes Σ u -> + eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance pb napp t u = + eqb_term_upto_univ_napp cmpu' cmps' gen_compare_global_instance' pb napp t u. Proof. -intros Hequ Heqlu Hcompare Hgen_compare Ht Hu. apply eq_true_iff_eq. split; intros. -- eapply introT. - * eapply reflect_eq_term_upto_univ; intros. - 1-2: apply idP. - + apply reflect_iff. rewrite <- Hgen_compare, <- Hcompare. - eapply reflect_R_global_instance with (p := wf_universeb Σ); eauto. - 1: intros; rewrite <- Hequ; eauto. all: try apply idP. - ++ revert H2. eapply reflect_iff; eapply wf_universe_reflect. - ++ revert H3. eapply reflect_iff; eapply wf_universe_reflect. - + eassumption. - + eassumption. - * eapply elimT. 2: exact H. - eapply reflect_eq_term_upto_univ; intros; try assumption. - 1: intros; rewrite <- Hequ; try apply idP. - 1: revert H0; eapply reflect_iff; eapply wf_universe_reflect. - 1: revert H1; eapply reflect_iff; eapply wf_universe_reflect. - 1: intros; rewrite <- Heqlu; try apply idP. - 1: revert H0; eapply reflect_iff; eapply wf_universe_reflect. - 1: revert H1; eapply reflect_iff; eapply wf_universe_reflect. - 2-3: eassumption. - + apply reflect_iff. rewrite <- Hcompare. - eapply reflect_R_global_instance; eauto. - 1: intros; rewrite <- Hequ; try apply idP. - 1: revert H2; eapply reflect_iff; eapply wf_universe_reflect. - 1: revert H3; eapply reflect_iff; eapply wf_universe_reflect. - - eapply introT. - * eapply reflect_eq_term_upto_univ; intros. - 1-2: apply idP. - 2-3: eassumption. - + apply reflect_iff. rewrite <- Hcompare. - eapply reflect_R_global_instance; eauto. - intros; rewrite Hequ; try apply idP. - 1: revert H2; eapply reflect_iff; eapply wf_universe_reflect. - 1: revert H3; eapply reflect_iff; eapply wf_universe_reflect. - * eapply elimT. 2: exact H. - eapply reflect_eq_term_upto_univ; intros; try eassumption. - 1: intros; rewrite <- Hequ; try apply idP. - 1: revert H0; eapply reflect_iff; eapply wf_universe_reflect. - 1: revert H1; eapply reflect_iff; eapply wf_universe_reflect. - 1: intros; rewrite <- Heqlu; try apply idP. - 1: revert H0; eapply reflect_iff; eapply wf_universe_reflect. - 1: revert H1; eapply reflect_iff; eapply wf_universe_reflect. - + apply reflect_iff. rewrite <- Hgen_compare, <- Hcompare. - eapply reflect_R_global_instance; eauto. - intros; rewrite Hequ; try apply idP. - 1: revert H2; eapply reflect_iff; eapply wf_universe_reflect. - 1: revert H3; eapply reflect_iff; eapply wf_universe_reflect. + intros Hequ Heqs Hcompare Hgen_compare Ht Hu. apply eq_true_iff_eq. + eassert _ as X. + 2: split; [apply introT|apply elimT]; apply X. + eapply reflectT_change_left. + 2: eapply reflect_eq_term_upto_univ with (cmp_universe := cmpu) (cmp_sort := cmps). + 1: eassert _ as X; [eapply reflect_eq_term_upto_univ with (cmp_universe := cmpu) (cmp_sort := cmps) | split; [apply introT|apply elimT]; eapply X]. + all: intros; eauto. + 1-4: apply idP. + 1-2: rewrite -Hcompare; eapply reflect_cmp_global_instance; intros; eauto using idP. + 1-2: rewrite Hequ; eauto using idP. + 1-4: now apply/wf_universe_reflect. + 1-2: rewrite Heqs; eauto using idP. + 1-4: now apply/wf_sort_reflect. + 1-2: rewrite -Hgen_compare -Hcompare; eapply reflect_cmp_global_instance; intros; eauto using idP. Defined. Lemma compare_global_instance_refl : - forall Σ (eqb leqb : Universe.t -> Universe.t -> bool) gr napp u, - (forall u, eqb u u) -> - (forall u, leqb u u) -> - compare_global_instance Σ eqb leqb gr napp u u. + forall Σ (cmpu : conv_pb -> Universe.t -> Universe.t -> bool) gr pb napp u, + (forall u, cmpu Conv u u) -> + (forall u, cmpu pb u u) -> + compare_global_instance Σ cmpu pb gr napp u u. Proof. - intros Σ eqb leqb gr napp u eqb_refl leqb_refl. + intros Σ cmpu gr pb napp u cmpu_refl cmpu_refl'. rewrite /compare_global_instance. - destruct global_variance_gen as [v|]. - - induction u in v |- *; destruct v; simpl; auto. - rtoProp. split; auto. - destruct t; simpl; auto. - - rewrite /compare_universe_instance. - rewrite forallb2_map; eapply forallb2_refl; intro; apply eqb_refl. + destruct global_variance_gen as [| |v]. + - apply All2_forallb2, All2_refl; auto. + - apply eqb_refl. + - apply orb_true_iff. right. + apply All2_forallb2, All2_refl; auto. Qed. Lemma All_All2_diag {A} {P : A -> A -> Prop} {l} : @@ -921,174 +622,169 @@ Proof. induction 1; constructor; auto. Qed. -Lemma R_global_instance_refl_wf Σ (Re Rle : Universe.t -> Universe.t -> Prop) gr napp l : -(forall u, wf_universe Σ u -> Re u u) -> -(forall u, wf_universe Σ u -> Rle u u) -> -forallb (wf_universeb Σ) (map Universe.make l) -> -R_global_instance Σ Re Rle gr napp l l. +Lemma cmp_universe_instance_refl_wf Σ (cmp_universe : Universe.t -> Universe.t -> Prop) l : + (forall u, wf_universe Σ u -> cmp_universe u u) -> + forallb (wf_universeb Σ) (map Universe.make' l) -> + cmp_universe_instance cmp_universe l l. Proof. - intros rRE rRle Hl. - rewrite /R_global_instance_gen. - destruct global_variance_gen as [v|] eqn:lookup. - - induction l in v , Hl |- *; simpl; auto. - apply andb_and in Hl as [? Hl]. revert a H. move => ? /wf_universe_reflect ?. - unfold R_opt_variance in IHl; destruct v; simpl; auto. - split; auto. - destruct t; simpl; eauto. - - eapply Forall_Forall2_diag. eapply forallb_Forall in Hl. - eapply Forall_impl; eauto. - move => ? /wf_universe_reflect ?; eauto. + intros rRE Hl. + unfold cmp_universe_instance. solve_all. + eapply All_All2; tea. intros. apply rRE. + now apply/wf_universe_reflect. Qed. -Definition eq_term_upto_univ_refl_wf Σ (Re Rle : Universe.t -> Universe.t -> Prop) napp : - (forall u, wf_universe Σ u -> Re u u) -> - (forall u, wf_universe Σ u -> Rle u u) -> - forall t, wf_universes Σ t -> eq_term_upto_univ_napp Σ Re Rle napp t t. +Lemma cmp_global_instance_refl_wf Σ (cmp_universe : conv_pb -> Universe.t -> Universe.t -> Prop) gr pb napp l : + (forall u, wf_universe Σ u -> cmp_universe Conv u u) -> + forallb (wf_universeb Σ) (map Universe.make' l) -> + cmp_global_instance Σ cmp_universe pb gr napp l l. Proof. - intros hRe hRle t wt. - induction t in napp, Rle, hRle, wt |- * using term_forall_list_ind. - all: repeat (apply andb_and in wt as [? wt]). + intros rRE Hl. + rewrite /cmp_global_instance_gen. + destruct global_variance_gen as [| |v] => //=. 2: left. all: now eapply cmp_universe_instance_refl_wf. +Qed. + +Definition eq_term_upto_univ_refl_wf Σ (cmp_universe : forall _ _ _, Prop) (cmp_sort : forall _ _ _, Prop) pb napp : + (forall u, wf_universe Σ u -> cmp_universe Conv u u) -> + (forall s, wf_sort Σ s -> cmp_sort Conv s s) -> + (forall s, wf_sort Σ s -> cmp_sort pb s s) -> + forall t, wf_universes Σ t -> eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp t t. +Proof. + intros hU hS hS' t wt. + induction t in pb, napp, hS', wt |- * using term_forall_list_ind. + all: repeat (cbn in wt; apply andb_and in wt as [? wt]). all: try constructor. all: eauto. - apply forallb_All in wt; eapply All_mix in wt; try exact X; eapply All_All2 ; try exact wt; intros ? [? ?]; eauto. - - revert s wt; move => ? /wf_universe_reflect ?; eauto. - - apply forallb_All in wt. apply All2_Forall2. induction u; cbn. - + eapply All2_nil. - + cbn in wt. inversion wt; subst. eapply All2_cons; eauto. - clear -a H0 hRe; revert a H0; move => ? /wf_universe_reflect ?; eauto. - - apply R_global_instance_refl_wf; auto. - - apply R_global_instance_refl_wf; auto. + - revert s wt; move => ? /wf_sort_reflect ?; eauto. + - eapply cmp_universe_instance_refl_wf; eauto. + - apply cmp_global_instance_refl_wf; auto. + - apply cmp_global_instance_refl_wf; auto. - destruct X as [? [? ?]]. unfold eq_predicate. repeat split; eauto. - + eapply forallb_All in H0. eapply All_mix in H0; try apply a. clear a. eapply All_All2; eauto. - clear H0. cbn; intros x [Hx Hclose]. apply Hx; eauto. - + unfold R_universe_instance. clear - H hRe. apply Forall_Forall2_diag. - apply forallb_Forall in H. eapply Forall_impl; eauto. - move => ? /wf_universe_reflect ?; eauto. - + eapply onctx_eq_ctx in a0; eauto. - - eapply forallb_All in wt; eapply All_mix in X0; try apply wt. - clear wt. eapply All_All2; eauto; simpl; intuition eauto. - + eapply onctx_eq_ctx in a0; eauto. - + eapply b0; eauto. apply andb_and in a as [? a]. exact a. + + solve_all. eapply All_All2; tea. solve_all. + + eapply cmp_universe_instance_refl_wf; eauto. + + reflexivity. + - solve_all. + eapply All_All2; tea. solve_all. + unfold test_branch in *. rtoProp. + split. 1: reflexivity. + eapply b0; tea. - eapply forallb_All in wt; eapply All_mix in X; try apply wt; clear wt. eapply All_All2; eauto; simpl; intuition eauto; apply andb_and in a as [? ?]; eauto. - eapply forallb_All in wt; eapply All_mix in X; try apply wt; clear wt. eapply All_All2; eauto; simpl; intuition eauto; apply andb_and in a as [? ?]; eauto. - - destruct p as [? []]; cbn -[Universe.make] in X, wt; rtoProp; intuition eauto; constructor; eauto. - + eapply hRe. now move/wf_universe_reflect: H. + - destruct p as [? []]; cbn -[Universe.make'] in X, wt; rtoProp; intuition eauto; constructor; eauto. + + eapply hU. now move/wf_universe_reflect: H. + solve_all. eapply All_All2; eauto; simpl; intuition eauto. Defined. -Lemma eqb_term_upto_univ_refl Σ (eqb leqb : Universe.t -> Universe.t -> bool) (Re : Universe.t -> Universe.t -> Prop) - (gen_compare_global_instance : (Universe.t -> Universe.t -> bool) -> global_reference -> nat -> list Level.t -> list Level.t -> bool) - napp t : - (forall u, wf_universe Σ u -> eqb u u) -> - (forall u, wf_universe Σ u -> leqb u u) -> - (forall u u', wf_universe Σ u -> wf_universe Σ u' -> reflect (Re u u') (eqb u u')) -> - (forall R leq , - (forall u u', wf_universe Σ u -> wf_universe Σ u' -> reflect (R u u') (leq u u')) -> - forall ref n l l' , - forallb (wf_universeb Σ) (map Universe.make l) -> - forallb (wf_universeb Σ) (map Universe.make l') -> - R_global_instance Σ Re R ref n l l' <-> - gen_compare_global_instance leq ref n l l') -> +Lemma eqb_term_upto_univ_refl Σ (cmpu : forall _ _ _, bool) (cmps : forall _ _ _, bool) gen_compare_global_instance pb napp t : + (forall u, wf_universe Σ u -> cmpu Conv u u) -> + (forall s, wf_sort Σ s -> cmps Conv s s) -> + (forall s, wf_sort Σ s -> cmps pb s s) -> + (forall gr napp ui ui', forallb (wf_universeb Σ) (map Universe.make' ui) -> forallb (wf_universeb Σ) (map Universe.make' ui') -> reflect (cmp_global_instance Σ cmpu Conv gr napp ui ui') (gen_compare_global_instance Conv gr napp ui ui')) -> + (forall gr napp ui ui', forallb (wf_universeb Σ) (map Universe.make' ui) -> forallb (wf_universeb Σ) (map Universe.make' ui') -> reflect (cmp_global_instance Σ cmpu pb gr napp ui ui') (gen_compare_global_instance pb gr napp ui ui')) -> wf_universes Σ t -> - eqb_term_upto_univ_napp eqb leqb gen_compare_global_instance napp t t. + eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance pb napp t t. Proof. - intros eqb_refl leqb_refl eqRe Hcompare Ht. - case: (reflect_eq_term_upto_univ Σ eqb leqb (wf_universeb Σ) closedu Re leqb gen_compare_global_instance napp _ _ _ t t) => //; eauto. - - move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. now apply eqRe. - - intros; apply/idP. - - intros; apply Hcompare; eauto. move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?; now apply X. - - unshelve epose proof (eq_term_upto_univ_refl_wf Σ Re leqb napp _ _ t); eauto. - + intros u Hu; pose proof (eqb_refl u Hu) as H. revert H. apply reflect_iff; eauto. - + intro H. destruct (H (X Ht)). + intros eqb_refl leqb_refl eqRe Hglobal Hglobal' Ht. + eapply introT. + 2: eapply eq_term_upto_univ_refl_wf; eauto. + 1: eapply reflect_eq_term_upto_univ with (p := wf_universeb Σ) (cmp_universe := cmpu) (cmp_sort := cmps); eauto. + 1-4: intros; apply idP. + all: cbn; tas. Qed. -(* genereic equality for contexts *) - -Fixpoint eqb_ctx_gen equ gen_compare_global_instance - (Γ Δ : context) : bool := - match Γ, Δ with - | [], [] => true - | {| decl_name := na1 ; decl_body := None ; decl_type := t1 |} :: Γ, - {| decl_name := na2 ; decl_body := None ; decl_type := t2 |} :: Δ => - eqb_binder_annot na1 na2 && eqb_term_upto_univ equ equ gen_compare_global_instance t1 t2 && eqb_ctx_gen equ gen_compare_global_instance Γ Δ - | {| decl_name := na1 ; decl_body := Some b1 ; decl_type := t1 |} :: Γ, - {| decl_name := na2 ; decl_body := Some b2 ; decl_type := t2 |} :: Δ => - eqb_binder_annot na1 na2 && eqb_term_upto_univ equ equ gen_compare_global_instance b1 b2 && eqb_term_upto_univ equ equ gen_compare_global_instance t1 t2 && eqb_ctx_gen equ gen_compare_global_instance Γ Δ - | _, _ => false - end. +(* generic equality for contexts *) - Lemma eqb_binder_annot_spec {A} na na' : eqb_binder_annot (A:=A) na na' -> eq_binder_annot (A:=A) na na'. - Proof. case: eqb_annot_reflect => //. Qed. - - Lemma reflect_eqb_ctx_gen Σ equ - (p : Universe.t -> bool) (q : nat -> term -> bool) - (Re : Universe.t -> Universe.t -> Prop) - (gen_compare_global_instance : (Universe.t -> Universe.t -> bool) -> global_reference -> nat -> list Level.t -> list Level.t -> bool) : - (forall u u', p u -> p u' -> reflect (Re u u') (equ u u')) -> - (forall R leq, - (forall u u', p u -> p u' -> reflect (R u u') (leq u u')) -> - forall ref n l l' , - forallb p (map Universe.make l) -> - forallb p (map Universe.make l') -> - R_global_instance Σ Re R ref n l l' <-> - gen_compare_global_instance leq ref n l l') -> +Definition eqb_decl_gen eqb_term pb (d d' : context_decl) : bool := + match d, d' with + | {| decl_name := na; decl_body := None; decl_type := T |}, + {| decl_name := na'; decl_body := None; decl_type := T' |} => + eqb_binder_annot na na' && eqb_term pb T T' + | {| decl_name := na; decl_body := Some b; decl_type := T |}, + {| decl_name := na'; decl_body := Some b'; decl_type := T' |} => + eqb_binder_annot na na' && eqb_term Conv b b' && eqb_term pb T T' + | _, _ => false + end. + +Notation eqb_context_gen eqb_term pb := (forallb2 (eqb_decl_gen eqb_term pb)). + +Definition eqb_ctx_upto cmpu cmps gen_compare_global_instance pb : context -> context -> bool := + eqb_context_gen (fun pb => eqb_term_upto_univ cmpu cmps gen_compare_global_instance pb) pb. + +Lemma eqb_binder_annot_spec {A} na na' : eqb_binder_annot (A:=A) na na' -> eq_binder_annot (A:=A) na na'. +Proof. case: eqb_annot_reflect => //. Qed. + +Section reflectContext. + Context Σ (p : Universe.t -> bool) (q : nat -> term -> bool) cmpu cmps cmp_universe cmp_sort + (gen_compare_global_instance : conv_pb -> global_reference -> nat -> list Level.t -> list Level.t -> bool) + pb + (hu : forall u u', p u -> p u' -> reflect (cmp_universe Conv u u') (cmpu Conv u u')) + (hu' : forall u u', p u -> p u' -> reflect (cmp_universe pb u u') (cmpu pb u u')) + (hs : forall s s', Sort.on_sort p true s -> Sort.on_sort p true s' -> reflect (cmp_sort Conv s s') (cmps Conv s s')) + (hs' : forall s s', Sort.on_sort p true s -> Sort.on_sort p true s' -> reflect (cmp_sort pb s s') (cmps pb s s')) + (hglobal : forall gr napp ui ui', forallb p (map Universe.make' ui) -> forallb p (map Universe.make' ui') -> reflect (cmp_global_instance Σ cmp_universe Conv gr napp ui ui') (gen_compare_global_instance Conv gr napp ui ui')) + (hglobal' : forall gr napp ui ui', forallb p (map Universe.make' ui) -> forallb p (map Universe.make' ui') -> reflect (cmp_global_instance Σ cmp_universe pb gr napp ui ui') (gen_compare_global_instance pb gr napp ui ui')). + + Lemma reflect_eqb_decl_gen : + forall d d', + on_decl_universes p q d -> + on_decl_universes p q d' -> + reflectT (compare_decls (fun pb => eq_term_upto_univ Σ cmp_universe cmp_sort pb) pb d d') + (eqb_decl_gen (fun pb => eqb_term_upto_univ cmpu cmps gen_compare_global_instance pb) pb d d'). + Proof. + unfold on_decl_universes, compare_decls. + move => [na [b|] A] [na' [b'|] A'] /= ond ond'. + 2,3: constructor; intro X; depelim X. + all: rtoProp. + - eapply reflectT_change_left3. 1: { split; intros XE. 1: destruct XE as [XE1 XE2 XE3]; constructor; [apply XE1|apply XE2|apply XE3]. now depelim XE. } + + apply reflect_reflectT, eqb_annot_reflect. + + eapply reflect_eq_term_upto_univ; tea. + + eapply reflect_eq_term_upto_univ; tea. + - eapply reflectT_change_left2. 1: { split; intros XE. 1: destruct XE as [XE1 XE2]; constructor; [apply XE1|apply XE2]. now depelim XE. } + + apply reflect_reflectT, eqb_annot_reflect. + + eapply reflect_eq_term_upto_univ; tea. + Qed. + + Lemma reflect_eqb_ctx_gen : forall Γ Δ, on_ctx_universes p q Γ -> on_ctx_universes p q Δ -> - eqb_ctx_gen equ gen_compare_global_instance Γ Δ -> - eq_context_upto Σ Re Re Γ Δ. + reflectT (eq_context_upto Σ cmp_universe cmp_sort pb Γ Δ) + (eqb_ctx_upto cmpu cmps gen_compare_global_instance pb Γ Δ). Proof. - intros Hequ Hcompare Γ Δ hΓ hΔ h. - induction Γ as [| [na [b|] A] Γ ih ] in Δ, hΓ, hΔ, h |- *. - all: destruct Δ as [| [na' [b'|] A'] Δ]. - all: try discriminate. - - constructor. - - simpl in h. apply andb_andI in h as [[[h1 h2]%andb_and h3]%andb_and h4]. - simpl in hΓ. apply andb_andI in hΓ as [[hΓ1 hΓ2]%andb_and hΓ]. - simpl in hΔ. apply andb_andI in hΔ as [[hΔ1 hΔ2]%andb_and hΔ]. cbn in *. - constructor; auto. constructor; auto. - + now apply eqb_binder_annot_spec in h1. - + eapply eqb_term_upto_univ_impl; eauto. - + eapply eqb_term_upto_univ_impl; eauto. - - simpl in h. apply andb_and in h as [[h1 h2]%andb_and h3]. - simpl in hΓ. apply andb_andI in hΓ as [[hΓ1 hΓ2]%andb_and hΓ]. - simpl in hΔ. apply andb_andI in hΔ as [[hΔ1 hΔ2]%andb_and hΔ]. cbn in *. - constructor; auto; constructor. - + now apply eqb_binder_annot_spec. - + eapply eqb_term_upto_univ_impl; eauto. + intros. + eapply reflectT_change_left. 1: { split; apply All2_fold_All2. } + eapply All_reflect_reflect_All2. 2: apply forallb_All in H0; apply H0. + apply forallb_All in H. solve_all. + now apply reflect_eqb_decl_gen. Qed. - - Definition eqb_ctx_gen_proper (Σ:global_env_ext) equ equ' gen_compare_global_instance - gen_compare_global_instance' (Γ Δ : context) : - (forall u u', wf_universe Σ u -> wf_universe Σ u' -> equ u u' = equ' u u') -> - (forall leq ref n l l', compare_global_instance (lookup_env Σ) equ leq ref n l l' = - gen_compare_global_instance leq ref n l l') -> - (forall leq ref n l l', compare_global_instance (lookup_env Σ) equ' leq ref n l l' = - gen_compare_global_instance' leq ref n l l') -> - (forall leq ref n l l', gen_compare_global_instance' leq ref n l l' = - gen_compare_global_instance leq ref n l l') -> +End reflectContext. + +Definition eqb_ctx_gen_proper Σ cmpu cmpu' cmps cmps' + (gen_compare_global_instance gen_compare_global_instance' : conv_pb -> global_reference -> nat -> list Level.t -> list Level.t -> bool) + pb : + (forall pb u u', wf_universe Σ u -> wf_universe Σ u' -> cmpu pb u u' = cmpu' pb u u') -> + (forall pb s s', wf_sort Σ s -> wf_sort Σ s' -> cmps pb s s' = cmps' pb s s') -> + (forall ref pb n l l', compare_global_instance (lookup_env Σ) cmpu pb ref n l l' = gen_compare_global_instance pb ref n l l') -> + (forall ref pb n l l', gen_compare_global_instance ref pb n l l' = + gen_compare_global_instance' ref pb n l l') -> + forall Γ Δ, wf_ctx_universes Σ Γ -> wf_ctx_universes Σ Δ -> - eqb_ctx_gen equ gen_compare_global_instance Γ Δ = - eqb_ctx_gen equ' gen_compare_global_instance' Γ Δ. - Proof. - revert Δ; induction Γ; destruct Δ; simpl; eauto. - intros Hequ Hcompare Hcompare' Hgen_compare HΓ HΔ. - destruct a. destruct decl_body. - all: destruct c; destruct decl_body; eauto; cbn in *; - apply eq_true_iff_eq; split; intros. - all: repeat (let foo := fresh "H" in apply andb_and in H; destruct H as [H foo]); - repeat (let foo := fresh "HΓ" in apply andb_and in HΓ; destruct HΓ as [HΓ foo]); - repeat (let foo := fresh "HΔ" in apply andb_and in HΔ; destruct HΔ as [HΔ foo]); - repeat (apply andb_and; split; eauto); - try first[ rewrite <- IHΓ | rewrite IHΓ]; eauto. - all: erewrite <- eqb_term_upto_univ_proper; eauto. - all: intros; symmetry; eapply Hequ; eauto. - Defined. + eqb_ctx_upto cmpu cmps gen_compare_global_instance pb Γ Δ = + eqb_ctx_upto cmpu' cmps' gen_compare_global_instance' pb Γ Δ. +Proof. + intros hu hs hglob hglob'. + induction Γ; destruct Δ; simpl; eauto. + intros HΓ HΔ. rtoProp; f_equal; eauto. + destruct a as [na [b|] ty], c as [na' [b'|] ty']; cbnr. + all: unfold wf_decl_universes, on_decl_universes in *; rtoProp; cbn in *. + all: repeat apply (f_equal2 andb); cbnr. + all: eapply eqb_term_upto_univ_proper; tea. +Defined. (** Checking equality *) @@ -1200,10 +896,10 @@ Section EqualityDecGen. Qed. Lemma leq_universeP_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) u u' : - wf_universe Σ u -> - wf_universe Σ u' -> - reflect (leq_universe Σ u u') (check_leqb_universe_gen leqb_level_n_gen u u'). + (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) u u' : + wf_universe Σ u -> + wf_universe Σ u' -> + reflect (leq_universe Σ u u') (check_leqb_universe_gen leqb_level_n_gen u u'). Proof using hΣ. intros. apply (equivP idP) ; split. @@ -1220,48 +916,127 @@ Section EqualityDecGen. + now eapply global_ext_uctx_consistent. Qed. - Definition eqb_ctx leqb_level_n_gen := eqb_ctx_gen (check_eqb_universe_gen leqb_level_n_gen) (compare_global_instance (lookup_env Σ) (check_eqb_universe_gen leqb_level_n_gen)). + Definition check_cmpb_universe_gen leqb_level_n_gen := + (conv_pb_relb_gen (check_eqb_universe_gen leqb_level_n_gen) (check_leqb_universe_gen leqb_level_n_gen)). + + Lemma compare_universeP_gen leqb_level_n_gen + (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) pb u u' : + wf_universe Σ u -> + wf_universe Σ u' -> + reflect (compare_universe Σ pb u u') (check_cmpb_universe_gen leqb_level_n_gen pb u u'). + Proof. + destruct pb. + - now apply eq_universeP_gen. + - now apply leq_universeP_gen. + Qed. + + Lemma eq_sortP_gen leqb_level_n_gen + (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) + s s' : + wf_sort Σ s -> + wf_sort Σ s' -> + reflect (eq_sort Σ s s') (check_eqb_sort_gen leqb_level_n_gen s s'). + Proof using hΣ. + intros. destruct Σ as [Σ' φ]. + apply (equivP idP); split; sq. + all: pose proof hΣ as hΣ' ; sq. + - intros e. + eapply check_eqb_sort_spec_gen' + with (uctx := global_ext_uctx (Σ', φ)) in e ; eauto. + + now eapply wf_ext_global_uctx_invariants. + + now eapply global_ext_uctx_consistent. + - intros e. + eapply check_eqb_sort_complete_gen + with (uctx := global_ext_uctx (Σ', φ)); eauto. + + now eapply wf_ext_global_uctx_invariants. + + now eapply global_ext_uctx_consistent. + Qed. + + Lemma leq_sortP_gen leqb_level_n_gen + (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) s s' : + wf_sort Σ s -> + wf_sort Σ s' -> + reflect (leq_sort Σ s s') (check_leqb_sort_gen leqb_level_n_gen s s'). + Proof using hΣ. + intros. + apply (equivP idP) ; split. + all: pose proof hΣ as hΣ' ; sq. + - intros e. + eapply check_leqb_sort_spec_gen' + with (uctx := global_ext_uctx Σ) in e ; eauto. + + now eapply wf_ext_global_uctx_invariants. + + now eapply global_ext_uctx_consistent. + - intros e. + eapply check_leqb_sort_complete_gen + with (uctx := global_ext_uctx Σ); eauto. + + now eapply wf_ext_global_uctx_invariants. + + now eapply global_ext_uctx_consistent. + Qed. + + Definition check_cmpb_sort_gen leqb_level_n_gen := + (conv_pb_relb_gen (check_eqb_sort_gen leqb_level_n_gen) (check_leqb_sort_gen leqb_level_n_gen)). + + Lemma compare_sortP_gen leqb_level_n_gen + (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) pb s s' : + wf_sort Σ s -> + wf_sort Σ s' -> + reflect (compare_sort Σ pb s s') (check_cmpb_sort_gen leqb_level_n_gen pb s s'). + Proof. + destruct pb. + - now apply eq_sortP_gen. + - now apply leq_sortP_gen. + Qed. + + Definition eqb_ctx leqb_level_n_gen := + eqb_ctx_upto (check_cmpb_universe_gen leqb_level_n_gen) (check_cmpb_sort_gen leqb_level_n_gen) + (compare_global_instance (lookup_env Σ) (check_cmpb_universe_gen leqb_level_n_gen)). - Definition eqb_termp_napp pb leqb_level_n_gen := - eqb_termp_napp_gen pb (check_eqb_universe_gen leqb_level_n_gen) (check_leqb_universe_gen leqb_level_n_gen) - (compare_global_instance (lookup_env Σ) (check_eqb_universe_gen leqb_level_n_gen)). + Definition eqb_termp_napp leqb_level_n_gen := + eqb_term_upto_univ_napp (check_cmpb_universe_gen leqb_level_n_gen) (check_cmpb_sort_gen leqb_level_n_gen) + (compare_global_instance (lookup_env Σ) (check_cmpb_universe_gen leqb_level_n_gen)). Lemma reflect_eqb_termp_napp pb leqb_level_n_gen (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) napp t u : wf_universes Σ t -> wf_universes Σ u -> - reflectT (eq_termp_napp pb Σ napp t u) (eqb_termp_napp pb leqb_level_n_gen napp t u). + reflectT (eq_termp_napp Σ pb napp t u) (eqb_termp_napp leqb_level_n_gen pb napp t u). Proof using hΣ. apply reflect_eq_term_upto_univ. - move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. - now apply eq_universeP_gen. + now apply compare_universeP_gen. - move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. - destruct pb. - + now apply eq_universeP_gen. - + now eapply leq_universeP_gen. - - intros. apply reflect_iff. - eapply reflect_R_global_instance with (p := wf_universeb Σ); eauto. - move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?; now apply eq_universeP_gen; eauto. + now apply compare_universeP_gen. + - move => ? ? /wf_sort_reflect ? - /wf_sort_reflect ?. + now apply compare_sortP_gen. + - move => ? ? /wf_sort_reflect ? - /wf_sort_reflect ?. + now apply compare_sortP_gen. + - intros. + eapply reflect_cmp_global_instance; eauto. + + move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. + now apply compare_universeP_gen. + + move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. + now apply compare_universeP_gen. + - intros. + eapply reflect_cmp_global_instance; eauto. + + move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. + now apply compare_universeP_gen. + + move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. + now apply compare_universeP_gen. Qed. Lemma eqb_termp_napp_spec pb leqb_level_n_gen (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) napp t u : wf_universes Σ t -> wf_universes Σ u -> - eqb_termp_napp pb leqb_level_n_gen napp t u -> - eq_termp_napp pb Σ napp t u. + eqb_termp_napp leqb_level_n_gen pb napp t u -> + eq_termp_napp Σ pb napp t u. Proof using hΣ. - pose proof hΣ. - eapply eqb_term_upto_univ_impl. - - move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?; now apply eq_universeP_gen; eauto. - - destruct pb. - + move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?; now apply eq_universeP_gen; eauto. - + move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?; now apply leq_universeP_gen; eauto. - - intros. apply reflect_iff. eapply reflect_R_global_instance; eauto. - move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?; now apply eq_universeP_gen; eauto. + intros. + eapply elimT. 1: apply reflect_eqb_termp_napp. + all: eassumption. Qed. - Definition eqb_termp pb leq := (eqb_termp_napp pb leq 0). + Definition eqb_termp pb leq := (eqb_termp_napp leq pb 0). Definition eqb_term := (eqb_termp Conv). Definition leqb_term := (eqb_termp Cumul). @@ -1312,26 +1087,42 @@ Section EqualityDecGen. (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) : forall t, wf_universes Σ t -> eqb_term leqb_level_n_gen t t. Proof using hΣ. - intro t. eapply eqb_term_upto_univ_refl with (Re := eq_universe Σ). - all: intros; try eapply check_eqb_universe_refl_gen; eauto. - - eapply eq_universeP_gen; eauto. - - apply reflect_iff. eapply reflect_R_global_instance; eauto. - + move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?; apply eq_universeP_gen; eauto. - + move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?; apply X; eauto. + intro t. eapply eqb_term_upto_univ_refl. + 4,5: intros; eapply reflect_cmp_global_instance; tea; intros; cbnr; try apply idP. + - intros. cbn. unfold check_eqb_universe_gen; toProp; left. toProp. right. apply eqb_refl. + - intros. eapply check_eqb_sort_refl_gen; eauto. + - intros. eapply check_eqb_sort_refl_gen; eauto. Qed. Lemma eqb_ctx_spec leqb_level_n_gen (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) : - forall Γ Δ, + forall pb Γ Δ, wf_ctx_universes Σ Γ -> wf_ctx_universes Σ Δ -> - eqb_ctx leqb_level_n_gen Γ Δ -> - eq_context_upto Σ (eq_universe Σ) (eq_universe Σ) Γ Δ. + eqb_ctx leqb_level_n_gen pb Γ Δ -> + eq_context_upto Σ (compare_universe Σ) (compare_sort Σ) pb Γ Δ. Proof using hΣ. - intros Γ Δ hΓ hΔ h. eapply reflect_eqb_ctx_gen; eauto. - - move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?; now apply eq_universeP_gen; eauto. - - intros. apply reflect_iff. eapply reflect_R_global_instance; eauto. - move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?; now apply eq_universeP_gen; eauto. + intros pb Γ Δ hΓ hΔ h. eapply elimT. 1: eapply reflect_eqb_ctx_gen; eauto. 7: tea. + - move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. + now apply compare_universeP_gen. + - move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. + now apply compare_universeP_gen. + - move => ? ? /wf_sort_reflect ? - /wf_sort_reflect ?. + now apply compare_sortP_gen. + - move => ? ? /wf_sort_reflect ? - /wf_sort_reflect ?. + now apply compare_sortP_gen. + - intros. + eapply reflect_cmp_global_instance; eauto. + + move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. + now apply compare_universeP_gen. + + move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. + now apply compare_universeP_gen. + - intros. + eapply reflect_cmp_global_instance; eauto. + + move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. + now apply compare_universeP_gen. + + move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. + now apply compare_universeP_gen. Qed. (* diff --git a/safechecker/theories/PCUICSafeChecker.v b/safechecker/theories/PCUICSafeChecker.v index 07633a782..038c990c2 100644 --- a/safechecker/theories/PCUICSafeChecker.v +++ b/safechecker/theories/PCUICSafeChecker.v @@ -475,7 +475,7 @@ Section CheckEnv. eapply red_cumul. repeat constructor. * eapply inversion_Prod in h as [? [? [h1 [? ?]]]]; auto. specialize (IHΔ _ _ _ t) as [s'' Hs'']. - exists (Universe.sort_of_product x s''). + exists (Sort.sort_of_product x s''). apply unlift_TypUniv in h1. eapply type_Cumul'; eauto. econstructor; pcuic. pcuic. reflexivity. @@ -485,7 +485,7 @@ Section CheckEnv. Γ Δ s (wfΓ : forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ wf_local Σ Γ ∥) : typing_result (forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ type_local_ctx (lift_typing typing) Σ Γ Δ s ∥) := match Δ with - | [] => match abstract_env_ext_wf_universeb X_ext s with true => ret _ | false => raise (Msg "Ill-formed universe") end + | [] => match abstract_env_ext_wf_sortb X_ext s with true => ret _ | false => raise (Msg "Ill-formed universe") end | {| decl_body := None; decl_type := ty |} :: Δ => checkΔ <- check_type_local_ctx X_ext Γ Δ s wfΓ ;; checkty <- check_type_wf_env X_ext (Γ ,,, Δ) _ ty (tSort s) ;; @@ -496,8 +496,8 @@ Section CheckEnv. ret _ end. Next Obligation. - erewrite <- abstract_env_ext_wf_universeb_correct in Heq_anonymous; eauto. - now sq; apply/PCUICWfUniverses.wf_universe_reflect. + erewrite <- abstract_env_ext_wf_sortb_correct in Heq_anonymous; eauto. + now sq; apply/PCUICWfUniverses.wf_sort_reflect. Qed. Next Obligation. specialize_Σ H. sq. now eapply PCUICContexts.type_local_ctx_wf_local in checkΔ. @@ -561,33 +561,23 @@ Section CheckEnv. typing_result (forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ ws_cumul_ctx_pb_rel le Σ Γ Δ Δ' ∥) := check_ws_cumul_ctx X_impl X_ext le Γ Δ Δ' wfΔ wfΔ'. - Notation eqb_term_conv X conv_pb := (eqb_term_upto_univ (abstract_env_eq X) (abstract_env_conv_pb_relb X conv_pb) (abstract_env_compare_global_instance _ X)). + Notation eqb_term_conv X conv_pb := (eqb_term_upto_univ (abstract_env_compare_universe X) (abstract_env_compare_sort X) (abstract_env_compare_global_instance _ X) conv_pb). Program Definition check_eq_term pb X_ext t u (wft : forall Σ, abstract_env_ext_rel X_ext Σ -> wf_universes Σ t) (wfu : forall Σ, abstract_env_ext_rel X_ext Σ -> wf_universes Σ u) : - typing_result (forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ compare_term pb Σ Σ t u ∥) := + typing_result (forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ compare_term Σ Σ pb t u ∥) := check <- check_eq_true (eqb_term_conv X_ext pb t u) (Msg "Terms are not equal") ;; ret _. Next Obligation. simpl in *; sq. - eapply eqb_term_upto_univ_impl in check; sq; eauto. - - intros u0 u'. repeat erewrite <- abstract_env_ext_wf_universeb_correct; eauto. - move => / wf_universe_reflect ? => /wf_universe_reflect ?. - apply iff_reflect. eapply (abstract_env_compare_universe_correct _ _ Conv); eauto. - - intros u0 u'. repeat erewrite <- abstract_env_ext_wf_universeb_correct; eauto. - move => /wf_universe_reflect ? => /wf_universe_reflect ?. - apply iff_reflect. eapply (abstract_env_compare_universe_correct _ _ pb); eauto. - - intros. apply compare_global_instance_correct; eauto. - + apply wf_universe_instance_iff. rewrite <- wf_universeb_instance_forall; eauto. - + apply wf_universe_instance_iff. rewrite <- wf_universeb_instance_forall; eauto. - Unshelve. all: eauto. + eapply cmpb_term_correct in check; sq; eauto. Qed. Program Definition check_eq_decl pb X_ext d d' (wfd : forall Σ, abstract_env_ext_rel X_ext Σ -> wf_decl_universes Σ d) (wfd' : forall Σ, abstract_env_ext_rel X_ext Σ -> wf_decl_universes Σ d') : - typing_result (forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ compare_decl pb Σ Σ d d' ∥) := + typing_result (forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ compare_decl Σ Σ pb d d' ∥) := match d, d' return (forall Σ, abstract_env_ext_rel X_ext Σ -> wf_decl_universes Σ d) -> (forall Σ, abstract_env_ext_rel X_ext Σ -> wf_decl_universes Σ d') -> typing_result _ with @@ -630,7 +620,7 @@ Section CheckEnv. Program Fixpoint check_compare_context (pb : conv_pb) X_ext Γ Δ (wfΓ : forall Σ, abstract_env_ext_rel X_ext Σ -> wf_ctx_universes Σ Γ) (wfΔ : forall Σ, abstract_env_ext_rel X_ext Σ -> wf_ctx_universes Σ Δ) : - typing_result (forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ PCUICEquality.compare_context pb Σ Σ Γ Δ ∥) := + typing_result (forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ PCUICEquality.compare_context Σ Σ pb Γ Δ ∥) := match Γ, Δ return (forall Σ, abstract_env_ext_rel X_ext Σ -> wf_ctx_universes Σ Γ) -> (forall Σ, abstract_env_ext_rel X_ext Σ -> wf_ctx_universes Σ Δ) -> typing_result _ with @@ -661,7 +651,7 @@ Section CheckEnv. Program Fixpoint check_leq_terms (pb : conv_pb) X_ext l l' (wfl : forall Σ, abstract_env_ext_rel X_ext Σ -> forallb (wf_universes Σ) l) (wfl' : forall Σ, abstract_env_ext_rel X_ext Σ -> forallb (wf_universes Σ) l') : - typing_result (forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ All2 (compare_term pb Σ Σ) l l' ∥) := + typing_result (forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ All2 (compare_term Σ Σ pb) l l' ∥) := match l, l' return (forall Σ, abstract_env_ext_rel X_ext Σ -> forallb (wf_universes Σ) l) -> (forall Σ, abstract_env_ext_rel X_ext Σ -> forallb (wf_universes Σ) l') -> _ with | [], [] => fun _ _ => ret (fun Σ wfΣ => sq _) @@ -1081,7 +1071,7 @@ Section CheckEnv. * len in sp. now rewrite app_context_nil_l in sp. * set (decl := d) in *. - assert (wf_universe Σ s). + assert (wf_sort Σ s). { eapply typing_spine_isType_dom in sp. eapply isType_it_mkProd_or_LetIn_inv in sp; auto. destruct sp as (_ & ? & Hs & _). now eapply inversion_Sort in Hs as [? []]. } @@ -1447,65 +1437,6 @@ Section CheckEnv. eapply All2_fold_length in H. len in H. Qed. - Lemma eq_decl_eq_decl_upto (Σ : global_env_ext) x y : - compare_decl Cumul Σ Σ x y -> - eq_decl_upto_gen Σ (eq_universe Σ) (leq_universe Σ) x y. - Proof using Type. - intros []; constructor; intuition auto. cbn. constructor. - cbn. constructor; auto. - Qed. - - Lemma eq_decl_upto_refl (Σ : global_env_ext) x : eq_decl_upto_gen Σ (eq_universe Σ) (leq_universe Σ) x x. - Proof using Type. - destruct x as [na [b|] ty]; constructor; simpl; auto. - split; constructor; reflexivity. reflexivity. - split; constructor; reflexivity. reflexivity. - Qed. - - - Lemma eq_context_upto_cumul_context (Σ : global_env_ext) Re Rle : - RelationClasses.subrelation Re (eq_universe Σ) -> - RelationClasses.subrelation Rle (leq_universe Σ) -> - RelationClasses.subrelation Re Rle -> - CRelationClasses.subrelation (eq_context_upto Σ Re Rle) (fun Γ Γ' => cumul_context cumulSpec0 Σ Γ Γ'). - Proof using Type. - intros HRe HRle hR Γ Δ h. induction h. - - constructor. - - constructor; tas. - depelim p; constructor; auto. - eapply eq_term_upto_univ_cumulSpec. - eapply eq_term_upto_univ_impl. 5:eauto. all:tea. - now transitivity Rle. auto. - eapply eq_term_upto_univ_cumulSpec. - eapply eq_term_upto_univ_impl; eauto. - eapply eq_term_upto_univ_cumulSpec. - eapply eq_term_upto_univ_impl. 5:eauto. all:tea. - now transitivity Rle. auto. - Qed. - - Lemma eq_context_upto_univ_cumul_context {Σ : global_env_ext} Γ Δ : - eq_context_upto Σ.1 (eq_universe Σ) (leq_universe Σ) Γ Δ -> - cumul_context cumulSpec0 Σ Γ Δ. - Proof using Type. - intros h. eapply eq_context_upto_cumul_context; tea. - reflexivity. tc. tc. - Qed. - - Lemma leq_context_cumul_context (Σ : global_env_ext) Γ Δ Δ' : - PCUICEquality.compare_context Cumul Σ Σ Δ Δ' -> - cumul_ctx_rel cumulSpec0 Σ Γ Δ Δ'. - Proof using Type. - intros eqc. - apply cumul_ctx_rel_close'. - apply eq_context_upto_univ_cumul_context. - apply All2_eq_context_upto. - eapply All2_app. red in eqc. - eapply All2_fold_All2; eauto. - eapply All2_fold_impl; eauto. - intros; now eapply eq_decl_eq_decl_upto. - eapply All2_refl. intros. simpl. eapply (eq_decl_upto_refl Σ). - Qed. - Lemma wt_cstrs {n mdecl cstrs cs} X_ext : (forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ All2 (fun (cstr : constructor_body) (cs0 : constructor_univs) => @@ -1653,7 +1584,7 @@ Section CheckEnv. Lemma wf_decl_universes_subst_instance Σ udecl udecl' d u : wf_ext (Σ, udecl) -> - wf_universe_instance (Σ, udecl') u -> + wf_instance (Σ, udecl') u -> wf_decl_universes (Σ, udecl) d -> wf_decl_universes (Σ, udecl') d@[u]. Proof using Type. @@ -1668,7 +1599,7 @@ Section CheckEnv. Lemma wf_ctx_universes_subst_instance Σ udecl udecl' Γ u : wf_ext (Σ, udecl) -> - wf_universe_instance (Σ, udecl') u -> + wf_instance (Σ, udecl') u -> wf_ctx_universes (Σ, udecl) Γ -> wf_ctx_universes (Σ, udecl') Γ@[u]. Proof using Type. @@ -1780,7 +1711,7 @@ Section CheckEnv. intros v0 [= <-]. red. rewrite -Heq_anonymous. split; auto. erewrite (abstract_env_irr _ _ wfΣ0); eauto. - now apply leq_context_cumul_context. + now eapply PCUICContextConversionTyp.eq_context_cumul_Spec_rel. clear check_args. eapply All2_impl. eauto. simpl; intros. erewrite (abstract_env_irr _ _ wfΣ0); eauto. now eapply eq_term_upto_univ_cumulSpec. @@ -2021,15 +1952,15 @@ End monad_Alli_nth_forall. destruct ind_projs => //. Qed. - Definition checkb_constructors_smaller X_ext (cs : list constructor_univs) (ind_sort : Universe.t) := - List.forallb (List.forallb (fun argsort => abstract_env_leq X_ext argsort ind_sort)) cs. + Definition checkb_constructors_smaller X_ext (cs : list constructor_univs) (ind_sort : sort) := + List.forallb (List.forallb (fun argsort => abstract_env_compare_sort X_ext Cumul argsort ind_sort)) cs. Definition wf_cs_sorts X_ext cs := - forall Σ, abstract_env_ext_rel X_ext Σ -> Forall (Forall (wf_universe Σ)) cs. + forall Σ, abstract_env_ext_rel X_ext Σ -> Forall (Forall (wf_sort Σ)) cs. Lemma check_constructors_smallerP X_ext cs ind_sort : wf_cs_sorts X_ext cs -> - (forall Σ, abstract_env_ext_rel X_ext Σ -> wf_universe Σ ind_sort) -> + (forall Σ, abstract_env_ext_rel X_ext Σ -> wf_sort Σ ind_sort) -> forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ reflect (check_constructors_smaller Σ cs ind_sort) (checkb_constructors_smaller X_ext cs ind_sort) ∥. Proof using Type. unfold check_constructors_smaller, checkb_constructors_smaller. @@ -2038,7 +1969,7 @@ End monad_Alli_nth_forall. eapply forallbP_cond; eauto. clear wfcs. simpl; intros c wfc. eapply forallbP_cond; eauto. simpl. intros x wfx. specialize_Σ H. - apply iff_reflect. apply (abstract_env_compare_universe_correct _ H Cumul); eauto. + apply iff_reflect. apply (abstract_env_compare_sort_correct _ H Cumul); eauto. Qed. Program Definition do_check_ind_sorts X_ext {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext X_ext -> NormalizationIn Σ} (params : context) @@ -2046,18 +1977,18 @@ End monad_Alli_nth_forall. (kelim : allowed_eliminations) (indices : context) (cs : list constructor_univs) (wfcs : wf_cs_sorts X_ext cs) - (ind_sort : Universe.t) - (wfi : forall Σ, abstract_env_ext_rel X_ext Σ -> wf_universe Σ ind_sort): + (ind_sort : sort) + (wfi : forall Σ, abstract_env_ext_rel X_ext Σ -> wf_sort Σ ind_sort): typing_result (forall Σ, abstract_env_ext_rel X_ext Σ -> ∥ check_ind_sorts (lift_typing typing) Σ params kelim indices cs ind_sort ∥) := match ind_sort with - | Universe.lSProp => + | sSProp => check_eq_true (allowed_eliminations_subset kelim (elim_sort_sprop_ind cs)) (Msg "Incorrect allowed_elimination for inductive") ;; ret _ - | Universe.lProp => + | sProp => check_eq_true (allowed_eliminations_subset kelim (elim_sort_prop_ind cs)) (Msg "Incorrect allowed_elimination for inductive") ;; ret _ - | Universe.lType u => + | sType u => check_eq_true (checkb_constructors_smaller X_ext cs ind_sort) (Msg ("Incorrect inductive sort: The constructor arguments universes are not smaller than the declared inductive sort")) ;; match indices_matter with @@ -2072,13 +2003,13 @@ End monad_Alli_nth_forall. Next Obligation. unfold check_ind_sorts. simpl. - pose proof (check_constructors_smallerP X_ext cs (Universe.lType u) wfcs wfi). + pose proof (check_constructors_smallerP X_ext cs (sType u) wfcs wfi). rewrite -Heq_anonymous. specialize_Σ H. sq. split => //. match goal with [ H : reflect _ _ |- _ ] => destruct H => // end. Qed. Next Obligation. unfold check_ind_sorts. simpl. - pose proof (check_constructors_smallerP X_ext cs (Universe.lType u) wfcs wfi). + pose proof (check_constructors_smallerP X_ext cs (sType u) wfcs wfi). specialize_Σ H. sq. split. match goal with [ H : reflect _ _ |- _ ] => destruct H => // end. rewrite -Heq_anonymous; auto. @@ -2086,14 +2017,14 @@ End monad_Alli_nth_forall. Lemma sorts_local_ctx_wf_sorts (Σ : global_env_ext) {wfX : wf Σ} Γ Δ s : sorts_local_ctx (lift_typing typing) Σ Γ Δ s -> - Forall (wf_universe Σ) s. + Forall (wf_sort Σ) s. Proof using Type. induction Δ in s |- *; destruct s; simpl; auto. destruct a as [na [b|] ty]. - intros []. eauto. - intros []; eauto. constructor; eauto. destruct l as (_ & ? & t0 & <-). - now eapply typing_wf_universe in t0. + now eapply typing_wf_sort in t0. Qed. Obligation Tactic := Program.Tactics.program_simplify. @@ -2168,7 +2099,7 @@ End monad_Alli_nth_forall. unfold check_variance in mdeclvar. rewrite -eqvar in mdeclvar. destruct (ind_universes mdecl) as [|[inst cstrs]] => //. - now eapply leq_context_cumul_context. + now eapply PCUICContextConversionTyp.eq_context_cumul_Spec_rel. Qed. Next Obligation. diff --git a/safechecker/theories/PCUICSafeConversion.v b/safechecker/theories/PCUICSafeConversion.v index 3837a15fa..b72f18a2c 100644 --- a/safechecker/theories/PCUICSafeConversion.v +++ b/safechecker/theories/PCUICSafeConversion.v @@ -160,16 +160,13 @@ Section Conversion. eapply H0. eapply r; eauto. Qed. - Import PCUICAlpha. - - Definition eqt u v := ∥ u ≡α v ∥. + Definition eqt u v := ∥ u = v :> term ∥. Lemma eqt_eqterm {Σ} {wfΣ : abstract_env_ext_rel X Σ} {u v} : - u ≡α v -> eq_term Σ Σ u v. + u = v -> eq_term Σ Σ u v. Proof using Type. - intros eq. - eapply upto_names_eq_term_refl; tc. - exact eq. + intros <-. + reflexivity. Qed. Local Instance eqt_refl : RelationClasses.Reflexive eqt. @@ -526,11 +523,13 @@ Section Conversion. eapply R_aux_stateR. all: simpl. all: auto. Qed. - Definition abstract_env_compare_global_instance := compare_global_instance (abstract_env_lookup X) (abstract_env_eq X). + Definition abstract_env_compare_global_instance := compare_global_instance (abstract_env_lookup X) (abstract_env_compare_universe X). - Notation eqb_ctx := (eqb_ctx_gen (abstract_env_eq X) abstract_env_compare_global_instance). - Notation eqb_term := (eqb_term_upto_univ (abstract_env_eq X) (abstract_env_eq X) abstract_env_compare_global_instance). - Notation leqb_term := (eqb_term_upto_univ (abstract_env_eq X) (abstract_env_leq X) abstract_env_compare_global_instance). + Notation eqb_ctx := (eqb_ctx_upto (abstract_env_compare_universe X) (abstract_env_compare_sort X) abstract_env_compare_global_instance Conv). + Notation cmpb_term_napp := (eqb_term_upto_univ_napp (abstract_env_compare_universe X) (abstract_env_compare_sort X) abstract_env_compare_global_instance). + Notation cmpb_term pb := (eqb_term_upto_univ (abstract_env_compare_universe X) (abstract_env_compare_sort X) abstract_env_compare_global_instance pb). + Notation eqb_term := (cmpb_term Conv). + Notation leqb_term := (cmpb_term Cumul). Definition eqb_term_stack t1 π1 t2 π2 := eqb_ctx (stack_context π1) (stack_context π2) && @@ -550,10 +549,16 @@ Section Conversion. symmetry; apply reflect_iff. eapply wf_universe_reflect. Qed. - Definition wf_universe_instance_iff Σ u : - wf_universeb_instance Σ u <-> wf_universe_instance Σ u. + Definition wf_sort_iff Σ s : + wf_sortb Σ s <-> wf_sort Σ s. + Proof using Type. + symmetry; apply reflect_iff. eapply wf_sort_reflect. + Qed. + + Definition wf_instance_iff Σ u : + wf_instanceb Σ u <-> wf_instance Σ u. Proof using Type. - symmetry; apply reflect_iff. eapply wf_universe_instanceP. + symmetry; apply reflect_iff. eapply wf_instanceP. Qed. Notation conv_stack_ctx Γ π1 π2 := @@ -1341,62 +1346,47 @@ Section Conversion. eapply typing_wf_local in X0; eauto. Qed. - Definition eqb_universe_instance_gen eq u v := - forallb2 eq (map Universe.make u) (map Universe.make v). - Definition eqb_universe_instance := - eqb_universe_instance_gen (abstract_env_eq X). + compare_universe_instance (abstract_env_compare_universe X Conv). Lemma eqb_universe_instance_spec : forall u v Σ (wfΣ : abstract_env_ext_rel X Σ), - forallb (wf_universeb Σ) (map Universe.make u) -> - forallb (wf_universeb Σ) (map Universe.make v) -> + forallb (wf_universeb Σ) (map Universe.make' u) -> + forallb (wf_universeb Σ) (map Universe.make' v) -> eqb_universe_instance u v -> - R_universe_instance (eq_universe (global_ext_constraints Σ)) u v. + cmp_universe_instance (eq_universe (global_ext_constraints Σ)) u v. Proof using Type. - intros u v Σ wfΣ Hu Hv e. - unfold eqb_universe_instance in e. - eapply forallb2_Forall2 in e. - eapply forallb_Forall in Hu. - eapply forallb_Forall in Hv. - eapply Forall_Forall2_and in e; try exact Hu; clear Hu. - eapply Forall_Forall2_and' in e; try exact Hv; clear Hv. - eapply Forall2_impl. 1: eassumption. - intros. cbn in H. destruct H as [[Hx H] Hy]. - eapply (abstract_env_compare_universe_correct _ _ Conv); eauto; now eapply wf_universe_iff. - Unshelve. eauto. + intros u v Σ wfΣ Hu Hv. + eapply elimT. + eapply reflect_reflectT, reflect_cmp_universe_instance; tea. + intros. + apply iff_reflect. + eapply abstract_env_compare_universe_correct with (conv_pb := Conv); tas. + all: now eapply wf_universe_iff. Qed. Arguments LevelSet.mem : simpl never. - Definition abstract_conv_pb_relb `{cf : checker_flags} - (pb : conv_pb) := - match pb with - | Conv => abstract_env_eq X - | Cumul => abstract_env_leq X - end. - - Lemma compare_universeb_complete Σ (wfΣ : abstract_env_ext_rel X Σ) leq u u' : + Lemma compare_universeb_complete Σ (wfΣ : abstract_env_ext_rel X Σ) pb u u' : wf_universe Σ u -> wf_universe Σ u' -> - compare_universe leq (global_ext_constraints Σ) u u' -> - abstract_conv_pb_relb leq u u'. + compare_universe (global_ext_constraints Σ) pb u u' -> + abstract_env_compare_universe X pb u u'. Proof using Type. intros all1 all2 conv. destruct (heΣ _ wfΣ). - destruct leq; eapply (abstract_env_compare_universe_correct _ _ _); eauto. - Unshelve. all: eauto. + eapply abstract_env_compare_universe_correct; eauto. Qed. Lemma get_level_make l : LevelExpr.get_level (LevelExpr.make l) = l. Proof using Type. now destruct l. Qed. - Lemma compare_universeb_make_complete Σ (wfΣ : abstract_env_ext_rel X Σ) leq x y : - wf_universe_level Σ x -> - wf_universe_level Σ y -> - compare_universe leq (global_ext_constraints Σ) (Universe.make x) (Universe.make y) -> - abstract_conv_pb_relb leq (Universe.make x) (Universe.make y). + Lemma compare_universeb_make_complete Σ (wfΣ : abstract_env_ext_rel X Σ) pb x y : + wf_level Σ x -> + wf_level Σ y -> + compare_universe (global_ext_constraints Σ) pb (Universe.make' x) (Universe.make' y) -> + abstract_env_compare_universe X pb (Universe.make' x) (Universe.make' y). Proof using Type. intros wfx wfy r. eapply compare_universeb_complete; eauto. @@ -1405,64 +1395,52 @@ Qed. Qed. Lemma eqb_universe_instance_complete Σ (wfΣ : abstract_env_ext_rel X Σ) u u' : - wf_universe_instance Σ u -> - wf_universe_instance Σ u' -> - R_universe_instance (eq_universe (global_ext_constraints Σ)) u u' -> + wf_instance Σ u -> + wf_instance Σ u' -> + cmp_universe_instance (eq_universe (global_ext_constraints Σ)) u u' -> eqb_universe_instance u u'. Proof using Type. - intros memu memu' r. - induction u in u', memu, memu', r |- *. - - now destruct u'. - - destruct u'; [easy|]. - depelim memu. - depelim memu'. - depelim r. - cbn in *. - apply Bool.andb_true_iff. - split. - + eapply (compare_universeb_make_complete _ _ Conv); eauto. - + apply IHu; eauto. - Unshelve. all:eauto. - Qed. - - Lemma compare_universe_variance_complete Σ (wfΣ : abstract_env_ext_rel X Σ) leq v u u' : - wf_universe_level Σ u -> - wf_universe_level Σ u' -> - R_universe_variance (eq_universe Σ) (compare_universe leq Σ) v u u' -> - compare_universe_variance (abstract_env_eq X) (abstract_conv_pb_relb leq) v u u'. + intros memu memu'. + eapply introT. + unfold wf_instance in *. + eapply reflect_reflectT, reflect_cmp_universe_instance with (p := wf_universeb Σ); tea. + 1: intros ????; eapply iff_reflect, abstract_env_compare_universe_correct with (conv_pb := Conv); tea. + 1,2: now eapply wf_universe_iff. + all: solve_all; eapply wf_universe_iff; intros ? ->%LevelExprSet.singleton_spec; auto. + Qed. + + Lemma compare_universe_variance_complete Σ (wfΣ : abstract_env_ext_rel X Σ) pb v u u' : + wf_level Σ u -> + wf_level Σ u' -> + cmp_universe_variance (compare_universe Σ) pb v u u' -> + compare_universe_variance (abstract_env_compare_universe X) pb v u u'. Proof using Type. intros memu memu' r. destruct v; cbn in *; eauto. - eapply compare_universeb_make_complete; eauto. - - eapply (compare_universeb_make_complete _ _ Conv); eauto. - Unshelve. eauto. + - eapply compare_universeb_make_complete with (pb := Conv); eauto. Qed. - Lemma compare_universe_instance_variance_complete Σ (wfΣ : abstract_env_ext_rel X Σ) leq v u u' : - wf_universe_instance Σ u -> - wf_universe_instance Σ u' -> - R_universe_instance_variance (eq_universe Σ) (compare_universe leq Σ) v u u' -> - compare_universe_instance_variance (abstract_env_eq X) (abstract_conv_pb_relb leq) v u u'. + Lemma compare_universe_instance_variance_complete Σ (wfΣ : abstract_env_ext_rel X Σ) pb v u u' : + wf_instance Σ u -> + wf_instance Σ u' -> + cmp_universe_instance_variance (compare_universe Σ) pb v u u' -> + compare_universe_instance_variance (abstract_env_compare_universe X) pb v u u'. Proof using Type. intros memu memu' r. - induction u in v, u', memu, memu', r |- *. - - now destruct u'. - - destruct u'; [easy|]. - depelim memu. + induction r in memu, memu' |- *; cbnr. + - depelim memu. depelim memu'. - cbn in *. - destruct v; auto. apply Bool.andb_true_iff. - destruct r. split. + eapply compare_universe_variance_complete; eauto. - + now apply IHu. + + now apply IHr. Qed. Lemma consistent_instance_ext_wf Σ udecl u : consistent_instance_ext Σ udecl u -> - wf_universe_instance Σ u. + wf_instance Σ u. Proof using Type. intros cons. unfold consistent_instance_ext, consistent_instance in *. @@ -1679,7 +1657,7 @@ Qed. eapply declared_constant_inj in decl1; eauto; subst. apply consistent_instance_ext_wf in cons1. apply consistent_instance_ext_wf in cons2. - eapply eqb_universe_instance_complete in r; auto. + eapply eqb_universe_instance_complete in c1; auto. Qed. (* Why Solve All Obligations is not working here ??? *) Next Obligation. solve_unfold_constants aux eq1 eq2 Σ wfΣ. Defined. @@ -1906,7 +1884,7 @@ Qed. [× forall Σ (wfΣ : abstract_env_ext_rel X Σ), declared_inductive Σ ci mdecl idecl, #|pparams p| = ind_npars mdecl, #|pparams p'| = ind_npars mdecl, - eq_context_gen eq eq br.(bcontext) br'.(bcontext), + eq_context_upto_names br.(bcontext) br'.(bcontext), test_context_k (fun k : nat => on_free_vars (closedP k (fun _ : nat => true))) #|pparams p| br.(bcontext) & test_context_k (fun k : nat => on_free_vars (closedP k (fun _ : nat => true))) @@ -1966,7 +1944,7 @@ Qed. - intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - eapply (wf_predicate_length_pars wf_pred). - eapply (wf_predicate_length_pars wf_pred0). - - eapply alpha_eq_context_gen. etransitivity; tea. + - etransitivity; tea. now symmetry. - eapply PCUICConfluence.eq_context_upto_names_on_free_vars. 2:symmetry; exact p0. @@ -2665,7 +2643,7 @@ Qed. eapply PCUICSpine.typing_spine_strengthen in typ_args; eauto. 2:{ eapply PCUICArities.isType_Sort. 2:pcuic. eapply unlift_TypUniv in h1. - eapply wf_universe_product; now eapply typing_wf_universe. } + eapply wf_sort_product; now eapply typing_wf_sort. } clear -typ_args. depelim typ_args. - easy. @@ -2690,21 +2668,37 @@ Qed. Qed. Definition compare_global_instance_correct {Σ} - (wfΣ : abstract_env_ext_rel X Σ) R leq ref n l l' : - (forall u u', wf_universeb Σ u -> wf_universeb Σ u' -> reflect (R u u') (leq u u')) -> - wf_universe_instance Σ l -> - wf_universe_instance Σ l' -> - R_global_instance Σ (eq_universe Σ) R ref n l l' <-> - abstract_env_compare_global_instance leq ref n l l'. + (wfΣ : abstract_env_ext_rel X Σ) pb ref n l l' : + wf_instance Σ l -> + wf_instance Σ l' -> + cmp_global_instance Σ (compare_universe Σ) pb ref n l l' <-> + abstract_env_compare_global_instance pb ref n l l'. Proof. - intros hle hl hl'. apply reflect_iff. eapply reflect_R_global_instance; eauto. - all: try rewrite wf_universeb_instance_forall. - - intros ? ? Hu Hu'; apply iff_reflect; apply (abstract_env_compare_universe_correct _ wfΣ Conv). - + revert Hu. apply reflect_iff. apply wf_universe_reflect. - + revert Hu'. apply reflect_iff. apply wf_universe_reflect. + intros hl hl'. apply reflect_iff. eapply reflect_cmp_global_instance; eauto. + all: try rewrite -> wf_universeb_instance_forall. + - intros ? ? Hu Hu'; apply iff_reflect; apply (abstract_env_compare_universe_correct _ wfΣ). + all: now apply wf_universe_iff. + - intros ? ? Hu Hu'; apply iff_reflect; apply (abstract_env_compare_universe_correct _ wfΣ). + all: now apply wf_universe_iff. - intros; now eapply abstract_env_lookup_correct'. - - revert hl. apply reflect_iff, wf_universe_instanceP. - - revert hl'. apply reflect_iff, wf_universe_instanceP. + - revert hl. apply reflect_iff, wf_instanceP. + - revert hl'. apply reflect_iff, wf_instanceP. + Qed. + + Lemma cmpb_term_correct Σ (wfΣ : abstract_env_ext_rel X Σ) pb napp t u : + wf_universes Σ t -> + wf_universes Σ u -> + cmpb_term_napp pb napp t u <~> + compare_term_napp Σ Σ pb napp t u. + Proof. + intros ht hu. + eassert _ as H. + 2: split; [eapply elimT|eapply introT]; apply H. + eapply reflect_eq_term_upto_univ; tea. + 1,2: intros ????; apply iff_reflect, abstract_env_compare_universe_correct; tea; now apply wf_universe_iff. + 1,2: intros ????; apply iff_reflect, abstract_env_compare_sort_correct; tea; now apply wf_sort_iff. + 1,2: intros ??????; apply iff_reflect, compare_global_instance_correct; tea. + all: rewrite -> wf_universeb_instance_forall in *; now eapply wf_instance_iff. Qed. Lemma reduced_case_discriminee_whne Σ (wfΣ : abstract_env_ext_rel X Σ) Γ π ci p c brs h : @@ -2717,13 +2711,7 @@ Qed. intros eq ir. pose proof (heΣ _ wfΣ) as [[]]. pose proof (hΣ _ wfΣ). destruct ir as (_&[wh]); eauto. - eapply eqb_term_upto_univ_impl with (p := wf_universeb Σ) (q := closedu) in eq; tea. - 2-3: intros; apply iff_reflect; eapply (abstract_env_compare_universe_correct _ wfΣ Conv) ; now eapply wf_universe_iff. - 2:{ intros. rewrite !wf_universeb_instance_forall in H0, H1. - apply wf_universe_instance_iff in H0. - apply wf_universe_instance_iff in H1. - apply compare_global_instance_correct; eauto. - } + eapply cmpb_term_correct in eq; tea. - epose proof (reduce_term_complete _ _ _ _ _ _) as [wh']. eapply whnf_eq_term in eq; [|exact wh']. rewrite zipp_as_mkApps in wh. @@ -2814,12 +2802,7 @@ Qed. intros eq%eq_sym ir. destruct ir as (_&[wh]); eauto. pose proof (hΣ _ wfΣ). - eapply eqb_term_upto_univ_impl in eq; tea. - 2-3: intros; apply iff_reflect; eapply (abstract_env_compare_universe_correct _ wfΣ Conv) ; now eapply wf_universe_iff. - 2:{ intros. rewrite !wf_universeb_instance_forall in H0, H1. - apply wf_universe_instance_iff in H0. - apply wf_universe_instance_iff in H1. - eapply (compare_global_instance_correct wfΣ); eauto. } + eapply cmpb_term_correct in eq; tea. - epose proof (reduce_term_complete _ _ _ _ _ _) as [wh']. eapply whnf_eq_term in eq; [|exact wh']. rewrite zipp_as_mkApps in wh. @@ -3057,11 +3040,11 @@ Qed. (hp : ∥ ws_cumul_pb_terms Σ (Γ,,, stack_context π) (pparams p) (pparams p') ∥) : ∥ ∑ mdecl idecl, [× declared_inductive Σ ci mdecl idecl, - forallb (wf_universeb Σ) (map Universe.make (puinst p)), - forallb (wf_universeb Σ) (map Universe.make (puinst p')), + forallb (wf_universeb Σ) (map Universe.make' (puinst p)), + forallb (wf_universeb Σ) (map Universe.make' (puinst p')), #|pparams p| = ind_npars mdecl, #|pparams p'| = ind_npars mdecl, - eq_context_gen eq eq p.(pcontext) p'.(pcontext), + eq_context_upto_names p.(pcontext) p'.(pcontext), test_context_k (fun k : nat => on_free_vars (closedP k (fun _ : nat => true))) #|pparams p| p.(pcontext) & test_context_k (fun k : nat => on_free_vars (closedP k (fun _ : nat => true))) @@ -3099,13 +3082,13 @@ Qed. exists mdecl, idecl. destruct hcase. destruct hcase'. split; tea. - - eapply Forall_forallb; try eapply consistent_instance_wf_universe; eauto. + - eapply Forall_forallb; try eapply consistent_instance_wf_sort; eauto. intros; apply wf_universe_iff; eauto. - - eapply Forall_forallb; try eapply consistent_instance_wf_universe; eauto. + - eapply Forall_forallb; try eapply consistent_instance_wf_sort; eauto. intros; apply wf_universe_iff; eauto. - eapply (wf_predicate_length_pars wf_pred). - eapply (wf_predicate_length_pars wf_pred0). - - eapply alpha_eq_context_gen. etransitivity; tea. + - etransitivity; tea. now symmetry. - now rewrite <- test_context_k_closed_on_free_vars_ctx. - rewrite test_context_k_closed_on_free_vars_ctx. @@ -3166,7 +3149,7 @@ Qed. | Error ce not_conv_params => no ce; | Success conv_params - with inspect (eqb_universe_instance_gen (abstract_env_eq X) p1.(puinst) p2.(puinst)) := { + with inspect (eqb_universe_instance p1.(puinst) p2.(puinst)) := { | exist false not_eq_insts => no (CasePredUnequalUniverseInstances (Γ,,, stack_context π1) ci1 p1 c1 brs1 @@ -3256,8 +3239,7 @@ Qed. apply consistent_instance_ext_wf in cons. apply consistent_instance_ext_wf in cons0. specialize_Σ wfΣ; destruct H as [[]]. - apply eqb_universe_instance_complete in r; eauto. - unfold eqb_universe_instance in r. + apply eqb_universe_instance_complete in c; eauto. congruence. Qed. Next Obligation. @@ -3406,7 +3388,7 @@ Equations (noeqns) isconv_array_values_aux | prog_view_App _ _ _ _ := False_rect _ _; | prog_view_Const c u c' u' with eq_dec c c' := { - | left eq1 with inspect (eqb_universe_instance_gen (abstract_env_eq X) u u') := { + | left eq1 with inspect (eqb_universe_instance u u') := { | @exist true eq2 with isconv_args_raw leq (tConst c u) π1 (tConst c' u') π2 aux := { | Success h := yes ; (* Unfold both constants at once *) @@ -3605,7 +3587,7 @@ Equations (noeqns) isconv_array_values_aux { | @exist true eqf := yes | @exist false neqf := no (DistinctPrimValues (Γ ,,, stack_context π1) p (Γ ,,, stack_context π2) p') } | (primArray; primArrayModel a) | (primArray; primArrayModel a') - with inspect (abstract_env_eq X (Universe.make (array_level a)) (Universe.make (array_level a'))) := + with inspect (abstract_env_compare_universe X Conv (Universe.make' (array_level a)) (Universe.make' (array_level a'))) := { | @exist false neql := no (ArrayNotConvertibleLevels (Γ ,,, stack_context π1) a (Γ ,,, stack_context π2) a') | @exist true eql with isconv_red_raw Conv (array_type a) (PrimArray_ty a.(array_level) a.(array_value) a.(array_default) :: π1) (array_type a') (PrimArray_ty a'.(array_level) a'.(array_value) a'.(array_default) :: π2) aux := { @@ -3646,10 +3628,10 @@ Equations (noeqns) isconv_array_values_aux - destruct h. eapply welltyped_zipc_zipp in h1; auto. fvs. - constructor. eapply eqb_universe_instance_spec; eauto. + eapply welltyped_zipc_tConst_inv in h1 as (?&?&?); eauto; - eapply Forall_forallb; try eapply consistent_instance_wf_universe; eauto. + eapply Forall_forallb; try eapply consistent_instance_wf_sort; eauto. intros; apply wf_universe_iff; eauto. + eapply welltyped_zipc_tConst_inv in h2 as (?&?&?); eauto; - eapply Forall_forallb; try eapply consistent_instance_wf_universe; eauto. + eapply Forall_forallb; try eapply consistent_instance_wf_sort; eauto. intros; apply wf_universe_iff; eauto. Qed. Next Obligation. @@ -3732,7 +3714,6 @@ Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; right; split; [easy|]. - unfold eqb_universe_instance. now rewrite <- uneq_u. Qed. @@ -3997,20 +3978,12 @@ Qed. destruct (reduce_stack_Req f _ X _ wfΣ Γ c' [] h) as [e' | hr] end. 1:{ - exfalso. Transparent reduce_term. - unfold reduce_term in eq4. - rewrite e' in eq4. cbn in eq4. - epose proof (eqb_term_upto_univ_refl Σ _ _ _ _ 0 c' _ _). - erewrite H in eq4. - - discriminate. - - intros. apply iff_reflect. eapply abstract_env_compare_universe_correct with (conv_pb := Conv) ; eauto. - - intros. rewrite !wf_universeb_instance_forall in H0, H1. - apply wf_universe_instance_iff in H0. - apply wf_universe_instance_iff in H1. - eapply compare_global_instance_correct; eauto. - clear -X0. intros ? ? Hu Hu'; apply X0. - + revert Hu. apply reflect_iff. apply wf_universe_reflect. - + revert Hu'. apply reflect_iff. apply wf_universe_reflect. + enough false by auto. rewrite eq4. + Transparent reduce_term. + unfold reduce_term. + rewrite e'. cbn. + assert (wf_universes Σ c'). + 2: eapply cmpb_term_correct; tea; cbnr. - pose proof h2 as Hc. specialize_Σ wfΣ. pose proof (hΣ _ wfΣ); sq. apply welltyped_zipc_inv in Hc; eauto. apply welltyped_wf in Hc; eauto. @@ -4018,22 +3991,13 @@ Qed. } dependent destruction hr. 2:{ - exfalso. + enough false by auto. rewrite eq4. destruct y'. simpl in H0. inversion H0. subst. - unfold reduce_term in eq4. - rewrite <- H2 in eq4. - cbn in eq4. - epose proof (eqb_term_upto_univ_refl Σ _ _ _ _ 0 c' _ _). - erewrite H1 in eq4. - - discriminate. - - intros. apply iff_reflect. eapply abstract_env_compare_universe_correct with (conv_pb := Conv); eauto. - - intros. rewrite !wf_universeb_instance_forall in H3, H4. - apply wf_universe_instance_iff in H3. - apply wf_universe_instance_iff in H4. - eapply compare_global_instance_correct; eauto. - clear -X0. intros ? ? Hu Hu'; apply X0. - + revert Hu. apply reflect_iff. apply wf_universe_reflect. - + revert Hu'. apply reflect_iff. apply wf_universe_reflect. + unfold reduce_term. + rewrite <- H2. + cbn. + assert (wf_universes Σ c'). + 2: eapply cmpb_term_correct; tea; cbnr. - pose proof h2 as Hc. specialize_Σ wfΣ. pose proof (hΣ _ wfΣ); sq. apply welltyped_zipc_inv in Hc; eauto. apply welltyped_wf in Hc; eauto. @@ -4043,7 +4007,7 @@ Qed. all: try reflexivity. simpl. intros. eapply cored_zipc. eapply cored_case. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. all: eauto. all: intros; eapply abstract_env_compare_universe_correct with (conv_pb := Conv); eauto; reflexivity. + Unshelve. all: eauto. all: intros; eapply abstract_env_compare_sort_correct with (conv_pb := Conv); eauto; reflexivity. Qed. Next Obligation. @@ -4101,20 +4065,12 @@ Qed. destruct (reduce_stack_Req f _ X _ wfΣ Γ c [] h) as [e' | hr] end. 1:{ - exfalso. - unfold reduce_term in eq3. - rewrite e' in eq3. cbn in eq3. - epose proof (eqb_term_upto_univ_refl Σ _ _ _ _ 0 c _ _). - erewrite H in eq3. - - discriminate. - - intros. apply iff_reflect. eapply abstract_env_compare_universe_correct with (conv_pb := Conv); eauto. - - intros. rewrite !wf_universeb_instance_forall in H0, H1. - apply wf_universe_instance_iff in H0. - apply wf_universe_instance_iff in H1. - eapply compare_global_instance_correct; eauto. - clear -X0. intros ? ? Hu Hu'; apply X0. - + revert Hu. apply reflect_iff. apply wf_universe_reflect. - + revert Hu'. apply reflect_iff. apply wf_universe_reflect. + enough false by auto. rewrite eq3. + unfold reduce_term. + rewrite e'. + cbn. + assert (wf_universes Σ c). + 2: eapply cmpb_term_correct; tea; cbnr. - pose proof h1 as Hc. specialize_Σ wfΣ. pose proof (hΣ _ wfΣ); sq. apply welltyped_zipc_inv in Hc; eauto. apply welltyped_wf in Hc; eauto. @@ -4122,22 +4078,13 @@ Qed. } dependent destruction hr. 2:{ - exfalso. + enough false by auto. rewrite eq3. destruct y'. simpl in H0. inversion H0. subst. - unfold reduce_term in eq3. - rewrite <- H2 in eq3. - cbn in eq3. - epose proof (eqb_term_upto_univ_refl Σ _ _ _ _ 0 c _ _). - erewrite H1 in eq3. - - discriminate. - - intros. apply iff_reflect. eapply abstract_env_compare_universe_correct with (conv_pb := Conv); eauto. - - intros. rewrite !wf_universeb_instance_forall in H3, H4. - apply wf_universe_instance_iff in H3. - apply wf_universe_instance_iff in H4. - eapply compare_global_instance_correct; eauto. - clear -X0. intros ? ? Hu Hu'; apply X0. - + revert Hu. apply reflect_iff. apply wf_universe_reflect. - + revert Hu'. apply reflect_iff. apply wf_universe_reflect. + unfold reduce_term. + rewrite <- H2. + cbn. + assert (wf_universes Σ c). + 2: eapply cmpb_term_correct; tea; cbnr. - pose proof h1 as Hc. specialize_Σ wfΣ. pose proof (hΣ _ wfΣ); sq. apply welltyped_zipc_inv in Hc; eauto. apply welltyped_wf in Hc; eauto. @@ -4146,7 +4093,7 @@ Qed. unshelve eapply R_cored. simpl. intros; eapply cored_zipc. eapply cored_case. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto. - Unshelve. all: eauto. all: intros; eapply abstract_env_compare_universe_correct with (conv_pb := Conv); eauto; reflexivity. + Unshelve. all: eauto. all: intros; eapply abstract_env_compare_sort_correct with (conv_pb := Conv); eauto; reflexivity. Qed. Next Obligation. rename H into wfΣ; specialize_Σ wfΣ. @@ -4252,42 +4199,25 @@ Qed. destruct (reduce_stack_Req f _ X _ wfΣ Γ c' [] h) as [e' | hr] end. 1:{ - exfalso. - unfold reduce_term in eq4. - rewrite e' in eq4. cbn in eq4. - epose proof (eqb_term_upto_univ_refl Σ _ _ _ _ 0 c' _ _). - erewrite H in eq4. - - discriminate. - - intros. apply iff_reflect. eapply abstract_env_compare_universe_correct with (conv_pb := Conv); eauto. - - intros. rewrite !wf_universeb_instance_forall in H0, H1. - apply wf_universe_instance_iff in H0. - apply wf_universe_instance_iff in H1. - eapply compare_global_instance_correct; eauto. - clear -X0. intros ? ? Hu Hu'; apply X0. - + revert Hu. apply reflect_iff. apply wf_universe_reflect. - + revert Hu'. apply reflect_iff. apply wf_universe_reflect. + enough false by auto. rewrite eq4. + unfold reduce_term. + rewrite e'. + cbn. + assert (wf_universes Σ c'). + 2: eapply cmpb_term_correct; tea; cbnr. - pose proof h2 as Hc. specialize_Σ wfΣ. pose proof (hΣ _ wfΣ); sq. apply welltyped_zipc_inv in Hc; eauto. apply welltyped_wf in Hc; eauto. } dependent destruction hr. 2:{ - exfalso. + enough false by auto. rewrite eq4. destruct y'. simpl in H0. inversion H0. subst. - unfold reduce_term in eq4. - rewrite <- H2 in eq4. - cbn in eq4. - epose proof (eqb_term_upto_univ_refl Σ _ _ _ _ 0 c' _ _). - erewrite H1 in eq4. - - discriminate. - - intros. apply iff_reflect. eapply abstract_env_compare_universe_correct with (conv_pb := Conv); eauto. - - intros. rewrite !wf_universeb_instance_forall in H3, H4. - apply wf_universe_instance_iff in H3. - apply wf_universe_instance_iff in H4. - eapply compare_global_instance_correct; eauto. - clear -X0. intros ? ? Hu Hu'; apply X0. - + revert Hu. apply reflect_iff. apply wf_universe_reflect. - + revert Hu'. apply reflect_iff. apply wf_universe_reflect. + unfold reduce_term. + rewrite <- H2. + cbn. + assert (wf_universes Σ c'). + 2: eapply cmpb_term_correct; tea; cbnr. - pose proof h2 as Hc. specialize_Σ wfΣ. pose proof (hΣ _ wfΣ); sq. apply welltyped_zipc_inv in Hc; eauto. apply welltyped_wf in Hc; eauto. @@ -4296,7 +4226,7 @@ Qed. all: try reflexivity. simpl. intros; eapply cored_zipc. eapply cored_proj. erewrite (abstract_env_ext_irr _ _ wfΣ); eassumption. - Unshelve. all: eauto. all: intros; eapply abstract_env_compare_universe_correct with (conv_pb := Conv); eauto; reflexivity. + Unshelve. all: eauto. all: intros; eapply abstract_env_compare_sort_correct with (conv_pb := Conv); eauto; reflexivity. Qed. Next Obligation. rename H into wfΣ. specialize_Σ wfΣ. @@ -4357,42 +4287,25 @@ Qed. destruct (reduce_stack_Req f _ X _ wfΣ Γ c [] h) as [e' | hr] end. 1:{ - exfalso. - unfold reduce_term in eq3. - rewrite e' in eq3. cbn in eq3. - epose proof (eqb_term_upto_univ_refl Σ _ _ _ _ 0 c _ _). - erewrite H in eq3. - - discriminate. - - intros. apply iff_reflect. eapply abstract_env_compare_universe_correct with (conv_pb := Conv); eauto. - - intros. rewrite !wf_universeb_instance_forall in H0, H1. - apply wf_universe_instance_iff in H0. - apply wf_universe_instance_iff in H1. - eapply compare_global_instance_correct; eauto. - clear -X0. intros ? ? Hu Hu'; apply X0. - + revert Hu. apply reflect_iff. apply wf_universe_reflect. - + revert Hu'. apply reflect_iff. apply wf_universe_reflect. + enough false by auto. rewrite eq3. + unfold reduce_term. + rewrite e'. + cbn. + assert (wf_universes Σ c). + 2: eapply cmpb_term_correct; tea; cbnr. - pose proof h1 as Hc. specialize_Σ wfΣ. pose proof (hΣ _ wfΣ); sq. apply welltyped_zipc_inv in Hc; eauto. apply welltyped_wf in Hc; eauto. } dependent destruction hr. 2:{ - exfalso. + enough false by auto. rewrite eq3. destruct y'. simpl in H0. inversion H0. subst. - unfold reduce_term in eq3. - rewrite <- H2 in eq3. - cbn in eq3. - epose proof (eqb_term_upto_univ_refl Σ _ _ _ _ 0 c _ _). - erewrite H1 in eq3. - - discriminate. - - intros. apply iff_reflect. eapply abstract_env_compare_universe_correct with (conv_pb := Conv); eauto. - - intros. rewrite !wf_universeb_instance_forall in H3, H4. - apply wf_universe_instance_iff in H3. - apply wf_universe_instance_iff in H4. - eapply compare_global_instance_correct; eauto. - clear -X0. intros ? ? Hu Hu'; apply X0. - + revert Hu. apply reflect_iff. apply wf_universe_reflect. - + revert Hu'. apply reflect_iff. apply wf_universe_reflect. + unfold reduce_term. + rewrite <- H2. + cbn. + assert (wf_universes Σ c). + 2: eapply cmpb_term_correct; tea; cbnr. - pose proof h1 as Hc. specialize_Σ wfΣ. pose proof (hΣ _ wfΣ); sq. apply welltyped_zipc_inv in Hc; eauto. apply welltyped_wf in Hc; eauto. @@ -4400,7 +4313,7 @@ Qed. unshelve eapply R_cored. simpl. intros; eapply cored_zipc. eapply cored_proj. erewrite (abstract_env_ext_irr _ _ wfΣ); eassumption. - Unshelve. all: eauto. all: intros; eapply abstract_env_compare_universe_correct with (conv_pb := Conv); eauto; reflexivity. + Unshelve. all: eauto. all: intros; eapply abstract_env_compare_sort_correct with (conv_pb := Conv); eauto; reflexivity. Qed. Next Obligation. rename H into wfΣ. specialize_Σ wfΣ. @@ -4903,8 +4816,8 @@ Qed. specialize (convdiscrdef _ H) as [convdef]. specialize (convdiscrval _ H) as [convval]. cbn in convty, convdef. - symmetry in eql. unfold abstract_env_eq in eql. - eapply abstract_env_compare_universe_correct in eql; eauto. + symmetry in eql. + eapply abstract_env_compare_universe_correct with (conv_pb := Conv) in eql; eauto. 2:{ destruct h1 as [? ty]; eapply typing_wf_universes in ty; eauto. move/andP: ty => []. rewrite H0 /=. cbn -[wf_universeb]. rtoProp; intuition auto. @@ -4989,8 +4902,8 @@ Qed. specialize (H _ wfΣ). symmetry in neql. destruct H as [H]; eapply invert_cumul_Prim in H; depelim H. + enough false by auto. rewrite <- neql. unshelve eapply (abstract_env_compare_universe_correct _ _ Conv) in e0; eauto. - - unfold abstract_env_eq in neql. now erewrite neql in e0. - rewrite H0 in h1. destruct h1 as [? wt]. eapply typing_wf_universes in wt; eauto. move/andP: wt => []. cbn -[wf_universeb wf_universe]. rtoProp; intuition auto. @@ -5725,8 +5638,7 @@ Qed. isconv_prog leq t1 π1 rt2' (θ2' ++ θ2) aux } } ; - | exist None nored2 with inspect (eqb_termp_napp_gen leq (abstract_env_eq X) (abstract_env_leq X) - abstract_env_compare_global_instance #|(decompose_stack π1).1| t1 t2) := { + | exist None nored2 with inspect (cmpb_term_napp leq #|(decompose_stack π1).1| t1 t2) := { | exist true eq1 := isconv_args leq t1 π1 t2 π2 aux; | exist false noteq := no ( @@ -5983,22 +5895,14 @@ Qed. rewrite Nat.add_0_r. apply All2_length in a. rewrite a in eq1. - eapply eqb_term_upto_univ_impl with (q := closedu); eauto. - + intros. eapply iff_reflect. - eapply (abstract_env_compare_universe_correct _ H Conv) ; now eapply wf_universe_iff. - + intros. eapply iff_reflect. destruct leq. - * eapply (abstract_env_compare_universe_correct _ H Conv) ; now eapply wf_universe_iff. - * eapply (abstract_env_compare_universe_correct _ H Cumul) ; now eapply wf_universe_iff. - + intros. rewrite !wf_universeb_instance_forall in H0, H1. - apply wf_universe_instance_iff in H0. - apply wf_universe_instance_iff in H1. - eapply compare_global_instance_correct; eauto. + eapply cmpb_term_correct; tea. + pose proof h1 as Hc. specialize_Σ H. pose proof (hΣ _ H); sq. apply welltyped_zipc_inv in Hc; eauto. apply welltyped_wf in Hc; eauto. + pose proof h2 as Hc. specialize_Σ H. pose proof (hΣ _ H); sq. apply welltyped_zipc_inv in Hc; eauto. apply welltyped_wf in Hc; eauto. + + now symmetry. Qed. Next Obligation. apply h; clear h. intros Σ wfΣ. @@ -6070,9 +5974,6 @@ Qed. apply consistent_instance_ext_wf in c0. apply consistent_instance_ext_wf in c. eapply compare_global_instance_correct in H3; eauto. - 2: { intros; apply iff_reflect. eapply (abstract_env_compare_universe_correct _ _ leq); apply wf_universe_iff; eauto. - all: apply wf_universe_iff; eauto. - } rewrite eqb_refl in noteq. apply All2_length in rargs1. rewrite <- rargs1 in H3. @@ -6098,14 +5999,6 @@ Qed. rewrite <- rargs1 in H4. apply ssrbool.not_false_is_true. rewrite noteq. cbn. eapply compare_global_instance_correct; eauto. - intros ? ? Hu Hu'. apply iff_reflect. - destruct leq; - [ apply abstract_env_compare_universe_correct with (conv_pb := Conv); eauto | - apply abstract_env_compare_universe_correct with (conv_pb := Cumul); eauto]. - + revert Hu. apply reflect_iff. apply wf_universe_reflect. - + revert Hu'. apply reflect_iff. apply wf_universe_reflect. - + revert Hu. apply reflect_iff. apply wf_universe_reflect. - + revert Hu'. apply reflect_iff. apply wf_universe_reflect. } all: apply conv_cum_alt in conv_hds as [(?&?&[r1 r2 ?])]; auto. all: eapply whnf_red_inv in r1; auto. @@ -6130,7 +6023,7 @@ Qed. simpl in h2. apply inversion_Sort in h2 as (_&h2&_); auto. apply inversion_Sort in h1 as (_&h1&_); auto. - eapply compare_universeb_complete in H0; eauto. + eapply abstract_env_compare_sort_correct in H0; eauto. destruct leq; cbn in *; easy. Unshelve. all:eauto. Qed. @@ -6166,10 +6059,8 @@ Qed. - cbn in *. specialize_Σ wfΣ. eapply cored'_postpone in H as [u' [cor eq]]. eapply cored_welltyped in cor; tea. - destruct eq as [eq]. - eapply welltyped_alpha; tea. symmetry. exact eq. - - simpl in *. destruct e. eapply welltyped_alpha; tea. - now symmetry. + now destruct eq as [<-]. + - simpl in *. destruct e. now rewrite e. Qed. Equations(noeqns) isconv_full (s : state) (Γ : context) diff --git a/safechecker/theories/PCUICSafeReduce.v b/safechecker/theories/PCUICSafeReduce.v index 05be3bf4a..a7ebc08cc 100644 --- a/safechecker/theories/PCUICSafeReduce.v +++ b/safechecker/theories/PCUICSafeReduce.v @@ -2025,7 +2025,7 @@ Section ReduceFns. (* Definition of assumption-only arities (without lets) *) Definition arity_ass := aname * term. - Fixpoint mkAssumArity (l : list arity_ass) (s : Universe.t) : term := + Fixpoint mkAssumArity (l : list arity_ass) (s : sort) : term := match l with | [] => tSort s | (na, A) :: l => tProd na A (mkAssumArity l s) @@ -2046,7 +2046,7 @@ Section ReduceFns. constructor; auto. Qed. - Lemma mkAssumArity_it_mkProd_or_LetIn (l : list arity_ass) (s : Universe.t) : + Lemma mkAssumArity_it_mkProd_or_LetIn (l : list arity_ass) (s : sort) : mkAssumArity l s = it_mkProd_or_LetIn (arity_ass_context l) (tSort s). Proof using Type. unfold arity_ass_context. @@ -2066,7 +2066,7 @@ Section ReduceFns. Record conv_arity {Γ T} : Type := build_conv_arity { conv_ar_context : list arity_ass; - conv_ar_univ : Universe.t; + conv_ar_univ : sort; conv_ar_red : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ Σ ;;; Γ ⊢ T ⇝ mkAssumArity conv_ar_context conv_ar_univ ∥ }. diff --git a/safechecker/theories/PCUICSafeRetyping.v b/safechecker/theories/PCUICSafeRetyping.v index 86d2b5c16..467e12876 100644 --- a/safechecker/theories/PCUICSafeRetyping.v +++ b/safechecker/theories/PCUICSafeRetyping.v @@ -99,7 +99,7 @@ Lemma inductive_cumulative_indices_smash {cf : checker_flags} {Σ : global_env_e on_udecl_prop Σ (ind_universes mdecl) -> consistent_instance_ext Σ (ind_universes mdecl) u -> consistent_instance_ext Σ (ind_universes mdecl) u' -> - PCUICEquality.R_global_instance Σ (eq_universe Σ) (leq_universe Σ) (IndRef ind) napp u u' -> + PCUICEquality.cmp_ind_universes Σ ind napp u u' -> forall Γ pars pars', spine_subst Σ Γ pars (List.rev pars) (smash_context [] (subst_instance u (ind_params mdecl))) -> spine_subst Σ Γ pars' (List.rev pars') (smash_context [] (subst_instance u' (ind_params mdecl))) -> @@ -181,10 +181,10 @@ Qed. ∑ u, forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ Σ ;;; Γ |- T ▹□ u ∥. #[local] Definition principal_type_type {Γ t} (wt : principal_type Γ t) : term := projT1 wt. - #[local] Definition principal_sort_sort {Γ T} (ps : principal_sort Γ T) : Universe.t + #[local] Definition principal_sort_sort {Γ T} (ps : principal_sort Γ T) : sort := projT1 ps. #[local] Coercion principal_type_type : principal_type >-> term. - #[local] Coercion principal_sort_sort : principal_sort >-> Universe.t. + #[local] Coercion principal_sort_sort : principal_sort >-> sort. Program Definition infer_as_sort {Γ T} (wfΓ : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ wf_local Σ Γ ∥) @@ -303,7 +303,7 @@ Qed. infer Γ wfΓ (tVar n) wt := !; infer Γ wfΓ (tEvar ev args) wt := !; - infer Γ wfΓ (tSort s) wt := ret (tSort (Universe.super s)); + infer Γ wfΓ (tSort s) wt := ret (tSort (Sort.super s)); infer Γ wfΓ (tProd n ty b) wt := let wfΓ' : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ wf_local Σ (Γ ,, vass n ty) ∥ := _ in @@ -311,7 +311,7 @@ Qed. let s1 := infer_as_sort wfΓ (fun a b => (welltyped_subterm (wt a b)).1) ty1 in let ty2 := infer (Γ ,, vass n ty) wfΓ' b (fun a b => (welltyped_subterm (wt a b)).2) in let s2 := infer_as_sort wfΓ' (fun a b => (welltyped_subterm (wt a b)).2) ty2 in - ret (tSort (Universe.sort_of_product s1 s2)); + ret (tSort (Sort.sort_of_product s1 s2)); infer Γ wfΓ (tLambda n t b) wt := let t2 := infer (Γ ,, vass n t) _ b (fun a b => (welltyped_subterm (wt a b)).2) in @@ -828,7 +828,7 @@ Qed. Opaque type_of_typing. Equations? sort_of_type (Γ : context) (t : PCUICAst.term) (wt : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥ isType Σ Γ t ∥) : - (∑ u : Universe.t, forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> + (∑ u : sort, forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥ Σ ;;; Γ |- t : tSort u ∥) := sort_of_type Γ t wt with (@type_of_typing Γ t _) := { | T with inspect (reduce_to_sort (X:=X) Γ T.π1 _) := diff --git a/safechecker/theories/PCUICTypeChecker.v b/safechecker/theories/PCUICTypeChecker.v index 924104c66..31594a770 100644 --- a/safechecker/theories/PCUICTypeChecker.v +++ b/safechecker/theories/PCUICTypeChecker.v @@ -215,13 +215,13 @@ Qed. (* Lemma compare_global_instance_sound {cf Σ} (wfΣ : wf_ext Σ) gr napp (Hφ : on_udecl Σ.1 Σ.2) (G : universes_graph) (HG : is_graph_of_uctx G (global_ext_uctx Σ)) : - subrelation (compare_global_instance Σ (check_eqb_universe G) (check_leqb_universe G) gr napp) - (R_global_instance Σ (eq_universe Σ) (leq_universe Σ) gr napp). -Proof. eapply reflect_R_global_instance. compare_global_instance_impl; tc; intros x y. - - eapply (check_eqb_universe_spec' _ (global_ext_uctx Σ)) => //. + subrelation (compare_global_instance Σ (check_eqb_sort G) (check_leqb_sort G) gr napp) + (cmp_global_instance Σ (eq_sort Σ) (leq_sort Σ) gr napp). +Proof. eapply reflect_cmp_global_instance. compare_global_instance_impl; tc; intros x y. + - eapply (check_eqb_sort_spec' _ (global_ext_uctx Σ)) => //. now eapply wf_ext_global_uctx_invariants. cbn. eapply wfΣ. - - eapply (check_leqb_universe_spec' _ (global_ext_uctx Σ)) => //. + - eapply (check_leqb_sort_spec' _ (global_ext_uctx Σ)) => //. now eapply wf_ext_global_uctx_invariants. cbn. eapply wfΣ. Qed. *) @@ -291,12 +291,12 @@ Section Typecheck. Notation hnf := (hnf (X := X)). - Definition conv_pb_relb_gen_proper pb equ equ' eqlu eqlu' : + Definition conv_pb_relb_gen_proper {T} pb equ equ' eqlu eqlu' : (forall u u', equ u u' = equ' u u') -> (forall u u', eqlu u u' = eqlu' u u') -> - forall u u', - conv_pb_relb_gen pb equ eqlu u u' = - conv_pb_relb_gen pb equ' eqlu' u u'. + forall (u u' : T), + conv_pb_relb_gen equ eqlu pb u u' = + conv_pb_relb_gen equ' eqlu' pb u u'. Proof using Type. now destruct pb. Qed. @@ -315,7 +315,7 @@ Section Typecheck. (hu : forall Σ (wfΣ : abstract_env_ext_rel X Σ), welltyped Σ Γ u) : typing_result_comp (forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ Σ ;;; Γ ⊢ t ≤[le] u ∥) := convert le Γ t u ht hu - with inspect (eqb_termp_napp_gen le (abstract_env_eq X) (abstract_env_leq X) (abstract_env_compare_global_instance _ X) 0 t u) := { + with inspect (eqb_term_upto_univ (abstract_env_compare_universe X) (abstract_env_compare_sort X) (abstract_env_compare_global_instance _ X) le t u) := { | @exist true He := ret _ ; | @exist false He with inspect (isconv_term _ X Γ le t ht u hu) := { @@ -326,19 +326,9 @@ Section Typecheck. raise (NotCumulSmaller false X Γ t u t' u' e) }}. Next Obligation. - unfold eqb_termp_napp_gen in He. pose (heΣ _ wfΣ) as heΣ; sq. + unfold eqb_term_upto_univ_napp in He. pose (heΣ _ wfΣ) as heΣ; sq. constructor; fvs. specialize_Σ wfΣ. - eapply eqb_term_upto_univ_impl; eauto. - - intros. eapply iff_reflect. - eapply (abstract_env_compare_universe_correct _ wfΣ Conv); - try eassumption; apply wf_universe_iff; eauto. - - intros. eapply iff_reflect. destruct le; - eapply (abstract_env_compare_universe_correct _ wfΣ _); - try eassumption; apply wf_universe_iff; eauto. - - intros. rewrite wf_universeb_instance_forall in H. rewrite wf_universeb_instance_forall in H0. - apply wf_universe_instance_iff in H. - apply wf_universe_instance_iff in H0. - eapply (compare_global_instance_correct _ X wfΣ); eauto. + eapply cmpb_term_correct; eauto. - destruct ht as [? ht]. eapply typing_wf_universes in ht; eauto. pose proof ht as [? ?]%andb_and; eassumption. - destruct hu as [? hu]. eapply typing_wf_universes in hu; eauto. @@ -368,7 +358,7 @@ Section Typecheck. typing_result_comp ({ A : term & forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ Σ ;;; Γ |- t ▹ A ∥ })). Equations infer_type Γ (HΓ : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ wf_local Σ Γ ∥) t - : typing_result_comp ({u : Universe.t & forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ Σ ;;; Γ |- t ▹□ u ∥}) := + : typing_result_comp ({u : sort & forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ Σ ;;; Γ |- t ▹□ u ∥}) := infer_type Γ HΓ t := tx <- infer Γ HΓ t ;; s <- reduce_to_sort (X := X) Γ tx.π1 _ ;; @@ -785,20 +775,20 @@ Section Typecheck. Qed. Equations check_alpha_ws_cumul_ctx Δ Δ' - : typing_result_comp (∥ eq_context_gen eq eq Δ Δ' ∥) := + : typing_result_comp (∥ eq_context_upto_names Δ Δ' ∥) := check_alpha_ws_cumul_ctx Δ Δ' with - inspect (forallb2 (bcompare_decls eqb eqb) Δ Δ') := { + inspect (eqb_context_upto_names Δ Δ') := { | @exist true e := ret _ ; | @exist false e' := raise (Msg "While checking alpha-conversion of contexts: contexts differ") }. Next Obligation. move: e. - elim: reflect_eq_ctx => //. + elim: reflect_eq_context_upto_names => //. Qed. Next Obligation. sq. move: e'. - elim: reflect_eq_ctx => //. + elim: reflect_eq_context_upto_names => //. Qed. (* Equations infer_terms Γ (wfΓ : ∥ wf_local Σ Γ ∥) ts @@ -1049,22 +1039,22 @@ Section Typecheck. Qed. Equations check_is_allowed_elimination - (u : Universe.t) (wfu : forall Σ (wfΣ : abstract_env_ext_rel X Σ), wf_universe Σ u) + (u : sort) (wfu : forall Σ (wfΣ : abstract_env_ext_rel X Σ), wf_sort Σ u) (al : allowed_eliminations) : typing_result_comp (forall Σ (wfΣ : abstract_env_ext_rel X Σ), is_allowed_elimination Σ al u) := check_is_allowed_elimination u wfu IntoSProp - with inspect (Universe.is_sprop u) := { + with inspect (Sort.is_sprop u) := { | @exist true e := ret _ ; | @exist false _ := raise (Msg "Cannot eliminate over this sort") } ; check_is_allowed_elimination u wfu IntoPropSProp - with inspect (is_propositional u) := { + with inspect (Sort.is_propositional u) := { | @exist true _ := ret _ ; | @exist false _ := raise (Msg "Cannot eliminate over this sort") }; check_is_allowed_elimination u wfu IntoSetPropSProp - with inspect (is_propositional u || abstract_env_eq X u Universe.type0) := { + with inspect (Sort.is_propositional u || abstract_env_compare_sort X Conv u Sort.type0) := { | @exist true _ := ret _ ; | @exist false _ := raise (Msg "Cannot eliminate over this sort") } ; @@ -1080,7 +1070,7 @@ Section Typecheck. Next Obligation. symmetry in e; toProp e; destruct e as [-> | e]; [auto|right]. specialize_Σ wfΣ; pose proof (heΣ _ wfΣ) as [heΣ]. - eapply abstract_env_compare_universe_correct with (conv_pb := Conv) in e; eauto using wf_universe_type0. + eapply abstract_env_compare_sort_correct with (conv_pb := Conv) in e; eauto using wf_sort_type0. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ; @@ -1089,7 +1079,7 @@ Section Typecheck. symmetry in e0; toProp e0; destruct e0 as [e1 e0]. destruct H as [H|H]; [rewrite H in e1; discriminate e1 | clear e1]. apply diff_false_true. rewrite -e0. - eapply abstract_env_compare_universe_correct with (conv_pb := Conv); eauto using wf_universe_type0. + eapply abstract_env_compare_sort_correct with (conv_pb := Conv); eauto using wf_sort_type0. Qed. Notation wt_brs Γ ci mdecl idecl p ptm ctors brs n := @@ -1101,7 +1091,7 @@ Section Typecheck. Section check_brs. Context (infer : forall (Γ : context) (HΓ : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ wf_local Σ Γ ∥) (t : term), typing_result_comp ({ A : term & forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ Σ ;;; Γ |- t ▹ A ∥ })) - (Γ : context) (wfΓ : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ wf_local Σ Γ ∥) (ps : Universe.t) + (Γ : context) (wfΓ : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ wf_local Σ Γ ∥) (ps : sort) (ci : case_info) (mdecl : mutual_inductive_body) (idecl : one_inductive_body) (p : predicate term) (args : list term). @@ -1116,7 +1106,7 @@ Section Typecheck. Lemma branch_helper n cdecl ctors br (isdecl' : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ Alli (fun i cdecl => declared_constructor Σ (ci, i) mdecl idecl cdecl) n (cdecl :: ctors) ∥) : - ∥ eq_context_gen eq eq (bcontext br) (cstr_branch_context ci mdecl cdecl) ∥ -> + ∥ eq_context_upto_names (bcontext br) (cstr_branch_context ci mdecl cdecl) ∥ -> forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ wf_branch cdecl br × let brctxty := case_branch_type ci.(ci_ind) mdecl idecl p br ptm n cdecl in wf_local Σ (Γ,,, brctxty.1) × Σ;;; Γ,,, brctxty.1 |- brctxty.2 ◃ tSort ps ∥. @@ -1125,7 +1115,7 @@ Section Typecheck. have wfbr : wf_branch cdecl br. { sq. specialize_Σ wfΣ. do 2 red. unfold cstr_branch_context, expand_lets_ctx, expand_lets_k_ctx in H. - move/eq_context_gen_binder_annot: H. + move/eq_context_upto_names_binder_annot: H. now do 3 move/eq_annots_fold. } assert (wfpret' : ∥Σ ;;; Γ ,,, predctx |- preturn p : tSort ps∥). { specialize_Σ wfΣ. sq. eapply infering_sort_typing ; eauto. @@ -1191,7 +1181,7 @@ Section Typecheck. eapply branch_helper in i; tea. specialize_Σ wfΣ; sq. constructor ; tea. split. - * now eapply All2_fold_All2 in check_eq_bcontext. + * assumption. * now destruct i as [? []]. Qed. Next Obligation. @@ -1207,19 +1197,18 @@ Section Typecheck. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ; sq. depelim H. - apply All2_fold_All2. - now inversion p0. + apply p0. Qed. End check_brs. Lemma eq_context_gen_wf_predicate p ci mdecl idecl : #|pparams p| = ind_npars mdecl -> - eq_context_gen eq eq (pcontext p) (ind_predicate_context ci mdecl idecl) -> + eq_context_upto_names (pcontext p) (ind_predicate_context ci mdecl idecl) -> wf_predicate mdecl idecl p. Proof using Type. intros eqp e. do 2 red. split => //. - eapply eq_context_gen_binder_annot in e. + eapply eq_context_upto_names_binder_annot in e. rewrite /ind_predicate_context in e. rewrite /idecl_binder. destruct (forget_types (pcontext p)); depelim e; cbn in *. @@ -1228,12 +1217,12 @@ Section Typecheck. Qed. Lemma eq_context_gen_wf_branch ci mdecl cdecl br : - eq_context_gen eq eq (bcontext br) (cstr_branch_context ci mdecl cdecl) -> + eq_context_upto_names (bcontext br) (cstr_branch_context ci mdecl cdecl) -> wf_branch cdecl br. Proof using Type. intros e. do 2 red. - eapply eq_context_gen_binder_annot in e. + eapply eq_context_upto_names_binder_annot in e. rewrite /cstr_branch_context in e. now do 3 eapply (proj1 (eq_annots_fold _ _ _)) in e. Qed. @@ -1322,15 +1311,15 @@ Section Typecheck. | primInt | decl := check_eq_true (eqb decl.(cst_body) None) (Msg "primitive type is registered to a defined constant") ;; check_eq_true (eqb decl.(cst_universes) Monomorphic_ctx) (Msg "primitive type is registered to a non-monomorphic constant") ;; - check_eq_true (eqb decl.(cst_type) (tSort Universe.type0)) (Msg "primitive type for integers is registered to an axiom whose type is not the sort Set") ;; + check_eq_true (eqb decl.(cst_type) (tSort Sort.type0)) (Msg "primitive type for integers is registered to an axiom whose type is not the sort Set") ;; ret _ | primFloat | decl := check_eq_true (eqb decl.(cst_body) None) (Msg "primitive type is registered to a defined constant") ;; check_eq_true (eqb decl.(cst_universes) Monomorphic_ctx) (Msg "primitive type for floats is registered to non-monomorphic constant") ;; - check_eq_true (eqb decl.(cst_type) (tSort Universe.type0)) (Msg "primitive type for floats is registered to an axiom whose type is not the sort Set") ;; + check_eq_true (eqb decl.(cst_type) (tSort Sort.type0)) (Msg "primitive type for floats is registered to an axiom whose type is not the sort Set") ;; ret _ | primArray | decl := - let s := Universe.make (Level.lvar 0) in + let s := sType (Universe.make' (Level.lvar 0)) in check_eq_true (eqb decl.(cst_body) None) (Msg "primitive type is registered to a defined constant") ;; check_eq_true (eqb decl.(cst_universes) (Polymorphic_ctx array_uctx)) (Msg "primitive type is registered to a monomorphic constant") ;; check_eq_true (eqb decl.(cst_type) (tImpl (tSort s) (tSort s))) (Msg "primitive type for arrays is registered to an axiom whose type is not of shape Type -> Type") ;; @@ -1374,8 +1363,8 @@ Section Typecheck. | (primInt; primIntModel i) := ret _ | (primFloat; primFloatModel f) := ret _ | (primArray; primArrayModel a) := - check_eq_true (abstract_env_ext_wf_universeb X (Universe.make a.(array_level))) (Msg "primitive array level is not well-formed") ;; - check_type <- bdcheck infer Γ wfΓ a.(array_type) (tSort (Universe.make a.(array_level))) _ ;; + check_eq_true (abstract_env_ext_wf_universeb X (Universe.make' a.(array_level))) (Msg "primitive array level is not well-formed") ;; + check_type <- bdcheck infer Γ wfΓ a.(array_type) (tSort (sType (Universe.make' a.(array_level)))) _ ;; check_default <- bdcheck infer Γ wfΓ a.(array_default) a.(array_type) _ ;; check_values <- make_All (fun x => bdcheck infer Γ wfΓ x a.(array_type) _) a.(array_value) ;; ret _. @@ -1400,7 +1389,7 @@ Section Typecheck. now move/@wf_universe_reflect: i. - specialize (check_type _ wfΣ) as []. specialize (check_default _ wfΣ) as []. - assert (∥ Σ;;; Γ |- array_type a : tSort (Universe.make (array_level a)) ∥) as []. + assert (∥ Σ;;; Γ |- array_type a : tSort (sType (Universe.make' (array_level a))) ∥) as []. { sq. eapply checking_typing in X0; eauto. erewrite <- abstract_env_ext_wf_universeb_correct in i; tea. eapply has_sort_isType; eapply type_Sort; eauto. now move/@wf_universe_reflect: i. } @@ -1459,15 +1448,15 @@ Section Typecheck. infer Γ HΓ (tEvar ev _) := raise (UnboundEvar ev) ; - infer Γ HΓ (tSort u) with inspect (@abstract_env_ext_wf_universeb _ _ _ _ X u) := { - | exist true _ := ret (tSort (Universe.super u);_) ; - | exist false _ := raise (Msg ("Sort contains an undeclared level " ^ string_of_sort u)) + infer Γ HΓ (tSort s) with inspect (@abstract_env_ext_wf_sortb _ _ _ _ X s) := { + | exist true _ := ret (tSort (Sort.super s);_) ; + | exist false _ := raise (Msg ("Sort contains an undeclared level " ^ string_of_sort s)) } ; infer Γ HΓ (tProd na A B) := - s1 <- infer_type infer Γ HΓ A ;; + s1 <- infer_type infer Γ HΓ A ;; s2 <- infer_type infer (Γ,,vass na A) _ B ;; - Checked_comp (tSort (Universe.sort_of_product s1.π1 s2.π1);_) ; + Checked_comp (tSort (Sort.sort_of_product s1.π1 s2.π1);_) ; infer Γ HΓ (tLambda na A t) := infer_type infer Γ HΓ A ;; @@ -1532,8 +1521,7 @@ Section Typecheck. let chop_args := chop ci.(ci_npar) args in let params := chop_args.1 in let indices := chop_args.2 in cu <- check_consistent_instance (ind_universes mdecl) _ p.(puinst) ;; - check_eq_true (abstract_env_compare_global_instance _ X (abstract_env_leq X) (IndRef ind') - #|args| u p.(puinst)) + check_eq_true (abstract_env_compare_global_instance _ X Cumul (IndRef ind') #|args| u p.(puinst)) (Msg "invalid universe annotation on case, not larger than the discriminee's universes") ;; wt_params <- check_inst infer Γ HΓ (List.rev (smash_context [] (ind_params mdecl))@[p.(puinst)]) _ _ p.(pparams) ;; eq_params <- check_ws_cumul_pb_terms Γ params p.(pparams) _ _ ;; @@ -1613,15 +1601,15 @@ Section Typecheck. Next Obligation. specialize_Σ wfΣ; sq. symmetry in e. - erewrite <- abstract_env_ext_wf_universeb_correct in e; eauto. - eapply (elimT wf_universe_reflect) in e. + erewrite <- abstract_env_ext_wf_sortb_correct in e; eauto. + move: e => /wf_sort_reflect e. sq; econstructor; tas. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. specialize_Σ wfΣ; sq. - inversion X1 ; subst. erewrite <- abstract_env_ext_wf_universeb_correct in e0; eauto. - move: H0 e0 => /wf_universe_reflect -> //. + inversion X1 ; subst. erewrite <- abstract_env_ext_wf_sortb_correct in e0; eauto. + move: H0 e0 => /wf_sort_reflect -> //. Qed. (* tProd *) Next Obligation. @@ -1984,9 +1972,6 @@ Section Typecheck. rewrite -(spine_subst_inst_subst X4). rewrite - !smash_context_subst /= !subst_context_nil. erewrite <- compare_global_instance_correct in i1; eauto. - 2: intros; eapply iff_reflect; - eapply abstract_env_compare_universe_correct with (conv_pb := Cumul); - try eassumption; apply wf_universe_iff; eauto. 2: { eapply consistent_instance_ext_wf; eauto. } 2: { eapply consistent_instance_ext_wf; eauto. } eapply (inductive_cumulative_indices X1); tea. @@ -2043,10 +2028,7 @@ Section Typecheck. Next Obligation. intros. cbn in *. - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - pose proof (heΣ _ wfΣ) as [heΣ]. - cbn in *. specialize_Σ wfΣ ; sq. - now eapply All2_fold_All2 in check_wfpctx_conv. + assumption. Qed. Next Obligation. @@ -2077,23 +2059,18 @@ Section Typecheck. induction check_brs; constructor; auto. destruct r0. solve_all. - eapply eq_context_gen_wf_branch. - now eapply All2_fold_All2. + now eapply eq_context_gen_wf_branch. } econstructor ; eauto. - econstructor ; tea. now apply closed_red_red. - - now eapply All2_fold_All2 in check_wfpctx_conv. - now eapply wf_local_rel_wf_local_bd, All_local_env_app_inv, wf_case_predicate_context. - eapply ctx_inst_typing_bd ; eauto. eapply ctx_inst_smash. now rewrite subst_instance_smash /= in wt_params. - now eapply negbTE. - erewrite <- compare_global_instance_correct in i1; eauto. - 1: intros; eapply iff_reflect; - eapply abstract_env_compare_universe_correct with (conv_pb := Cumul); - try eassumption; apply wf_universe_iff; eauto. - 1: { apply/wf_universe_instanceP. + 1: { apply/wf_instanceP. rewrite -wf_universeb_instance_forall. assert (tyu : isType Σ Γ (mkApps (tInd ci u) args)). { @@ -2116,7 +2093,6 @@ Section Typecheck. eapply wf_case_branches_types' ; tea. - apply infering_sort_typing ; eauto. now eapply wf_case_predicate_context. - - now eapply All2_fold_All2. } cbn ; intros ? ? ? [? []] ; intuition auto. now eapply wf_local_rel_wf_local_bd, All_local_env_app_inv. @@ -2202,7 +2178,7 @@ Section Typecheck. subst. apply absurd. sq. - now eapply All2_fold_All2. + assumption. Qed. Next Obligation. @@ -2283,10 +2259,7 @@ Section Typecheck. erewrite All2_length. 2: eassumption. erewrite <- All2_length ; tea. - - intros. eapply iff_reflect. - eapply abstract_env_compare_universe_correct with (conv_pb := Cumul); - try eassumption; apply wf_universe_iff; eauto. - - apply/wf_universe_instanceP. + - apply/wf_instanceP. rewrite -wf_universeb_instance_forall. assert (tyu : isType Σ Γ (mkApps (tInd ind' u) args)). { @@ -2300,7 +2273,7 @@ Section Typecheck. - apply infering_typing, typing_wf_universes in ty ; auto. move: ty => /andP []. rewrite {1}/wf_universes /= wf_universeb_instance_forall => - /andP [] /wf_universe_instanceP; eauto. + /andP [] /wf_instanceP; eauto. Qed. Next Obligation. diff --git a/safechecker/theories/PCUICWfEnv.v b/safechecker/theories/PCUICWfEnv.v index 97278d1a5..d46644153 100644 --- a/safechecker/theories/PCUICWfEnv.v +++ b/safechecker/theories/PCUICWfEnv.v @@ -48,17 +48,13 @@ Definition abstract_env_fixguard {cf:checker_flags} {abstract_env_impl abstract Definition abstract_env_cofixguard {cf:checker_flags} {abstract_env_impl abstract_env_ext_impl : Type} `{!abstract_env_struct abstract_env_impl abstract_env_ext_impl} (X:abstract_env_ext_impl) := abstract_env_guard X CoFix. -Definition abstract_env_conv_pb_relb {cf:checker_flags} {abstract_env_impl abstract_env_ext_impl : Type} `{!abstract_env_struct abstract_env_impl abstract_env_ext_impl} +Definition abstract_env_compare_universe {cf:checker_flags} {abstract_env_impl abstract_env_ext_impl : Type} `{!abstract_env_struct abstract_env_impl abstract_env_ext_impl} (X:abstract_env_ext_impl) : conv_pb -> Universe.t -> Universe.t -> bool := - fun conv_pb => conv_pb_relb_gen conv_pb - (check_eqb_universe_gen (abstract_env_leqb_level_n X)) - (check_leqb_universe_gen (abstract_env_leqb_level_n X)). + check_cmpb_universe_gen (abstract_env_leqb_level_n X). -Definition abstract_env_eq {cf:checker_flags} {abstract_env_impl abstract_env_ext_impl : Type} `{!abstract_env_struct abstract_env_impl abstract_env_ext_impl} - (X:abstract_env_ext_impl) := abstract_env_conv_pb_relb X Conv. - -Definition abstract_env_leq {cf:checker_flags} {abstract_env_impl abstract_env_ext_impl : Type} `{!abstract_env_struct abstract_env_impl abstract_env_ext_impl} - (X:abstract_env_ext_impl) := abstract_env_conv_pb_relb X Cumul. +Definition abstract_env_compare_sort {cf:checker_flags} {abstract_env_impl abstract_env_ext_impl : Type} `{!abstract_env_struct abstract_env_impl abstract_env_ext_impl} + (X:abstract_env_ext_impl) : conv_pb -> sort -> sort -> bool := + check_cmpb_sort_gen (abstract_env_leqb_level_n X). Definition abstract_env_check_constraints {cf:checker_flags} {abstract_env_impl abstract_env_ext_impl : Type} `{!abstract_env_struct abstract_env_impl abstract_env_ext_impl} (X:abstract_env_ext_impl) : ConstraintSet.t -> bool := @@ -66,11 +62,11 @@ Definition abstract_env_check_constraints {cf:checker_flags} {abstract_env_impl Definition abstract_env_ext_wf_universeb {cf:checker_flags} {abstract_env_impl abstract_env_ext_impl : Type} `{!abstract_env_struct abstract_env_impl abstract_env_ext_impl} (X:abstract_env_ext_impl) : Universe.t -> bool := - fun (s : Universe.t) => - match s with - | Universe.lType l => LevelExprSet.for_all (fun l => abstract_env_level_mem X (LevelExpr.get_level l)) l - | _ => true - end. + fun (u : Universe.t) => LevelExprSet.for_all (fun l => abstract_env_level_mem X (LevelExpr.get_level l)) u. + +Definition abstract_env_ext_wf_sortb {cf:checker_flags} {abstract_env_impl abstract_env_ext_impl : Type} `{!abstract_env_struct abstract_env_impl abstract_env_ext_impl} +(X:abstract_env_ext_impl) : sort -> bool := + Sort.on_sort (abstract_env_ext_wf_universeb X) true. Definition abstract_env_level_mem' {cf:checker_flags} {abstract_env_impl abstract_env_ext_impl : Type} `{!abstract_env_struct abstract_env_impl abstract_env_ext_impl} (X:abstract_env_ext_impl) : LevelSet.t -> Level.t -> bool := @@ -221,25 +217,35 @@ Definition abstract_env_is_consistent_empty {cf:checker_flags} {X_type : abstrac Lemma abstract_env_compare_universe_correct {cf:checker_flags} {X_type : abstract_env_impl} (X:X_type.π2.π1) {Σ} (wfΣ : abstract_env_ext_rel X Σ) conv_pb u u' : wf_universe Σ u -> wf_universe Σ u' -> - compare_universe conv_pb Σ u u' <-> - abstract_env_conv_pb_relb X conv_pb u u'. + compare_universe Σ conv_pb u u' <-> + abstract_env_compare_universe X conv_pb u u'. Proof. intros wfu wfu'. pose proof (abstract_env_ext_wf X wfΣ). sq. pose (Hleq := abstract_env_leqb_level_n_correct X wfΣ). erewrite uctx'_eq in Hleq. - destruct conv_pb; split; cbn; intro. - - eapply (check_eqb_universe_complete_gen _ (global_ext_levels Σ, global_ext_constraints Σ)); eauto. - + eapply wf_ext_global_uctx_invariants; eauto. - + eapply wf_ext_consistent; eauto. - - eapply (check_eqb_universe_spec_gen' _ (global_ext_levels Σ, global_ext_constraints Σ)); eauto. - + eapply wf_ext_global_uctx_invariants; eauto. - + eapply wf_ext_consistent; eauto. - - eapply (check_leqb_universe_complete_gen _ (global_ext_levels Σ, global_ext_constraints Σ)); eauto. - + eapply wf_ext_global_uctx_invariants; eauto. - + eapply wf_ext_consistent; eauto. - - eapply (check_leqb_universe_spec_gen' _ (global_ext_levels Σ, global_ext_constraints Σ)); eauto. - + eapply wf_ext_global_uctx_invariants; eauto. - + eapply wf_ext_consistent; eauto. + eapply compare_universeP_gen with (pb := conv_pb) in Hleq. + apply reflect_reflectT in Hleq. + split. + 1: now eapply introT. + 1: now eapply elimT. + all: tea. +Qed. + +Lemma abstract_env_compare_sort_correct {cf:checker_flags} {X_type : abstract_env_impl} + (X:X_type.π2.π1) {Σ} (wfΣ : abstract_env_ext_rel X Σ) conv_pb s s' : + wf_sort Σ s -> wf_sort Σ s' -> + compare_sort Σ conv_pb s s' <-> + abstract_env_compare_sort X conv_pb s s'. +Proof. + intros wfu wfu'. pose proof (abstract_env_ext_wf X wfΣ). sq. + pose (Hleq := abstract_env_leqb_level_n_correct X wfΣ). + erewrite uctx'_eq in Hleq. + eapply compare_sortP_gen with (pb := conv_pb) in Hleq. + apply reflect_reflectT in Hleq. + split. + 1: now eapply introT. + 1: now eapply elimT. + all: tea. Qed. Lemma check_constraints_spec {cf:checker_flags} {X_type : abstract_env_impl} @@ -286,7 +292,7 @@ Lemma abstract_env_ext_wf_universeb_correct {cf:checker_flags} {X_type : abstrac ( X:X_type.π2.π1) {Σ} (wfΣ : abstract_env_ext_rel X Σ) u : wf_universeb Σ u = abstract_env_ext_wf_universeb X u. Proof. - destruct u => //; destruct t as [ [] ?]; cbn. clear is_ok t_ne. + destruct u as [ [] ?]; cbn. clear is_ok t_ne. induction this => //; cbn. set (b := LevelSet.Raw.mem _ _). set (b' := abstract_env_level_mem _ _). assert (Hbb' : b = b'). { unfold b'. apply eq_true_iff_eq. rewrite <- (abstract_env_level_mem_correct X wfΣ (LevelExpr.get_level a)). @@ -294,6 +300,14 @@ Proof. destruct Hbb', b => //. Qed. +Lemma abstract_env_ext_wf_sortb_correct {cf:checker_flags} {X_type : abstract_env_impl} +( X:X_type.π2.π1) {Σ} (wfΣ : abstract_env_ext_rel X Σ) s : + wf_sortb Σ s = abstract_env_ext_wf_sortb X s. +Proof. + destruct s as [| |u]; cbnr. + now apply abstract_env_ext_wf_universeb_correct. +Qed. + Lemma abstract_env_level_mem_correct' {cf:checker_flags} {X_type : abstract_env_impl} ( X:X_type.π2.π1) {Σ} (wfΣ : abstract_env_ext_rel X Σ) levels u : LevelSet.mem u (LevelSet.union levels (global_ext_levels Σ)) = abstract_env_level_mem' X levels u. diff --git a/template-coq/src/ast_denoter.ml b/template-coq/src/ast_denoter.ml index a102c550a..9dd801273 100644 --- a/template-coq/src/ast_denoter.ml +++ b/template-coq/src/ast_denoter.ml @@ -17,7 +17,7 @@ struct type quoted_name = name type quoted_aname = name binder_annot type quoted_relevance = relevance - type quoted_sort = Universes0.Universe.t + type quoted_sort = Universes0.Sort.t type quoted_cast_kind = cast_kind type quoted_kernel_name = kername type quoted_inductive = inductive @@ -211,19 +211,20 @@ struct let unquote_level_expr (trm : Universes0.Level.t * quoted_int) : Univ.Universe.t = let l = unquote_level (fst trm) in let u = Univ.Universe.make l in - let n = unquote_int (snd trm) in - if n > 0 then Univ.Universe.super u else u + Caml_nat.iter_nat Univ.Universe.super u (snd trm) - let unquote_universe evd (trm : Universes0.Universe.t) = + let unquote_universe (trm : Universes0.Universe.t) = + let u = Universes0.t_set trm in + let ux_list = Universes0.LevelExprSet.elements u in + let l = List.map unquote_level_expr ux_list in + let u = List.fold_left Univ.Universe.sup (List.hd l) (List.tl l) in + u + + let unquote_sort evd trm = match trm with - | Universes0.Universe.Coq_lSProp -> evd, Sorts.sprop - | Universes0.Universe.Coq_lProp -> evd, Sorts.prop - | Universes0.Universe.Coq_lType u -> - let u = Universes0.t_set u in - let ux_list = Universes0.LevelExprSet.elements u in - let l = List.map unquote_level_expr ux_list in - let u = List.fold_left Univ.Universe.sup (List.hd l) (List.tl l) in - evd, Sorts.sort_of_univ u + | Universes0.Sort.Coq_sSProp -> evd, Sorts.sprop + | Universes0.Sort.Coq_sProp -> evd, Sorts.prop + | Universes0.Sort.Coq_sType u -> evd, Sorts.sort_of_univ (unquote_universe u) let unquote_universe_level evm l = evm, unquote_level l let unquote_universe_instance(evm: Evd.evar_map) (l: quoted_univ_instance): Evd.evar_map * Univ.Instance.t diff --git a/template-coq/src/ast_quoter.ml b/template-coq/src/ast_quoter.ml index 14462a188..2a987dfb5 100644 --- a/template-coq/src/ast_quoter.ml +++ b/template-coq/src/ast_quoter.ml @@ -18,7 +18,7 @@ struct type quoted_name = BasicAst.name type quoted_aname = BasicAst.aname type quoted_relevance = BasicAst.relevance - type quoted_sort = Universes0.Universe.t + type quoted_sort = Universes0.Sort.t type quoted_cast_kind = cast_kind type quoted_kernel_name = Kernames.kername type quoted_inductive = inductive @@ -79,32 +79,26 @@ struct let quote_float64 x = x - (* NOTE: fails if it hits Prop or SProp *) - let quote_nonprop_level (l : Univ.Level.t) : Universes0.Level.t = + let quote_level (l : Univ.Level.t) : Universes0.Level.t = if Univ.Level.is_set l then Universes0.Level.Coq_lzero else match Univ.Level.var_index l with | Some x -> Universes0.Level.Coq_lvar (quote_int x) | None -> Universes0.Level.Coq_level (quote_string (Univ.Level.to_string l)) - let quote_level (l : Univ.Level.t) : (Universes0.PropLevel.t, Universes0.Level.t) Datatypes.sum = - try Coq_inr (quote_nonprop_level l) - with e -> assert false + let quote_level_expr (lvl, shft) : Universes0.LevelExpr.t = quote_level lvl, quote_int shft - let quote_universe s : Universes0.Universe.t = - match Univ.Universe.level s with - Some l -> Universes0.Universe.of_levels (quote_level l) + let quote_universe u : Universes0.Universe.t = + match Univ.Universe.level u with + Some l -> Universes0.Universe.make' (quote_level l) | _ -> - let univs = List.map (fun (l,i) -> - match quote_level l with - | Coq_inl lprop -> assert false - | Coq_inr ql -> (ql, i > 0)) (Univ.Universe.repr s) in - Universes0.Universe.from_kernel_repr (List.hd univs) (List.tl univs) + let levels = Univ.Universe.repr u |> List.map quote_level_expr in + Universes0.Universe.from_kernel_repr (List.hd levels) (List.tl levels) let quote_sort s = match s with - | Sorts.Set -> quote_universe Univ.Universe.type0 - | Sorts.SProp -> Universes0.Universe.of_levels (Coq_inl Universes0.PropLevel.Coq_lSProp) - | Sorts.Prop -> Universes0.Universe.of_levels (Coq_inl Universes0.PropLevel.Coq_lProp) - | Sorts.Type u -> quote_universe u + | Sorts.Set -> Universes0.Sort.type0 + | Sorts.SProp -> Universes0.Sort.Coq_sSProp + | Sorts.Prop -> Universes0.Sort.Coq_sProp + | Sorts.Type u -> Universes0.Sort.Coq_sType (quote_universe u) let quote_sort_family s = match s with @@ -154,14 +148,13 @@ struct | _ -> false let quote_univ_constraint ((l, ct, l') : Univ.univ_constraint) : quoted_univ_constraint = - try ((quote_nonprop_level l, quote_constraint_type ct), quote_nonprop_level l') + try ((quote_level l, quote_constraint_type ct), quote_level l') with e -> assert false - let quote_univ_level = quote_nonprop_level + let quote_univ_level = quote_level let quote_univ_instance (i : Univ.Instance.t) : quoted_univ_instance = let arr = Univ.Instance.to_array i in - (* we assume that valid instances do not contain [Prop] or [SProp] *) - try CArray.map_to_list quote_nonprop_level arr + try CArray.map_to_list quote_level arr with e -> assert false (* (Prop, Le | Lt, l), (Prop, Eq, Prop) -- trivial, (l, c, Prop) -- unsatisfiable *) @@ -188,12 +181,7 @@ struct (names, (quote_univ_instance levels, quote_univ_constraints constraints)) let quote_univ_contextset (uctx : Univ.ContextSet.t) : quoted_univ_contextset = - (* CHECKME: is is safe to assume that there will be no Prop or SProp? *) - let levels = filter_map - (fun l -> match quote_level l with - | Coq_inl _ -> None - | Coq_inr l -> Some l) - (Univ.Level.Set.elements (Univ.ContextSet.levels uctx)) in + let levels = List.map quote_level (Univ.Level.Set.elements (Univ.ContextSet.levels uctx)) in let constraints = Univ.ContextSet.constraints uctx in (Universes0.LevelSetProp.of_list levels, quote_univ_constraints constraints) diff --git a/template-coq/src/caml_nat.ml b/template-coq/src/caml_nat.ml index 5a78380a1..729361a24 100644 --- a/template-coq/src/caml_nat.ml +++ b/template-coq/src/caml_nat.ml @@ -1,11 +1,11 @@ -let nat_of_caml_int i = +let nat_of_caml_int i = let rec aux acc i = if i < 0 then acc else aux (Datatypes.S acc) (i - 1) in aux Datatypes.O (i - 1) -let rec caml_int_of_nat_aux n acc = - match n with +let rec iter_nat f acc = function | Datatypes.O -> acc - | Datatypes.S x -> caml_int_of_nat_aux x (succ acc) -let caml_int_of_nat n = caml_int_of_nat_aux n 0 + | Datatypes.S x -> iter_nat f (f acc) x + +let caml_int_of_nat n = iter_nat succ 0 n diff --git a/template-coq/src/caml_nat.mli b/template-coq/src/caml_nat.mli index b11cab111..72d7f29e5 100644 --- a/template-coq/src/caml_nat.mli +++ b/template-coq/src/caml_nat.mli @@ -1,3 +1,4 @@ val caml_int_of_nat : Datatypes.nat -> int -val nat_of_caml_int : int -> Datatypes.nat \ No newline at end of file +val iter_nat : ('a -> 'a) -> 'a -> Datatypes.nat -> 'a +val nat_of_caml_int : int -> Datatypes.nat diff --git a/template-coq/src/constr_denoter.ml b/template-coq/src/constr_denoter.ml index 675be7ec1..6e4c36987 100644 --- a/template-coq/src/constr_denoter.ml +++ b/template-coq/src/constr_denoter.ml @@ -213,55 +213,66 @@ struct else not_supported_verb trm "unquote_level" + let unquote_universe_level = unquote_level + + let iter_int f a n = + if n < 0 then failwith "Negative number of iterations" + else + let rec loop f a = function 0 -> a | n -> loop f (f a) (n-1) + in + loop f a n + + let unquote_univ_expr evm trm (* of type LevelExpr.t *) : Evd.evar_map * Univ.Universe.t = let (h,args) = app_full trm [] in if constr_equall h c_pair then let l, b = unquote_pair trm in let evm, l' = unquote_level evm l in let u = Univ.Universe.make l' in - evm, if unquote_nat b > 0 then Univ.Universe.super u else u + evm, iter_int Univ.Universe.super u (unquote_nat b) else not_supported_verb trm "unquote_univ_expr" - let unquote_universe evm trm (* of type universe *) = + let unquote_universe evm trm (* of type universe *) = let (h,args) = app_full trm [] in - if constr_equall h lSProp then - match args with - | [] -> evm, Sorts.sprop - | _ -> bad_term_verb trm "unquote_univ_expr" - else if constr_equall h lProp then - match args with - | [] -> evm, Sorts.prop - | _ -> bad_term_verb trm "unquote_univ_expr" - else if constr_equall h lnpe then - match args with - | [x] -> - let (h,args) = app_full x [] in - if constr_equall h tBuild_Universe then - (match args with - | x :: _ :: [] -> - (let (h,args) = app_full x [] in - if constr_equall h tMktLevelExprSet then - match args with - | x :: _ :: [] -> - (match unquote_list x with - | [] -> assert false - | e::q -> - let evm, u = List.fold_left (fun (evm,u) e -> - let evm, u' = unquote_univ_expr evm e - in evm, Univ.Universe.sup u u') - (unquote_univ_expr evm e) q - in evm, Sorts.sort_of_univ u) - | _ -> bad_term_verb trm "unquote_universe 0" - else - not_supported_verb trm "unquote_universe 0") - | _ -> bad_term_verb trm "unquote_universe 1") - else not_supported_verb trm "unquote_universe 2" - | _ -> bad_term_verb trm "unquote_universe 3" - else bad_term_verb trm "unquote_universe 4" - - - let unquote_universe_level evm trm = unquote_level evm trm + if constr_equall h tBuild_Universe then + (match args with + | x :: _ :: [] -> + (let (h,args) = app_full x [] in + if constr_equall h tMktLevelExprSet then + match args with + | x :: _ :: [] -> + (match unquote_list x with + | [] -> assert false + | e::q -> + let evm, u = List.fold_left (fun (evm,u) e -> + let evm, u' = unquote_univ_expr evm e + in evm, Univ.Universe.sup u u') + (unquote_univ_expr evm e) q + in evm, u) + | _ -> bad_term_verb trm "unquote_universe 0" + else + not_supported_verb trm "unquote_universe 0") + | _ -> bad_term_verb trm "unquote_universe 1") + else not_supported_verb trm "unquote_universe 2" + + let unquote_sort evm trm (* of type sort *) = + let (h,args) = app_full trm [] in + if constr_equall h sSProp then + match args with + | [_univ] -> evm, Sorts.sprop + | _ -> bad_term_verb trm "unquote_sort_sprop_args" + else if constr_equall h sProp then + match args with + | [_univ] -> evm, Sorts.prop + | _ -> bad_term_verb trm "unquote_sort_prop_args" + else if constr_equall h sType then + match args with + | [_univ; x] -> + let evm, u = unquote_universe evm x in + evm, Sorts.sort_of_univ u + | _ -> bad_term_verb trm "unquote_sort_type_too_many_args" + else bad_term_verb trm "unquote_sort_type_no_args" let unquote_universe_instance evm trm (* of type universe_instance *) = let l = unquote_list trm in diff --git a/template-coq/src/constr_quoter.ml b/template-coq/src/constr_quoter.ml index b007b6655..1bab1577f 100644 --- a/template-coq/src/constr_quoter.ml +++ b/template-coq/src/constr_quoter.ml @@ -194,27 +194,23 @@ struct let string_of_level s = to_string (Univ.Level.to_string s) - let quote_nonprop_level l = + let quote_level l = if Level.is_set l then Lazy.force lzero else match Level.var_index l with | Some x -> constr_mkApp (tLevelVar, [| quote_int x |]) | None -> constr_mkApp (tLevel, [| string_of_level l |]) - let quote_level l = - Tm_util.debug (fun () -> str"quote_level " ++ Level.pr l); - constr_mkApp (cInr, [|Lazy.force tproplevel;Lazy.force tlevel; quote_nonprop_level l |]) - let quote_universe s = match Univ.Universe.level s with - Some l -> constr_mkApp (tof_levels, [| quote_level l |]) - | _ -> let levels = List.map (fun (l,i) -> pairl tlevel bool_type (quote_nonprop_level l) (quote_bool (i > 0))) (Universe.repr s) in + Some l -> constr_mkApp (tof_level, [| quote_level l |]) + | _ -> let levels = List.map (fun (l,i) -> pairl tlevel tnat (quote_level l) (quote_int i)) (Universe.repr s) in let hd = List.hd levels in - let tl = to_coq_list (prodl tlevel bool_type) (List.tl levels) in + let tl = to_coq_list (prodl tlevel tnat) (List.tl levels) in constr_mkApp (tfrom_kernel_repr, [| hd ; tl |]) let quote_levelset s = let levels = Univ.Level.Set.elements s in - let levels' = to_coq_listl tlevel (List.map quote_nonprop_level levels) in + let levels' = to_coq_listl tlevel (List.map quote_level levels) in constr_mkApp (tLevelSet_of_list, [|levels'|]) let quote_constraint_type (c : Univ.constraint_type) = @@ -224,17 +220,17 @@ struct | Eq -> Lazy.force tunivEq let quote_univ_constraint ((l1, ct, l2) : Univ.univ_constraint) = - let l1 = quote_nonprop_level l1 in - let l2 = quote_nonprop_level l2 in + let l1 = quote_level l1 in + let l2 = quote_level l2 in let ct = quote_constraint_type ct in constr_mkApp (tmake_univ_constraint, [| l1; ct; l2 |]) - let quote_univ_level u = quote_nonprop_level u + let quote_univ_level u = quote_level u (* todo : can be deduced from quote_level, hence shoud be in the Reify module *) let quote_univ_instance u = let arr = Univ.Instance.to_array u in (* we assume that valid instances do not contain [Prop] or [SProp] *) - to_coq_listl tlevel (CArray.map_to_list quote_nonprop_level arr) + to_coq_listl tlevel (CArray.map_to_list quote_level arr) let is_Lt = function | Univ.Lt -> true @@ -326,22 +322,22 @@ struct constr_mkApp (tadd_global_constraints, [|constr_mkApp (cMonomorphic_ctx, [| uctx |]); Lazy.force tinit_graph|]) - let sprop_level = - lazy (constr_mkApp (cInl, [|Lazy.force tproplevel;Lazy.force tlevel;Lazy.force tlevelSProp |])) - let prop_level = - lazy (constr_mkApp (cInl, [|Lazy.force tproplevel;Lazy.force tlevel;Lazy.force tlevelProp |])) + let sprop = + lazy (constr_mkApp (sSProp, [|Lazy.force tuniverse |])) + let prop = + lazy (constr_mkApp (sProp, [|Lazy.force tuniverse |])) let quote_sort s = match s with - | Sorts.Set -> quote_universe Universe.type0 - | Sorts.Prop -> constr_mkApp (tof_levels, [| Lazy.force prop_level |]) - | Sorts.SProp -> constr_mkApp (tof_levels, [| Lazy.force sprop_level |]) - | Sorts.Type u -> quote_universe u + | Sorts.Set -> constr_mkApp (sType, [| Lazy.force tuniverse; quote_universe Universe.type0 |]) + | Sorts.Prop -> Lazy.force prop + | Sorts.SProp -> Lazy.force sprop + | Sorts.Type u -> constr_mkApp (sType, [| Lazy.force tuniverse; quote_universe u |]) let quote_sort_family = function | Sorts.InProp -> Lazy.force sfProp | Sorts.InSet -> Lazy.force sfSet | Sorts.InType -> Lazy.force sfType - | Sorts.InSProp -> Lazy.force sfProp (* FIXME SProp *) + | Sorts.InSProp -> Lazy.force sfSProp let quote_context_decl na b t = constr_mkApp (tmkdecl, [| Lazy.force tTerm; na; quote_optionl tTerm b; t |]) diff --git a/template-coq/src/constr_reification.ml b/template-coq/src/constr_reification.ml index dc323027f..ff8c9f665 100644 --- a/template-coq/src/constr_reification.ml +++ b/template-coq/src/constr_reification.ml @@ -125,9 +125,9 @@ struct let kVmCast = ast "VmCast" let kNative = ast "NativeCast" let kCast = ast "Cast" - let lSProp = ast "universe.lsprop" - let lProp = ast "universe.lprop" - let lnpe = ast "universe.lnpe" + let sSProp = ast "sort.sprop" + let sProp = ast "sort.prop" + let sType = ast "sort.type" let lzero = ast "level.lzero" let tsort_family = ast "sort_family" let lfresh_universe = ast "fresh_universe" @@ -163,6 +163,7 @@ struct let tMPdot = ast "MPdot" let tfresh_evar_id = ast "fresh_evar_id" + let tuniverse = ast "universe.t" let tproplevel = ast "level.prop_level_type" let tlevelSProp = ast "level.lsprop" let tlevelProp = ast "level.lprop" @@ -177,13 +178,12 @@ struct let tBuild_Universe = ast "universe.build0" let tfrom_kernel_repr = ast "universe.from_kernel_repr" (* let tto_kernel_repr = ast "universe.to_kernel_repr" *) - let tof_levels = ast "universe.of_levels" + let tof_level = ast "universe.make_of_level" let tLevelSet_of_list = ast "universe.of_list" let noprop_tSet = ast "noproplevel.lzero" let noprop_tLevel = ast "noproplevel.Level" let noprop_tLevelVar = ast "noproplevel.Var" let univexpr_lProp = ast "levelexpr.prop" - let univexpr_npe = ast "levelexpr.npe" (* let tunivcontext = resolve_symbol pkg_univ "universe_context" *) let tVariance = ast "variance.t" diff --git a/template-coq/src/denoter.ml b/template-coq/src/denoter.ml index 880033ac2..bfb34c032 100644 --- a/template-coq/src/denoter.ml +++ b/template-coq/src/denoter.ml @@ -22,7 +22,7 @@ sig val unquote_inductive : quoted_inductive -> Names.inductive (*val unquote_univ_instance : quoted_univ_instance -> Univ.Instance.t *) val unquote_proj : quoted_proj -> (quoted_inductive * quoted_int * quoted_int) - val unquote_universe : Evd.evar_map -> quoted_sort -> Evd.evar_map * Sorts.t + val unquote_sort : Evd.evar_map -> quoted_sort -> Evd.evar_map * Sorts.t val unquote_universe_level : Evd.evar_map -> quoted_univ_level -> Evd.evar_map * Univ.Level.t val unquote_universe_instance: Evd.evar_map -> quoted_univ_instance -> Evd.evar_map * Univ.Instance.t (* val representsIndConstuctor : quoted_inductive -> Term.constr -> bool *) @@ -72,7 +72,7 @@ struct | ACoq_tEvar (n, l) -> let evm, l' = map_evm (aux env) evm l in D.unquote_evar env evm n l' - | ACoq_tSort x -> let evm, u = D.unquote_universe evm x in evm, Constr.mkSort u + | ACoq_tSort x -> let evm, s = D.unquote_sort evm x in evm, Constr.mkSort s | ACoq_tCast (t,c,ty) -> let evm, t = aux env evm t in let evm, ty = aux env evm ty in evm, Constr.mkCast (t, D.unquote_cast_kind c, ty) diff --git a/template-coq/theories/Ast.v b/template-coq/theories/Ast.v index dbc367c9d..e0cf8a9dc 100644 --- a/template-coq/theories/Ast.v +++ b/template-coq/theories/Ast.v @@ -400,7 +400,7 @@ Inductive term : Type := | tRel (n : nat) | tVar (id : ident) (* For free variables (e.g. in a goal) *) | tEvar (ev : nat) (args : list term) -| tSort (s : Universe.t) +| tSort (s : sort) | tCast (t : term) (kind : cast_kind) (v : term) | tProd (na : aname) (ty : term) (body : term) | tLambda (na : aname) (ty : term) (body : term) @@ -569,7 +569,7 @@ Fixpoint noccur_between k n (t : term) : bool := | tArray u' arr def ty => tArray (subst_instance_level u u') (List.map (subst_instance_constr u) arr) (subst_instance_constr u def) (subst_instance_constr u ty) | tEvar ev args => tEvar ev (List.map (subst_instance_constr u) args) - | tSort s => tSort (subst_instance_univ u s) + | tSort s => tSort (subst_instance_sort u s) | tConst c u' => tConst c (subst_instance_instance u u') | tInd i u' => tInd i (subst_instance_instance u u') | tConstruct ind k u' => tConstruct ind k (subst_instance_instance u u') @@ -595,7 +595,7 @@ Fixpoint noccur_between k n (t : term) : bool := (** Tests that the term is closed over [k] universe variables *) Fixpoint closedu (k : nat) (t : term) : bool := match t with - | tSort univ => closedu_universe k univ + | tSort univ => closedu_sort k univ | tInd _ u => closedu_instance k u | tConstruct _ _ u => closedu_instance k u | tConst _ u => closedu_instance k u diff --git a/template-coq/theories/AstUtils.v b/template-coq/theories/AstUtils.v index 07e3c0d16..8dd36445b 100644 --- a/template-coq/theories/AstUtils.v +++ b/template-coq/theories/AstUtils.v @@ -380,13 +380,15 @@ Definition mkCase_old (Σ : global_env) (ci : case_info) (p : term) (c : term) ( tt oib.(ind_ctors) brs ;; ret (tCase ci p' c brs'). -Definition default_sort_family (u : Universe.t) : allowed_eliminations := - if Universe.is_sprop u then IntoAny - else if Universe.is_prop u then IntoPropSProp - else IntoAny. +Definition default_sort_family (s : sort) : allowed_eliminations := + match s with + | sSProp => IntoSProp + | sProp => IntoPropSProp + | _ => IntoAny + end. -Definition default_relevance (u : Universe.t) : relevance := - if Universe.is_sprop u then Irrelevant +Definition default_relevance (s : sort) : relevance := + if Sort.is_sprop s then Irrelevant else Relevant. (** Convenience functions for building constructors and inductive declarations *) @@ -411,15 +413,15 @@ Definition make_constructor_body (id : ident) (indrel : nat) derived from the universe (i.e. does not handle inductives with singleton elimination, or impredicate set eliminations). *) Definition make_inductive_body (id : ident) (params : context) (indices : context) - (u : Universe.t) (ind_ctors : list constructor_body) : one_inductive_body := + (s : sort) (ind_ctors : list constructor_body) : one_inductive_body := {| ind_name := id; ind_indices := indices; - ind_sort := u; - ind_type := it_mkProd_or_LetIn (params ,,, indices) (tSort u); - ind_kelim := default_sort_family u; + ind_sort := s; + ind_type := it_mkProd_or_LetIn (params ,,, indices) (tSort s); + ind_kelim := default_sort_family s; ind_ctors := ind_ctors; ind_projs := []; - ind_relevance := default_relevance u |}. + ind_relevance := default_relevance s |}. Ltac change_Sk := repeat match goal with diff --git a/template-coq/theories/Checker.v b/template-coq/theories/Checker.v index 8a8574408..6b5c7b1fc 100644 --- a/template-coq/theories/Checker.v +++ b/template-coq/theories/Checker.v @@ -368,7 +368,7 @@ Fixpoint eq_term `{checker_flags} (φ : universes_graph) (t u : term) {struct t} | tRel n, tRel n' => Nat.eqb n n' | tEvar ev args, tEvar ev' args' => Nat.eqb ev ev' && forallb2 (eq_term φ) args args' | tVar id, tVar id' => eqb id id' - | tSort s, tSort s' => check_eqb_universe φ s s' + | tSort s, tSort s' => check_eqb_sort φ s s' | tCast f k T, tCast f' k' T' => eq_term φ f f' && eq_term φ T T' | tApp f args, tApp f' args' => eq_term φ f f' && forallb2 (eq_term φ) args args' | tConst c u, tConst c' u' => eq_constant c c' && eqb_univ_instance φ u u' @@ -400,7 +400,7 @@ Fixpoint leq_term `{checker_flags} (φ : universes_graph) (t u : term) {struct t | tRel n, tRel n' => Nat.eqb n n' | tEvar ev args, tEvar ev' args' => Nat.eqb ev ev' && forallb2 (eq_term φ) args args' | tVar id, tVar id' => eqb id id' - | tSort s, tSort s' => check_leqb_universe φ s s' + | tSort s, tSort s' => check_leqb_sort φ s s' | tApp f args, tApp f' args' => eq_term φ f f' && forallb2 (eq_term φ) args args' | tCast f k T, tCast f' k' T' => eq_term φ f f' && eq_term φ T T' | tConst c u, tConst c' u' => eq_constant c c' && eqb_univ_instance φ u u' @@ -631,7 +631,7 @@ Section Typecheck. | None => raise (NotEnoughFuel fuel) end. - Definition reduce_to_sort Γ (t : term) : typing_result Universe.t := + Definition reduce_to_sort Γ (t : term) : typing_result sort := match t with | tSort s => ret s | _ => @@ -723,7 +723,7 @@ Section Typecheck. | tVar n => raise (UnboundVar n) | tEvar ev args => raise (UnboundEvar ev) - | tSort s => ret (tSort (Universe.super s)) + | tSort s => ret (tSort (Sort.super s)) | tCast c k t => infer_type infer Γ t ;; @@ -733,7 +733,7 @@ Section Typecheck. | tProd n t b => s1 <- infer_type infer Γ t ;; s2 <- infer_type infer (Γ ,, vass n t) b ;; - ret (tSort (Universe.sort_of_product s1 s2)) + ret (tSort (Sort.sort_of_product s1 s2)) | tLambda n t b => infer_type infer Γ t ;; diff --git a/template-coq/theories/Constants.v b/template-coq/theories/Constants.v index 1c7834eca..62c1a06a7 100644 --- a/template-coq/theories/Constants.v +++ b/template-coq/theories/Constants.v @@ -106,8 +106,9 @@ Register MetaCoq.Common.Universes.ConstraintType.Lt as metacoq.ast.constraints.L Register MetaCoq.Common.Universes.ConstraintType.Le0 as metacoq.ast.constraints.Le0. Register MetaCoq.Common.Universes.ConstraintType.Le as metacoq.ast.constraints.Le. Register MetaCoq.Common.Universes.ConstraintType.Eq as metacoq.ast.constraints.Eq. +Register MetaCoq.Common.Universes.Universe.t as metacoq.ast.universe.t. +Register MetaCoq.Common.Universes.Universe.make' as metacoq.ast.universe.make_of_level. Register MetaCoq.Common.Universes.Universe.from_kernel_repr as metacoq.ast.universe.from_kernel_repr. -Register MetaCoq.Common.Universes.Universe.of_levels as metacoq.ast.universe.of_levels. Register MetaCoq.Common.Universes.LevelSetProp.of_list as metacoq.ast.universe.of_list. Register MetaCoq.Common.Universes.Level.t as metacoq.ast.level.t. Register MetaCoq.Common.Universes.Level.level as metacoq.ast.level.Level. @@ -116,13 +117,12 @@ Register MetaCoq.Common.Universes.PropLevel.lProp as metacoq.ast.level.lprop. Register MetaCoq.Common.Universes.PropLevel.lSProp as metacoq.ast.level.lsprop. Register MetaCoq.Common.Universes.Level.lzero as metacoq.ast.level.lzero. Register MetaCoq.Common.Universes.Level.lvar as metacoq.ast.level.Var. -Register MetaCoq.Common.Universes.Universe.lType as metacoq.ast.levelexpr.npe. Register MetaCoq.Common.Universes.LevelExprSet.Mkt as metacoq.ast.levelexprset.mkt. Register MetaCoq.Common.Universes.Build_nonEmptyLevelExprSet as metacoq.ast.universe.build0. -Register MetaCoq.Common.Universes.Universe.lSProp as metacoq.ast.universe.lsprop. -Register MetaCoq.Common.Universes.Universe.lProp as metacoq.ast.universe.lprop. -Register MetaCoq.Common.Universes.Universe.lType as metacoq.ast.universe.lnpe. +Register MetaCoq.Common.Universes.Sort.sSProp as metacoq.ast.sort.sprop. +Register MetaCoq.Common.Universes.Sort.sProp as metacoq.ast.sort.prop. +Register MetaCoq.Common.Universes.Sort.sType as metacoq.ast.sort.type. Register MetaCoq.Common.Universes.Variance.t as metacoq.ast.variance.t. diff --git a/template-coq/theories/EtaExpand.v b/template-coq/theories/EtaExpand.v index 2a57e7a22..2142e448c 100644 --- a/template-coq/theories/EtaExpand.v +++ b/template-coq/theories/EtaExpand.v @@ -255,7 +255,7 @@ Inductive expanded (Γ : list nat): term -> Prop := | expanded_tRel_app (n : nat) args m : nth_error Γ n = Some m -> m <= #|args| -> Forall (expanded Γ) args -> expanded Γ (tApp (tRel n) args) | expanded_tVar (id : ident) : expanded Γ (tVar id) | expanded_tEvar (ev : nat) (args : list term) : Forall (expanded Γ) args -> expanded Γ (tEvar ev args) -| expanded_tSort (s : Universe.t) : expanded Γ (tSort s) +| expanded_tSort (s : sort) : expanded Γ (tSort s) | expanded_tCast (t : term) (kind : cast_kind) (v : term) : expanded Γ t -> expanded Γ v -> expanded Γ (tCast t kind v) | expanded_tProd (na : aname) (ty : term) (body : term) : (* expanded Γ ty -> expanded Γ body -> *) expanded Γ (tProd na ty body) | expanded_tLambda (na : aname) (ty : term) (body : term) : (* expanded Γ ty -> *) expanded (0 :: Γ) body -> expanded Γ (tLambda na ty body) @@ -308,7 +308,7 @@ forall (Σ : global_env) (P : list nat -> term -> Prop), (forall Γ, forall n : nat, forall args, forall m, nth_error Γ n = Some m -> forall Heq : m <= #|args|, Forall (expanded Σ Γ) args -> Forall (P Γ) args -> P Γ (tApp (tRel n) args)) -> (forall Γ, forall id : ident, P Γ (tVar id)) -> (forall Γ, forall (ev : nat) (args : list term), Forall (expanded Σ Γ) args -> Forall (P Γ) args -> P Γ (tEvar ev args)) -> -(forall Γ, forall s : Universe.t, P Γ (tSort s)) -> +(forall Γ, forall s : sort, P Γ (tSort s)) -> (forall Γ, forall (t : term) (kind : cast_kind) (v : term), expanded Σ Γ t -> P Γ t -> expanded Σ Γ v -> P Γ v -> P Γ (tCast t kind v)) -> (forall Γ, forall (na : aname) (ty body : term), P Γ (tProd na ty body)) -> diff --git a/template-coq/theories/Pretty.v b/template-coq/theories/Pretty.v index 694ce8383..2a16201f6 100644 --- a/template-coq/theories/Pretty.v +++ b/template-coq/theories/Pretty.v @@ -131,11 +131,11 @@ Module PrintTermTree. let ctx' := fix_context defs in print_list (print_def (print_term Γ true) (print_term (fresh_names Σ Γ ctx') true)) (nl ^ " with ") defs. - Definition print_universe u := - match u with - | Universe.lProp => "Prop" - | Universe.lSProp => "SProp" - | Universe.lType l => + Definition print_sort (s : sort) := + match s with + | sProp => "Prop" + | sSProp => "SProp" + | sType l => if with_universes then ("Type(" ++ MCString.string_of_list string_of_level_expr (LevelExprSet.elements l) ++ @@ -153,7 +153,7 @@ Module PrintTermTree. end | tVar n => "Var(" ^ n ^ ")" | tEvar ev args => "Evar(" ^ string_of_nat ev ^ "[]" (* TODO *) ^ ")" - | tSort s => print_universe s + | tSort s => print_sort s | tCast c k t => parens top (print_term Γ true c ^ ":" ^ print_term Γ true t) | tProd na dom codom => let na' := (fresh_name Σ Γ na.(binder_name) (Some dom)) in diff --git a/template-coq/theories/ReflectAst.v b/template-coq/theories/ReflectAst.v index 712f4ebd0..f2decc81a 100644 --- a/template-coq/theories/ReflectAst.v +++ b/template-coq/theories/ReflectAst.v @@ -24,7 +24,7 @@ Local Ltac fcase c := Local Ltac term_dec_tac term_dec := repeat match goal with | t : term, u : term |- _ => fcase (term_dec t u) - | u : Universe.t, u' : Universe.t |- _ => fcase (eq_dec u u') + | u : sort, u' : sort |- _ => fcase (eq_dec u u') | x : Instance.t, y : Instance.t |- _ => fcase (eq_dec x y) | x : list Level.t, y : Instance.t |- _ => diff --git a/template-coq/theories/TemplateMonad/Core.v b/template-coq/theories/TemplateMonad/Core.v index f06d419a8..56452ab8b 100644 --- a/template-coq/theories/TemplateMonad/Core.v +++ b/template-coq/theories/TemplateMonad/Core.v @@ -204,12 +204,18 @@ Definition TypeInstanceOptimized : Common.TMInstance := Definition TypeInstance : Common.TMInstance := Eval hnf in TypeInstanceUnoptimized. -Definition tmQuoteUniverse@{U t u} : TemplateMonad@{t u} Universe.t - := u <- @tmQuote Prop (Type@{U} -> True);; - match u with - | tProd _ (tSort u) _ => ret u +Definition tmQuoteSort@{U t u} : TemplateMonad@{t u} sort + := p <- @tmQuote Prop (Type@{U} -> True);; + match p with + | tProd _ (tSort s) _ => ret s | _ => tmFail "Anomaly: tmQuote (Type -> True) should be (tProd _ (tSort _) _)!"%bs end. +Definition tmQuoteUniverse@{U t u} : TemplateMonad@{t u} Universe.t + := s <- @tmQuoteSort@{U t u};; + match s with + | sType u => ret u + | _ => tmFail "Sort does not carry a universe (is not Type)"%bs + end. Definition tmQuoteLevel@{U t u} : TemplateMonad@{t u} Level.t := u <- tmQuoteUniverse@{U t u};; match Universe.get_is_level u with diff --git a/template-coq/theories/TermEquality.v b/template-coq/theories/TermEquality.v index 653533f9a..e390f61fa 100644 --- a/template-coq/theories/TermEquality.v +++ b/template-coq/theories/TermEquality.v @@ -9,8 +9,8 @@ From Equations.Prop Require Import DepElim. From Equations Require Import Equations. Set Equations With UIP. -Definition R_universe_instance R := - fun u u' => Forall2 R (List.map Universe.make u) (List.map Universe.make u'). +Definition cmp_universe_instance (cmp_univ : Universe.t -> Universe.t -> Prop) : Instance.t -> Instance.t -> Prop := + Forall2 (on_rel cmp_univ Universe.make'). (** Cumulative inductive types: @@ -19,26 +19,15 @@ Definition R_universe_instance R := even on ill-formed terms. It corresponds to the right notion on well-formed terms. *) -Definition R_universe_variance (Re Rle : Universe.t -> Universe.t -> Prop) v u u' := +Definition cmp_universe_variance (cmp_univ : conv_pb -> Universe.t -> Universe.t -> Prop) pb v u u' := match v with | Variance.Irrelevant => True - | Variance.Covariant => Rle (Universe.make u) (Universe.make u') - | Variance.Invariant => Re (Universe.make u) (Universe.make u') + | Variance.Covariant => on_rel (cmp_univ pb) Universe.make' u u' + | Variance.Invariant => on_rel (cmp_univ Conv) Universe.make' u u' end. -Fixpoint R_universe_instance_variance Re Rle v u u' := - match u, u' return Prop with - | u :: us, u' :: us' => - match v with - | [] => R_universe_instance_variance Re Rle v us us' - (* Missing variance stands for irrelevance, we still check that the instances have - the same length. *) - | v :: vs => R_universe_variance Re Rle v u u' /\ - R_universe_instance_variance Re Rle vs us us' - end - | [], [] => True - | _, _ => False - end. +Definition cmp_universe_instance_variance cmp_univ pb v u u' := + Forall3 (cmp_universe_variance cmp_univ pb) v u u'. Definition global_variance_gen lookup gr napp := match gr with @@ -46,64 +35,128 @@ Definition global_variance_gen lookup gr napp := match lookup_inductive_gen lookup ind with | Some (mdecl, idecl) => match destArity [] idecl.(ind_type) with - | Some (ctx, _) => if (context_assumptions ctx) <=? napp then mdecl.(ind_variance) - else None - | None => None + | Some (ctx, _) => if (context_assumptions ctx) <=? napp then + match mdecl.(ind_variance) with + | Some var => Variance var + | None => AllEqual + end + else AllEqual + | None => AllEqual end - | None => None + | None => AllEqual end | ConstructRef ind k => match lookup_constructor_gen lookup ind k with | Some (mdecl, idecl, cdecl) => if (cdecl.(cstr_arity) + mdecl.(ind_npars))%nat <=? napp then (** Fully applied constructors are always compared at the same supertype, - which implies that no universe ws_cumul_pb needs to be checked here. *) - Some [] - else None - | _ => None + which implies that no universe ws_cumul_pb needs to be checked here. + We will still check that the instances have the same length. *) + AllIrrelevant + else AllEqual + | _ => AllEqual end - | _ => None + | _ => AllEqual end. Notation global_variance Σ := (global_variance_gen (lookup_env Σ)). -Definition R_opt_variance Re Rle v := +Definition cmp_opt_variance cmp_univ pb v := match v with - | Some v => R_universe_instance_variance Re Rle v - | None => R_universe_instance Re + | AllEqual => cmp_universe_instance (cmp_univ Conv) + | AllIrrelevant => fun l l' => #|l| = #|l'| + | Variance v => fun u u' => cmp_universe_instance (cmp_univ Conv) u u' \/ cmp_universe_instance_variance cmp_univ pb v u u' end. -Definition R_global_instance_gen Σ Re Rle gr napp := - R_opt_variance Re Rle (global_variance_gen Σ gr napp). +Lemma cmp_instance_opt_variance cmp_univ pb v : + RelationClasses.subrelation (cmp_opt_variance cmp_univ pb AllEqual) (cmp_opt_variance cmp_univ pb v). +Proof. + intros u u' H. + destruct v as [| |v] => //=. + 1: now apply Forall2_length in H. + now left. +Qed. + +Lemma cmp_universe_universe_variance (cmp_univ : conv_pb -> Universe.t -> Universe.t -> Prop) pb v u u' : + RelationClasses.subrelation (cmp_univ Conv) (cmp_univ pb) -> + on_rel (cmp_univ Conv) Universe.make' u u' -> cmp_universe_variance cmp_univ pb v u u'. +Proof. + destruct v => //=. + intros H H1; apply H, H1. +Qed. + +Lemma cmp_instance_variance cmp_univ pb v u u' : + RelationClasses.subrelation (cmp_univ Conv) (cmp_univ pb) -> + #|v| = #|u| -> + cmp_universe_instance (cmp_univ Conv) u u' -> cmp_universe_instance_variance cmp_univ pb v u u'. +Proof. + intros Hsub Hlen Hu. + apply Forall2_triv in Hlen. + eapply Forall2_Forall2_Forall3 in Hu; tea. + apply Forall3_impl with (1 := Hu) => v1 u1 u1' [] _ H1. + now apply cmp_universe_universe_variance. +Qed. + +Lemma cmp_opt_variance_var_dec cmp_univ pb v ui ui' : + RelationClasses.subrelation (cmp_univ Conv) (cmp_univ pb) -> + cmp_universe_instance (cmp_univ Conv) ui ui' \/ cmp_universe_instance_variance cmp_univ pb v ui ui' -> + { cmp_universe_instance (cmp_univ Conv) ui ui' } + { cmp_universe_instance_variance cmp_univ pb v ui ui' }. +Proof. + intros subr H. + elim:(eq_dec #|v| #|ui|). + - right. + destruct H as [|]; tas. + now eapply cmp_instance_variance. + - left. + destruct H as [|]; tas. + eapply @Forall3_Forall2_left with (Q := fun _ _ => True) in H => //. + apply Forall2_length in H. + now exfalso. +Qed. + +Definition cmp_global_instance_gen Σ cmp_universe pb gr napp := + cmp_opt_variance cmp_universe pb (global_variance_gen Σ gr napp). -Notation R_global_instance Σ := (R_global_instance_gen (lookup_env Σ)). +Notation cmp_global_instance Σ := (cmp_global_instance_gen (lookup_env Σ)). -Lemma R_universe_instance_impl R R' : +Lemma cmp_universe_instance_impl R R' : RelationClasses.subrelation R R' -> - RelationClasses.subrelation (R_universe_instance R) (R_universe_instance R'). + RelationClasses.subrelation (cmp_universe_instance R) (cmp_universe_instance R'). Proof. - intros H x y xy. eapply Forall2_impl ; tea. + intros H x y xy. eapply Forall2_impl; tea; unfold on_rel; auto. Qed. -Lemma R_universe_instance_impl' R R' : +Lemma cmp_universe_instance_impl' R R' : RelationClasses.subrelation R R' -> - forall u u', R_universe_instance R u u' -> R_universe_instance R' u u'. + forall u u', cmp_universe_instance R u u' -> cmp_universe_instance R' u u'. Proof. - intros H x y xy. eapply Forall2_impl ; tea. + intros H x y xy. eapply Forall2_impl; tea; unfold on_rel; auto. Qed. -Inductive compare_decls (eq_term leq_term : term -> term -> Type) : context_decl -> context_decl -> Type := - | compare_vass na T na' T' : eq_binder_annot na na' -> - leq_term T T' -> - compare_decls eq_term leq_term (vass na T) (vass na' T') - | compare_vdef na b T na' b' T' : eq_binder_annot na na' -> - eq_term b b' -> leq_term T T' -> - compare_decls eq_term leq_term (vdef na b T) (vdef na' b' T'). +Lemma cmp_universe_instance_variance_impl R R' pb pb' v : + RelationClasses.subrelation (R Conv) (R' Conv) -> + RelationClasses.subrelation (R pb) (R' pb') -> + RelationClasses.subrelation (cmp_universe_instance_variance R pb v) (cmp_universe_instance_variance R' pb' v). +Proof. + intros HConv Hpb x y xy. + eapply Forall3_impl; tea. clear v x y xy. + intros v u u'. + destruct v => //=. + all: unfold on_rel; now auto. +Qed. + + +Inductive eq_decl_upto_names : context_decl -> context_decl -> Type := + | compare_vass {na na' T} : + eq_binder_annot na na' -> eq_decl_upto_names (vass na T) (vass na' T) + | compare_vdef {na na' b T} : + eq_binder_annot na na' -> eq_decl_upto_names (vdef na b T) (vdef na' b T). -Derive Signature NoConfusion for compare_decls. +Derive Signature NoConfusion for eq_decl_upto_names. +Notation eq_context_upto_names := (All2 eq_decl_upto_names). Lemma alpha_eq_context_assumptions {Γ Δ} : - All2 (compare_decls eq eq) Γ Δ -> + eq_context_upto_names Γ Δ -> context_assumptions Γ = context_assumptions Δ. Proof. induction 1 in |- *; cbn; auto. @@ -111,7 +164,7 @@ Proof. Qed. Lemma alpha_eq_extended_subst {Γ Δ k} : - All2 (compare_decls eq eq) Γ Δ -> + eq_context_upto_names Γ Δ -> extended_subst Γ k = extended_subst Δ k. Proof. induction 1 in k |- *; cbn; auto. @@ -120,7 +173,7 @@ Proof. Qed. Lemma expand_lets_eq {Γ Δ t} : - All2 (compare_decls eq eq) Γ Δ -> + eq_context_upto_names Γ Δ -> expand_lets Γ t = expand_lets Δ t. Proof. intros. rewrite /expand_lets /expand_lets_k. @@ -128,16 +181,16 @@ Proof. Qed. Lemma alpha_eq_subst_context {Γ Δ s k} : - All2 (compare_decls eq eq) Γ Δ -> - All2 (compare_decls eq eq) (subst_context s k Γ) (subst_context s k Δ). + eq_context_upto_names Γ Δ -> + eq_context_upto_names (subst_context s k Γ) (subst_context s k Δ). Proof. intros. rewrite /subst_context. induction X. - cbn; auto. - rewrite !fold_context_k_snoc0. constructor; auto. + rewrite -(All2_length X). destruct r; subst; constructor; cbn; auto. - all:now rewrite (All2_length X). Qed. (** ** Syntactic equality up-to universes @@ -147,129 +200,137 @@ Qed. that surround the current term, used to implement cumulativity of inductive types correctly (only fully applied constructors and inductives benefit from it). *) -Inductive eq_term_upto_univ_napp Σ (Re Rle : Universe.t -> Universe.t -> Prop) (napp : nat) : term -> term -> Type := +Inductive eq_term_upto_univ_napp Σ + (cmp_universe : conv_pb -> Universe.t -> Universe.t -> Prop) + (cmp_sort : conv_pb -> sort -> sort -> Prop) + (pb : conv_pb) (napp : nat) : term -> term -> Type := | eq_Rel n : - eq_term_upto_univ_napp Σ Re Rle napp (tRel n) (tRel n) + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (tRel n) (tRel n) | eq_Evar e args args' : - All2 (eq_term_upto_univ_napp Σ Re Re 0) args args' -> - eq_term_upto_univ_napp Σ Re Rle napp (tEvar e args) (tEvar e args') + All2 (eq_term_upto_univ_napp Σ cmp_universe cmp_sort Conv 0) args args' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (tEvar e args) (tEvar e args') | eq_Var id : - eq_term_upto_univ_napp Σ Re Rle napp (tVar id) (tVar id) + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (tVar id) (tVar id) | eq_Sort s s' : - Rle s s' -> - eq_term_upto_univ_napp Σ Re Rle napp (tSort s) (tSort s') + cmp_sort pb s s' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (tSort s) (tSort s') | eq_App t t' u u' : - eq_term_upto_univ_napp Σ Re Rle (#|u| + napp) t t' -> - All2 (eq_term_upto_univ_napp Σ Re Re 0) u u' -> - eq_term_upto_univ_napp Σ Re Rle napp (tApp t u) (tApp t' u') + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb (#|u| + napp) t t' -> + All2 (eq_term_upto_univ_napp Σ cmp_universe cmp_sort Conv 0) u u' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (tApp t u) (tApp t' u') | eq_Const c u u' : - R_universe_instance Re u u' -> - eq_term_upto_univ_napp Σ Re Rle napp (tConst c u) (tConst c u') + cmp_universe_instance (cmp_universe Conv) u u' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (tConst c u) (tConst c u') | eq_Ind i u u' : - R_global_instance Σ Re Rle (IndRef i) napp u u' -> - eq_term_upto_univ_napp Σ Re Rle napp (tInd i u) (tInd i u') + cmp_global_instance Σ cmp_universe pb (IndRef i) napp u u' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (tInd i u) (tInd i u') | eq_Construct i k u u' : - R_global_instance Σ Re Rle (ConstructRef i k) napp u u' -> - eq_term_upto_univ_napp Σ Re Rle napp (tConstruct i k u) (tConstruct i k u') + cmp_global_instance Σ cmp_universe pb (ConstructRef i k) napp u u' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (tConstruct i k u) (tConstruct i k u') | eq_Lambda na na' ty ty' t t' : eq_binder_annot na na' -> - eq_term_upto_univ_napp Σ Re Re 0 ty ty' -> - eq_term_upto_univ_napp Σ Re Rle 0 t t' -> - eq_term_upto_univ_napp Σ Re Rle napp (tLambda na ty t) (tLambda na' ty' t') + eq_term_upto_univ_napp Σ cmp_universe cmp_sort Conv 0 ty ty' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb 0 t t' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (tLambda na ty t) (tLambda na' ty' t') | eq_Prod na na' a a' b b' : eq_binder_annot na na' -> - eq_term_upto_univ_napp Σ Re Re 0 a a' -> - eq_term_upto_univ_napp Σ Re Rle 0 b b' -> - eq_term_upto_univ_napp Σ Re Rle napp (tProd na a b) (tProd na' a' b') + eq_term_upto_univ_napp Σ cmp_universe cmp_sort Conv 0 a a' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb 0 b b' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (tProd na a b) (tProd na' a' b') | eq_LetIn na na' t t' ty ty' u u' : eq_binder_annot na na' -> - eq_term_upto_univ_napp Σ Re Re 0 t t' -> - eq_term_upto_univ_napp Σ Re Re 0 ty ty' -> - eq_term_upto_univ_napp Σ Re Rle 0 u u' -> - eq_term_upto_univ_napp Σ Re Rle napp (tLetIn na t ty u) (tLetIn na' t' ty' u') + eq_term_upto_univ_napp Σ cmp_universe cmp_sort Conv 0 t t' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort Conv 0 ty ty' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb 0 u u' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (tLetIn na t ty u) (tLetIn na' t' ty' u') | eq_Case ind p p' c c' brs brs' : - All2 (eq_term_upto_univ_napp Σ Re Re 0) p.(pparams) p'.(pparams) -> - R_universe_instance Re p.(puinst) p'.(puinst) -> - eq_term_upto_univ_napp Σ Re Re 0 p.(preturn) p'.(preturn) -> + All2 (eq_term_upto_univ_napp Σ cmp_universe cmp_sort Conv 0) p.(pparams) p'.(pparams) -> + cmp_universe_instance (cmp_universe Conv) p.(puinst) p'.(puinst) -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort Conv 0 p.(preturn) p'.(preturn) -> All2 eq_binder_annot p.(pcontext) p'.(pcontext) -> - eq_term_upto_univ_napp Σ Re Re 0 c c' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort Conv 0 c c' -> All2 (fun x y => All2 (eq_binder_annot) (bcontext x) (bcontext y) * - eq_term_upto_univ_napp Σ Re Re 0 (bbody x) (bbody y) + eq_term_upto_univ_napp Σ cmp_universe cmp_sort Conv 0 (bbody x) (bbody y) ) brs brs' -> - eq_term_upto_univ_napp Σ Re Rle napp (tCase ind p c brs) (tCase ind p' c' brs') + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (tCase ind p c brs) (tCase ind p' c' brs') | eq_Proj p c c' : - eq_term_upto_univ_napp Σ Re Re 0 c c' -> - eq_term_upto_univ_napp Σ Re Rle napp (tProj p c) (tProj p c') + eq_term_upto_univ_napp Σ cmp_universe cmp_sort Conv 0 c c' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (tProj p c) (tProj p c') | eq_Fix mfix mfix' idx : All2 (fun x y => - eq_term_upto_univ_napp Σ Re Re 0 x.(dtype) y.(dtype) * - eq_term_upto_univ_napp Σ Re Re 0 x.(dbody) y.(dbody) * + eq_term_upto_univ_napp Σ cmp_universe cmp_sort Conv 0 x.(dtype) y.(dtype) * + eq_term_upto_univ_napp Σ cmp_universe cmp_sort Conv 0 x.(dbody) y.(dbody) * (x.(rarg) = y.(rarg)) * eq_binder_annot x.(dname) y.(dname) )%type mfix mfix' -> - eq_term_upto_univ_napp Σ Re Rle napp (tFix mfix idx) (tFix mfix' idx) + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (tFix mfix idx) (tFix mfix' idx) | eq_CoFix mfix mfix' idx : All2 (fun x y => - eq_term_upto_univ_napp Σ Re Re 0 x.(dtype) y.(dtype) * - eq_term_upto_univ_napp Σ Re Re 0 x.(dbody) y.(dbody) * + eq_term_upto_univ_napp Σ cmp_universe cmp_sort Conv 0 x.(dtype) y.(dtype) * + eq_term_upto_univ_napp Σ cmp_universe cmp_sort Conv 0 x.(dbody) y.(dbody) * (x.(rarg) = y.(rarg)) * eq_binder_annot x.(dname) y.(dname) ) mfix mfix' -> - eq_term_upto_univ_napp Σ Re Rle napp (tCoFix mfix idx) (tCoFix mfix' idx) + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (tCoFix mfix idx) (tCoFix mfix' idx) | eq_Cast t1 c t2 t1' c' t2' : - eq_term_upto_univ_napp Σ Re Re 0 t1 t1' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort Conv 0 t1 t1' -> eq_cast_kind c c' -> - eq_term_upto_univ_napp Σ Re Re 0 t2 t2' -> - eq_term_upto_univ_napp Σ Re Rle napp (tCast t1 c t2) (tCast t1' c' t2') + eq_term_upto_univ_napp Σ cmp_universe cmp_sort Conv 0 t2 t2' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (tCast t1 c t2) (tCast t1' c' t2') -| eq_Int i : eq_term_upto_univ_napp Σ Re Rle napp (tInt i) (tInt i) -| eq_Float f : eq_term_upto_univ_napp Σ Re Rle napp (tFloat f) (tFloat f) +| eq_Int i : eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (tInt i) (tInt i) +| eq_Float f : eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (tFloat f) (tFloat f) | eq_Array u u' arr arr' def def' ty ty' : - Re (Universe.make u) (Universe.make u') -> - All2 (eq_term_upto_univ_napp Σ Re Re 0) arr arr' -> - eq_term_upto_univ_napp Σ Re Re 0 def def' -> - eq_term_upto_univ_napp Σ Re Re 0 ty ty' -> - eq_term_upto_univ_napp Σ Re Rle napp (tArray u arr def ty) (tArray u' arr' def' ty'). + cmp_universe_instance (cmp_universe Conv) [u] [u'] -> + All2 (eq_term_upto_univ_napp Σ cmp_universe cmp_sort Conv 0) arr arr' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort Conv 0 def def' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort Conv 0 ty ty' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (tArray u arr def ty) (tArray u' arr' def' ty'). -Notation eq_term_upto_univ Σ Re Rle := (eq_term_upto_univ_napp Σ Re Rle 0). +Notation eq_term_upto_univ Σ cmp_universe cmp_sort pb := (eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb 0). (* ** Syntactic conversion/cumulativity up-to universes *) -Definition compare_term `{checker_flags} (pb : conv_pb) Σ φ := - eq_term_upto_univ Σ (eq_universe φ) (compare_universe pb φ). +Definition compare_term `{checker_flags} Σ φ (pb : conv_pb) := + eq_term_upto_univ Σ (compare_universe φ) (compare_sort φ) pb. -Notation eq_term := (compare_term Conv). -Notation leq_term := (compare_term Cumul). +Notation eq_term Σ φ := (compare_term Σ φ Conv). +Notation leq_term Σ φ := (compare_term Σ φ Cumul). -Lemma R_global_instance_refl Σ Re Rle gr napp u : - RelationClasses.Reflexive Re -> - RelationClasses.Reflexive Rle -> - R_global_instance Σ Re Rle gr napp u u. +Lemma cmp_universe_instance_refl cmp_universe : + RelationClasses.Reflexive cmp_universe -> + forall u, cmp_universe_instance cmp_universe u u. +Proof. + intros refl_univ u. + apply Forall2_same; reflexivity. +Qed. + +Lemma cmp_global_instance_refl Σ cmp_universe pb gr napp : + RelationClasses.Reflexive (cmp_universe Conv) -> + RelationClasses.Reflexive (cmp_universe pb) -> + forall u, cmp_global_instance Σ cmp_universe pb gr napp u u. Proof. intros rRE rRle. - rewrite /R_global_instance_gen. - destruct global_variance_gen as [v|] eqn:lookup. - - induction u in v |- *; simpl; auto; - unfold R_opt_variance in IHu; destruct v; simpl; auto. - split; auto. - destruct t; simpl; auto. - - apply Forall2_same; eauto. + unfold cmp_global_instance_gen. + destruct global_variance_gen as [| |v] => //= u. + - now apply cmp_universe_instance_refl. + - left. now apply cmp_universe_instance_refl. Qed. #[global] Instance eq_binder_annot_equiv {A} : RelationClasses.Equivalence (@eq_binder_annot A A). @@ -295,13 +356,15 @@ Proof. intros ? ? ? ? ?. now etransitivity. Qed. -Lemma eq_term_upto_univ_refl Σ Re Rle : - RelationClasses.Reflexive Re -> - RelationClasses.Reflexive Rle -> - forall napp t, eq_term_upto_univ_napp Σ Re Rle napp t t. +Lemma eq_term_upto_univ_refl Σ cmp_universe cmp_sort pb : + RelationClasses.Reflexive (cmp_universe Conv) -> + RelationClasses.Reflexive (cmp_universe pb) -> + RelationClasses.Reflexive (cmp_sort Conv) -> + RelationClasses.Reflexive (cmp_sort pb) -> + forall napp t, eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp t t. Proof. - intros hRe hRle napp. - induction t in napp, Rle, hRle |- * using term_forall_list_rect; simpl; + intros refl_univ refl_univ' refl_sort refl_sort' napp t. + induction t in napp, pb, refl_univ', refl_sort' |- * using term_forall_list_rect; simpl; try constructor; try apply Forall_Forall2; try apply All_All2 ; try easy; try now (try apply Forall_All ; apply Forall_True). - eapply All_All2. 1: eassumption. @@ -309,8 +372,8 @@ Proof. - destruct c; constructor. - eapply All_All2. 1: eassumption. intros. easy. - - now apply R_global_instance_refl. - - now apply R_global_instance_refl. + - now apply cmp_global_instance_refl. + - now apply cmp_global_instance_refl. - destruct X as [Ppars Preturn]. eapply All_All2. 1:eassumption. intros; easy. - destruct X as [Ppars Preturn]. now apply Preturn. @@ -325,16 +388,20 @@ Qed. Lemma eq_term_refl `{checker_flags} Σ φ t : eq_term Σ φ t t. Proof. apply eq_term_upto_univ_refl. - - intro; apply eq_universe_refl. - - intro; apply eq_universe_refl. + - apply eq_universe_refl. + - apply eq_universe_refl. + - apply eq_sort_refl. + - apply eq_sort_refl. Qed. Lemma leq_term_refl `{checker_flags} Σ φ t : leq_term Σ φ t t. Proof. apply eq_term_upto_univ_refl. - - intro; apply eq_universe_refl. - - intro; apply leq_universe_refl. + - apply eq_universe_refl. + - apply leq_universe_refl. + - intro; apply eq_sort_refl. + - intro; apply leq_sort_refl. Qed. (* Lemma eq_term_leq_term `{checker_flags} Σ φ napp t u : @@ -343,120 +410,82 @@ Proof. induction t in u |- * using term_forall_list_rect; simpl; inversion 1; subst; constructor; try (now unfold eq_term, leq_term in * ); try eapply Forall2_impl' ; try eapply All2_impl' ; try easy. - now apply eq_universe_leq_universe. - all: try (apply Forall_True, eq_universe_leq_universe). + now apply eq_sort_leq_sort. + all: try (apply Forall_True, eq_sort_leq_sort). apply IHt. Qed. *) -#[global] Instance R_global_instance_impl_same_napp Σ Re Re' Rle Rle' gr napp : - RelationClasses.subrelation Re Re' -> - RelationClasses.subrelation Rle Rle' -> - subrelation (R_global_instance Σ Re Rle gr napp) (R_global_instance Σ Re' Rle' gr napp). -Proof. - intros he hle t t'. - rewrite /R_global_instance_gen /R_opt_variance. - destruct global_variance_gen as [v|] eqn:glob. - induction t in v, t' |- *; destruct v, t'; simpl; auto. - intros []; split; auto. - destruct t0; simpl; auto. - now eapply R_universe_instance_impl'. -Qed. - -Lemma eq_term_upto_univ_morphism0 Σ (Re Re' : _ -> _ -> Prop) - (Hre : forall t u, Re t u -> Re' t u) - : forall t u napp, eq_term_upto_univ_napp Σ Re Re napp t u -> eq_term_upto_univ_napp Σ Re' Re' napp t u. -Proof. - fix aux 4. - destruct 1; constructor; eauto. - all: unfold R_universe_instance in *. - all: try solve[ match goal with - | H : All2 _ _ _ |- _ => clear -H aux; induction H; constructor; eauto - | H : Forall2 _ _ _ |- _ => induction H; constructor; eauto - end]. - - eapply R_global_instance_impl_same_napp; eauto. - - eapply R_global_instance_impl_same_napp; eauto. - - induction a1; constructor; auto. intuition auto. - - induction a; constructor; auto. intuition auto. - - induction a; constructor; auto. intuition auto. -Qed. - -Lemma eq_term_upto_univ_morphism Σ (Re Re' Rle Rle' : _ -> _ -> Prop) - (Hre : forall t u, Re t u -> Re' t u) - (Hrle : forall t u, Rle t u -> Rle' t u) - : forall t u napp, eq_term_upto_univ_napp Σ Re Rle napp t u -> eq_term_upto_univ_napp Σ Re' Rle' napp t u. +#[global] Instance cmp_global_instance_impl_same_napp Σ cmp_universe cmp_universe' pb pb' gr napp : + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe' Conv) -> + RelationClasses.subrelation (cmp_universe pb) (cmp_universe' pb') -> + subrelation (cmp_global_instance Σ cmp_universe pb gr napp) (cmp_global_instance Σ cmp_universe' pb' gr napp). Proof. - fix aux 4. - destruct 1; constructor; eauto using eq_term_upto_univ_morphism0. - all: unfold R_universe_instance in *. - all: try solve [match goal with - | H : Forall2 _ _ _ |- _ => induction H; constructor; - eauto using eq_term_upto_univ_morphism0 - | H : All2 _ _ _ |- _ => induction H; constructor; - eauto using eq_term_upto_univ_morphism0 - end]. - - clear X. induction a; constructor; eauto using eq_term_upto_univ_morphism0. - - eapply R_global_instance_impl_same_napp; eauto. - - eapply R_global_instance_impl_same_napp; eauto. - - clear X1 X2. induction a1; constructor; eauto using eq_term_upto_univ_morphism0. - destruct r0. split; eauto using eq_term_upto_univ_morphism0. - - induction a; constructor; eauto using eq_term_upto_univ_morphism0. - destruct r as [[[? ?] ?] ?]. - repeat split; eauto using eq_term_upto_univ_morphism0. - - induction a; constructor; eauto using eq_term_upto_univ_morphism0. - destruct r as [[[? ?] ?] ?]. - repeat split; eauto using eq_term_upto_univ_morphism0. + intros sub_conv sub_pb u u'. + unfold cmp_global_instance_gen, cmp_opt_variance. + destruct global_variance_gen as [| |v] => //. + 1: now apply cmp_universe_instance_impl. + + intros [H | H]; [left | right]. + 1: eapply cmp_universe_instance_impl; tea. + + eapply Forall3_impl; tea. clear v u u' H. + intros v u u'. + destruct v => //=. + all: unfold on_rel; now auto. Qed. - -Lemma global_variance_napp_mon {Σ gr napp napp' v} : +Lemma global_variance_napp_mon Σ gr {napp napp'} : napp <= napp' -> - global_variance Σ gr napp = Some v -> - global_variance Σ gr napp' = Some v. + match global_variance Σ gr napp with + | Variance v => global_variance Σ gr napp' = Variance v + | AllEqual => True + | AllIrrelevant => global_variance Σ gr napp' = AllIrrelevant + end. Proof. intros hnapp. rewrite /global_variance_gen. - destruct gr; try congruence. - - destruct lookup_inductive_gen as [[mdecl idec]|] => //. - destruct destArity as [[ctx s]|] => //. - elim: Nat.leb_spec => // cass indv. + destruct gr => //=. + - destruct lookup_inductive_gen as [[mdecl idec]|] => //=. + destruct destArity as [[ctx s]|] => //=. + elim: Nat.leb_spec => // cass. + destruct ind_variance => //=. elim: Nat.leb_spec => //. lia. - - destruct lookup_constructor_gen as [[[mdecl idecl] cdecl]|] => //. - elim: Nat.leb_spec => // cass indv. + - destruct lookup_constructor_gen as [[[mdecl idecl] cdecl]|] => //=. + elim: Nat.leb_spec => // cass. elim: Nat.leb_spec => //. lia. Qed. -#[global] Instance R_global_instance_impl Σ Re Re' Rle Rle' gr napp napp' : - RelationClasses.subrelation Re Re' -> - RelationClasses.subrelation Re Rle' -> - RelationClasses.subrelation Rle Rle' -> +#[global] +Instance cmp_global_instance_impl Σ cmp_universe cmp_universe' pb pb' gr napp napp' : + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe' Conv) -> + RelationClasses.subrelation (cmp_universe pb) (cmp_universe' pb') -> napp <= napp' -> - subrelation (R_global_instance Σ Re Rle gr napp) (R_global_instance Σ Re' Rle' gr napp'). + subrelation (cmp_global_instance Σ cmp_universe pb gr napp) (cmp_global_instance Σ cmp_universe' pb' gr napp'). Proof. - intros he hle hele hnapp t t'. - rewrite /R_global_instance_gen /R_opt_variance. - destruct global_variance_gen as [v|] eqn:glob. - rewrite (global_variance_napp_mon hnapp glob). - induction t in v, t' |- *; destruct v, t'; simpl; auto. - intros []; split; auto. - destruct t0; simpl; auto. - destruct (global_variance _ _ napp') as [v|] eqn:glob'; eauto using R_universe_instance_impl'. - induction t in v, t' |- *; destruct v, t'; simpl; auto; intros H; inv H. - eauto. - split; auto. - destruct t0; simpl; auto. + intros sub_conv sub_pb lenapp u u'. + unfold cmp_global_instance_gen. + move: (global_variance_napp_mon Σ gr lenapp). + destruct global_variance_gen as [| |v] => //. + all: [> intros _ | intros ->; cbn ..]; auto. + 1: intro H; apply: cmp_instance_opt_variance; move: H => /=. + - now apply cmp_universe_instance_impl. + - intros [H | H]; [left | right]. + 1: eapply cmp_universe_instance_impl; tea. + eapply cmp_universe_instance_variance_impl; eassumption. Qed. -#[global] Instance eq_term_upto_univ_impl Σ Re Re' Rle Rle' napp napp' : - RelationClasses.subrelation Re Re' -> - RelationClasses.subrelation Rle Rle' -> - RelationClasses.subrelation Re Rle' -> +#[global] Instance eq_term_upto_univ_impl Σ cmp_universe cmp_universe' cmp_sort cmp_sort' pb pb' napp napp' : + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe' Conv) -> + RelationClasses.subrelation (cmp_universe pb) (cmp_universe' pb') -> + RelationClasses.subrelation (cmp_sort Conv) (cmp_sort' Conv) -> + RelationClasses.subrelation (cmp_sort pb) (cmp_sort' pb') -> napp <= napp' -> - subrelation (eq_term_upto_univ_napp Σ Re Rle napp) (eq_term_upto_univ_napp Σ Re' Rle' napp'). + subrelation (eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp) (eq_term_upto_univ_napp Σ cmp_universe' cmp_sort' pb' napp'). Proof. - intros he hle hele hnapp t t'. - induction t in napp, napp', hnapp, t', Rle, Rle', hle, hele |- * using term_forall_list_rect; + intros univ_sub_conv univ_sub_pb sort_sub_conv sort_sub_pb hnapp t t'. + induction t in napp, napp', hnapp, pb, pb', univ_sub_pb, sort_sub_pb, t' |- * using term_forall_list_rect; try (inversion 1; subst; constructor; - eauto using R_universe_instance_impl'; fail). + eauto using cmp_universe_instance_impl'; fail). - inversion 1; subst; constructor. eapply All2_impl'; tea. eapply All_impl; eauto. @@ -464,14 +493,14 @@ Proof. eapply IHt. 4:eauto. all:auto with arith. eauto. solve_all. - inversion 1; subst; constructor. - eapply R_global_instance_impl. 5:eauto. all:auto. + eapply cmp_global_instance_impl. 4:eauto. all:auto. - inversion 1; subst; constructor. - eapply R_global_instance_impl. 5:eauto. all:eauto. + eapply cmp_global_instance_impl. 4:eauto. all:eauto. - destruct X as [IHpars IHret]. inversion 1; subst; constructor; eauto. eapply All2_impl'; tea. eapply All_impl; eauto. - eapply R_universe_instance_impl; eauto. + eapply cmp_universe_instance_impl; eauto. eapply All2_impl'; eauto. cbn. eapply All_impl; eauto. @@ -485,20 +514,44 @@ Proof. eapply All_impl; eauto. cbn. intros x [? ?] y [[[? ?] ?] ?]. repeat split; eauto. - inversion 1; subst; constructor; eauto. + 1: eapply cmp_universe_instance_impl; eauto. eapply All2_impl'; tea. eapply All_impl; eauto. Qed. +Lemma eq_term_upto_univ_morphism0 Σ cmp_universe cmp_universe' cmp_sort cmp_sort' : + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe' Conv) -> + RelationClasses.subrelation (cmp_sort Conv) (cmp_sort' Conv) -> + forall t u napp, eq_term_upto_univ_napp Σ cmp_universe cmp_sort Conv napp t u -> eq_term_upto_univ_napp Σ cmp_universe' cmp_sort' Conv napp t u. +Proof. + intros univ_sub sort_sub t u napp. + apply eq_term_upto_univ_impl. + 5: auto with arith. all: auto. +Qed. + +Lemma eq_term_upto_univ_morphism Σ cmp_universe cmp_universe' cmp_sort cmp_sort' pb pb' : + RelationClasses.subrelation (cmp_universe Conv) (cmp_universe' Conv) -> + RelationClasses.subrelation (cmp_universe pb) (cmp_universe' pb') -> + RelationClasses.subrelation (cmp_sort Conv) (cmp_sort' Conv) -> + RelationClasses.subrelation (cmp_sort pb) (cmp_sort' pb') -> + forall t u napp, eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp t u -> eq_term_upto_univ_napp Σ cmp_universe' cmp_sort' pb' napp t u. +Proof. + intros univ_sub univ_sub_pb sort_sub sort_sub_pb t u napp. + apply eq_term_upto_univ_impl. + 5: auto with arith. all: auto. +Qed. Lemma eq_term_leq_term `{checker_flags} Σ φ t u : eq_term Σ φ t u -> leq_term Σ φ t u. Proof. - eapply eq_term_upto_univ_morphism. auto. - intros. - now apply eq_universe_leq_universe. + eapply eq_term_upto_univ_morphism. + - reflexivity. + - apply eq_leq_universe. + - reflexivity. + - apply eq_leq_sort. Qed. -Lemma eq_term_upto_univ_App `{checker_flags} Σ Re Rle napp f f' : - eq_term_upto_univ_napp Σ Re Rle napp f f' -> +Lemma eq_term_upto_univ_App `{checker_flags} Σ cmp_universe cmp_sort pb napp f f' : + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp f f' -> isApp f = isApp f'. Proof. inversion 1; reflexivity. @@ -511,14 +564,14 @@ Proof. inversion 1; reflexivity. Qed. -Lemma eq_term_upto_univ_mkApps `{checker_flags} Σ Re Rle napp f l f' l' : - eq_term_upto_univ_napp Σ Re Rle (#|l| + napp) f f' -> - All2 (eq_term_upto_univ Σ Re Re) l l' -> - eq_term_upto_univ_napp Σ Re Rle napp (mkApps f l) (mkApps f' l'). +Lemma eq_term_upto_univ_mkApps `{checker_flags} Σ cmp_universe cmp_sort pb napp f l f' l' : + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb (#|l| + napp) f f' -> + All2 (eq_term_upto_univ Σ cmp_universe cmp_sort Conv) l l' -> + eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp (mkApps f l) (mkApps f' l'). Proof. induction l in f, f' |- *; intro e; inversion_clear 1. - assumption. - - pose proof (eq_term_upto_univ_App _ _ _ _ _ _ e). + - pose proof (eq_term_upto_univ_App _ _ _ _ _ _ _ e). case_eq (isApp f). + intro X; rewrite X in H0. destruct f; try discriminate. @@ -540,10 +593,9 @@ Lemma leq_term_mkApps `{checker_flags} Σ φ f l f' l' : leq_term Σ φ (mkApps f l) (mkApps f' l'). Proof. intros. - eapply eq_term_upto_univ_mkApps. - eapply eq_term_upto_univ_impl. 5:eauto. 4:auto with arith. - 1-3:typeclasses eauto. - apply X0. + eapply eq_term_upto_univ_mkApps. 2: assumption. + eapply eq_term_upto_univ_impl. 6:eauto. 5:auto with arith. + all:typeclasses eauto. Qed. Lemma leq_term_App `{checker_flags} Σ φ f f' : @@ -551,4 +603,4 @@ Lemma leq_term_App `{checker_flags} Σ φ f f' : isApp f = isApp f'. Proof. inversion 1; reflexivity. -Qed. \ No newline at end of file +Qed. diff --git a/template-coq/theories/Typing.v b/template-coq/theories/Typing.v index c55ed10ff..2a313d667 100644 --- a/template-coq/theories/Typing.v +++ b/template-coq/theories/Typing.v @@ -521,7 +521,7 @@ Reserved Notation " Σ ;;; Γ |- t <=[ pb ] u " (at level 50, Γ, t, u at next l *) Inductive cumul_gen `{checker_flags} (Σ : global_env_ext) (Γ : context) (pb : conv_pb) : term -> term -> Type := - | cumul_refl t u : compare_term pb Σ (global_ext_constraints Σ) t u -> Σ ;;; Γ |- t <=[pb] u + | cumul_refl t u : compare_term Σ (global_ext_constraints Σ) pb t u -> Σ ;;; Γ |- t <=[pb] u | cumul_red_l t u v : red1 Σ.1 Γ t v -> Σ ;;; Γ |- v <=[pb] u -> Σ ;;; Γ |- t <=[pb] u | cumul_red_r t u v : Σ ;;; Γ |- t <=[pb] v -> red1 Σ.1 Γ u v -> Σ ;;; Γ |- t <=[pb] u where "Σ ;;; Γ |- t <=[ pb ] u " := (cumul_gen Σ Γ pb t u). @@ -772,8 +772,8 @@ Inductive typing `{checker_flags} (Σ : global_env_ext) (Γ : context) : term -> | type_Sort s : wf_local Σ Γ -> - wf_universe Σ s -> - Σ ;;; Γ |- tSort s : tSort (Universe.super s) + wf_sort Σ s -> + Σ ;;; Γ |- tSort s : tSort (Sort.super s) | type_Cast c k t s : Σ ;;; Γ |- t : tSort s -> @@ -783,7 +783,7 @@ Inductive typing `{checker_flags} (Σ : global_env_ext) (Γ : context) : term -> | type_Prod na t b s1 s2 : lift_typing typing Σ Γ (j_vass_s na t s1) -> Σ ;;; Γ ,, vass na t |- b : tSort s2 -> - Σ ;;; Γ |- tProd na t b : tSort (Universe.sort_of_product s1 s2) + Σ ;;; Γ |- tProd na t b : tSort (Sort.sort_of_product s1 s2) | type_Lambda na t b bty : lift_typing typing Σ Γ (j_vass na t) -> @@ -884,7 +884,7 @@ Inductive typing `{checker_flags} (Σ : global_env_ext) (Γ : context) : term -> primitive_constant Σ primArray = Some prim_ty -> declared_constant Σ prim_ty cdecl -> primitive_invariants primArray cdecl -> - let s := Universe.make u in + let s := sType (Universe.make' u) in Σ ;;; Γ |- ty : tSort s -> Σ ;;; Γ |- def : ty -> All (fun t => Σ ;;; Γ |- t : ty) arr -> @@ -1048,14 +1048,14 @@ Defined. #[global] Hint Resolve typing_wf_local : wf. Lemma type_Prop `{checker_flags} Σ : - Σ ;;; [] |- tSort Universe.lProp : tSort Universe.type1. - change ( Σ ;;; [] |- tSort (Universe.lProp) : tSort Universe.type1); + Σ ;;; [] |- tSort sProp : tSort Sort.type1. + change ( Σ ;;; [] |- tSort (sProp) : tSort Sort.type1); constructor;auto. constructor. constructor. Defined. Lemma type_Prop_wf `{checker_flags} Σ Γ : wf_local Σ Γ -> - Σ ;;; Γ |- tSort Universe.lProp : tSort Universe.type1. + Σ ;;; Γ |- tSort sProp : tSort Sort.type1. Proof. constructor;auto. constructor. Defined. @@ -1153,21 +1153,21 @@ Lemma typing_ind_env `{cf : checker_flags} : nth_error Γ n = Some decl -> PΓ Σ Γ wfΓ -> P Σ Γ (tRel n) (lift0 (S n) decl.(decl_type))) -> - (forall Σ (wfΣ : wf Σ) (Γ : context) (wfΓ : wf_local Σ Γ) (u : Universe.t), + (forall Σ (wfΣ : wf Σ) (Γ : context) (wfΓ : wf_local Σ Γ) (u : sort), PΓ Σ Γ wfΓ -> - wf_universe Σ u -> - P Σ Γ (tSort u) (tSort (Universe.super u))) -> + wf_sort Σ u -> + P Σ Γ (tSort u) (tSort (Sort.super u))) -> (forall Σ (wfΣ : wf Σ) (Γ : context) (wfΓ : wf_local Σ Γ) (c : term) (k : cast_kind) - (t : term) (s : Universe.t), + (t : term) (s : sort), Σ ;;; Γ |- t : tSort s -> P Σ Γ t (tSort s) -> Σ ;;; Γ |- c : t -> P Σ Γ c t -> P Σ Γ (tCast c k t) t) -> - (forall Σ (wfΣ : wf Σ) (Γ : context) (wfΓ : wf_local Σ Γ) (na : aname) (t b : term) (s1 s2 : Universe.t), + (forall Σ (wfΣ : wf Σ) (Γ : context) (wfΓ : wf_local Σ Γ) (na : aname) (t b : term) (s1 s2 : sort), PΓ Σ Γ wfΓ -> lift_typing typing Σ Γ (j_vass_s na t s1) -> Pj Σ Γ (j_vass_s na t s1) -> Σ ;;; Γ,, vass na t |- b : tSort s2 -> - P Σ (Γ,, vass na t) b (tSort s2) -> P Σ Γ (tProd na t b) (tSort (Universe.sort_of_product s1 s2))) -> + P Σ (Γ,, vass na t) b (tSort s2) -> P Σ Γ (tProd na t b) (tSort (Sort.sort_of_product s1 s2))) -> (forall Σ (wfΣ : wf Σ) (Γ : context) (wfΓ : wf_local Σ Γ) (na : aname) (t b : term) (bty : term), PΓ Σ Γ wfΓ -> @@ -1290,7 +1290,7 @@ Lemma typing_ind_env `{cf : checker_flags} : primitive_constant Σ primArray = Some prim_ty -> declared_constant Σ prim_ty cdecl -> primitive_invariants primArray cdecl -> - let s := Universe.make u in + let s := sType (Universe.make' u) in Σ ;;; Γ |- ty : tSort s -> P Σ Γ ty (tSort s) -> Σ ;;; Γ |- def : ty -> @@ -1345,7 +1345,7 @@ Proof. destruct Xg. rename udecl0 into udecl. rename on_global_decl_d0 into Xg. constructor; auto; try constructor; auto. - - unshelve eset (IH' := IH ((Σ', udecl); wfΣ; []; tSort Universe.lProp; _; _)). + - unshelve eset (IH' := IH ((Σ', udecl); wfΣ; []; tSort sProp; _; _)). shelve. simpl. apply type_Prop. forward IH'. constructor 1; cbn. lia. apply IH'; auto. @@ -1384,8 +1384,7 @@ Proof. apply (IH (_; _; _; Hs)). } -- pose proof (onProjections Xg); auto. -- pose proof (ind_sorts Xg) as Xg'. unfold check_ind_sorts in *. - destruct Universe.is_prop; auto. - destruct Universe.is_sprop; auto. + destruct Sort.to_family; auto. split. apply Xg'. destruct indices_matter; auto. eapply type_local_ctx_impl. eapply Xg'. auto. intros ?? Hj. apply Xj; tas. apply lift_typing_impl with (1 := Hj); intros ?? Hs. split; tas. diff --git a/template-coq/theories/TypingWf.v b/template-coq/theories/TypingWf.v index 5c8acb0e1..a122f6b0d 100644 --- a/template-coq/theories/TypingWf.v +++ b/template-coq/theories/TypingWf.v @@ -264,6 +264,21 @@ Proof. solve_all. eapply wf_decl_extends; tea; typeclasses eauto. Qed. +Lemma sorts_local_ctx_All_wf_decl {cf:checker_flags} {Σ} {mdecl} {u: list sort} {args} : + sorts_local_ctx (fun Σ : global_env_ext => wf_decl_pred Σ) Σ + (arities_context (ind_bodies mdecl),,, ind_params mdecl) + args u -> + All (wf_decl Σ) args. +Proof. + induction args as [|[na [b|] ty] args] in u |- * ; + constructor. + - constructor; now destruct X as (?&?&?). + - eapply IHargs; now apply X. + - destruct u => //; constructor; cbnr; now destruct X as (?&?&?). + - destruct u => //; eapply IHargs; now apply X. +Qed. + + Lemma declared_inductive_wf_ctors {cf:checker_flags} {Σ} {ind} {mdecl idecl} : on_global_env cumul_gen wf_decl_pred Σ -> declared_inductive Σ ind mdecl idecl -> @@ -277,14 +292,10 @@ Proof. apply onInductives in prf. eapply nth_error_alli in Hidecl; eauto. pose proof (onConstructors Hidecl). red in X0. - solve_all. destruct X0. - clear -X ext on_cargs. - induction (cstr_args x) as [|[na [b|] ty] args] in on_cargs, y |- * ; - [| |destruct y => //]; - try destruct on_cargs; - constructor; eauto. - - destruct w; split; cbn in *; eauto using wf_extends with typeclass_instances. - - destruct w; split; cbn in *; eauto using wf_extends with typeclass_instances. + solve_all. + apply on_cargs in X0. + eapply sorts_local_ctx_All_wf_decl in X0. + solve_all. eapply wf_decl_extends; tea; typeclasses eauto. Qed. Lemma All_local_env_wf_decls Σ ctx : @@ -651,13 +662,8 @@ Section WfLookup. { unfold on_constructors in onConstructors. clear -onConstructors. induction onConstructors; constructor; auto. - destruct r. - clear -on_cargs. - revert on_cargs. revert y. generalize (cstr_args x). - induction c as [|[? [] ?] ?]; simpl; - destruct y; intuition auto; - constructor; - try red; simpl; try red in a, b; intuition eauto. } + apply on_cargs in r. + eapply sorts_local_ctx_All_wf_decl; tea. } split => //. - now destruct onArity. - rewrite ind_arity_eq in onArity . diff --git a/template-pcuic/theories/PCUICToTemplateCorrectness.v b/template-pcuic/theories/PCUICToTemplateCorrectness.v index 3633f22a3..9ef998cae 100644 --- a/template-pcuic/theories/PCUICToTemplateCorrectness.v +++ b/template-pcuic/theories/PCUICToTemplateCorrectness.v @@ -633,7 +633,7 @@ Qed. Lemma alpha_eq_trans {Γ Δ} : eq_context_upto_names Γ Δ -> - All2 (TermEquality.compare_decls eq eq) (trans_local Γ) (trans_local Δ). + TermEquality.eq_context_upto_names (trans_local Γ) (trans_local Δ). Proof. intros. eapply All2_map, All2_impl; tea. @@ -665,7 +665,7 @@ Section wtsub. ci.(ci_npar) = mdecl.(ind_npars), consistent_instance_ext Σ (PCUICEnvironment.ind_universes mdecl) (PCUICAst.puinst p), wf_predicate mdecl idecl p, - All2 (PCUICEquality.compare_decls eq eq) (PCUICCases.ind_predicate_context ci mdecl idecl) (PCUICAst.pcontext p), + eq_context_upto_names (PCUICCases.ind_predicate_context ci mdecl idecl) (PCUICAst.pcontext p), wf_local_rel Σ (Γ ,,, smash_context [] (ind_params mdecl)@[p.(puinst)]) p.(pcontext)@[p.(puinst)], PCUICSpine.spine_subst Σ Γ (PCUICAst.pparams p) (List.rev (PCUICAst.pparams p)) (PCUICEnvironment.smash_context [] (PCUICEnvironment.ind_params mdecl)@[PCUICAst.puinst p]), @@ -673,9 +673,9 @@ Section wtsub. wt Γ c & All2i (fun i cdecl br => [× wf_branch cdecl br, - All2 (PCUICEquality.compare_decls eq eq) (bcontext br) (PCUICCases.cstr_branch_context ci mdecl cdecl), + eq_context_upto_names (bcontext br) (PCUICCases.cstr_branch_context ci mdecl cdecl), wf_local_rel Σ (Γ ,,, smash_context [] (ind_params mdecl)@[p.(puinst)]) br.(bcontext)@[p.(puinst)], - All2 (PCUICEquality.compare_decls eq eq) + eq_context_upto_names (Γ ,,, PCUICCases.case_branch_context ci mdecl p (forget_types br.(bcontext)) cdecl) (Γ ,,, inst_case_branch_context p br) & wt (Γ ,,, PCUICCases.case_branch_context ci mdecl p (forget_types br.(bcontext)) cdecl) br.(bbody)]) 0 idecl.(ind_ctors) brs] @@ -834,8 +834,8 @@ Qed. Lemma map2_set_binder_name_alpha (nas : list aname) (Δ Δ' : context) : All2 (fun x y => eq_binder_annot x (decl_name y)) nas Δ -> - All2 (TermEquality.compare_decls eq eq) Δ Δ' -> - All2 (TermEquality.compare_decls eq eq) (map2 set_binder_name nas Δ) Δ'. + TermEquality.eq_context_upto_names Δ Δ' -> + TermEquality.eq_context_upto_names (map2 set_binder_name nas Δ) Δ'. Proof. intros hl. induction 1 in nas, hl |- *; cbn; auto. destruct nas; cbn; auto. @@ -866,7 +866,7 @@ Qed. Lemma map2_set_binder_name_alpha_eq (nas : list aname) (Δ Δ' : context) : All2 (fun x y => x = (decl_name y)) nas Δ' -> - All2 (TermEquality.compare_decls eq eq) Δ Δ' -> + TermEquality.eq_context_upto_names Δ Δ' -> (map2 set_binder_name nas Δ) = Δ'. Proof. intros hl. induction 1 in nas, hl |- *; cbn; auto. @@ -935,26 +935,26 @@ Proof. Qed. #[global] -Instance compare_decls_refl : Reflexive (TermEquality.compare_decls eq eq). +Instance compare_decls_refl : Reflexive (TermEquality.eq_decl_upto_names). Proof. intros [na [b|] ty]; constructor; auto. Qed. #[global] -Instance All2_compare_decls_refl : Reflexive (All2 (TermEquality.compare_decls eq eq)). +Instance All2_compare_decls_refl : Reflexive (TermEquality.eq_context_upto_names). Proof. intros x; apply All2_refl; reflexivity. Qed. #[global] -Instance All2_compare_decls_sym : Symmetric (All2 (TermEquality.compare_decls eq eq)). +Instance All2_compare_decls_sym : Symmetric (TermEquality.eq_context_upto_names). Proof. intros x y. eapply All2_symP. clear. intros d d' []; subst; constructor; auto; now symmetry. Qed. #[global] -Instance All2_compare_decls_trans : Transitive (All2 (TermEquality.compare_decls eq eq)). +Instance All2_compare_decls_trans : Transitive (TermEquality.eq_context_upto_names). Proof. intros x y z. eapply All2_trans. clear. intros d d' d'' [] H; depelim H; subst; constructor; auto; now etransitivity. @@ -1049,7 +1049,7 @@ Qed. Lemma red1_alpha_eq Σ Γ Δ T U : TT.red1 Σ Γ T U -> - All2 (TermEquality.compare_decls eq eq) Γ Δ -> + TermEquality.eq_context_upto_names Γ Δ -> TT.red1 Σ Δ T U. Proof. intros r; revert Δ. @@ -1104,7 +1104,7 @@ Proof. Qed. Lemma map2_set_binder_name_eq nas Δ Δ' : - All2 (TermEquality.compare_decls eq eq) Δ Δ' -> + TermEquality.eq_context_upto_names Δ Δ' -> map2 set_binder_name nas Δ = map2 set_binder_name nas Δ'. Proof. induction 1 in nas |- *; cbn; auto. @@ -1145,7 +1145,7 @@ Proof. Qed. Lemma trans_local_set_binder_name_eq nas Γ Δ : - All2 (PCUICEquality.compare_decls eq eq) Γ Δ -> + eq_context_upto_names Γ Δ -> trans_local (map2 PCUICEnvironment.set_binder_name nas Γ) = trans_local (map2 PCUICEnvironment.set_binder_name nas Δ). Proof. @@ -1327,19 +1327,17 @@ Proof. eapply PCUICSafeLemmata.wf_inst_case_context; tea. destruct w2. pcuic. rewrite /inst_case_context. - apply compare_decls_conv. + apply PCUICContextConversion.eq_context_upto_names_conv_context. eapply All2_app. 2:{ reflexivity. } - eapply compare_decls_eq_context. apply (PCUICAlpha.inst_case_predicate_context_eq (ind:=ci) w). - cbn. apply compare_decls_eq_context. now symmetry. } + cbn. now symmetry. } rewrite [trans_local _]map_app. eapply All2_app; [|reflexivity]. symmetry. etransitivity. rewrite (trans_case_predicate_context _ _ _ _ p d c0 s w). reflexivity. eapply alpha_eq_trans. - eapply All2_fold_All2, PCUICAlpha.inst_case_predicate_context_eq => //. - symmetry. now eapply All2_fold_All2. + eapply PCUICAlpha.inst_case_predicate_context_eq => //. - eapply wt_inv in wt as [hpars [mdecl [idecl []]]]. econstructor; eauto. @@ -1360,7 +1358,7 @@ Proof. destruct w4 as [s' Hs]. exists s'. eapply PCUICContextConversionTyp.context_conversion; tea. eapply wf_local_alpha; tea. pcuic. - now eapply compare_decls_conv. + now eapply PCUICContextConversion.eq_context_upto_names_conv_context. - eapply red1_mkApp; auto. eapply trans_wf; tea. - eapply (red1_mkApps_r _ _ _ [_] [_]); auto. @@ -1401,12 +1399,12 @@ Proof. eapply OnOne2_map. solve_all. Qed. -Lemma trans_R_global_instance Σ Re Rle gref napp u u' : - PCUICEquality.R_global_instance Σ Re Rle gref napp u u' -> - TermEquality.R_global_instance (trans_global_env Σ) Re Rle gref napp u u'. +Lemma trans_cmp_global_instance Σ cmp_universe pb gref napp u u' : + PCUICEquality.cmp_global_instance Σ cmp_universe pb gref napp u u' -> + TermEquality.cmp_global_instance (trans_global_env Σ) cmp_universe pb gref napp u u'. Proof. - unfold PCUICEquality.R_global_instance, PCUICEquality.R_global_instance_gen, PCUICEquality.global_variance. - unfold TermEquality.R_global_instance, TermEquality.global_variance. + unfold PCUICEquality.cmp_global_instance, PCUICEquality.cmp_global_instance_gen, PCUICEquality.global_variance. + unfold TermEquality.cmp_global_instance, TermEquality.global_variance. destruct gref; simpl; auto. - unfold S.lookup_inductive, S.lookup_minductive. unfold S.lookup_inductive_gen, S.lookup_minductive_gen. @@ -1431,21 +1429,19 @@ Proof. Qed. Lemma trans_eq_context_gen_eq_binder_annot Γ Δ : - eq_context_gen eq eq Γ Δ -> + eq_context_upto_names Γ Δ -> All2 eq_binder_annot (map decl_name (trans_local Γ)) (map decl_name (trans_local Δ)). Proof. - move/All2_fold_All2. intros; do 2 eapply All2_map. solve_all. destruct X; cbn; auto. Qed. -Lemma trans_eq_term_upto_univ {cf} : - forall Σ Re Rle t u napp, - PCUICEquality.eq_term_upto_univ_napp Σ Re Rle napp t u -> - TermEquality.eq_term_upto_univ_napp (trans_global_env Σ) Re Rle napp (trans t) (trans u). +Lemma trans_eq_term_upto_univ {cf} Σ cmp_universe cmp_sort pb napp t u : + PCUICEquality.eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp t u -> + TermEquality.eq_term_upto_univ_napp (trans_global_env Σ) cmp_universe cmp_sort pb napp (trans t) (trans u). Proof. - intros Σ Re Rle t u napp e. - induction t using term_forall_list_ind in Rle, napp, u, e |- *. + intros e. + induction t using term_forall_list_ind in pb, napp, u, e |- *. all: invs e; cbn. all: try solve [ constructor ; auto ]. all: try solve [ @@ -1455,11 +1451,12 @@ Proof. eapply ih ; auto end ]. - 1,6,7: try solve [ constructor; solve_all ]. - all: try solve [ constructor; now eapply trans_R_global_instance ]. - - eapply (TermEquality.eq_term_upto_univ_mkApps _ _ _ _ _ [_] _ [_]); simpl; eauto. + 1,6,7: try solve [ constructor; unfold eq_mfixpoint in *; solve_all ]. + all: try solve [ constructor; now eapply trans_cmp_global_instance ]. + - eapply (TermEquality.eq_term_upto_univ_mkApps _ _ _ _ _ _ [_] _ [_]); simpl; eauto. - destruct X1 as [Hpars [Huinst [Hctx Hret]]]. destruct X as [IHpars [IHctx IHret]]. + unfold eq_branches, eq_branch in *. constructor; cbn; auto. solve_all. red in X0. eapply trans_eq_context_gen_eq_binder_annot in Hctx. @@ -1468,6 +1465,7 @@ Proof. eapply trans_eq_context_gen_eq_binder_annot in a. now rewrite !map_context_trans. - depelim X0; cbn in X |- *; try econstructor; intuition eauto; solve_all. + repeat (constructor; tas). Qed. Lemma trans_leq_term {cf} Σ ϕ T U : diff --git a/template-pcuic/theories/TemplateToPCUIC.v b/template-pcuic/theories/TemplateToPCUIC.v index 595df18f5..7df5f442f 100644 --- a/template-pcuic/theories/TemplateToPCUIC.v +++ b/template-pcuic/theories/TemplateToPCUIC.v @@ -46,7 +46,7 @@ Section Trans. Context (Σ : global_env_map). Definition dummy_decl : context_decl := - vass {| binder_name := nAnon; binder_relevance := Relevant |} (tSort Universe.type0). + vass {| binder_name := nAnon; binder_relevance := Relevant |} (tSort Sort.type0). Definition trans_predicate ind mdecl idecl pparams puinst pcontext preturn := let pctx := map2_bias_left set_binder_name dummy_decl pcontext (ind_predicate_context ind mdecl idecl) in @@ -90,7 +90,7 @@ Section Trans. still work. *) tCase ci {| pparams := p'.(Ast.pparams); puinst := p'.(Ast.puinst); - pcontext := map (fun na => vass na (tSort Universe.type0)) p'.(Ast.pcontext); + pcontext := map (fun na => vass na (tSort Sort.type0)) p'.(Ast.pcontext); preturn := p'.(Ast.preturn) |} (trans c) [] end diff --git a/template-pcuic/theories/TemplateToPCUICCorrectness.v b/template-pcuic/theories/TemplateToPCUICCorrectness.v index 8fb49cd97..1f7514b1c 100644 --- a/template-pcuic/theories/TemplateToPCUICCorrectness.v +++ b/template-pcuic/theories/TemplateToPCUICCorrectness.v @@ -794,13 +794,13 @@ Section Trans_Global. Context (wfΣ : Typing.wf Σ). Context (wfΣ' : wf Σ'). - Lemma trans_R_global_instance {Re Rle gref napp u u'} : - SEq.R_global_instance Σ Re Rle gref napp u u' -> - R_global_instance (trans_global_env Σ) Re Rle gref napp u u'. + Lemma trans_cmp_global_instance {cmp_universe pb gref napp u u'} : + SEq.cmp_global_instance Σ cmp_universe pb gref napp u u' -> + cmp_global_instance (trans_global_env Σ) cmp_universe pb gref napp u u'. Proof. - unfold SEq.R_global_instance, SEq.global_variance. + unfold SEq.cmp_global_instance, SEq.global_variance. destruct gref; simpl; auto. - - unfold R_global_instance_gen, R_opt_variance; cbn. + - unfold cmp_global_instance_gen, cmp_opt_variance; cbn. unfold Ast.lookup_inductive_gen, lookup_inductive_gen, Ast.lookup_minductive_gen, lookup_minductive_gen. rewrite trans_lookup. destruct Ast.Env.lookup_env eqn:look => //; simpl. @@ -813,7 +813,7 @@ Section Trans_Global. generalize (trans_destArity Σ [] (Ast.Env.ind_type o) wfty wfΣ'). destruct Ast.destArity as [[ctx ps]|] eqn:eq' => /= // -> //. now rewrite context_assumptions_map. - - unfold R_global_instance_gen, R_opt_variance; cbn. + - unfold cmp_global_instance_gen, cmp_opt_variance; cbn. unfold lookup_constructor, lookup_inductive, lookup_minductive. unfold Ast.lookup_constructor, Ast.lookup_inductive, Ast.lookup_minductive. unfold lookup_constructor_gen, lookup_inductive_gen, lookup_minductive_gen. @@ -827,7 +827,7 @@ Section Trans_Global. Lemma eq_binder_annot_eq_context_gen_set_binder_name Γ Γ' Δ : All2 eq_binder_annot Γ Γ' -> - eq_context_gen eq eq (map2 set_binder_name Γ Δ) (map2 set_binder_name Γ' Δ). + eq_context_upto_names (map2 set_binder_name Γ Δ) (map2 set_binder_name Γ' Δ). Proof. induction 1 in Δ |- *. - constructor. @@ -858,16 +858,14 @@ Section Trans_Global. induction 1 in l' |- *; intros H; depelim H; intros H'; depelim H'; cbn; constructor; auto. Qed. - (* TODO updateTemplate Coq's eq_term to reflect PCUIC's cumulativity *) - Lemma trans_eq_term_upto_univ {Re Rle t u napp} : - RelationClasses.subrelation Re Rle -> + Lemma trans_eq_term_upto_univ {cmp_universe cmp_sort pb napp t u} : WfAst.wf Σ t -> WfAst.wf Σ u -> - SEq.eq_term_upto_univ_napp Σ Re Rle napp t u -> - eq_term_upto_univ_napp (trans_global_env Σ) Re Rle napp (trans (trans_global_env Σ) t) (trans (trans_global_env Σ) u). + SEq.eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp t u -> + eq_term_upto_univ_napp (trans_global_env Σ) cmp_universe cmp_sort pb napp (trans (trans_global_env Σ) t) (trans (trans_global_env Σ) u). Proof. - intros sub wt wu e. - induction t using Induction.term_forall_list_rect in sub, Rle, napp, wt, u, wu, e |- *. + intros wt wu e. + induction t using Induction.term_forall_list_rect in pb, napp, wt, u, wu, e |- *. all: invs e; cbn. all: try solve [ constructor ; auto ]. all: repeat (match goal with @@ -877,17 +875,17 @@ Section Trans_Global. all: try solve [ repeat constructor ; auto ; match goal with - | ih : forall Rle (u : Ast.term) (napp : nat), _ |- _ => + | ih : forall pb napp (u : Ast.term), _ |- _ => now eapply ih end ]. - constructor. - solve_all. eapply a; auto. tc. + solve_all. - eapply eq_term_upto_univ_napp_mkApps. + rewrite map_length. now eapply IHt. - + destruct wt, wu. solve_all. eapply a0; auto; tc. - - constructor. apply trans_R_global_instance; auto. - - constructor. apply trans_R_global_instance; auto. + + destruct wt, wu. solve_all. + - constructor. apply trans_cmp_global_instance; auto. + - constructor. apply trans_cmp_global_instance; auto. - red in X, X0. destruct wt as [mdecl' [idecl' [decli hci hpctx lenpar eqpars eqret eqc eqbrs]]]. destruct wu as [mdecl'' [idecl'' [decli' hci' hpctx' lenpars' eqpars' eqret' eqc' eqbrs']]]. @@ -902,7 +900,7 @@ Section Trans_Global. destruct X. constructor. all: try solve [ match goal with - | ih : forall Rle u, _ |- _ => + | ih : forall pb napp u, _ |- _ => now eapply ih end ]. @@ -919,7 +917,8 @@ Section Trans_Global. eapply All2_All2_All2_All3; tea. cbn. intros cdecl br br' [[eq wfb] IH] [eq' wfb'] [eqbs eqbods]. split. - { rewrite map2_map2_bias_left; len. + { unfold trans_branch; cbn. + rewrite map2_map2_bias_left; len. eapply All2_length in eq. now len in eq. rewrite map2_map2_bias_left; len. eapply All2_length in eq'. now len in eq'. @@ -951,7 +950,7 @@ Section Trans_Global. simpl. intros [? ? ? ?] [? ? ? ?] [[[? ?] [[ih1 ih2] [? ?]]] [? ?]]. simpl in *. - intuition eauto. now eapply ih1. now eapply ih2. + intuition eauto. - constructor. assert ( w1 : @@ -972,11 +971,10 @@ Section Trans_Global. simpl. intros [? ? ? ?] [? ? ? ?] [[[? ?] [[ih1 ih2] [? ?]]] [? ?]]. simpl in *. - intuition eauto. now eapply ih1. now eapply ih2. + intuition eauto. - constructor; eauto. intuition auto; constructor; cbn; eauto. - eapply (IHt1 Re); eauto. reflexivity. - eapply (IHt2 Re); eauto. reflexivity. - solve_all. eapply a; eauto. reflexivity. + + inv H4. auto. + + solve_all. Qed. Lemma trans_leq_term ϕ T U : @@ -984,7 +982,7 @@ Section Trans_Global. leq_term (trans_global_env Σ) ϕ (trans Σ' T) (trans Σ' U). Proof. intros HT HU H. - eapply trans_eq_term_upto_univ ; eauto. tc. + eapply trans_eq_term_upto_univ ; eauto. Qed. Lemma trans_eq_term φ t u : @@ -992,7 +990,7 @@ Section Trans_Global. eq_term (trans_global_env Σ) φ (trans Σ' t) (trans Σ' u). Proof. intros HT HU H. - eapply trans_eq_term_upto_univ ; eauto. tc. + eapply trans_eq_term_upto_univ ; eauto. Qed. Lemma trans_eq_term_list {φ l l'} : @@ -2206,10 +2204,10 @@ Proof. rewrite trans_reln //. Qed. -Lemma trans_wf_universe Σ u : S.wf_universe Σ u -> - wf_universe (trans_global Σ) u. +Lemma trans_wf_sort Σ u : S.wf_sort Σ u -> + wf_sort (trans_global Σ) u. Proof. - unfold S.wf_universe, wf_universe. + unfold S.wf_sort, wf_sort, S.wf_universe, wf_universe. now rewrite global_ext_levels_trans. Qed. @@ -2220,9 +2218,9 @@ Proof. induction decls; cbn; auto. Qed. -Local Hint Resolve trans_wf_universe : trans. +Local Hint Resolve trans_wf_sort : trans. Local Hint Transparent Ast.Env.global_env_ext : trans. -Local Hint Transparent Universe.t : trans. +Local Hint Transparent sort : trans. Local Hint Variables Transparent : trans. Ltac trans := try typeclasses eauto with trans. (* bug in Coq, typeclasses eauto tries exact with a quantified hypothesis starting with a let-in *) @@ -2505,7 +2503,7 @@ Proof. now rewrite H1 H2 H3 /= in H0 |- *. + constructor; eauto. cbn [array_level a]. eapply validity in X1; eauto. eapply PCUICWfUniverses.isType_wf_universes in X1. cbn [trans PCUICWfUniverses.wf_universes] in X1. - unfold PCUICWfUniverses.wf_universes in X1. cbn [PCUICWfUniverses.on_universes] in X1. + unfold PCUICWfUniverses.wf_universes in X1. cbn [PCUICWfUniverses.on_universes Sort.on_sort s] in X1. move: X1. case: PCUICWfUniverses.wf_universe_reflect => //; eauto. eauto. cbn [a array_value]. solve_all. - assert (WfAst.wf Σ B). @@ -2909,7 +2907,7 @@ Lemma trans_type_local_ctx {cf} {Σ : Ast.Env.global_env_ext} Γ cs s (Σ' := tr (trans_local Σ' cs) s. Proof. intros IH wfΣ wfΣ'. induction cs; simpl; auto. - { now intros; eapply trans_wf_universe. } + { now intros; eapply trans_wf_sort. } destruct a as [na [b|] ty] => //; intros [? ?]; cbn. all: split; auto. @@ -2950,8 +2948,7 @@ Lemma trans_check_ind_sorts {cf} Σ udecl kn mdecl n idecl Proof. intros wfΣ wfΣ' IH oni. unfold ST.check_ind_sorts, check_ind_sorts. cbn. - destruct Universe.is_prop => //. - destruct Universe.is_sprop => //. + destruct Sort.to_family => //. intros []. split => //. now rewrite -global_ext_constraints_trans in c. destruct indices_matter => //. diff --git a/test-suite/bug369.v b/test-suite/bug369.v index 22546bb68..88bfa87f9 100644 --- a/test-suite/bug369.v +++ b/test-suite/bug369.v @@ -13,7 +13,7 @@ Definition mkImplN name (A B : term) : term := Definition one_pt_i : one_inductive_entry := {| mind_entry_typename := "Point"; - mind_entry_arity := tSort Universe.type0; + mind_entry_arity := tSort Sort.type0; mind_entry_consnames := ["mkPoint"]; mind_entry_lc := [ mkImplN "coordx"%bs (tRel 0) (mkImplN "coordy"%bs (tRel 1) (tApp (tRel 3) [tRel 2]))]; @@ -24,7 +24,7 @@ Definition mut_pt_i : mutual_inductive_entry := mind_entry_record := Some (Some "mkPoint" (* Irrelevant *)); mind_entry_finite := BiFinite; mind_entry_params := [{| decl_name := bnamed "A"; decl_body := None; - decl_type := (tSort Universe.type0) |}]; + decl_type := (tSort Sort.type0) |}]; mind_entry_inds := [one_pt_i]; mind_entry_universes := Monomorphic_entry ContextSet.empty; mind_entry_template := false; diff --git a/test-suite/tmFix.v b/test-suite/tmFix.v index db8c26c69..85c370e11 100644 --- a/test-suite/tmFix.v +++ b/test-suite/tmFix.v @@ -71,7 +71,7 @@ Module Unquote. Local Unset Universe Minimization ToSet. (* idk why this is needed... *) #[local] Hint Extern 1 (Monad _) => refine TemplateMonad_Monad : typeclass_instances. - Definition tmQuoteUniverse@{U t u} : TemplateMonad@{t u} Universe.t + Definition tmQuoteUniverse@{U t u} : TemplateMonad@{t u} sort := u <- @tmQuote Prop (Type@{U} -> True);; match u with | tProd _ (tSort u) _ => ret u diff --git a/utils/theories/All_Forall.v b/utils/theories/All_Forall.v index b1ae09e83..13c8e97d6 100644 --- a/utils/theories/All_Forall.v +++ b/utils/theories/All_Forall.v @@ -80,7 +80,17 @@ Inductive All3 {A B C : Type} (R : A -> B -> C -> Type) : list A -> list B -> li R x y z -> All3 R l l' l'' -> All3 R (x :: l) (y :: l') (z :: l''). Arguments All3_nil {_ _ _ _}. Arguments All3_cons {_ _ _ _ _ _ _ _ _ _}. -Derive Signature NoConfusionHom for All3. + +Inductive Forall3 {A B C : Type} (R : A -> B -> C -> Type) : list A -> list B -> list C -> Prop := + Forall3_nil : Forall3 R [] [] [] +| Forall3_cons : forall (x : A) (y : B) (z : C) (l : list A) (l' : list B) (l'' : list C), + R x y z -> Forall3 R l l' l'' -> Forall3 R (x :: l) (y :: l') (z :: l''). +Arguments Forall3_nil {_ _ _ _}. +Arguments Forall3_cons {_ _ _ _ _ _ _ _ _ _}. + +#[global] Hint Constructors All3 Forall3 : core. +Derive Signature for All3 Forall3. +Derive NoConfusionHom for All3. Definition invert_Forall2 {A B R l l'} (a : @Forall2 A B R l l') := match a in Forall2 _ l l' @@ -269,6 +279,18 @@ Section Forallb2. End Forallb2. +Section Forallb3. + Context {A B C} (f : A -> B -> C -> bool). + + Fixpoint forallb3 l l' l'' := + match l, l', l'' with + | hd :: tl, hd' :: tl', hd'' :: tl'' => f hd hd' hd'' && forallb3 tl tl' tl'' + | [], [], [] => true + | _, _, _ => false + end. + +End Forallb3. + Lemma forallb2_refl : forall A (R : A -> A -> bool), (forall x, R x x) -> @@ -428,10 +450,28 @@ Proof. rewrite andb_and. intuition auto. Qed. -Lemma All2P {A B : Type} {p : A -> B -> bool} {l l'} : - reflectT (All2 p l l') (forallb2 p l l'). +Lemma forallb3_All3 {A B C : Type} {p : A -> B -> C -> bool} + {l : list A} {l' : list B} {l'' : list C}: + is_true (forallb3 p l l' l'') -> All3 (fun x y z => is_true (p x y z)) l l' l''. Proof. - apply equiv_reflectT. apply All2_forallb2. apply forallb2_All2. + induction l in l', l'' |- *; destruct l', l''; simpl; intros; try congruence. + - constructor. + - constructor. revert H; rewrite andb_and; intros [px pl]. auto. + apply IHl. revert H; rewrite andb_and; intros [px pl]. auto. +Qed. + +Lemma All3_forallb3 {A B C : Type} {p : A -> B -> C -> bool} + {l : list A} {l' : list B} {l'' : list C} : + All3 (fun x y z => is_true (p x y z)) l l' l'' -> is_true (forallb3 p l l' l''). +Proof. + induction 1; simpl; intros; try congruence. + rewrite andb_and. intuition auto. +Qed. + +Lemma All3P {A B C : Type} {p : A -> B -> C -> bool} {l l' l''} : + reflectT (All3 p l l' l'') (forallb3 p l l' l''). +Proof. + apply equiv_reflectT. apply All3_forallb3. apply forallb3_All3. Qed. Lemma All2_refl {A} {P : A -> A -> Type} l : @@ -715,6 +755,18 @@ Proof. eapply All2_All_right; tea. auto. Qed. +Lemma All2P {A B : Type} {P : A -> B -> Type} {p : A -> B -> bool} {l l'} : + (forall x y, reflectT (P x y) (p x y)) -> + reflectT (All2 P l l') (forallb2 p l l'). +Proof. + intro H. + apply equiv_reflectT; intro X. + - eapply All2_forallb2, All2_impl with (1 := X). + move => x y /H //. + - apply forallb2_All2 in X. + eapply All2_impl with (1 := X). + move => x y /H //. +Qed. Lemma All2i_All_left {A B} {P : nat -> A -> B -> Type} {Q : A -> Type} {n l l'} : All2i P n l l' -> @@ -1648,6 +1700,49 @@ Proof. induction 1; split; constructor; intuition eauto. Qed. +Lemma All_reflect_reflect_All2 {A B} R (P : A -> B -> Type) (p : A -> B -> bool) l l' : + All (fun x => forall y, R y -> reflectT (P x y) (p x y)) l -> + All R l' -> + reflectT (All2 P l l') (forallb2 p l l'). +Proof. + intros X' XP. + apply equiv_reflectT; intro X. + - apply All2_All_mix_left with (1 := X'), All2_All_mix_right with (1 := XP) in X. + eapply All2_forallb2, All2_impl with (1 := X). + move => x y [] [] H /H //. + - apply forallb2_All2, All2_All_mix_left with (1 := X'), All2_All_mix_right with (1 := XP) in X. + eapply All2_impl with (1 := X). + move => x y [] [] H /H //. +Qed. + +Lemma All2_reflect_reflect_All2 {A B} (P : A -> B -> Type) (p : A -> B -> bool) l l' : + All2 (fun x y => reflectT (P x y) (p x y)) l l' -> + reflectT (All2 P l l') (forallb2 p l l'). +Proof. + intro X'. + apply equiv_reflectT; intro X. + - apply All2_All2_mix with (1 := X') in X. + eapply All2_forallb2, All2_impl with (1 := X). + move => x y [] H /H //. + - apply forallb2_All2, All2_All2_mix with (1 := X') in X. + eapply All2_impl with (1 := X). + move => x y [] H /H //. +Qed. + +Lemma All3_Forall3 {A B C} {P : A -> B -> C -> Prop} {l l' l''} : + All3 P l l' l'' -> Forall3 P l l' l''. +Proof. + induction 1; auto. +Qed. + +(* Bad! Uses template polymorphism. *) +Lemma Forall3_All3 {A B C} {P : A -> B -> C -> Prop} l l' l'' : Forall3 P l l' l'' -> All3 P l l' l''. +Proof. + intros f; induction l in l', l'', f |- *; destruct l', l''; try constructor; auto. + 1-6: elimtype False; inv f. + inv f; auto. + apply IHl. inv f; auto. +Qed. Ltac toAll := match goal with @@ -1663,10 +1758,18 @@ Ltac toAll := | |- Forall2 _ _ _ => apply All2_Forall2 + | H : Forall3 _ _ _ |- _ => apply Forall3_All3 in H + + | |- Forall3 _ _ _ => apply All3_Forall3 + | H : is_true (forallb2 _ _ _) |- _ => apply forallb2_All2 in H | |- is_true (forallb2 _ _ _) => apply All2_forallb2 + | H : is_true (forallb3 _ _ _) |- _ => apply forallb3_All3 in H + + | |- is_true (forallb3 _ _ _) => apply All3_forallb3 + | [ H : All2_dep (fun x y _ => @?R' x y) ?a |- _ ] => apply (@All2_undep _ _ _ R' _ _ a) in H | [ |- All2_dep (fun x y _ => @?R' x y) ?a ] => apply (@All2_undep _ _ _ R' _ _ a) @@ -2100,6 +2203,9 @@ Qed. Lemma Forall2_length {A B} {P : A -> B -> Prop} {l l'} : Forall2 P l l' -> #|l| = #|l'|. Proof. induction 1; simpl; auto. Qed. +Lemma Forall2_triv {A B} {l : list A} {l' : list B} : #|l| = #|l'| -> Forall2 (fun _ _ => True) l l'. +Proof. induction l in l' |- *; destruct l' => //=. auto. Qed. + Lemma Forall2_app_r {A} (P : A -> A -> Prop) l l' r r' : Forall2 P (l ++ [r]) (l' ++ [r']) -> (Forall2 P l l') /\ (P r r'). Proof. @@ -2803,6 +2909,14 @@ Proof. - constructor ; eauto. Qed. +Lemma Forall2_symP {A} (P : A -> A -> Prop) : + RelationClasses.Symmetric P -> + RelationClasses.Symmetric (Forall2 P). +Proof. + intros h l l' hl. + induction hl. all: auto. +Qed. + Lemma All_All2_All2_mix {A B} (P : B -> B -> Type) (Q R : A -> B -> Type) l l' l'' : All (fun x => forall y z, Q x y -> R x z -> ∑ v, P y v * P z v) l -> All2 Q l l' -> All2 R l l'' -> ∑ l''', All2 P l' l''' * All2 P l'' l'''. @@ -3165,6 +3279,33 @@ Proof. constructor; auto. now destruct (Hp a b). Qed. +Lemma forallb3_Forall3 : + forall A B C (p : A -> B -> C -> bool) l l' l'', + forallb3 p l l' l'' -> + Forall3 (fun x y z => p x y z) l l' l''. +Proof. + intros A B C p l l' l'' h. + induction l in l', l'', h |- *. + - destruct l', l''; try discriminate. + constructor. + - destruct l', l''; try discriminate. + simpl in h. move/andb_and: h => [? ?]. + constructor. all: auto. +Qed. + +Lemma forallb3P {A B C} (P : A -> B -> C -> Prop) (p : A -> B -> C -> bool) l l' l'' : + (forall x y z, reflect (P x y z) (p x y z)) -> + reflect (Forall3 P l l' l'') (forallb3 p l l' l''). +Proof. + intros Hp. + apply iff_reflect; change (forallb3 p l l' l'' = true) with (forallb3 p l l' l'' : Prop); split. + - induction 1; rewrite /= // IHForall3 // andb_true_r. + now destruct (Hp x y z). + - induction l in l', l'' |- *; destruct l', l''; rewrite /= //. rewrite andb_and. + intros [pa pl]. + constructor; auto. now destruct (Hp a b c). +Qed. + (** All, All2 and In interactions. *) Lemma All2_In {A B} (P : A -> B -> Type) l l' x : In x l -> @@ -3579,6 +3720,14 @@ Section All2_fold. induction H; constructor; auto. Qed. + Lemma All2_fold_flip Γ Δ : + All2_fold P Γ Δ -> + All2_fold (fun Γ Γ' x y => P Γ' Γ y x) Δ Γ. + Proof using Type. + intros H. + induction H; constructor; auto. + Qed. + Lemma All2_fold_app_inv Γ Γ' Δ Δ' : #|Δ| = #|Δ'| -> All2_fold P (Δ ++ Γ) (Δ' ++ Γ') -> @@ -3872,6 +4021,90 @@ Proof. induction 1; constructor; auto. Qed. +Lemma Forall3_impl {A B C} {P Q : A -> B -> C -> Prop} {l l' l''} : + Forall3 P l l' l'' -> + (forall x y z, P x y z -> Q x y z) -> + Forall3 Q l l' l''. +Proof. + induction 1; constructor; auto. +Qed. + +Lemma Forall3_Forall2_left {A B C} {P : A -> B -> C -> Prop} {Q : A -> B -> Prop} {l l' l''} : + Forall3 P l l' l'' -> + (forall x y z, P x y z -> Q x y) -> + Forall2 Q l l'. +Proof. + induction 1; constructor; eauto. +Qed. + +Lemma Forall3_Forall2_edges {A B C} {P : A -> B -> C -> Prop} {Q : A -> C -> Prop} {l l' l''} : + Forall3 P l l' l'' -> + (forall x y z, P x y z -> Q x z) -> + Forall2 Q l l''. +Proof. + induction 1; constructor; eauto. +Qed. + +Lemma Forall3_Forall2_right {A B C} {P : A -> B -> C -> Prop} {Q : B -> C -> Prop} {l l' l''} : + Forall3 P l l' l'' -> + (forall x y z, P x y z -> Q y z) -> + Forall2 Q l' l''. +Proof. + induction 1; constructor; eauto. +Qed. + +Lemma Forall2_Forall2_Forall3 {A B C} {P : A -> B -> Prop} {Q : B -> C -> Prop} {l l' l''} : + Forall2 P l l' -> + Forall2 Q l' l'' -> + Forall3 (fun x y z => P x y /\ Q y z) l l' l''. +Proof. + induction 1 in l'' |- *; intro HQ; inv HQ; constructor; eauto. +Qed. + +Lemma Forall3_symP {A B} (P : B -> A -> A -> Prop) : + (forall b, RelationClasses.Symmetric (P b)) -> + forall l, RelationClasses.Symmetric (Forall3 P l). +Proof. + intros h l l' l'' hl. + induction hl; constructor; eauto. + now symmetry. +Qed. + +Lemma Forall3_transP {A B} (P : B -> A -> A -> Prop) : + (forall b, RelationClasses.Transitive (P b)) -> + forall l, RelationClasses.Transitive (Forall3 P l). +Proof. + intros h l0 l l' l'' hl hl'. + induction hl in l'', hl' |- *; inv hl'; econstructor; eauto. + now etransitivity. +Qed. + +Lemma Forall3_antisymP {A B} (P P' : B -> A -> A -> Prop) : + (forall b x y, P b x y -> P b y x -> P' b x y) -> + forall l l' l'', Forall3 P l l' l'' -> Forall3 P l l'' l' -> Forall3 P' l l' l''. +Proof. + intros h l l' l'' hl hl'. + induction hl in hl' |- *; inv hl'; constructor; eauto. +Qed. + +Lemma Forall3_map_inv {A B C A' B' C'} (R : A' -> B' -> C' -> Prop) (f : A -> A') (g : B -> B') (h : C -> C') l l' l'' : + Forall3 R (map f l) (map g l') (map h l'') -> + Forall3 (fun x y z => R (f x) (g y) (h z)) l l' l''. +Proof. + induction l in l', l'' |- * ; destruct l', l''; try solve [ inversion 1 ]. + - constructor. + - constructor. + + inversion H. subst. assumption. + + eapply IHl. inversion H. assumption. +Qed. + +Lemma Forall3_map {A B C A' B' C'} (R : A' -> B' -> C' -> Prop) (f : A -> A') (g : B -> B') (h : C -> C') l l' l'' : + Forall3 (fun x y z => R (f x) (g y) (h z)) l l' l'' -> + Forall3 R (map f l) (map g l') (map h l''). +Proof. + induction 1; constructor; auto. +Qed. + Lemma map2_app {A B C} (f : A -> B -> C) l0 l0' l1 l1' : #|l0| = #|l1| -> #|l0'| = #|l1'| -> map2 f (l0 ++ l0') (l1 ++ l1') = diff --git a/utils/theories/MCReflect.v b/utils/theories/MCReflect.v index 86b1b4040..9ec78f43c 100644 --- a/utils/theories/MCReflect.v +++ b/utils/theories/MCReflect.v @@ -35,6 +35,12 @@ Proof. intros [] => //. Qed. Hint View for move/ introT|2. +Lemma reflectT_change_left P Q p : + CRelationClasses.iffT P Q -> reflectT P p -> reflectT Q p. +Proof. + intros [] []; constructor; auto. +Qed. + Lemma reflectT_subrelation {A} {R} {r : A -> A -> bool} : (forall x y, reflectT (R x y) (r x y)) -> CRelationClasses.subrelation R r. Proof. intros. intros x y h. destruct (X x y); auto. diff --git a/utils/theories/MCRelations.v b/utils/theories/MCRelations.v index 59bf5552f..a2fe36e2b 100644 --- a/utils/theories/MCRelations.v +++ b/utils/theories/MCRelations.v @@ -2,6 +2,7 @@ Require Import ssreflect. Require Import Equations.Type.Relation Equations.Type.Relation_Properties. Require Import CRelationClasses. +Require RelationClasses. #[global] Hint Mode Reflexive ! ! : typeclass_instances. @@ -34,6 +35,60 @@ Notation Trel_sig R S := Notation on_Trel_eq R f g := (fun x y => (R (f x) (f y) * (g x = g y)))%type. +#[global] +Instance on_rel_refl {A B} (P : B -> B -> Prop) (f : A -> B) : + RelationClasses.Reflexive P -> + RelationClasses.Reflexive (on_rel P f). +Proof. + intros refl u. + apply refl. +Qed. + +#[global] +Instance on_rel_sym {A B} (P : B -> B -> Prop) (f : A -> B) : + RelationClasses.Symmetric P -> + RelationClasses.Symmetric (on_rel P f). +Proof. + intros sym u u'. + apply sym. +Qed. + +#[global] +Instance on_rel_trans {A B} (P : B -> B -> Prop) (f : A -> B) : + RelationClasses.Transitive P -> + RelationClasses.Transitive (on_rel P f). +Proof. + intros trans u u' u''. + apply trans. +Qed. + +#[global] +Instance on_Trel_refl {A B} (P : B -> B -> Type) (f : A -> B) : + Reflexive P -> + Reflexive (on_Trel P f). +Proof. + intros refl u. + apply refl. +Qed. + +#[global] +Instance on_Trel_sym {A B} (P : B -> B -> Type) (f : A -> B) : + Symmetric P -> + Symmetric (on_Trel P f). +Proof. + intros sym u u'. + apply sym. +Qed. + +#[global] +Instance on_Trel_trans {A B} (P : B -> B -> Type) (f : A -> B) : + Transitive P -> + Transitive (on_Trel P f). +Proof. + intros trans u u' u''. + apply trans. +Qed. + Section Flip. Local Set Universe Polymorphism. Context {A : Type} (R : crelation A).