Require Import CSet Util Get Drop Var Map OptionR AllInRel OUnion MoreList MoreListSet.

Set Implicit Arguments.

Definition restr (G:set var) (o:option (set var)) :=
  match o with
    | None => None
    | Some G' => if [G' ⊆ G] then Some G' else None
  end.

Lemma restr_iff G o G'
  : restr G o = Some G' <-> G' ⊆ G /\ o = Some G'.
Proof.
  unfold restr; destruct o; intros.
  cases; split; intros A; inv A; isabsurd; eauto.
  split; intros; dcr; congruence.
Qed.

Lemma restr_idem G o G'
  : G' ⊆ G -> restr G' (restr G o) = restr G' o.
Proof.
  unfold restr; destruct o; eauto. repeat cases; eauto.
  intros. exfalso. eapply NOTCOND. rewrite <- H. eauto.
Qed.

Lemma restr_comm o G G'
  : restr G' (restr G o) = restr G (restr G' o).
Proof.
  destruct o; unfold restr; eauto.
  repeat cases; eauto.
  exfalso; eauto.
Qed.

Instance restr_morphism
  : Proper (Equal ==> option_eq Equal ==> option_eq Equal) restr.
Proof.
  unfold Proper, respectful; intros.
  destruct x0,y0; unfold restr;
    repeat cases; try econstructor; eauto with cset;
  cset_tac.
Qed.

Instance restr_morphism_eq
  : Proper (Equal ==> eq ==> eq) restr.
Proof.
  unfold Proper, respectful; intros.
  destruct x0,y0; unfold restr;
  repeat cases; try econstructor;
  eauto; cset_tac.
Qed.

Instance restr_m2
  : Proper (Equal ==> pointwise_relation _ eq) restr.
Proof.
  unfold Proper, respectful, pointwise_relation, restr; intros; subst.
  repeat cases; eauto.
  - exfalso. eapply NOTCOND. rewrite <- H. eauto.
  - exfalso. eapply NOTCOND. rewrite H. eauto.
Qed.

Lemma restr_comp_meet G o G'
  : restr G' (restr G o) = restr (G ∩ G') o.
Proof.
  unfold restr; destruct o; eauto.
  repeat cases; eauto.
  - exfalso. eapply NOTCOND. cset_tac.
  - exfalso. rewrite COND0 in NOTCOND. eapply NOTCOND. cset_tac.
  - rewrite COND in NOTCOND. exfalso; eapply NOTCOND. cset_tac.
Qed.

Lemma restrict_comp_meet DL G G'
  : restr G' ⊝ (restr G ⊝ DL) = restr (G ∩ G') ⊝ DL.
Proof.
  rewrite map_map.
  setoid_rewrite restr_comp_meet. reflexivity.
Qed.

Lemma restrict_idem DL G G'
  : G ⊆ G' -> restr G ⊝ (restr G' ⊝ DL) = restr G ⊝ DL.
Proof.
  rewrite restrict_comp_meet; intros.
  rewrite meet_comm, <- incl_meet; eauto.
Qed.

(*
Instance restrict_morphism
  : Proper (PIR2 (option_eq Equal) ==>
                    Equal ==> PIR2 (option_eq Equal)) (restrict.
Proof.
  unfold Proper, respectful; intros.
  general induction H; simpl; try econstructor; eauto.
  rewrite pf, H0. reflexivity.
Qed.

Instance restrict_morphism_eq
  : Proper (eq ==> Equal ==> eq) restrict.
Proof.
  unfold Proper, respectful; intros; subst.
  general induction y; simpl; try econstructor; eauto.
  f_equal. rewrite H0; reflexivity. eauto.
Qed.
 *)

Fixpoint bounded (DL:list (option (set var))) (G:set var) :=
  match DL with
    | nil => True
    | Some G'::DL => G' ⊆ G /\ bounded DL G
    | None::DL => bounded DL G
  end.

Instance bounded_morphism_subset
  : Proper (eq ==> Subset ==> impl) bounded.
Proof.
  unfold Proper, respectful, impl; intros.
  subst.
  general induction y; simpl; eauto.
  destruct a; simpl in *; cset_tac; intuition.
Qed.

Instance bounded_morphism
  : Proper (eq ==> Equal ==> iff) bounded.
Proof.
  unfold Proper, respectful, impl; intros; split; intros; subst;
  eapply double_inclusion in H0; dcr.
  rewrite <- H; eauto.
  rewrite <- H2; eauto.
Qed.

Instance bounded_instance_1 DL
  : Proper (Equal ==> flip impl) (bounded DL).
Proof.
  unfold Proper, respectful, flip, impl; intros.
  rewrite H; eauto.
Qed.

Lemma bounded_get DL G G' n
  : bounded DL G -> get DL n (Some G') -> G' ⊆ G.
Proof.
  intros. general induction H0; simpl in *; eauto.
  destruct x'; eapply IHget; intuition.
Qed.

Lemma bounded_restrict DL G' G
  : G' ⊆ G -> bounded (restr G' ⊝ DL) G.
Proof.
  general induction DL; simpl; eauto.
  case_eq (restr G' a); intros; try split; eauto.
  eapply restr_iff in H0; cset_tac; intuition.
Qed.

Lemma bounded_restrict_eq DL G' G
  : G ⊆ G' -> bounded DL G -> restr G' ⊝ DL = DL.
Proof.
  general induction DL; simpl; eauto.
  case_eq (restr G' a); intros; try split; eauto.
  - eapply restr_iff in H1; dcr; simpl in *.
    subst; dcr.
    f_equal. eauto.
  - destruct a; unfold restr in H1; dcr.
    + exfalso. cases in H1; isabsurd.
      simpl in H0; dcr. cset_tac.
    + f_equal. eauto.
Qed.

Lemma restr_subset (x y: option (set var)) (G G':set var)
  (R:fstNoneOrR (flip Subset) x y) (INCL:G ⊆ G')
  : fstNoneOrR (flip Subset) (restr G x) (restr G' y).
Proof.
  unfold flip in *.
  inv R; simpl in *.
  + simpl. econstructor.
  + unfold restr. repeat cases; try econstructor; eauto.
    cset_tac.
Qed.

Lemma restrict_subset2 DL DL' G G'
: PIR2 (fstNoneOrR (flip Subset)) DL DL'
  -> G ⊆ G'
  -> PIR2 (fstNoneOrR (flip Subset)) (restr G ⊝ DL) (restr G' ⊝ DL').
Proof.
  intros. induction H; simpl; econstructor; eauto using restr_subset.
Qed.

Lemma restr_subset' (x y: option (set var)) (G G':set var)
  (R:fstNoneOrR Equal x y) (INCL:G ⊆ G')
  : fstNoneOrR Equal (restr G x) (restr G' y).
Proof.
  inv R.
  + simpl. econstructor.
  + unfold restr. repeat cases; try econstructor; eauto.
    cset_tac.
Qed.

Lemma restrict_subset DL DL' G G'
: PIR2 (fstNoneOrR Equal) DL DL'
  -> G ⊆ G'
  -> PIR2 (fstNoneOrR Equal) (restr G ⊝ DL) (restr G' ⊝ DL').
Proof.
   intros. induction H; simpl; eauto using PIR2, restr_subset'.
Qed.

Definition lookup_seto (ϱ:var->var) (x:option (set var)) : option (set var):=
  match x with
    | None => None
    | Some x => Some (lookup_set ϱ x)
  end.

Lemma lookup_seto_restr G s ϱ
  : lookup_seto ϱ (restr G ⎣ s ⎦) =
    if [ s ⊆ G ] then Some (lookup_set ϱ s) else None.
Proof.
  unfold restr; cases; reflexivity.
Qed.

Definition live_global (p:set var * list var) := Some (fst p \ of_list (snd p)).

Lemma bounded_map_lookup G (ϱ: var -> var) DL
  : bounded DL G -> bounded (lookup_seto ϱ ⊝ DL) (lookup_set ϱ G).
Proof.
  general induction DL; simpl; eauto.
  destruct a; simpl in *; dcr; eauto using lookup_set_incl.
Qed.

Lemma restrict_incl_ext DL G G' D
:  bounded DL D
   -> G ∩ D [=] G' ∩ D
   -> restr G ⊝ DL = restr G' ⊝ DL.
Proof.
  intros.
  general induction DL; simpl in *; try destruct a; dcr; eauto.
  f_equal; eauto.
  - unfold restr. repeat cases; eauto.
    exfalso. eapply NOTCOND. eapply meet_incl_eq in H0; eauto.
    rewrite meet_comm in H0. rewrite <- incl_meet in H0; eauto.
    rewrite H0. eapply meet_incl; reflexivity.
    exfalso. eapply NOTCOND. eapply meet_incl_eq in H0; eauto. symmetry in H0.
    rewrite meet_comm in H0. rewrite <- incl_meet in H0; eauto.
    rewrite H0. eapply meet_incl; reflexivity.
  - f_equal; eauto.
Qed.

Lemma list_eq_special DL ϱ A B A'
: A ⊆ B
  -> lookup_set ϱ A ⊆ A'
  -> PIR2 (fstNoneOrR Equal)
         (lookup_seto ϱ ⊝ (restr A ⊝ DL))
         (restr A' ⊝ (lookup_seto ϱ ⊝ (restr B ⊝ DL))).
Proof.
  intros. general induction DL; simpl. econstructor.
  unfold restr. unfold lookup_seto.
  destruct a; repeat cases; eauto using PIR2, @fstNoneOrR.
  - exfalso. eapply NOTCOND. lset_tac; eauto. eapply H0; lset_tac.
  - exfalso. eapply NOTCOND; rewrite <- H. eauto.
Qed.

Lemma list_eq_fstNoneOrR_incl DL ϱ A B
: A ⊆ B ->
  PIR2 (fstNoneOrR Equal)
       (lookup_seto ϱ ⊝ (restr A ⊝ DL))
       (lookup_seto ϱ ⊝ (restr B ⊝ DL)).
Proof.
  intros. general induction DL; simpl.
  - econstructor.
  - unfold restr; destruct a; repeat cases;
      simpl; econstructor; eauto; try econstructor; eauto.
    exfalso. cset_tac; intuition.
Qed.

Lemma bounded_app L L' s
: bounded (L++L') s <-> bounded L s /\ bounded L' s.
Proof.
  general induction L; simpl.
  - intuition.
  - destruct a; edestruct (IHL L' s); eauto. intuition.
Qed.

Inductive fstNoneOrR' {X Y:Type} (R:X->Y->Prop)
  : option X -> Y -> Prop :=
| fstNone' (y:Y) : fstNoneOrR' R None y
| bothR' (x:X) (y:Y) : R x y -> fstNoneOrR' R (Some x) y
.

Definition eqReq := (fstNoneOrR' (fun (s : set var) (t : set var * list var) =>
                                   s [=] fst t \ of_list (snd t))).

Lemma restrict_eqReq DL DL' G
: PIR2 eqReq DL DL'
  -> PIR2 eqReq (restr G ⊝ DL) DL'.
Proof.
  intros. induction H; simpl; econstructor; eauto.
  unfold restr. destruct pf. constructor.
  cases; eauto. subst. constructor; eauto. constructor.
Qed.

Lemma restrict_get DL lv n s
: get (restr lv ⊝ DL) n ⎣ s ⎦
  -> get DL n (Some s) /\ s ⊆ lv.
Proof.
  intros. general induction H.
  - destruct DL; simpl in *; isabsurd.
    inv Heql. unfold restr in H0. destruct o; isabsurd.
    + cases in H0.
      eauto using get. congruence.
  - destruct DL; simpl in *; isabsurd.
    inv Heql. edestruct IHget; eauto.
    eauto using get.
Qed.

Lemma get_bounded L D
: (forall n x, get L n (Some x) -> x ⊆ D)
  -> bounded L D.
Proof.
  general induction L; simpl; isabsurd; eauto.
  destruct a; eauto 50 using get.
Qed.

Lemma bounded_incl DL G G'
: bounded DL G
  -> G ⊆ G'
  -> bounded DL G'.
Proof.
  intros. rewrite <- H0; eauto.
Qed.

Lemma restrict_disj (DL : 〔؟⦃var⦄〕) (s t : ⦃var⦄)
  : (forall n u, get DL n (Some u) -> disj (s ∩ t) u)
    -> restr (s \ t) ⊝ DL = restr s ⊝ DL.
Proof.
  general induction DL; simpl; eauto.
  rewrite IHDL; eauto using get.
  unfold restr. destruct a; eauto.
  exploit H; eauto using get.
  repeat cases; eauto.
  - exfalso. rewrite COND in NOTCOND. cset_tac.
  - exfalso. eapply NOTCOND.
    intros a aIns.
    cset_tac.
Qed.

Hint Resolve bounded_incl.

Lemma PIR2_restrict A B s
:  A ≿ B
   -> restr s ⊝ A ≿ B.
Proof.
  intros. general induction H; simpl.
  - econstructor.
  - econstructor; eauto.
    + inv pf; simpl.
      * econstructor.
      * cases. econstructor; eauto. econstructor.
Qed.

Lemma restrict_get_Some L s t n
: get L n (Some s)
  -> s ⊆ t
  -> get (restr t ⊝ L) n (Some s).
Proof.
  intros. general induction H; simpl; eauto using get.
  - cases; eauto using get.
Qed.

Ltac inv_get_step_restrict :=
  match goal with
  | [ H : get (restr ?G ⊝ ?DL) ?n (Some ?lv) |- _ ] =>
    eapply (@restrict_get DL G n lv) in H; destruct H as [H ?]
  end.

Smpl Add 10 inv_get_step_restrict : inv_get.

Lemma restrict_ifFstR B (R:⦃var⦄->B->Prop) DL GL G
: PIR2 (ifFstR R) DL GL
  -> PIR2 (ifFstR R) (restr G ⊝ DL) GL.
Proof.
  intros. induction H; simpl; eauto using PIR2, @ifFstR.
  unfold restr. destruct pf.
  - eauto using @PIR2, @ifFstR.
  - cases; eauto using PIR2, @ifFstR.
Qed.

Lemma PIR2_ifFstR_refl A (R:A->A->Prop) `{Reflexive _ R} L
  : PIR2 (ifFstR R) (Some ⊝ L) L.
Proof.
  eapply PIR2_get; intros; inv_get; eauto using @ifFstR with len.
Qed.

Lemma restrict_zip_ominus' DL LV lv x al
:  length DL = length LV
-> (forall n lv dl, get LV n (Some lv) -> get DL n dl -> x ∉ lv -> x ∉ dl)
-> al \ singleton x ⊆ lv
->  restr al ⊝ (zip ominus' DL LV)
 ≿ restr (lv \ singleton x) ⊝ (zip ominus' DL LV).
Proof.
  intros. eapply length_length_eq in H.
  general induction H; simpl in *.
  - econstructor.
  - econstructor; eauto using get.
    destruct y; intros; simpl; try now econstructor.
    repeat cases; try now econstructor.
    exfalso. eapply NOTCOND. rewrite <- H1, <- COND.
    decide (x0 ∈ s).
    + cset_tac.
    + exploit H0; eauto using get.
      cset_tac.
Qed.

Lemma zip_bounded DL LV lv x
: length DL = length LV
  -> bounded (List.map Some DL) lv
  -> (forall n lv dl, get LV n (Some lv) -> get DL n dl -> x ∉ lv -> x ∉ dl)
  -> bounded (zip (fun (s : set var) (t : option (set var)) => mdo t' <- t; ⎣s \ t' ⎦) DL LV) (lv \ {{ x }} ).
Proof.
  intros. eapply length_length_eq in H.
  general induction H; simpl; eauto.
  destruct y; simpl in * |- *.
  + split.
    - decide (x0 ∈ s).
      * cset_tac; intuition.
      * exploit H1; eauto using get. cset_tac; intuition.
    - destruct H0; eapply IHlength_eq; eauto.
      intros. eauto using get.
  + eapply IHlength_eq; eauto using get.
Qed.


From HoTT Require Export HoTT.

Local Set Default Proof Mode "Classic".

Set Universe Polymorphism.

Module Suspension.

Private Inductive Susp (A : Type) : Type :=
| N : Susp A
| S : Susp A.

Arguments N {A}.
Arguments S {A}.

Axiom merid : forall {A : Type}, A -> @N A = @S A.

Definition Susp_rec {A B : Type} (n s : B) (m : forall x : A, n = s) (x : Susp A) : B :=
match x with
| N => n
| S => s
end.

Axiom Susp_rec_comp :
  forall {A B : Type} (N' S' : B) (m : A -> N' = S') (x : A),
    ap (Susp_rec N' S' m) (merid x) = m x.

End Suspension.


Require Import Lang.Syntax Lang.Bindings_map.
Set Implicit Arguments.

Implicit Types EV HV V L : Set.

Section section_L_map_eq.

Definition L_map_lid_eq
L L' (f g : L → L') (Q : ∀ x, f x = g x)
(i : lid L) :
(L_map_lid f i) = (L_map_lid g i).
Proof.
destruct i ; crush.
Qed.

Definition L_map_lbl_eq
HV L L' (f g : L → L') (Q : ∀ x, f x = g x)
(ℓ : lbl HV L) :
(L_map_lbl f ℓ) = (L_map_lbl g ℓ).
Proof.
destruct ℓ ; simpl ;
repeat erewrite L_map_lid_eq with (g := g) ;
crush.
Qed.

Definition L_map_ef_eq
EV HV L L' (f g : L → L') (Q : ∀ x, f x = g x)
(ε : ef EV HV L) :
(L_map_ef f ε) = (L_map_ef g ε).
Proof.
destruct ε ; simpl ;
repeat erewrite L_map_lbl_eq with (g := g) ;
crush.
Qed.

Fixpoint L_map_eff_eq
EV HV L L' (f g : L → L') (Q : ∀ x, f x = g x)
(𝓔 : eff EV HV L) :
(L_map_eff f 𝓔) = (L_map_eff g 𝓔).
Proof.
destruct 𝓔 ; simpl ;
repeat erewrite L_map_ef_eq with (g := g) ;
repeat erewrite L_map_eff_eq with (g := g) ;
crush.
Qed.

Fixpoint L_map_ty_eq
EV HV L L' (f g : L → L') (Q : ∀ x, f x = g x)
(T : ty EV HV L) :
(L_map_ty f T) = (L_map_ty g T).
Proof.
destruct T ; simpl ;
repeat erewrite L_map_eff_eq with (g := g) ;
repeat erewrite L_map_ty_eq with (f := f) (g := g) ;
crush.
Qed.

Fixpoint
L_map_hd_eq
EV HV V L L' (f g : L → L') (Q : ∀ x, f x = g x)
(h : hd EV HV V L) :
(L_map_hd f h) = (L_map_hd g h)
with
L_map_tm_eq
EV HV V L L' (f g : L → L') (Q : ∀ x, f x = g x)
(t : tm EV HV V L) :
(L_map_tm f t) = (L_map_tm g t)
with
L_map_val_eq
EV HV V L L' (f g : L → L') (Q : ∀ x, f x = g x)
(v : val EV HV V L) :
(L_map_val f v) = (L_map_val g v).
Proof.
+ destruct h ; simpl ;
  repeat erewrite L_map_tm_eq with (g := g) ;
  repeat erewrite L_map_lid_eq with (g := g) ;
  crush.
+ destruct t ; simpl ;
  repeat erewrite L_map_eff_eq with (g := g) ;
  repeat erewrite L_map_ty_eq with (g := g) ;
  repeat erewrite L_map_tm_eq with (f := f) (g := g) ;
  repeat erewrite L_map_tm_eq with (g := map_inc g) ;
  repeat erewrite L_map_hd_eq with (g := g) ;
  repeat erewrite L_map_val_eq with (g := g) ;
  crush.
+ destruct v ; simpl ;
  repeat erewrite L_map_tm_eq with (g := g) ;
  repeat erewrite L_map_hd_eq with (g := g) ;
  crush.
Qed.

End section_L_map_eq.

Section section_V_map_eq.

Fixpoint
V_map_hd_eq
EV HV V V' L (f g : V → V') (Q : ∀ x, f x = g x)
(h : hd EV HV V L) :
(V_map_hd f h) = (V_map_hd g h)
with
V_map_tm_eq
EV HV V V' L (f g : V → V') (Q : ∀ x, f x = g x)
(t : tm EV HV V L) :
(V_map_tm f t) = (V_map_tm g t)
with
V_map_val_eq
EV HV V V' L (f g : V → V') (Q : ∀ x, f x = g x)
(v : val EV HV V L) :
(V_map_val f v) = (V_map_val g v).
Proof.
+ destruct h ; simpl ;
  repeat erewrite V_map_tm_eq with (g := map_inc (map_inc g)) ;
  crush.
+ destruct t ; simpl ;
  repeat erewrite V_map_tm_eq with (f := f)(g := g) ;
  repeat erewrite V_map_tm_eq with (f := map_inc f) (g := map_inc g) ;
  repeat erewrite V_map_hd_eq with (g := g) ;
  repeat erewrite V_map_val_eq with (g := g) ;
  crush.
+ destruct v ; simpl ;
  repeat erewrite V_map_tm_eq with (g := map_inc g) ;
  repeat erewrite V_map_tm_eq with (g := g) ;
  repeat erewrite V_map_hd_eq with (g := g) ;
  crush.
Qed.

End section_V_map_eq.


(************************************************************************)
(*                          Icharate Toolkit                            *)
(*                            Houda ANOUN                               *)
(*                          Pierre CASTERAN                             *)
(*                            2004 -2006                                *)
(*                              LaBRI                                   *)
(************************************************************************)

Require Export derivSem.
Set Implicit Arguments.

Section lambda_morphism.

Variables X Y:Set.
Variable typeX:X->semType.
Variable typeY:Y->semType.
Variable subst_X_by_Y:X->lambda_terms Y.

Fixpoint translate(lTerm1:lambda_terms X):lambda_terms Y:=
match lTerm1 with
| num n => (num Y n)
| ress r => (subst_X_by_Y r)
| hyps n ty=>hyps Y n ty
| appl l1 l2 => appl (translate l1) (translate l2)
| abs t1 l => abs t1 (translate l)
| twoL  l1 l2 =>  twoL (translate l1)(translate l2)
| pi1  l => pi1 (translate l)
| pi2 l =>  pi2 (translate l)
| box  l=> box (translate l)
| debox  l => debox (translate l)
| diam l =>  diam (translate l)
| dediam  l=>  dediam (translate l)
end.

Definition same_type :=forall (x:X),
                       isWellTyped typeY nil (subst_X_by_Y x) (typeX x).

Lemma same_type_after_subst:forall (l1:lambda_terms X) env t1,
                            isWellTyped typeX env l1 t1->
                            same_type->
                            isWellTyped typeY env (translate l1) t1.
Proof.
 intro l1; elim l1; intros.
 inversion H.
 simpl in |- *.
 constructor; auto.
 unfold same_type in H0; simpl in |- *.
 inversion H.
 change env with (nil ++ env) in |- *.
 apply wellTypedAppEnv; auto.
 inversion H; simpl in |- *; constructor; auto.
 simpl in |- *; inversion H1; econstructor; eauto.
 simpl in |- *; inversion H0; constructor; auto.
 simpl in |- *; inversion H1; constructor; auto.
 simpl in |- *; inversion H0; econstructor; eauto.
 simpl in |- *; inversion H0; econstructor; eauto.
 simpl in |- *; inversion H0; constructor; auto.
 simpl in |- *; inversion H0; constructor; auto.
 simpl in |- *; inversion H0; constructor; auto.
 simpl in |- *; inversion H0; constructor; auto.
Qed.

End lambda_morphism.

Section semantic.
Variables I J A W:Set.

Variable lexi:W->list ((Form I J A)*(option (lambda_terms logic_cst))).
Variable map:A->semType.

Inductive cst:Set:=
|formal:logic_cst->cst
|normal: W->nat->semType->cst.

Definition trans:lambda_terms logic_cst->lambda_terms cst
:=translate (fun (lc:logic_cst)=>(ress (formal lc))).

Definition word_to_lambda:word_type W->lambda_terms cst.
intro wt; case wt.
intros n w1 f1.
case (nth_error (lexi w1) n).
induction 1.
case b.
intro l;exact (trans l).
exact (ress(normal w1 n f1)).
exact (ress(normal w1 n f1)).
Defined.

(* well typeness of final semantics *)

Definition type_cst(ct:cst):semType:=
match ct with
|formal lcst=>setTypeLog lcst
|normal w n  f=> f
end.

(* to be continued ...*)
End semantic.

(* compute the whole semantics *)
Definition whole_sem(gr: syn_sem_gram)(l:list _)
(f:Form _ _ _)(red:deriveTo gr l f):=
translate (word_to_lambda (gr.(lexic)).(lex))
(getSemantic red).

(* the whole semantics is well typed *)
Lemma sem_wt:forall (gr: syn_sem_gram)(l:list _)
(f:Form _ _ _)(red:deriveTo gr l f),
 isWellTyped (type_cst (W:=((gr.(lexic)).(W))))  nil
 (whole_sem red) (mapExt (gr.(lexic)).(map) f).
unfold whole_sem;intros.
eapply same_type_after_subst.
apply wellTyped_deriv_sem.
unfold same_type.
intro wt;case wt.
simpl.
Admitted.


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

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

Print Assumptions mul.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O E Eprime B D U : Universe, ((wd_ U O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (col_ O E O /\ (col_ O E B /\ (col_ O E O /\ (col_ O E D /\ col_ O E U)))))))) -> col_ O U D)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

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

Print Assumptions mul.


Require Import List.
Export ListNotations.
Require Import PeanoNat.
Require Import Lia.

Require Import Ensembles.
Require Import Prop_Bi_Int_calcs.
Require Import Prop_Bi_Int_logics.
Require Import Prop_Bi_Int_extens_interactions.
Require Import Prop_wBi_Int_meta_interactions.
Require Import Prop_sBi_Int_meta_interactions.
Require Import Prop_Bi_Int_Kripke_sem.
Require Import Prop_Bi_Int_soundness.
Require Import Prop_Bi_Int_wcompleteness.
Require Import Prop_Bi_Int_scompleteness.

Variable q : V.
Variable p : V.
Hypothesis diff_prop : (p = q) -> False.

(* sBIC is not included in wBIC. *)

Lemma wBIC_not_der_p_DNp : forall (p : V),
  (wpair_derrec (Singleton _ (# p), Singleton _ (Neg (wNeg (# p))))) -> False.
Proof.
intros p wpair. apply wSoundness in wpair. unfold loc_conseq in wpair.
assert (J1: R_refl (fun x y => ((x = 0) /\ (y = 1)) \/ (x = y)) * R_trans (fun x y => ((x = 0) /\ (y = 1)) \/ (x = y))).
{ simpl. split.
  - unfold R_refl. intro ; auto.
  - unfold R_trans. intros. destruct H ; destruct H0. destruct H ; destruct H0 ; auto.
    subst ; auto. subst ; auto. subst ; auto. }
assert (J2: val_persist_R nat (fun (n : nat) (_ : V) => 1 <= n) (fun x y : nat => (x = 0) /\ (y = 1) \/ (x = y))).
{ unfold val_persist_R. intros. destruct H. destruct H. subst. auto. subst. auto. }
assert (J3: (forall A : BPropF V, In _ (Singleton _ (# p)) A ->
wforces nat (fun x y : nat => (x = 0) /\ (y = 1) \/ (x = y)) J1 (fun (n : nat) (_ : V) => 1 <= n) J2 1 A)).
{ intros. inversion H. subst. simpl. auto. }
pose (@wpair nat (fun x y => ((x = 0) /\ (y = 1)) \/ (x = y)) J1
(fun n p => 1 <= n) J2 1 J3).
destruct e. destruct H. inversion H. subst. simpl in H0.
assert (J4: (1 = 0) /\ (1 = 1) \/ (1 = 1)). auto.
pose (@H0 1 J4). apply f. exists 0. split. auto. split ; auto. intro. lia.
Qed.

Theorem sBIC_not_incl_wBIC : exists G,
   (spair_derrec G) /\
   ((wpair_derrec G) -> False).
Proof.
exists ((Singleton _ (# p), Singleton _ (Neg (wNeg (# p))))).
split. 2 : apply wBIC_not_der_p_DNp. pose (extens_diff_sBIC p). unfold spair_derrec.
exists [Neg (wNeg # p)]. repeat split. apply NoDup_cons. intro. inversion H. apply NoDup_nil.
intros. simpl. inversion H. subst. apply In_singleton. inversion H0.
simpl.
apply MPs with (ps:=[(Singleton _ # p, Imp (Neg (wNeg # p)) (Or (Neg (wNeg # p)) (Bot V)));(Singleton _ # p, (Neg (wNeg # p)))]).
2: apply MPRule_I. intros. inversion H. subst. apply Axs. apply AxRule_I.
apply RA2_I. exists (Neg (wNeg # p)). exists (Bot V). auto. inversion H0.
subst. assumption. inversion H1.
Qed.

Theorem failure_gen_sBIC_Deduction_Theorem : exists A B Γ,
  (spair_derrec (Union _ Γ (Singleton _ (A)), Singleton _ (B))) /\
  ((spair_derrec (Γ, Singleton _ (A → B))) -> False).
Proof.
exists (# p). exists (Neg (wNeg (# p))). exists (Empty_set _).
split.
- unfold spair_derrec. exists [(Neg (wNeg (# p)))].
  repeat split. apply NoDup_cons. intro. inversion H. apply NoDup_nil.
  intros. simpl. inversion H. subst. apply In_singleton. inversion H0.
  simpl. assert (Union _ (Empty_set _) (Singleton _ # p) = Singleton _ # p).
  apply Extensionality_Ensembles. unfold Same_set. split. intro. intros.
  inversion H. inversion H0. inversion H0. subst ; auto. intro. intros.
  inversion H. subst. apply Union_intror. auto. rewrite H. pose (extens_diff_sBIC p).
  apply MPs with (ps:=[(Singleton _ # p, Imp (Neg (wNeg # p)) (Or (Neg (wNeg # p)) (Bot V)));(Singleton _ # p, (Neg (wNeg # p)))]).
  2: apply MPRule_I. intros. inversion H0. subst. apply Axs. apply AxRule_I.
  apply RA2_I. exists (Neg (wNeg # p)). exists (Bot V). auto. inversion H1. subst.
  assumption. inversion H2.
- intro. apply sSoundness in H. unfold glob_conseq in H.
  assert (J1: R_refl (fun x y => ((x = 0) /\ (y = 1)) \/ (x = y)) * R_trans (fun x y => ((x = 0) /\ (y = 1)) \/ (x = y))).
  { simpl. split.
    - unfold R_refl. intro ; auto.
    - unfold R_trans. intros. destruct H0 ; destruct H1. destruct H0 ; destruct H1 ; auto.
      subst ; auto. subst ; auto. subst ; auto. }
  assert (J2: val_persist_R nat (fun (n : nat) (_ : V) => 1 <= n) (fun x y : nat => (x = 0) /\ (y = 1) \/ (x = y))).
  { unfold val_persist_R. intros. destruct H0. destruct H0. subst. auto. subst. auto. }
  assert (J3: (forall A : BPropF V, In _ (Empty_set _) A ->
  mforces nat (fun x y : nat => (x = 0) /\ (y = 1) \/ (x = y)) J1 (fun (n : nat) (_ : V) => 1 <= n) J2 A)).
  { intros. inversion H0. }
  pose (@H nat (fun x y => ((x = 0) /\ (y = 1)) \/ (x = y)) J1
  (fun n p => 1 <= n) J2 J3 1).
  destruct e. destruct H0. inversion H0. subst. simpl in H1.
  assert (J4: (1 = 0) /\ (1 = 1) \/ (1 = 1)). auto.
  assert (J5: 1 <= 1). auto.
  pose (@H1 1 J4 J5). apply f with (v:=1). auto. exists 0. split. auto. split ; auto. intro. lia.
Qed.

Theorem failure_gen_sBIC_Dual_Detachment_Theorem : exists A B Δ,
  (spair_derrec (Singleton _ (Excl A B), Δ)) /\
  ((spair_derrec (Singleton _ (A), Union _ (Singleton _ (B)) Δ)) -> False).
Proof.
exists (# p). exists (# q). exists (Singleton _ (Neg (wNeg (wNeg (# q))))). split.
- unfold spair_derrec. exists [(Neg (wNeg (wNeg (# q))))]. repeat split. apply NoDup_cons.
  intro. inversion H. apply NoDup_nil. intros. simpl. inversion H. subst. apply In_singleton.
  inversion H0. simpl.
  apply MPs with (ps:=[(Singleton _ (Excl # p # q), Imp (Neg (wNeg (wNeg # q))) (Or (Neg (wNeg (wNeg # q))) (Bot V)));(Singleton _ (Excl # p # q), (Neg (wNeg (wNeg # q))))]).
  2: apply MPRule_I. intros. inversion H. subst. apply Axs. apply AxRule_I.
  apply RA2_I. exists (Neg (wNeg (wNeg # q))). exists (Bot V). auto. inversion H0. subst.
  apply DNs with (ps:=[(Singleton _ (Excl # p # q), (wNeg # q))]). 2: apply DNsRule_I.
  intros. inversion H1. subst. apply sBIC_extens_wBIC.
  pose (wBIC_Detachment_Theorem (Empty_set _, Imp (Excl # p # q) (wNeg # q))). simpl in w.
  assert (Singleton _ (Excl # p # q) = Union _ (Empty_set _) (Singleton _ (Excl # p # q))).
  apply Extensionality_Ensembles. split. intro. intros. inversion H2. apply Union_intror. apply In_singleton.
  intro. intros. inversion H2. inversion H3. inversion H3. subst. apply In_singleton. rewrite H2. apply w ; try auto.
  apply wdual_residuation. pose (wBIC_Deduction_Theorem (Union _ (Empty_set _) (Singleton _ (# p)), Or # q (wNeg # q))).
  apply w0 ; auto. clear w0. clear w. pose (wBIC_monot (Empty_set _, Or # q (wNeg # q))). simpl in w.
  apply w. clear w.
  apply MP with (ps:=[(Empty_set _, Imp (Or # q (Excl (Top V) (# q))) (Or # q (wNeg # q)));(Empty_set _, Or # q (Excl (Top V) (# q)))]).
  2: apply MPRule_I. intros. inversion H3. subst.
  apply MP with (ps:=[(Empty_set _, ((Excl (Top V) # q) → Or # q (wNeg # q)) → (Or # q (Excl (Top V) # q) → Or # q (wNeg # q)));
  (Empty_set _, ((Excl (Top V) # q) → Or # q (wNeg # q)))]).
  2: apply MPRule_I. intros. inversion H4. subst.
  apply MP with (ps:=[(Empty_set _, (# q → Or # q (wNeg # q)) → ((Excl (Top V) # q) → Or # q (wNeg # q)) → (Or # q (Excl (Top V) # q) → Or # q (wNeg # q)));
  (Empty_set _, (# q) → Or # q (wNeg # q))]).
  2: apply MPRule_I. intros. inversion H5. subst. apply Ax. apply AxRule_I. apply RA4_I.
  exists (# q). exists (Excl (Top V) # q). exists (Or # q (wNeg # q)). auto. inversion H6. subst.
  apply Ax. apply AxRule_I. apply RA2_I. exists (# q). exists (wNeg # q). auto. inversion H7. inversion H5. subst.
  apply MP with (ps:=[(Empty_set _, ((wNeg # q) → Or # q (wNeg # q)) → (Excl (Top V) # q → Or # q (wNeg # q)));(Empty_set _, ((wNeg # q) → Or # q (wNeg # q)))]).
  2: apply MPRule_I. intros. inversion H6. subst.
  apply MP with (ps:=[(Empty_set _,(Excl (Top V) # q → (wNeg # q)) → ((wNeg # q) → Or # q (wNeg # q)) → (Excl (Top V) # q → Or # q (wNeg # q)));
  (Empty_set _, (Excl (Top V) # q → (wNeg # q)))]).
  2: apply MPRule_I. intros. inversion H7. subst.
  apply Ax. apply AxRule_I. apply RA1_I. exists (Excl (Top V) # q). exists (wNeg # q).
  exists (Or # q (wNeg # q)). auto. inversion H8. subst. apply wimp_Id_gen. inversion H9.
  inversion H7. subst. apply Ax.
  apply AxRule_I. apply RA3_I. exists (# q). exists (wNeg # q). auto. inversion H8.
  inversion H6. inversion H4. subst.
  apply MP with (ps:=[(Empty_set _, Imp (Top V) (Or # q (Excl (Top V) # q)));(Empty_set _, Top V)]).
  2: apply MPRule_I. intros. inversion H5. subst. apply Ax. apply AxRule_I.
  apply RA11_I. exists (Top V). exists (# q). auto. inversion H6. subst.
  apply MP with (ps:=[(Empty_set _, Imp (Imp (Top V) (Top V)) (Top V));(Empty_set _, (Imp (Top V) (Top V)))]).
  2: apply MPRule_I. intros. inversion H7. subst. apply Ax. apply AxRule_I. apply RA15_I. exists (Top V → Top V). auto.
  inversion H8. subst. apply wimp_Id_gen. inversion H9. inversion H7. inversion H5.
  intro. intros. inversion H3. inversion H2. inversion H1.
- intro. apply sSoundness in H. unfold glob_conseq in H. Inductive Three := u | w | v.
  assert (J1: R_refl (fun x y : Three => (x = v) /\ (y = w) \/ (x = u) /\ (y = w) \/ (x = y)) *
  R_trans (fun x y : Three => (x = v) /\ (y = w) \/ (x = u) /\ (y = w) \/ (x = y))).
  { simpl. split.
    * unfold R_refl. intro. auto.
    * unfold R_trans. intros. destruct H0. destruct H0. subst. destruct H1. destruct H0. subst. auto. destruct H0.
      destruct H0. subst. auto. subst. auto. destruct H0. destruct H0. destruct H1. destruct H1. subst. auto.
      destruct H1. destruct H1. subst. auto. subst. auto. destruct H1. destruct H1. subst. auto. destruct H1.
      destruct H1. subst. auto. subst. auto. }
  assert (J2: val_persist_R Three (fun (x : Three) (r : V) =>  (x = x) /\ (r = p) \/ ((x = w) \/ (x = v)) /\ (r = q))
  (fun x y : Three => (x = v) /\ (y = w) \/ (x = u) /\ (y = w) \/ (x = y))).
  { intro. intros. destruct H0. destruct H0. subst. destruct H1. destruct H0. subst. auto. destruct H0.
    destruct H0. subst. auto. subst. auto. destruct H0. destruct H0. destruct H1. destruct H1. subst. auto.
    destruct H1. destruct H1. subst. auto. subst. auto. destruct H1. destruct H1. subst. auto. destruct H1.
    destruct H1. subst. auto. subst. auto. }
  assert (J3: (forall A : BPropF V, In _ (Singleton _ # p) A ->  mforces Three (fun x y : Three => (x = v) /\ (y = w) \/ (x = u) /\ (y = w) \/ (x = y))
  J1 (fun (x : Three) (r : V) => (x = x) /\ (r = p) \/ ((x = w) \/ (x = v)) /\ (r = q)) J2 A)).
  { intros. inversion H0. subst. intro. simpl. auto. }
  pose (H Three (fun x y => ((x = v) /\ (y = w)) \/ ((x = u) /\ (y = w)) \/ (x = y)) J1
  (fun x r => ((x = x) /\ (r = p)) \/ (((x = w) \/ (x = v)) /\ (r = q))) J2 J3 u). destruct e.
  destruct H0. inversion H0. inversion H2. subst. simpl in H1. destruct H1. destruct H1. inversion H3.
  subst. apply diff_prop. auto. destruct H1. destruct H1. inversion H1. inversion H1. subst.
  clear H0. inversion H2. subst. simpl in H1. clear H2.
  assert (J4: (u = v) /\ (w = w) \/ (u = u) /\ (w = w) \/ (u = w)). auto.
  pose (H1 w J4). apply f. exists v. split. auto. split ; auto. intro. destruct H0. destruct H0. destruct H0.
  destruct H0. subst. inversion H3. destruct H0. destruct H0. inversion H3. subst.
  apply H2. auto.
Qed.


Set Implicit Arguments.

Require Import DataTypes StoreAtomicity.

Section ForAddr.
  Variable reqFn: Addr -> Cache -> Index -> Req.

  Record State := { mem: Addr -> Data;
                    next: Addr -> Cache -> Index
                  }.

  Inductive AtomicTrans s: State -> Set :=
  | AReq: forall a c, AtomicTrans s (Build_State
                                    (match desc (reqFn a c (next s a c)) with
                                       | Ld => mem s
                                       | St => fun a' =>
                                         if decAddr a a'
                                         then dataQ (reqFn a' c (next s a c))
                                         else mem s a'
                                     end)
                                    (fun a' t =>
                                       if decAddr a a'
                                       then
                                         match decTree t c with
                                                   | left _ => S (next s a' t)
                                                   | _ => next s a' t
                                         end
                                       else next s a' t
                                    ))
  | Idle: AtomicTrans s s.

  CoInductive AtomicTransList: State -> Set :=
    | Cons: forall s s', AtomicTrans s s' -> AtomicTransList s' -> AtomicTransList s.

End ForAddr.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Functor.
Require Export Category.Functor.Diagonal.
Require Export Category.Structure.Cone.
Require Export Category.Construction.Comma.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.

Program Definition Cones `(F : J ⟶ C) : Category := {|
  obj     := Cone F;
  hom     := fun N L => { u : vertex_obj[N] ~> vertex_obj[L]
                        & ∀ j, vertex_map[L] ∘ u ≈ @vertex_map _ _ F N j };
  homset  := fun _ _ => {| equiv := fun f g => `1 f ≈ `1 g |};
  id      := fun x => (id; _);
  compose := fun _ _ _ f g => (`1 f ∘ `1 g; _);
|}.
Next Obligation.
  rewrite comp_assoc.
  rewrite X0; auto.
Qed.

Definition Cocones `(F : J ⟶ C) := Cones (F^op).


From Undecidability Require Import
  L.L TM.TM Synthetic.Definitions Synthetic.ReducibilityFacts.

From Undecidability Require
  L.Reductions.HaltL_to_HaltLclosed
  LambdaCalculus.Reductions.HaltLclosed_to_wCBNclosed
  LambdaCalculus.Reductions.wCBNclosed_to_KrivineMclosed_HALT
  MinskyMachines.Reductions.KrivineMclosed_HALT_to_MMA_HALTING
  TM.Reductions.MMA_HALTING_n_to_HaltTM_n.

Lemma reduction : HaltL ⪯ HaltTM 5.
Proof.
  apply (reduces_transitive HaltL_to_HaltLclosed.reduction).
  apply (reduces_transitive HaltLclosed_to_wCBNclosed.reduction).
  apply (reduces_transitive wCBNclosed_to_KrivineMclosed_HALT.reduction).
  apply (reduces_transitive KrivineMclosed_HALT_to_MMA_HALTING.reduction).
  exact MMA_HALTING_n_to_HaltTM_n.reduction.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Require Import Nat Arith.

Inductive lst : Type :=
  | Nil : lst
  | Cons : nat -> lst -> lst.

  Fixpoint append (l1 : lst) (l2 : lst) : lst :=
   match l1 with
   | Nil => l2
   | Cons x y => Cons x (append y l2)
   end.

 Fixpoint rev (l : lst) : lst :=
   match l with
   | Nil => Nil
   | Cons x y => append (rev y) (Cons x Nil)
   end.

Theorem append_assoc : forall x y z : lst, append (append x y) z = append x (append y z).
Proof.
  intros.
  induction x.
  - reflexivity.
  - simpl. rewrite IHx. reflexivity.
Qed.

Theorem rev_append_cons_aux : forall (l1 l2 : lst) (x : nat), rev (append (rev l1) (Cons x l2)) = append (rev l2) (Cons x l1).
Proof.
  intro.
  induction l1.
  - reflexivity.
  - intros. simpl. rewrite append_assoc. simpl. rewrite IHl1. simpl.
    rewrite append_assoc. reflexivity.
Qed.

Theorem rev_append_cons : forall (l : lst) (x : nat), rev (append (rev l) (Cons x Nil)) = Cons x l.
Proof.
  intros.
  induction l.
  - reflexivity.
  - simpl. rewrite append_assoc. simpl. lfind. Admitted.


(* (c) Copyright Microsoft Corporation and Inria.                       *)
(* You may distribute this file under the terms of the CeCILL-B license *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat fintype bigop finset.
Require Import fingroup morphism automorphism quotient gproduct.

(******************************************************************************)
(*   This file provides basic interfaces for the notion of "generic"          *)
(* characteristic subgroups; these amount to subfunctors of the identity      *)
(* functor in some category of groups. The implementation proposed here is    *)
(* fairly basic, relying on first order function matching and on structure    *)
(* telescopes, both of which are somewhat limited and fragile. It should      *)
(* switch in the future to more general and more robust quotation matching.   *)
(*   The definitions in this file (types, properties and structures) are all  *)
(* packaged under the GFunctor submodule, i.e., client code should refer to   *)
(* GFunctor.continuous, GFunctor.map, etc. Notations, Coercions and Lemmas    *)
(* are exported and thus directly available, however.                         *)
(*   We provide the following:                                                *)
(*      object_map == the type of the (polymorphic) object map of a group     *)
(*                    functor; the %gF scope is bound to object_map.          *)
(*                 := forall gT : finGroupType, {set gT} -> {set gT}.         *)
(*  We define two operations on object_map (with notations in the %gF scope): *)
(*        F1 \o F2 == the composite map; (F1 \o F2) G expands to F1 (F2 G).   *)
(*        F1 %% F2 == F1 computed modulo F2; we have                          *)
(*                    (F1 %% F2) G / F2 G = F1 (G / F2 G)                     *)
(* We define the following (type-polymorphic) properties of an object_map F:  *)
(*     group_valued F <-> F G is a group when G is a group                    *)
(*           closed F <-> F G is a subgroup o fG when G is a group            *)
(*       continuous F <-> F is continuous with respect to morphism image:     *)
(*                        for any f : {morphism G >-> ..}, f @* (F G) is a    *)
(*                        a subgroup of F (f @* G); equivalently, F is        *)
(*                        functorial in the category Grp of groups.           *)
(*                        Most common "characteristic subgroup" are produced  *)
(*                        continuous object maps.                             *)
(*   iso_continuous F <-> F is continuous with respect to isomorphism image;  *)
(*                        equivalently, F is functorial in the Grp groupoid.  *)
(*                        The Puig and the Thompson J subgroups are examples  *)
(*                        of iso_continuous maps that are not continuous.     *)
(*      pcontinuous F <-> F is continuous with respect to partial morphism    *)
(*                        image, i.e., functorial in the category of groups   *)
(*                        and partial morphisms. The center and p-core are    *)
(*                        examples of pcontinuous maps.                       *)
(*       hereditary F <-> inclusion in the image of F is hereditary, i.e.,    *)
(*                        for any subgroup H of G, the intersection of H with *)
(*                        F G is included in H. Note that F is pcontinuous    *)
(*                        iff it is continuous and hereditary; indeed proofs  *)
(*                        of pcontinuous F coerce to proofs of hereditary F   *)
(*                        and continuous F.                                   *)
(*        monotonic F <-> F is monotonic with respect to inclusion: for any   *)
(*                        subgroup H of G, F H is a subgroup of F G. The      *)
(*                        derived and lower central series are examples of    *)
(*                        monotonic maps.                                     *)
(* Four structures provide interfaces to these properties:                    *)
(*    GFunctor.iso_map == structure for object maps that are group_valued,    *)
(*                        closed, and iso_continuous.                         *)
(*  [igFun by Fsub & !Fcont] == the iso_map structure for an object map F     *)
(*                        such that F G is canonically a group when G is, and *)
(*                        given Fsub : closed F and Fcont : iso_continuous F. *)
(*  [igFun by Fsub & Fcont] == as above, but expecting Fcont : continuous F.  *)
(*        [igFun of F] == clone an existing GFunctor.iso_map structure for F. *)
(*        GFunctor.map == structure for continuous object maps, inheriting    *)
(*                        from the GFunctor.iso_map structure.                *)
(*     [gFun by Fcont] == the map structure for an F with a canonical iso_map *)
(*                        structure, given Fcont : continuous F.              *)
(*         [gFun of F] == clone an existing GFunctor.map structure for F.     *)
(*       GFunctor.pmap == structure for pcontinuous object maps, inheriting   *)
(*                        from the GFunctor.map structure.                    *)
(*    [pgFun by Fher] == the pmap structure for an F with a canonical map     *)
(*                        structure, given Fher : hereditary F.               *)
(*        [pgFun of F] == clone an existing GFunctor.pmap structure for F.    *)
(*   GFunctor.mono_map == structure for monotonic, continuous object maps     *)
(*                        inheriting from the GFunctor.map structure.         *)
(*     [mgFun by Fmon] == the mono_map structure for an F with a canonical    *)
(*                        map structure, given Fmon : monotonic F.            *)
(*        [mgFun of F] == clone an existing GFunctor.mono_map structure for F *)
(* Lemmas for these group functors use either a 'gF' prefix or an 'F' suffix. *)
(* The (F1 \o F2) and (F1 %% F2) operations have canonical GFunctor.map       *)
(* structures when F1 is monotonic or hereditary, respectively.               *)
(******************************************************************************)

Import GroupScope.

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

Delimit Scope gFun_scope with gF.

Module GFunctor.

Definition object_map := forall gT : finGroupType, {set gT} -> {set gT}.

Bind Scope gFun_scope with object_map.

Section Definitions.

Implicit Types gT hT : finGroupType.

Variable F : object_map.

(* Group closure. *)
Definition group_valued := forall gT (G : {group gT}), group_set (F G).

(* Subgroup closure. *)
Definition closed := forall gT (G : {group gT}), F G \subset G.

(* General functoriality, i.e., continuity of the object map *)
Definition continuous :=
  forall gT hT (G : {group gT}) (phi : {morphism G >-> hT}),
    phi @* F G \subset F (phi @* G).

(* Functoriality on the Grp groupoid (arrows are restricted to isos). *)
Definition iso_continuous :=
  forall gT hT (G : {group gT}) (phi : {morphism G >-> hT}),
   'injm phi -> phi @* F G \subset F (phi @* G).

Lemma continuous_is_iso_continuous : continuous -> iso_continuous.
Proof. by move=> Fcont gT hT G phi inj_phi; exact: Fcont. Qed.

(* Functoriality on Grp with partial morphisms. *)
Definition pcontinuous :=
  forall gT hT (G D : {group gT}) (phi : {morphism D >-> hT}),
    phi @* F G \subset F (phi @* G).

Lemma pcontinuous_is_continuous : pcontinuous -> continuous.
Proof. by move=> Fcont gT hT G; exact: Fcont. Qed.

(* Heredity with respect to inclusion *)
Definition hereditary :=
  forall gT (H G : {group gT}), H \subset G -> F G :&: H \subset F H.

Lemma pcontinuous_is_hereditary : pcontinuous -> hereditary.
Proof.
move=> Fcont gT H G sHG; rewrite -{2}(setIidPl sHG) setIC.
by do 2!rewrite -(morphim_idm (subsetIl H _)) morphimIdom ?Fcont.
Qed.

(* Monotonicity with respect to inclusion *)
Definition monotonic :=
  forall gT (H G : {group gT}), H \subset G -> F H \subset F G.

(* Self-expanding composition, and modulo *)

Variables (k : unit) (F1 F2 : object_map).

Definition comp_head : object_map := fun gT A => let: tt := k in F1 (F2 A).

Definition modulo : object_map :=
  fun gT A => coset (F2 A) @*^-1 (F1 (A / (F2 A))).

End Definitions.

Section ClassDefinitions.

Structure iso_map := IsoMap {
  apply : object_map;
  _ : group_valued apply;
  _ : closed apply;
  _ : iso_continuous apply
}.
Local Coercion apply : iso_map >-> object_map.

Structure map := Map { iso_of_map : iso_map; _ : continuous iso_of_map }.
Local Coercion iso_of_map : map >-> iso_map.

Structure pmap := Pmap { map_of_pmap : map; _ : hereditary map_of_pmap }.
Local Coercion map_of_pmap : pmap >-> map.

Structure mono_map := MonoMap { map_of_mono : map; _ : monotonic map_of_mono }.
Local Coercion map_of_mono : mono_map >-> map.

Definition pack_iso F Fcont Fgrp Fsub := @IsoMap F Fgrp Fsub Fcont.

Definition clone_iso (F : object_map) :=
  fun Fgrp Fsub Fcont (isoF := @IsoMap F Fgrp Fsub Fcont) =>
  fun isoF0 & phant_id (apply isoF0) F & phant_id isoF isoF0 => isoF.

Definition clone (F : object_map) :=
  fun isoF & phant_id (apply isoF) F =>
  fun (funF0 : map) & phant_id (apply funF0) F =>
  fun Fcont (funF := @Map isoF Fcont) & phant_id funF0 funF => funF.

Definition clone_pmap (F : object_map) :=
  fun (funF : map) & phant_id (apply funF) F =>
  fun (pfunF0 : pmap) & phant_id (apply pfunF0) F =>
  fun Fher (pfunF := @Pmap funF Fher) & phant_id pfunF0 pfunF => pfunF.

Definition clone_mono (F : object_map) :=
  fun (funF : map) & phant_id (apply funF) F =>
  fun (mfunF0 : mono_map) & phant_id (apply mfunF0) F =>
  fun Fmon (mfunF := @MonoMap funF Fmon) & phant_id mfunF0 mfunF => mfunF.

End ClassDefinitions.

Module Exports.

Identity Coercion fun_of_object_map : object_map >-> Funclass.
Coercion apply : iso_map >-> object_map.
Coercion iso_of_map : map >-> iso_map.
Coercion map_of_pmap : pmap >-> map.
Coercion map_of_mono : mono_map >-> map.
Coercion continuous_is_iso_continuous : continuous >-> iso_continuous.
Coercion pcontinuous_is_continuous : pcontinuous >-> continuous.
Coercion pcontinuous_is_hereditary : pcontinuous >-> hereditary.

Notation "[ 'igFun' 'by' Fsub & Fcont ]" :=
    (pack_iso (continuous_is_iso_continuous Fcont) (fun gT G => groupP _) Fsub)
  (at level 0, format "[ 'igFun'  'by'  Fsub  &  Fcont ]") : form_scope.

Notation "[ 'igFun' 'by' Fsub & ! Fcont ]" :=
    (pack_iso Fcont (fun gT G => groupP _) Fsub)
  (at level 0, format "[ 'igFun'  'by'  Fsub  &  ! Fcont ]") : form_scope.

Notation "[ 'igFun' 'of' F ]" := (@clone_iso F _ _ _ _ id id)
  (at level 0, format "[ 'igFun'  'of'  F ]") : form_scope.

Notation "[ 'gFun' 'by' Fcont ]" := (Map Fcont)
  (at level 0, format "[ 'gFun'  'by'  Fcont ]") : form_scope.

Notation "[ 'gFun' 'of' F ]" := (@clone F _ id _ id _ id)
  (at level 0, format "[ 'gFun'  'of'  F ]") : form_scope.

Notation "[ 'pgFun' 'by' Fher ]" := (Pmap Fher)
  (at level 0, format "[ 'pgFun'  'by'  Fher ]") : form_scope.

Notation "[ 'pgFun' 'of' F ]" := (@clone_pmap F _ id _ id _ id)
  (at level 0, format "[ 'pgFun' 'of'  F ]") : form_scope.

Notation "[ 'mgFun' 'by' Fmon ]" := (MonoMap Fmon)
  (at level 0, format "[ 'mgFun'  'by'  Fmon ]") : form_scope.

Notation "[ 'mgFun' 'of' F ]" := (@clone_mono F _ id _ id _ id)
  (at level 0, format "[ 'mgFun' 'of'  F ]") : form_scope.

End Exports.

End GFunctor.
Export GFunctor.Exports.

Bind Scope gFun_scope with GFunctor.object_map.

Notation "F1 \o F2" := (GFunctor.comp_head tt F1 F2) : gFun_scope.
Notation "F1 %% F2" := (GFunctor.modulo F1 F2) : gFun_scope.

Section FunctorGroup.

Variables (F : GFunctor.iso_map) (gT : finGroupType) (G : {group gT}).
Lemma gFgroupset : group_set (F gT G). Proof. by case: F. Qed.
Canonical gFgroup := Group gFgroupset.

End FunctorGroup.

Canonical gFmod_group
    (F1 : GFunctor.iso_map) (F2 : GFunctor.object_map)
    (gT : finGroupType) (G : {group gT}) :=
  [group of (F1 %% F2)%gF gT G].

Section IsoFunctorTheory.

Implicit Types gT rT : finGroupType.
Variable F : GFunctor.iso_map.

Lemma gFsub gT (G : {group gT}) : F gT G \subset G.
Proof. by case: F gT G. Qed.

Lemma gF1 gT : F gT 1 = 1. Proof. exact/trivgP/gFsub. Qed.

Lemma gFiso_cont : GFunctor.iso_continuous F.
Proof. by case F. Qed.

Lemma gFchar gT (G : {group gT}) : F gT G \char G.
Proof.
apply/andP; split => //; first by apply: gFsub.
apply/forallP=> f; apply/implyP=> Af; rewrite -{2}(im_autm Af) -(autmE Af).
by rewrite -morphimEsub ?gFsub ?gFiso_cont ?injm_autm.
Qed.

Lemma gFnorm gT (G : {group gT}) : G \subset 'N(F gT G).
Proof. by rewrite char_norm ?gFchar. Qed.

Lemma gFnormal gT (G : {group gT}) : F gT G <| G.
Proof. by rewrite char_normal ?gFchar. Qed.

Lemma injmF_sub gT rT (G D : {group gT}) (f : {morphism D >-> rT}) :
  'injm f -> G \subset D -> f @* (F gT G) \subset F rT (f @* G).
Proof.
move=> injf sGD; apply/eqP; rewrite -(setIidPr (gFsub G)).
by rewrite-{3}(setIid G) -!(morphim_restrm sGD) gFiso_cont // injm_restrm.
Qed.

Lemma injmF gT rT (G D : {group gT}) (f : {morphism D >-> rT}) :
  'injm f -> G \subset D -> f @* (F gT G) = F rT (f @* G).
Proof.
move=> injf sGD; apply/eqP; rewrite eqEsubset injmF_sub //=.
rewrite -{2}(morphim_invm injf sGD) -[f @* F _ _](morphpre_invm injf).
have Fsubs := subset_trans (gFsub _).
by rewrite -sub_morphim_pre (injmF_sub, Fsubs) ?morphimS ?injm_invm.
Qed.

Lemma gFisom gT rT (G D : {group gT}) R (f : {morphism D >-> rT}) :
  G \subset D -> isom G (gval R) f -> isom (F gT G) (F rT R) f.
Proof.
case/(restrmP f)=> g [gf _ _ _]; rewrite -{f}gf.
by case/isomP=> injg <-; rewrite sub_isom ?gFsub ?injmF.
Qed.

Lemma gFisog gT rT (G : {group gT}) (R : {group rT}) :
  G \isog R -> F gT G \isog F rT R.
Proof. by case/isogP=> f injf <-; rewrite -injmF // sub_isog ?gFsub. Qed.

End IsoFunctorTheory.

Section FunctorTheory.

Implicit Types gT rT : finGroupType.
Variable F : GFunctor.map.

Lemma gFcont : GFunctor.continuous F.
Proof. by case F. Qed.

Lemma morphimF gT rT (G D : {group gT}) (f : {morphism D >-> rT}) :
  G \subset D -> f @* (F gT G) \subset F rT (f @* G).
Proof.
move=> sGD; rewrite -(setIidPr (gFsub F G)).
by rewrite -{3}(setIid G) -!(morphim_restrm sGD) gFcont.
Qed.

End FunctorTheory.

Section PartialFunctorTheory.

Implicit Types gT rT : finGroupType.

Section BasicTheory.

Variable F : GFunctor.pmap.

Lemma gFhereditary : GFunctor.hereditary F.
Proof. by case F. Qed.

Lemma gFunctorI gT (G H : {group gT}) :
  F gT G :&: H = F gT G :&: F gT (G :&: H).
Proof.
rewrite -{1}(setIidPr (gFsub F G)) [G :&: _]setIC -setIA.
rewrite -(setIidPr (gFhereditary (subsetIl G H))).
by rewrite setIC -setIA (setIidPr (gFsub F (G :&: H))).
Qed.

Lemma pmorphimF : GFunctor.pcontinuous F.
Proof.
move=> gT rT G D f; rewrite -morphimIdom -(setIidPl (gFsub F G)) setICA.
apply: (subset_trans (morphimS f (gFhereditary (subsetIr D G)))).
by rewrite (subset_trans (morphimF F _ _ )) ?morphimIdom ?subsetIl.
Qed.

Lemma gFid gT (G : {group gT}) : F gT (F gT G)  = F gT G.
Proof.
apply/eqP; rewrite eqEsubset gFsub.
by move/gFhereditary: (gFsub F G); rewrite setIid /=.
Qed.

End BasicTheory.

Section Modulo.

Variables (F1 : GFunctor.pmap) (F2 : GFunctor.map).

Lemma gFmod_closed : GFunctor.closed (F1 %% F2).
Proof. by move=> gT G; rewrite sub_cosetpre_quo ?gFsub ?gFnormal. Qed.

Lemma gFmod_cont : GFunctor.continuous (F1 %% F2).
Proof.
move=> gT rT G f; have nF2 := gFnorm F2.
have sDF: G \subset 'dom (coset (F2 _ G)) by rewrite nF2.
have sDFf: G \subset 'dom (coset (F2 _ (f @* G)) \o f).
  by rewrite -sub_morphim_pre ?subsetIl // nF2.
pose K := 'ker (restrm sDFf (coset (F2 _ (f @* G)) \o f)).
have sFK: 'ker (restrm sDF (coset (F2 _ G))) \subset K.
  rewrite {}/K !ker_restrm ker_comp /= subsetI subsetIl !ker_coset /=.
  by rewrite -sub_morphim_pre ?subsetIl // morphimIdom ?morphimF.
have sOF := gFsub F1 (G / F2 _ G); have sGG: G \subset G by [].
rewrite -sub_quotient_pre; last first.
  by apply: subset_trans (nF2 _ _); rewrite morphimS ?gFmod_closed.
suffices im_fact H : F2 _ G \subset gval H -> H \subset G ->
  factm sFK sGG @* (H / F2 _ G) = f @* H / F2 _ (f @* G).
- rewrite -2?im_fact ?gFmod_closed ?gFsub //.
    by rewrite cosetpreK morphimF /= ?morphim_restrm ?setIid.
  by rewrite -sub_quotient_pre ?normG //= trivg_quotient sub1G.
move=> sFH sHG; rewrite -(morphimIdom _ (H / _)) /= {2}morphim_restrm setIid.
rewrite -morphimIG ?ker_coset // -(morphim_restrm sDF) morphim_factm.
by rewrite morphim_restrm morphim_comp -quotientE morphimIdom.
Qed.

Canonical gFmod_igFun := [igFun by gFmod_closed & gFmod_cont].
Canonical gFmod_gFun := [gFun by gFmod_cont].

End Modulo.

Variables F1 F2 : GFunctor.pmap.

Lemma gFmod_hereditary : GFunctor.hereditary (F1 %% F2).
Proof.
move=> gT H G sHG; set FGH := _ :&: H; have nF2H := gFnorm F2 H.
rewrite -sub_quotient_pre; last exact: subset_trans (subsetIr _ _) _.
pose rH := restrm nF2H (coset (F2 _ H)); pose rHM := [morphism of rH].
have rnorm_simpl: rHM @* H = H / F2 _ H by rewrite morphim_restrm setIid.
have nF2G := subset_trans sHG (gFnorm F2 G).
pose rG := restrm nF2G (coset (F2 _ G)); pose rGM := [morphism of rG].
have sqKfK: 'ker rGM \subset 'ker rHM.
  rewrite !ker_restrm !ker_coset (setIidPr (gFsub F2 _)) setIC /=.
  exact: gFhereditary.
have sHH := subxx H; rewrite -rnorm_simpl /= -(morphim_factm sqKfK sHH) /=.
apply: subset_trans (gFcont F1 _); rewrite /= {2}morphim_restrm setIid /=.
apply: subset_trans (morphimS _ (gFhereditary _ (quotientS _ sHG))) => /=.
have ->: FGH / _ = restrm nF2H (coset _) @* FGH.
  by rewrite morphim_restrm setICA setIid.
rewrite -(morphim_factm sqKfK sHH) morphimS //= morphim_restrm -quotientE.
by rewrite setICA setIid (subset_trans (quotientI _ _ _)) // cosetpreK.
Qed.

Canonical gFmod_pgFun := [pgFun by gFmod_hereditary].

End PartialFunctorTheory.

Section MonotonicFunctorTheory.

Implicit Types gT rT : finGroupType.

Lemma gFunctorS (F : GFunctor.mono_map) : GFunctor.monotonic F.
Proof. by case: F. Qed.

Section Composition.

Variables (F1 : GFunctor.mono_map) (F2 : GFunctor.map).

Lemma gFcomp_closed : GFunctor.closed (F1 \o F2).
Proof. by move=> gT G; rewrite (subset_trans (gFsub _ _)) ?gFsub. Qed.

Lemma gFcomp_cont : GFunctor.continuous (F1 \o F2).
Proof.
move=> gT rT G phi; rewrite (subset_trans (morphimF _ _ (gFsub _ _))) //.
by rewrite (subset_trans (gFunctorS F1 (gFcont F2 phi))).
Qed.

Canonical gFcomp_igFun := [igFun by gFcomp_closed & gFcomp_cont].
Canonical gFcomp_gFun :=[gFun by gFcomp_cont].

End Composition.

Variables F1 F2 : GFunctor.mono_map.

Lemma gFcompS : GFunctor.monotonic (F1 \o F2).
Proof. by move=> gT H G sHG; rewrite !gFunctorS. Qed.

Canonical gFcomp_mgFun := [mgFun by gFcompS].

End MonotonicFunctorTheory.

Section GFunctorExamples.

Implicit Types gT : finGroupType.

Definition idGfun gT := @id {set gT}.

Lemma idGfun_closed : GFunctor.closed idGfun. Proof. by []. Qed.
Lemma idGfun_cont : GFunctor.continuous idGfun. Proof. by []. Qed.
Lemma idGfun_monotonic : GFunctor.monotonic idGfun. Proof. by []. Qed.

Canonical bgFunc_id := [igFun by idGfun_closed & idGfun_cont].
Canonical gFunc_id := [gFun by idGfun_cont].
Canonical mgFunc_id := [mgFun by idGfun_monotonic].

Definition trivGfun gT of {set gT} := [1 gT].

Lemma trivGfun_cont : GFunctor.pcontinuous trivGfun.
Proof. by move=> gT rT D G f; rewrite morphim1. Qed.

Canonical trivGfun_igFun := [igFun by sub1G & trivGfun_cont].
Canonical trivGfun_gFun := [gFun by trivGfun_cont].
Canonical trivGfun_pgFun := [pgFun by trivGfun_cont].

End GFunctorExamples.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Export Coq.ZArith.ZArith.
Require Export Coq.Arith.Compare.
Require Export CoRN.reals.NRootIR.
From Coq Require Import Lia.

(** printing p3m %\ensuremath{\frac13\hat{\ }}% *)
(** printing Halfeps %\ensuremath{\frac\varepsilon2}% *)

(**
* Technical lemmas for the FTA
** Key Lemma
*)

Section Key_Lemma.

(**
%\begin{convention}% Let [a:nat->IR] and [n:nat] such that [0 < n],
[forall (k : nat) ([0] [<=] (a k))], [(a n) [=] [1]] and [a_0 : IR],
and [eps : IR] such that [([0] [<] eps)] and [(eps [<=] a_0)].
%\end{convention}%
*)
Variable a : nat -> IR.
Variable n : nat.
Hypothesis gt_n_0 : 0 < n.
Variable eps : IR.
Hypothesis eps_pos : [0] [<] eps.
Hypothesis a_nonneg : forall k : nat, [0] [<=] a k.
Hypothesis a_n_1 : a n [=] [1].
Variable a_0 : IR.
Hypothesis eps_le_a_0 : eps [<=] a_0.

Lemma a_0_eps_nonneg : [0] [<=] a_0[-]eps.
Proof.
 apply shift_leEq_minus.
 astepl eps; auto.
Qed.

Lemma a_0_eps_fuzz : a_0[-]eps [<] a_0.
Proof.
 astepr (a_0[-][0]).
 apply minus_resp_less_rht.
 apply eps_pos.
Qed.

Lemma lem_1a : n - (n - 1) = 1.
Proof.
 cut (1 <= n).
  lia.
 auto with arith.
Qed.

Lemma lem_1b : forall n j : nat, n - S j <= n - j.
Proof.
 intros.
 lia.
Qed.

Lemma lem_1c : forall n j : nat, n - j <= n.
Proof.
 intros.
 lia.
Qed.

Lemma lem_1 : {t : IR | [0] [<=] t |
 {k : nat | 1 <= k /\ k <= n /\ a k[*]t[^]k [=] a_0[-]eps /\
 (forall i, 1 <= i -> i <= n -> a i[*]t[^]i [<=] a_0)}}.
Proof.
 cut (forall j : nat, let l := n - j in 1 <= l -> l <= n -> {t : IR | [0] [<=] t | {k : nat |
   l <= k /\ k <= n /\ a k[*]t[^]k [=] a_0[-]eps /\
     (forall i : nat, l <= i -> i <= n -> a i[*]t[^]i [<=] a_0)}}).
  intro H.
  rewrite <- lem_1a.
  apply H; rewrite lem_1a; auto with arith.
 intro j. induction  j as [| j Hrecj].
 replace (n - 0) with n.
   2: auto with arith.
  intros l H H0.
  exists (NRoot a_0_eps_nonneg gt_n_0).
   apply NRoot_nonneg.
  exists n.
  split. auto.
   split. auto.
   split.
   astepl ([1][*]NRoot a_0_eps_nonneg gt_n_0[^]n).
   Step_final (NRoot a_0_eps_nonneg gt_n_0[^]n).
  intros i H1 H2.
  replace i with n.
   2: apply le_antisym; auto.
  astepl ([1][*]NRoot a_0_eps_nonneg gt_n_0[^]n).
  astepl (NRoot a_0_eps_nonneg gt_n_0[^]n).
  astepl (a_0[-]eps).
  apply less_leEq; apply a_0_eps_fuzz.
 intros l H H0.
 cut (1 <= n - j). intro H1.
  2: apply le_trans with (n - S j); [ auto | apply lem_1b ].
 cut (n - j <= n). intro H2.
  2: apply lem_1c.
 elim (Hrecj H1 H2). intros t' H4 H5.
 elim H5. intros k' H6.
 elim H6. intros H7 H8. elim H8. intros H9 H10. elim H10. intros H11 H12.
 clear H10 H8 H6 H5.
 elim (less_cotransitive_unfolded _ _ _ a_0_eps_fuzz (a (n - S j) [*]t'[^] (n - S j))); intro H14.
  cut ([0] [<] a (n - S j)). intro H15.
   cut (a (n - S j) [#] [0]). intro H16.
    2: apply pos_ap_zero; auto.
   cut ([0] [<=] (a_0[-]eps[/] a (n - S j) [//]H16)). intro H17.
    cut (0 < n - S j). intro H18.
     2: auto with arith.
    exists (NRoot H17 H18).
     apply NRoot_nonneg.
    exists (n - S j).
    split. auto.
     split. auto.
     split.
     astepl (a (n - S j) [*] (a_0[-]eps[/] a (n - S j) [//]H16)).
     rational.
    intros i H19 H20.
    elim (le_lt_eq_dec _ _ H19); intro H22.
     apply leEq_transitive with (a i[*]t'[^]i).
      apply mult_resp_leEq_lft.
       apply power_resp_leEq.
        apply NRoot_nonneg.
       apply power_cancel_leEq with (n - S j); auto.
       astepl (a_0[-]eps[/] a (n - S j) [//]H16).
       apply shift_div_leEq.
        auto.
       astepr (a (n - S j) [*]t'[^] (n - S j)).
       apply less_leEq; auto.
      apply a_nonneg.
     apply H12.
      replace (n - j) with (S (n - S j)); [auto with arith|].
      rewrite minus_Sn_m; auto with arith.
     auto.
    rewrite <- H22.
    astepl (a (n - S j) [*] (a_0[-]eps[/] a (n - S j) [//]H16)).
    astepl (a_0[-]eps).
    apply less_leEq; apply a_0_eps_fuzz.
   apply shift_leEq_div; auto.
   astepl ZeroR; apply a_0_eps_nonneg.
  cut ([0] [<] a (n - S j) [*]t'[^] (n - S j)). intro H15.
   2: apply leEq_less_trans with (a_0[-]eps); auto.
   2: apply a_0_eps_nonneg.
  apply leEq_not_eq.
   apply a_nonneg.
  apply ap_symmetric_unfolded.
  exact (cring_mult_ap_zero _ _ _ (pos_ap_zero _ _ H15)).
 exists t'.
  auto.
 exists k'.
 split.
  apply le_trans with (n - j).
   unfold l in |- *; apply lem_1b.
  auto.
 split. auto.
  split. auto.
  intros i H15 H16.
 elim (le_lt_eq_dec _ _ H15); intro H18.
  apply H12.
   replace (n - j) with (S (n - S j)); [auto with arith|].
   rewrite minus_Sn_m; auto with arith.
  auto.
 rewrite <- H18.
 apply less_leEq; auto.
Qed.

Definition p3m (i : nat) := ([1] [/]ThreeNZ) [^]i:IR.

Lemma p3m_pos : forall i : nat, [0] [<] p3m i.
Proof.
 intros.
 unfold p3m in |- *.
 apply nexp_resp_pos.
 apply div_resp_pos.
  apply pos_three.
 apply pos_one.
Qed.

Lemma p3m_S : forall i : nat, p3m (S i) [=] p3m i [/]ThreeNZ.
Proof.
 intros.
 unfold p3m in |- *.
 astepl (([1] [/]ThreeNZ) [^]i[*] ([1] [/]ThreeNZ:IR)).
 rational.
Qed.

Hint Resolve p3m_S: algebra.

Lemma p3m_P : forall i : nat, p3m i [=] p3m (S i) [*]Three.
Proof.
 intros.
 Step_final (p3m i [/]ThreeNZ[*]Three).
Qed.

Lemma p3m_aux : forall i j : nat, p3m (S i) [^]j [=] p3m j[*]p3m i[^]j.
Proof.
 intros.
 unfold p3m in |- *.
 astepl (([1] [/]ThreeNZ) [^] (S i * j):IR).
 replace (S i * j) with (j + i * j).
  Step_final (([1] [/]ThreeNZ) [^]j[*] ([1] [/]ThreeNZ) [^] (i * j):IR).
 reflexivity.
Qed.

Lemma p3m_pow : forall i j : nat, p3m i[^]j [=] p3m (i * j).
Proof.
 intros.
 unfold p3m in |- *.
 algebra.
Qed.

Hint Resolve p3m_aux: algebra.

Lemma p3m_0 : p3m 0 [=] [1].
Proof.
 unfold p3m in |- *.
 simpl in |- *.
 algebra.
Qed.

Hint Resolve p3m_0: algebra.

Lemma third_pos : ZeroR [<] [1] [/]ThreeNZ.
Proof.
 apply recip_resp_pos.
 apply pos_three.
Qed.

Hint Resolve third_pos: algebra.

Lemma third_less_one : [1] [/]ThreeNZ [<] OneR.
Proof.
 apply pos_div_three'.
 apply pos_one.
Qed.

Hint Resolve third_less_one: algebra.

Lemma p3m_mon : forall i j : nat, i < j -> p3m j [<] p3m i.
Proof.
 intros.
 unfold p3m in |- *.
 apply small_nexp_resp_lt; algebra.
Qed.

Lemma p3m_mon' : forall i j : nat, i <= j -> p3m j [<=] p3m i.
Proof.
 intros.
 unfold p3m in |- *.
 apply small_nexp_resp_le; try apply less_leEq; algebra.
Qed.

Lemma p3m_small : forall i : nat, p3m i [<=] [1].
Proof.
 intro.
 astepr (p3m 0).
 apply p3m_mon'.
 auto with arith.
Qed.

Lemma p3m_smaller : forall i : nat, 0 < i -> p3m i [<=] Half.
Proof.
 intros.
 apply leEq_transitive with (p3m 1).
  apply p3m_mon'.
  auto with arith.
 unfold p3m in |- *.
 astepl ([1] [/]ThreeNZ:IR).
 unfold Half in |- *.
 apply less_leEq.
 apply recip_resp_less.
  apply pos_two.
 apply two_less_three.
Qed.

Definition chfun (k : nat -> nat) (a j i : nat) : nat :=
  match le_gt_dec i j with
  | left _  => k i
  | right _ => a
  end.

Lemma chfun_1 : forall k a j i, i <= j -> k i = chfun k a j i.
Proof.
 intros.
 unfold chfun in |- *.
 elim (le_gt_dec i j).
  auto.
 intro y.
 elim (le_not_gt _ _ H y).
Qed.

Lemma chfun_2 : forall k j a i, j < i -> a = chfun k a j i.
Proof.
 intros.
 unfold chfun in |- *.
 elim (le_gt_dec i j).
  intro y.
  elim (le_not_gt _ _ y H).
 auto.
Qed.

Lemma chfun_3 : forall k j a, (forall i, 1 <= k i /\ k i <= n) ->
 1 <= a -> a <= n -> forall i, 1 <= chfun k a j i /\ chfun k a j i <= n.
Proof.
 intros.
 unfold chfun in |- *.
 elim (le_gt_dec i j).
  auto.
 auto.
Qed.

Lemma chfun_4 : forall k j a, (forall i, k (S i) <= k i) ->
 a <= k j -> forall i, chfun k a j (S i) <= chfun k a j i.
Proof.
 intros.
 unfold chfun in |- *.
 elim (le_gt_dec i j); elim (le_gt_dec (S i) j); intros; auto.
  cut (i = j). intro.
   rewrite H1.
   auto.
  lia.
 lia.
Qed.

Definition Halfeps := Half[*]eps.

Lemma Halfeps_pos : [0] [<] Halfeps.
Proof.
 unfold Halfeps in |- *.
 apply mult_resp_pos.
  apply pos_half.
 apply eps_pos.
Qed.

Lemma Halfeps_Halfeps : forall x : IR, x[-]Halfeps[-]Halfeps [=] x[-]eps.
Proof.
 intros.
 unfold Halfeps in |- *.
 unfold Half in |- *.
 rational.
Qed.

Hint Resolve Halfeps_Halfeps: algebra.

Lemma Halfeps_eps : forall x y : IR, x[-]Halfeps [<=] y -> x[-]eps [<=] y.
Proof.
 intros.
 astepl (x[-]Halfeps[-]Halfeps).
 apply leEq_transitive with (x[-]Halfeps).
  apply less_leEq.
  apply shift_minus_less.
  apply shift_less_plus'.
  astepl ZeroR.
  apply Halfeps_pos.
 auto.
Qed.

Lemma Halfeps_trans : forall x y z : IR, x[-]Halfeps [<=] y -> y[-]Halfeps [<=] z -> x[-]eps [<=] z.
Proof.
 intros.
 astepl (x[-]Halfeps[-]Halfeps).
 apply leEq_transitive with (y[-]Halfeps).
  apply minus_resp_leEq.
  auto.
 auto.
Qed.

Lemma Key_1a : forall (i j : nat) (a t : IR), a[*] (t[*]p3m (S j)) [^]i [=] p3m i[*] (a[*] (t[*]p3m j) [^]i).
Proof.
 intros.
 astepl (a0[*] (t[^]i[*]p3m (S j) [^]i)).
 astepl (a0[*] (t[^]i[*] (p3m i[*]p3m j[^]i))).
 astepr (p3m i[*] (a0[*] (t[^]i[*]p3m j[^]i))).
 rational.
Qed.

Hint Resolve Key_1a: algebra.

Lemma Key_1b : forall k : nat, 1 <= k -> p3m k[*]eps [<=] Halfeps.
Proof.
 intros.
 unfold Halfeps in |- *.
 apply mult_resp_leEq_rht.
  apply p3m_smaller.
  auto.
 apply less_leEq; apply eps_pos.
Qed.

Lemma Key_1 : forall (i k j : nat) (ai ak t : IR),
 1 <= k -> k < i -> [0] [<=] ai -> [0] [<=] t -> ai[*] (t[*]p3m j) [^]i[-]eps [<=] ak[*] (t[*]p3m j) [^]k ->
 ai[*] (t[*]p3m (S j)) [^]i[-]Halfeps [<=] ak[*] (t[*]p3m (S j)) [^]k.
Proof.
 intros i k j ai ak t H H0 H1 H2 H3.
 apply leEq_transitive with (p3m k[*] (ai[*] (t[*]p3m j) [^]i) [-]p3m k[*]eps).
  apply minus_resp_leEq_both.
   astepl (p3m i[*] (ai[*] (t[*]p3m j) [^]i)).
   apply mult_resp_leEq_rht.
    apply less_leEq.
    apply p3m_mon; auto.
   astepl (ai[*][0]).
   apply mult_resp_leEq_lft; auto.
   apply nexp_resp_nonneg.
   apply mult_resp_nonneg; auto.
   apply less_leEq; apply p3m_pos.
  apply Key_1b; auto.
 astepl (p3m k[*] (ai[*] (t[*]p3m j) [^]i[-]eps)).
 astepr (p3m k[*] (ak[*] (t[*]p3m j) [^]k)).
 apply mult_resp_leEq_lft; auto.
 apply less_leEq; apply p3m_pos.
Qed.

Lemma Key_2 : forall (i k k' j : nat) (ai ak ak' t : IR),
 1 <= k -> k < i -> [0] [<=] ai -> [0] [<=] t ->
 ak[*] (t[*]p3m (S j)) [^]k[-]Halfeps [<=] ak'[*] (t[*]p3m (S j)) [^]k' ->
 ai[*] (t[*]p3m j) [^]i[-]eps [<=] ak[*] (t[*]p3m j) [^]k -> ai[*] (t[*]p3m (S j)) [^]i[-]eps [<=] ak'[*] (t[*]p3m (S j)) [^]k'.
Proof.
 intros.
 apply Halfeps_trans with (ak[*] (t[*]p3m (S j)) [^]k).
  apply Key_1; auto.
 auto.
Qed.

Lemma Key : {t : IR | [0] [<=] t | forall J, {k : nat -> nat |
 (forall i, 1 <= k i /\ k i <= n) /\ (forall i, k (S i) <= k i) /\
 (let k_0 := k 0 in a k_0[*]t[^]k_0 [=] a_0[-]eps) /\
 (forall j,  j <= J -> let k_j := k j in let r := t[*]p3m j in
  forall i, 1 <= i -> i <= n -> a i[*]r[^]i[-]eps [<=] a k_j[*]r[^]k_j)}}.
Proof.
 (* begin hide *)
Proof.
 elim lem_1. intro t. intros H0 H1.
 elim H1. intros k_0 H2.
 elim H2. intros H3 H4.
 elim H4. intros H5 H6.
 elim H6. intros H7 H8.
 clear H6 H4 H2 H1.
 exists t.
  auto.
 intro J.
 induction  J as [| J HrecJ].
  exists (fun j : nat => k_0).
  split. auto.
   split. auto.
   split. auto.
   intros j H9 k_j r i H10 H11.
  unfold k_j, r in |- *.
  rewrite <- (le_n_O_eq _ H9).
  replace (p3m 0) with OneR.
   2: auto.
  astepr (a k_0[*] (t[^]k_0[*][1][^]k_0)).
  astepr (a k_0[*] (t[^]k_0[*][1])).
  astepr (a k_0[*]t[^]k_0).
  astepr (a_0[-]eps).
  apply minus_resp_leEq.
  astepl (a i[*] (t[^]i[*][1][^]i)).
  astepl (a i[*] (t[^]i[*][1])).
  astepl (a i[*]t[^]i); auto.
 elim HrecJ. intros k' H9.
 elim H9. intros H10 H11. elim H11. intros H12 H13. elim H13. intros H14 H15.
 clear H9 H11 H13.
 cut (0 < k' J). intro H16.
  2: elim (H10 J); auto.
 elim (maj_upto_eps IR (fun i : nat => a i[*] (t[*]p3m (S J)) [^]i) ( k' J) Halfeps H16 Halfeps_pos).
 intros k_SJ H17.
 elim H17. intros H18 H19. elim H19. intros H20 H21.
 clear H17 H19.
 exists (chfun k' k_SJ J).
 split. intro i.
  apply chfun_3. auto. auto.
    apply le_trans with (k' J); auto.
  elim (H10 J). auto.
  split.
  intro i. apply chfun_4; auto.
  split.
  replace (chfun k' k_SJ J 0) with (k' 0); auto.
 intros j H22 k_j r i H23 H24.
 unfold k_j, r in |- *.
 elim (le_lt_eq_dec _ _ H22); intro H26.
  replace (chfun k' k_SJ J j) with (k' j).
   apply H15; auto with arith.
  apply chfun_1; auto with arith.
 replace (chfun k' k_SJ J j) with k_SJ.
  rewrite H26.
  elim (le_lt_dec i (k' J)); intro H28.
   apply Halfeps_eps.
   auto.
  apply Key_2 with (k' J) (a (k' J)); auto.
 apply chfun_2.
 rewrite H26.
 auto.
Qed.
(* end hide *)

End Key_Lemma.

#[global]
Hint Resolve p3m_S p3m_P p3m_pow: algebra.


Require Import List.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.Arith.Arith_base.

(*** terms and helper defs ***)

Definition level := nat.

Definition IndInfoH (T : Set) :=
  (level * (list ((list T) * (list (list T * list T)))))%type.

Inductive Term : Set :=
| Sort : level -> Term
| Pi : Term -> Term -> Term
| IndType : IndInfo -> TermList -> Term
| Var : nat -> Term
| App : Term -> Term -> Term
| Lam : Term -> Term -> Term
| CtorApp : IndInfo -> nat -> TermList -> TermList -> Term
| Elim : IndInfo -> TermList -> TermList -> Term -> Term
with TermList :=
| TL_nil : TermList
| TL_cons : TermList -> Term -> TermList
with Ctx :=
| Ctx_nil : Ctx
| Ctx_cons : Ctx -> Term -> Ctx
with IndInfo :=
| MkIndInfo : Ctx -> level -> CtorTypeList -> IndInfo
with CtorTypeList :=
| CTL_nil : CtorTypeList
| CTL_cons : CtorTypeList -> CtorType -> CtorTypeList
with CtorType :=
| MkCtorType : Ctx -> RecTpList -> TermList -> CtorType
with RecTpList :=
| RTL_nil : RecTpList
| RTL_cons : RecTpList -> RecTp -> RecTpList
with RecTp :=
| MkRecTp : Ctx -> TermList -> RecTp
.

(* Definition Ctx : Set := list Term. *)
(* Definition Ctx : Set := TermList. *)

(*** operations on my fake lists (stupid Coq) ***)

Fixpoint ctxLen (ctx : Ctx) :=
  match ctx with
    | Ctx_nil => 0
    | Ctx_cons ctx' _ => S (ctxLen ctx')
  end.

Fixpoint Ctx_app (ctx1 ctx2 : Ctx) :=
  match ctx2 with
    | Ctx_nil => ctx1
    | Ctx_cons ctx2' M => Ctx_cons (Ctx_app ctx1 ctx2') M
  end.

Fixpoint TL_Len (l : TermList) :=
  match l with
    | TL_nil => 0
    | TL_cons l' _ => S (TL_Len l')
  end.

Fixpoint TL_app (l1 l2 : TermList) :=
  match l2 with
    | TL_nil => l1
    | TL_cons l2' M => TL_cons (TL_app l1 l2') M
  end.

Fixpoint nth_or_fail_TL (n : nat) (l : TermList) : Term + { TL_Len l <= n } :=
  match n as n', l as l' return Term + { TL_Len l' <= n' } with
    | n, TL_nil => inright _ (le_O_n n)
    | 0, TL_cons _ M => inleft _ M
    | (S n'), (TL_cons l' _) =>
      match nth_or_fail_TL n' l' with
        | inleft M => inleft _ M
        | inright pf => inright _ (le_n_S _ _ pf)
      end
  end.

Fixpoint CTL_Len (l : CtorTypeList) :=
  match l with
    | CTL_nil => 0
    | CTL_cons l' _ => S (CTL_Len l')
  end.

Fixpoint nth_or_fail_CTL (n : nat) (l : CtorTypeList) : CtorType + { CTL_Len l <= n } :=
  match n as n', l as l' return CtorType + { CTL_Len l' <= n' } with
    | n, CTL_nil => inright _ (le_O_n n)
    | 0, CTL_cons _ ctp => inleft _ ctp
    | (S n'), (CTL_cons l' _) =>
      match nth_or_fail_CTL n' l' with
        | inleft ctp => inleft _ ctp
        | inright pf => inright _ (le_n_S _ _ pf)
      end
  end.

Inductive isNth_CTL (T : CtorType) : nat -> CtorTypeList -> Set :=
| isNth_CTL_base (l : CtorTypeList) : isNth_CTL T 0 (CTL_cons l T)
| isNth_CTL_cons (n : nat) (T' : CtorType) (l : CtorTypeList)
  : isNth_CTL T n l -> isNth_CTL T (S n) (CTL_cons l T').

Inductive isNth_TL (T : Term) : nat -> TermList -> Set :=
| isNth_TL_base (l : TermList) : isNth_TL T 0 (TL_cons l T)
| isNth_TL_cons (n : nat) (T' : Term) (l : TermList)
  : isNth_TL T n l -> isNth_TL T (S n) (TL_cons l T').

Inductive isNth_RTL (T : RecTp) : nat -> RecTpList -> Set :=
| isNth_RTL_base (l : RecTpList) : isNth_RTL T 0 (RTL_cons l T)
| isNth_RTL_cons (n : nat) (T' : RecTp) (l : RecTpList)
  : isNth_RTL T n l -> isNth_RTL T (S n) (RTL_cons l T').

Inductive isNth_Ctx (T : Term) : nat -> Ctx -> Set :=
| isNth_Ctx_base (ctx : Ctx) : isNth_Ctx T 0 (Ctx_cons ctx T)
| isNth_Ctx_cons (n : nat) (ctx : Ctx) (T' : Term)
  : isNth_Ctx T n ctx -> isNth_Ctx T (S n) (Ctx_cons ctx T').

(*** simple term maipulation ***)

Fixpoint makeLam (ctx : Ctx) (body : Term) {struct ctx} : Term :=
  match ctx with
    | Ctx_nil => body
    | Ctx_cons ctx' tp => makeLam ctx' (Lam tp body)
  end.
Fixpoint makePi (ctx : Ctx) (body : Term) {struct ctx} : Term :=
  match ctx with
    | Ctx_nil => body
    | Ctx_cons ctx' tp => makePi ctx' (Pi tp body)
  end.
Fixpoint makeApp (f : Term) (args : TermList) : Term :=
  match args with
    | TL_nil => f
    | TL_cons args' arg => App (makeApp f args') arg
  end.
Fixpoint makeVarList (n : nat) (ctx : Ctx) : TermList :=
  match ctx with
    | Ctx_nil => TL_nil
    | Ctx_cons ctx' tp => TL_cons (makeVarList (S n) ctx') (Var n)
  end.
Definition makeAppToVars (f : Term) (n : nat) (ctx : Ctx) : Term :=
  makeApp f (makeVarList n ctx).
(*
Fixpoint makeAppToVars (f : Term) (n : nat) (ctx : Ctx) : Term :=
  match ctx with
    | Ctx_nil => f
    | Ctx_cons ctx' tp => App (makeAppToVars f (S n) ctx') (Var n)
  end.
*)
Fixpoint makeVarListStep2 (n : nat) (ctx : Ctx) : TermList :=
  match ctx with
    | Ctx_cons (Ctx_cons ctx' tp1) tp2 =>
      TL_cons (makeVarListStep2 (S (S n)) ctx') (Var n)
    | _ => TL_nil
  end.

(* Definition dummyCtorType : CtorType := MkCtorType Ctx_nil RTL_nil TL_nil. *)

Definition ctorRecTps (ctp : CtorType) : RecTpList :=
  match ctp with
    MkCtorType ctx recTps indices => recTps
  end.

Definition numCtors (info : IndInfo) :=
  match info with
    MkIndInfo ctx l ctps => CTL_Len ctps
  end.

Definition nthCtorType (n : nat) (info : IndInfo) : option CtorType :=
  match info with
    MkIndInfo ctx l ctps =>
    match nth_or_fail_CTL n ctps with
      | inleft ctp => Some ctp
      | inright _ => None
(* | inright _ => dummyCtorType *)
    end
  end.

(*** proofs of the maximum sort + 1 in a term ***)
(* README: this (not entirely finished) is not closed under conv!
Inductive MaxSort (i : nat) : Term -> Set :=
| MS_Sort j : j < i -> MaxSort i (Sort j)
| MS_Pi A B i : MaxSort i A -> MaxSort i B -> MaxSort i (Pi A B)
| MS_IndType info args i :
  MaxSortIndInfo i info -> MaxSortTermList i args ->
  MaxSort i (IndType info args)
| MS_Var j i : MaxSort i (Var j)
| MS_App M N i : MaxSort i M -> MaxSort i N -> MaxSort i (App M N)
| MS_Lam A M i : MaxSort i A -> MaxSort i M -> MaxSort i (Lam A M)
| MS_CtorApp info j args recArgs i :
  MaxSortIndInfo i info -> MaxSortTermList i args ->
  MaxSortRecTpList i recArgs -> MaxSort i (CtorApp info j args recArgs)
| MS_Elim info fs params scrut i :
  MaxSortIndInfo i info -> MaxSortTermList i fs ->
  MaxSortTermList i params -> MaxSort i scrut ->
  MaxSort i (info fs params scrut)
with MaxSortTermList (i : nat) : TermList -> Set :=
| MS_TL_nil : MaxSortTermList i TL_nil
| MS_TL_cons l M : MaxSortTermList i l -> MaxSort i M ->
  MaxSortTermList i (TL_cons l M)
with MaxSortCtx (i : nat) : MaxSortCtx -> Set :=
| MS_Ctx_nil : MaxSortCtx i Ctx_nil
| MS_Ctx_cons l M : MaxSortCtx i l -> MaxSort i M ->
  MaxSortCtx i (Ctx_cons l M)
with MaxSortIndInfo (i : nat) : MaxSortIndInfo -> Set :=
| MS_MkIndInfo ctx j ctps :
  MaxSortCtx i ctx -> j <= i -> MaxSort
with MaxSortCtorTypeList (i : nat) : MaxSortCtorTypeList -> Set :=
| MS_CTL_nil : MaxSortCtorTypeList i CTL_nil
| MS_CTL_cons l M : MaxSortCtorTypeList i l -> MaxSort i M ->
  MaxSortCtorTypeList i (CTL_cons l M)
with MaxSortCtorType (i : nat) : MaxSortCtorType -> Set :=
| MS_MkCtorType : Ctx -> RecTpList -> TermList -> CtorType
with MaxSortRecTpList (i : nat) : MaxSortRecTpList -> Set :=
| MS_RTL_nil : MaxSortRecTpList i RTL_nil
| MS_RTL_cons l M : MaxSortRecTpList i l -> MaxSort i M ->
  MaxSortRecTpList i (RTL_cons l M)
with MaxSortRecTp (i : nat) : MaxSortRecTp -> Set :=
| MS_MkRecTp : Ctx -> TermList -> RecTp
.
*)

(*** substitution and lifting ***)

(* README: k is the amount we are incrementing the variables, and n is the
 * number of variable bindings under which we have traversed so far *)
Fixpoint lift (n k : nat) (M : Term) {struct M} : Term :=
  match M with
    | Sort i => Sort i
    | Pi A B => Pi (lift n k A) (lift (S n) k B)
    | IndType info indices =>
      IndType (liftIndInfo n k info) (liftTermList n k indices)
    | Var i =>
      match le_lt_dec n i with
        | left _ => Var (i + k) (* case: i >= n *)
        | right _ => Var i (* case: i < n *)
      end
    | App M1 M2 => App (lift n k M1) (lift n k M2)
    | Lam A M1 => Lam (lift n k A) (lift (S n) k M1)
    | CtorApp info i args recArgs =>
      CtorApp (liftIndInfo n k info) i (liftTermList n k args) (liftTermList n k recArgs)
    | Elim info fs params scrut =>
      Elim (liftIndInfo n k info) (liftTermList n k params)
      (liftTermList n k fs) (lift n k scrut)
  end
with liftTermList (n k : nat) (l : TermList) :=
  match l with
    | TL_nil => TL_nil
    | TL_cons l' M => TL_cons (liftTermList n k l') (lift n k M)
  end
with liftCtx (n k : nat) (ctx : Ctx) :=
  match ctx with
    | Ctx_nil => Ctx_nil
    | Ctx_cons ctx' M => Ctx_cons (liftCtx n k ctx') (lift (n + (ctxLen ctx')) k M)
  end
with liftIndInfo (n k : nat) (info : IndInfo) :=
  match info with
    | MkIndInfo ctx i ctorTypes => MkIndInfo (liftCtx n k ctx) i (liftCtorTypeList n k ctorTypes)
  end
with liftCtorTypeList (n k : nat) (l : CtorTypeList) :=
  match l with
    | CTL_nil => CTL_nil
    | CTL_cons l' ctp =>
      CTL_cons (liftCtorTypeList n k l') (liftCtorType n k ctp)
  end
with liftCtorType (n k : nat) (ctp : CtorType) :=
  match ctp with
    | MkCtorType ctx recCtx indices =>
      (MkCtorType (liftCtx n k ctx)
        (liftRecTpList (n + (ctxLen ctx)) k recCtx)
        (liftTermList (n + (ctxLen ctx)) k indices))
  end
with liftRecTpList (n k : nat) (l : RecTpList) :=
  match l with
    | RTL_nil => RTL_nil
    | RTL_cons l' r => RTL_cons (liftRecTpList n k l') (liftRecTp n k r)
  end
with liftRecTp (n k : nat) (r : RecTp) :=
  match r with
    | MkRecTp ctx indices =>
      MkRecTp (liftCtx n k ctx) (liftTermList (n + (ctxLen ctx)) k indices)
  end
  .

Fixpoint substH (n : nat) (s : TermList) (M : Term) {struct M} : Term :=
  match M with
    | Sort i => Sort i
    | Pi A B => Pi (substH n s A) (substH (S n) s B)
    | IndType info indices =>
      IndType (substIndInfo n s info) (substTermList n s indices)
    | Var i =>
      match le_lt_dec n i with
        | right _ => Var i (* case: i < n *)
        | left _ => (* case: i >= n *)
          match nth_or_fail_TL (i - n) s with
            | inleft N => lift 0 n N
            | _ => Var (i + n)
          end
      end
    | App M1 M2 => App (substH n s M1) (substH n s M2)
    | Lam A M1 => Lam (substH n s A) (substH (S n) s M1)
    | CtorApp info i args recArgs =>
      CtorApp (substIndInfo n s info) i (substTermList n s args) (substTermList n s recArgs)
    | Elim info fs params scrut =>
      Elim (substIndInfo n s info) (substTermList n s params)
      (substTermList n s fs) (substH n s scrut)
  end
with substTermList (n : nat) (s : TermList) (l : TermList) :=
  match l with
    | TL_nil => TL_nil
    | TL_cons l' M => TL_cons (substTermList n s l') (substH n s M)
  end
with substCtx (n : nat) (s : TermList) (ctx : Ctx) :=
  match ctx with
    | Ctx_nil => Ctx_nil
    | Ctx_cons ctx' M =>
      Ctx_cons (substCtx n s ctx') (substH (plus n (ctxLen ctx')) s M)
  end
with substIndInfo (n : nat) (s : TermList) (info : IndInfo) :=
  match info with
    | MkIndInfo ctx l ctorTypes =>
      MkIndInfo (substCtx n s ctx) l (substCtorTypeList n s ctorTypes)
  end
with substCtorTypeList (n : nat) (s : TermList) (l : CtorTypeList) :=
  match l with
    | CTL_nil => CTL_nil
    | CTL_cons l' ctp =>
      CTL_cons (substCtorTypeList n s l') (substCtorType n s ctp)
  end
with substCtorType (n : nat) (s : TermList) (ctp : CtorType) :=
  match ctp with
    | MkCtorType ctx recCtx indices =>
      (MkCtorType (substCtx n s ctx)
        (substRecTpList (plus n (ctxLen ctx)) s recCtx)
        (substTermList (plus n (ctxLen ctx)) s indices))
  end
with substRecTpList (n : nat) (s : TermList) (l : RecTpList) :=
  match l with
    | RTL_nil => RTL_nil
    | RTL_cons l' r => RTL_cons (substRecTpList n s l') (substRecTp n s r)
  end
with substRecTp (n : nat) (s : TermList) (r : RecTp) :=
  match r with
    | MkRecTp ctx indices =>
      MkRecTp (substCtx n s ctx) (substTermList (plus n (ctxLen ctx)) s indices)
  end
  .

Definition subst (s : TermList) (M : Term) := substH 0 s M.
Definition substOne (N M : Term) := substH 0 (TL_cons TL_nil N) M.

(*** auxiliary defs dependent on substitution ***)

Fixpoint termList2Ctx (l : TermList) : Ctx :=
  match l with
    | TL_nil => Ctx_nil
    | TL_cons l' A => Ctx_cons (termList2Ctx l') (lift 0 (TL_Len l') A)
  end.

(*** operations on inductive types: most of these require lifting ***)

Definition indLevel (info : IndInfo) :=
  match info with
    | MkIndInfo _ l _ => l
  end.

(* README: we assume info is well-typed in the "ambient" ctx, that
 * argCtx is well-formed in ctx, and that r is well-typed in (ctx,argCtx);
 * the returned term is well-typed in (ctx,argCtx) *)
Definition recTp2Type (info : IndInfo) (argCtx : Ctx) (r : RecTp) : Term :=
  match r with
    | MkRecTp ctx indices =>
      makePi ctx (IndType (liftIndInfo 0 (ctxLen ctx + ctxLen argCtx) info) indices)
  end.
Fixpoint recTps2Types (info : IndInfo) (argCtx : Ctx) (rs : RecTpList) : TermList :=
  match rs with
    | RTL_nil => TL_nil
    | RTL_cons rs' r =>
      TL_cons (recTps2Types info argCtx rs') (recTp2Type info argCtx r)
  end.

(* NOTE: the below requires lifting each result of (recTp2Type info r)
Fixpoint makeRecTpPi (info : IndInfo) (l : RecTpList) (body : Term) : Term :=
  match l with
    | RTL_nil => body
    | RTL_cons l' r => makeRecTpPi info l' (Pi (recTp2Type info r) body)
  end.
Definition ctorPiType (info : IndInfo) (ctp : CtorType) : Term :=
  match ctp with
    | MkCtorType ctx recCtx indices =>
      makePi ctx (makeRecTpPi info recCtx (IndType info indices))
  end.
*)

(*
Fixpoint recTp2Type (info : IndInfo) (r : RecTp) : Term :=
  match r with
    | MkRecTp arg recArgs => IndType info args
    | RT_cons varTp r' => Pi varTp (recTp2Type info r')
  end.
*)

(*
Definition isArgType (ctor i : nat) (info : IndInfo) (T : Term) : Set :=
  match info with
    | MkIndInfo _ ctorTypes =>
      { al : TermList & { rtl : RecTpList & isNth_CTL (MkCtorType al rtl) ctor ctorTypes & isNth_TL T i al } }
  end.

Definition isRecArgType (ctor i : nat) (info : IndInfo) (T : Term) : Set :=

  match info with
    | MkIndInfo _ ctorTypes =>
      { al : TermList & { rtl : RecTpList & isNth_CTL (MkCtorType al rtl) ctor ctorTypes & isNth_TL T i al } }
  end.
*)

(*** convertability ***)

(* README: we assume there is some "ambient" ctx and an argCtx for the
 * non-recursive args in the current constructor; elimF then takes in ctx',
 * some params that are well-typed in (ctx,argCtx,ctx'), and some scrut
 * that is well-typed in (ctx,ctx'), and returns a term well-typed in
 * (ctx,ctx'). *)
Definition elimRecArg (elimF : Ctx -> TermList -> Term -> Term)
  (r : RecTp) (recArg : Term) :=
  match r with
    | MkRecTp ctx indices =>
      makeLam ctx (elimF ctx indices
        (makeAppToVars (lift 0 (ctxLen ctx) recArg) 0 ctx))
  end.

(* README: elimRecArgsH takes each recursive argument recArg supplied
 * to a constructor and returns both recArg and the result of a
 * recursive call (using elimF) on recArg *)
Fixpoint elimRecArgsH (elimF : Ctx -> TermList -> Term -> Term)
  (rs : RecTpList) (recArgs : TermList) : option TermList :=
  match rs, recArgs with
    | RTL_nil, TL_nil => Some TL_nil
    | RTL_cons rs' r, TL_cons recArgs' recArg =>
      match elimRecArgsH elimF rs' recArgs' with
        | None => None
        | Some ret =>
          Some (TL_cons (TL_cons ret recArg) (elimRecArg elimF r recArg))
      end
    | _, _ => None
  end.

Definition elimRecArgs (info : IndInfo) (fs : TermList) (i : nat)
  (args : TermList) (recArgs : TermList) : option TermList :=
  match nthCtorType i info with
    | None => None
    | Some (MkCtorType ctx rs indices) =>
      elimRecArgsH (fun ctx params scrut =>
        Elim (liftIndInfo 0 (ctxLen ctx) info)
        (liftTermList 0 (ctxLen ctx) fs)
        (substTermList (ctxLen ctx) args params)
        scrut)
      rs recArgs
  end.

(*
Definition elimRecArg (info : IndInfo) (fs : TermList) (args : TermList) (r : RecTp) (recArg : Term) :=
  match r with
    | MkRecTp ctx indices =>
      makeLam ctx (
        Elim (liftIndInfo 0 (ctxLen ctx) info)
        (liftTermList 0 (ctxLen ctx) fs)
        (substTermList (ctxLen ctx) args indices)
        (makeAppToVars (lift 0 (ctxLen ctx) recArg) 0 ctx)
      )
  end.

Fixpoint elimRecArgsH (info : IndInfo) (fs : TermList) (args : TermList)
  (rs : RecTpList) (recArgs : TermList) : option TermList :=
  match rs, recArgs with
    | RTL_nil, TL_nil => Some TL_nil
    | RTL_cons rs' r, TL_cons recArgs' recArg =>
      match elimRecArgsH info fs args rs' recArgs' with
        | None => None
        | Some ret => Some (TL_cons ret (elimRecArg info fs args r recArg))
      end
    | _, _ => None
  end.

Definition elimRecArgs (info : IndInfo) (fs : TermList) (i : nat)
  (args : TermList) (recArgs : TermList) : option TermList :=
  match nthCtorType i info with
    | None => None
    | Some (MkCtorType ctx rs indices) =>
      elimRecArgsH info fs args rs recArgs
  end.
*)

Inductive rrto : Term -> Term -> Set :=
| RR_Beta : forall A M N, rrto (App (Lam A M) N) (substOne N M)
| RR_iota : forall info info' fs f params i args recArgs elimArgs,
  nth_or_fail_TL i fs = inleft _ f ->
  elimRecArgs info fs i args recArgs = Some elimArgs ->
  rrto (Elim info fs params (CtorApp info' i args recArgs))
  (makeApp (makeApp f args) elimArgs)
| RR_Pi1 : forall A A' B, rrto A A' -> rrto (Pi A B) (Pi A' B)
| RR_Pi2 : forall A B B', rrto B B' -> rrto (Pi A B) (Pi A B')
| RR_App1 : forall f f' a , rrto f f' -> rrto (App f a) (App f' a)
| RR_App2 : forall f a a', rrto a a' -> rrto (App f a) (App f a')
| RR_Lam1 : forall A A' M, rrto A A' -> rrto (Lam A M) (Lam A' M)
| RR_Lam2 : forall A M M', rrto M M' -> rrto (Lam A M) (Lam A M')
| RR_Elim1 : forall info info' fs params scrut,
  rrtoIndInfo info info' ->
    rrto (Elim info fs params scrut) (Elim info' fs params scrut)
| RR_Elim2 : forall info fs fs' params scrut,
  rrtoTermList fs fs' ->
    rrto (Elim info fs params scrut) (Elim info fs' params scrut)
| RR_Elim3 : forall info fs params params' scrut,
  rrtoTermList params params' ->
    rrto (Elim info fs params scrut) (Elim info fs params' scrut)
| RR_Elim4 : forall info fs params scrut scrut',
  rrto scrut scrut' ->
    rrto (Elim info fs params scrut) (Elim info fs params scrut')
with rrtoTermList : TermList -> TermList -> Set :=
| RR_TL_cons1 : forall M l l',
  rrtoTermList l l' -> rrtoTermList (TL_cons l M) (TL_cons l' M)
| RR_TL_cons2 : forall M M' l,
  rrto M M' -> rrtoTermList (TL_cons l M) (TL_cons l M')
with rrtoCtx : Ctx -> Ctx -> Set :=
| RR_Ctx_cons1 : forall ctx ctx' M,
  rrtoCtx ctx ctx' -> rrtoCtx (Ctx_cons ctx M) (Ctx_cons ctx' M)
| RR_Ctx_cons2 : forall ctx M M',
  rrto M M' -> rrtoCtx (Ctx_cons ctx M) (Ctx_cons ctx M')
with rrtoIndInfo : IndInfo -> IndInfo -> Set :=
| RR_MkIndInfo1 : forall ctx ctx' i ctps,
  rrtoCtx ctx ctx' ->
  rrtoIndInfo (MkIndInfo ctx i ctps) (MkIndInfo ctx' i ctps)
| RR_MkIndInfo2 : forall ctx i ctps ctps',
  rrtoCtorTypeList ctps ctps' ->
  rrtoIndInfo (MkIndInfo ctx i ctps) (MkIndInfo ctx i ctps')
with rrtoCtorTypeList : CtorTypeList -> CtorTypeList -> Set :=
| RR_CTL_cons1 : forall ctp l l',
  rrtoCtorTypeList l l' -> rrtoCtorTypeList (CTL_cons l ctp) (CTL_cons l' ctp)
| RR_CTL_cons2 : forall ctp ctp' l,
  rrtoCtorType ctp ctp' -> rrtoCtorTypeList (CTL_cons l ctp) (CTL_cons l ctp')
with rrtoCtorType : CtorType -> CtorType -> Set :=
| RR_MkCtorType1 : forall ctx ctx' rs indices,
  rrtoCtx ctx ctx' ->
  rrtoCtorType (MkCtorType ctx rs indices) (MkCtorType ctx' rs indices)
| RR_MkCtorType2 : forall ctx rs rs' indices,
  rrtoRecTpList rs rs' ->
  rrtoCtorType (MkCtorType ctx rs indices) (MkCtorType ctx rs' indices)
| RR_MkCtorType3 : forall ctx rs indices indices',
  rrtoTermList indices indices' ->
  rrtoCtorType (MkCtorType ctx rs indices) (MkCtorType ctx rs indices')
with rrtoRecTpList : RecTpList -> RecTpList -> Set :=
| RR_RTL_cons1 : forall r l l',
  rrtoRecTpList l l' -> rrtoRecTpList (RTL_cons l r) (RTL_cons l' r)
| RR_RTL_cons2 : forall r r' l,
  rrtoRecTp r r' -> rrtoRecTpList (RTL_cons l r) (RTL_cons l r')
with rrtoRecTp : RecTp -> RecTp -> Set :=
| RR_MkRecTp1 : forall ctx ctx' indices,
  rrtoCtx ctx ctx' ->
  rrtoRecTp (MkRecTp ctx indices) (MkRecTp ctx' indices)
| RR_MkRecTp2 : forall ctx indices indices',
  rrtoTermList indices indices' ->
  rrtoRecTp (MkRecTp ctx indices) (MkRecTp ctx indices')
.

Inductive conv : Term -> Term -> Set :=
| conv_refl : forall M , conv M M
| conv_stepR : forall M1 M2 M3 , rrto M1 M2 -> conv M2 M3 ->
  conv M1 M3
| conv_stepL : forall M1 M2 M3 , rrto M2 M1 -> conv M2 M3 ->
  conv M1 M3
.

(*** sub-typing ***)

Inductive subtype : Term -> Term -> Set :=
| SubTp_Refl : forall T , subtype T T
| SubTp_Sort : forall i j , i <= j -> subtype (Sort i) (Sort j)
| SubTp_Pi : forall A B B' , subtype B B' -> subtype (Pi A B) (Pi A B')
.

(*** typing ***)

(* translates a RecTp into the type of the eliminator for that RecTp
 *
 * README: we assume an "ambient" ctx, an argCtx that quantifies over
 * the non-recursive args for the current constructor, and an indCtx
 * that quantifies over the index args to the current inductive type,
 * where the latter two must be well-formed relative to ctx; we then
 * assume that r is well-typed w.r.t. (ctx,argCtx) and that B is
 * well-typed w.r.t. (ctx,argCtx,indCtx, --some IndType-- ), and
 * return a term that is well-typed in (ctx,argCtx, 0 : r)
 *)
Definition recTp2ElimType (r : RecTp) B :=
  match r with
    | MkRecTp ctx indices =>
      makePi (liftCtx 0 1 ctx) (substH ((ctxLen ctx) + 1)
        (TL_cons (liftTermList (ctxLen ctx) 1 indices)
          (makeAppToVars (Var (ctxLen ctx)) 0 ctx))
        (lift 0 ((ctxLen ctx) + 1) B))
  end.

(* README: we make the same context assumptions as recTp2ElimType and,
 * in addition, that info is well-typed in the "ambient" ctx. *)
Fixpoint recTps2ElimCtx (info : IndInfo) (argCtx : Ctx) (rs : RecTpList) B :=
  match rs with
    | RTL_nil => Ctx_nil
    | RTL_cons rs' r =>
      Ctx_cons (Ctx_cons (recTps2ElimCtx info argCtx rs' B)
        (lift 0 (ctxLen (recTps2ElimCtx info argCtx rs' B))
          (recTp2Type info argCtx r)))
      (lift 1 (ctxLen (recTps2ElimCtx info argCtx rs' B)) (recTp2ElimType r B))
  end.

(* README: same context assumptions as recTp2sElimCtx, but ctp is
 * well-typed w.r.t. the "ambient" ctx and B is well-typed w.r.t.
 * (ctx,indCtx, --some IndType--); we return a term that is well-typed
 * w.r.t. the ambient ctx *)
Definition ctorElimType (info : IndInfo) (indCtx : Ctx) (i : nat) (ctp : CtorType) B :=
  match ctp with
    | MkCtorType argCtx rs indices =>
      let elimCtx := (recTps2ElimCtx info argCtx rs
        (lift (ctxLen indCtx + 1) (ctxLen argCtx) B)) in
      makePi argCtx (
        makePi elimCtx
        (subst
          (TL_cons (liftTermList 0 (ctxLen elimCtx) indices)
            (CtorApp (liftIndInfo 0 (ctxLen argCtx + ctxLen elimCtx) info)
              i
              (makeVarList (ctxLen elimCtx) argCtx)
              (makeVarListStep2 0 elimCtx)
            ))
          (lift (ctxLen indCtx + 1) (ctxLen argCtx + ctxLen elimCtx) B))
      )
  end.

Fixpoint elimFsTypesH (info : IndInfo) (indCtx : Ctx) (i : nat) (ctps : CtorTypeList) B :=
  match ctps with
    | CTL_nil => TL_nil
    | CTL_cons ctps' ctp =>
      TL_cons (elimFsTypesH info indCtx (S i) ctps' B)
      (ctorElimType info indCtx i ctp B)
  end.

Definition elimFsTypes (info : IndInfo) B :=
  match info with
    | MkIndInfo indCtx _ ctps => elimFsTypesH info indCtx 0 ctps B
  end.

Inductive HasTp (ctx : Ctx) : Term -> Term -> Set :=
| HT_convR : forall M T T' , HasTp ctx M T -> rrto T T' -> HasTp ctx M T'
| HT_convL : forall M T T' , HasTp ctx M T -> rrto T' T -> HasTp ctx M T'
| HT_sub : forall M T T' , HasTp ctx M T -> subtype T T' -> HasTp ctx M T'
(* | HT_Prp : forall i , HasTp ctx Prp (Sort i) *)
| HT_Sort : forall i, HasTp ctx (Sort i) (Sort (S i))
| HT_Pi_P : forall i A B ,
  HasTp ctx A (Sort i) ->
  HasTp (Ctx_cons ctx A) B (Sort i) ->
  HasTp ctx (Pi A B) (Sort i)
| HT_Pi_I : forall i A B ,
  HasTp ctx A (Sort i) ->
  HasTp (Ctx_cons ctx A) B (Sort 0) ->
  HasTp ctx (Pi A B) (Sort 0)
| HT_IndType : forall info indices indCtx i ,
  WfIndInfo ctx info indCtx i ->
  HasTpTermList ctx indices indCtx ->
  HasTp ctx (IndType info indices) (Sort i)
| HT_Var : forall i T, isNth_Ctx T i ctx ->
  HasTp ctx (Var i) T
| HT_App : forall A B M N,
  HasTp ctx M (Pi A B) -> HasTp ctx N A ->
  HasTp ctx (App M N) (substOne N B)
| HT_Lam : forall i A M B,
  HasTp ctx A (Sort i) ->
  HasTp (Ctx_cons ctx A) M B ->
  HasTp ctx (Lam A M) (Pi A B)
| HT_CtorApp : forall info indCtx indI argCtx rs indices i args recArgs,
  WfIndInfo ctx info indCtx indI ->
  nthCtorType i info = Some (MkCtorType argCtx rs indices) ->
  HasTpTermList ctx args argCtx ->
  HasTpTermList_TL ctx recArgs (recTps2Types info argCtx rs) ->
  HasTp ctx (CtorApp info i args recArgs)
  (IndType info (substTermList 0 args indices))
| HT_Elim_P : forall info indCtx indI fs params scrut B Bi,
  WfIndInfo ctx info indCtx (S indI) ->
  (HasTp
    (Ctx_cons (Ctx_app ctx indCtx)
      (IndType (liftIndInfo 0 (ctxLen indCtx) info) (makeVarList 0 indCtx)))
    B (Sort Bi)) ->
  HasTpTermList_TL ctx fs (elimFsTypes info B) ->
  HasTpTermList ctx params indCtx ->
  HasTp ctx scrut (IndType info params) ->
  HasTp ctx (Elim info fs params scrut) (subst (TL_cons params scrut) B)
| HT_Elim_I : forall info indCtx fs params scrut B Bi,
  WfIndInfo ctx info indCtx 0 ->
  (HasTp
    (Ctx_cons (Ctx_app ctx indCtx)
      (IndType (liftIndInfo 0 (ctxLen indCtx) info) (makeVarList 0 indCtx)))
    B (Sort Bi)) ->
  ((Bi = 0) + (numCtors info <= 1)) ->
  HasTpTermList_TL ctx fs (elimFsTypes info B) ->
  HasTpTermList ctx params indCtx ->
  HasTp ctx scrut (IndType info params) ->
  HasTp ctx (Elim info fs params scrut) (subst (TL_cons params scrut) B)
(*
| HT_Elim_I0 : forall indCtx params scrut B,
  WfCtx ctx indCtx 0 ->
  HasTpTermList ctx params indCtx ->
  HasTp ctx scrut (IndType (MkIndInfo indCtx 0 CTL_nil) params) ->
  HasTp ctx (Elim (MkIndInfo indCtx 0 CTL_nil) TL_nil params scrut) (subst (TL_cons params scrut) B)
*)

(* FIXME: impredicative elims *)

with HasTpTermList (ctx : Ctx) : TermList -> Ctx -> Set :=
| HT_TL_nil : HasTpTermList ctx TL_nil Ctx_nil
| HT_TL_cons : forall l lCtx M T,
  HasTpTermList ctx l lCtx -> HasTp ctx M (subst l T) ->
  HasTpTermList ctx (TL_cons l M) (Ctx_cons lCtx T)

(* same as above, but with no substitution, since the types are not a
 * Ctx, and so are not dependent *)
with HasTpTermList_TL (ctx : Ctx) : TermList -> TermList -> Set :=
| HT_TL_nil_TL : HasTpTermList_TL ctx TL_nil TL_nil
| HT_TL_cons_TL : forall l Ts M T,
  HasTpTermList_TL ctx l Ts -> HasTp ctx M T ->
  HasTpTermList_TL ctx (TL_cons l M) (TL_cons Ts T)

(* states that a Ctx is well-formed with max sort i *)
with WfCtx (ctx : Ctx) : Ctx -> nat -> Set :=
| WF_Ctx_nil : forall i, WfCtx ctx Ctx_nil i
| WF_Ctx_cons : forall ctx' A i,
  WfCtx ctx ctx' i -> HasTp ctx A (Sort i) -> WfCtx ctx (Ctx_cons ctx' A) i

with WfIndInfo (ctx : Ctx) : IndInfo -> Ctx -> nat -> Set :=
| WF_MkIndInfo : forall indCtx i ctps,
  WfCtx ctx indCtx i ->
  WfCtorTypeList ctx indCtx ctps i ->
  WfIndInfo ctx (MkIndInfo indCtx i ctps) indCtx i

with WfCtorTypeList (ctx : Ctx) : Ctx -> CtorTypeList -> nat -> Set :=
| WF_CTL_nil : forall indCtx i, WfCtorTypeList ctx indCtx CTL_nil i
| WF_CTL_cons : forall indCtx i ctps ctp,
  WfCtorTypeList ctx indCtx ctps i ->
  WfCtorType ctx indCtx ctp i ->
  WfCtorTypeList ctx indCtx (CTL_cons ctps ctp) i

with WfCtorType (ctx : Ctx) : Ctx -> CtorType -> nat -> Set :=
| WF_MkCtorType : forall indCtx argCtx i r indices,
  WfCtx ctx argCtx i ->
  WfRecTpList ctx indCtx argCtx r i ->
  HasTpTermList (Ctx_app ctx argCtx) indices indCtx ->
  WfCtorType ctx indCtx (MkCtorType argCtx r indices) i

with WfRecTpList (ctx : Ctx) : Ctx -> Ctx -> RecTpList -> nat -> Set :=
| WF_RTL_nil : forall indCtx argCtx i, WfRecTpList ctx indCtx argCtx RTL_nil i
| WF_RTL_cons : forall indCtx argCtx i rs r,
  WfRecTpList ctx indCtx argCtx rs i ->
  WfRecTp ctx indCtx argCtx r i ->
  WfRecTpList ctx indCtx argCtx (RTL_cons rs r) i

with WfRecTp (ctx : Ctx) : Ctx -> Ctx -> RecTp -> nat -> Set :=
| WF_MkRecTp : forall indCtx argCtx i recCtx recIndices,
  WfCtx (Ctx_app ctx argCtx) recCtx i ->
  HasTpTermList (Ctx_app ctx argCtx) recIndices indCtx ->
  WfRecTp ctx indCtx argCtx (MkRecTp recCtx recIndices) i
.