(** * Validity of Annotations
In this file, we prove all the tools we need to show  that a welltyped judgment
of PTS can be annotated in a valid judgement of PTS_{atr}. With this, we give
a validity to the annotation system we chose.*)
Require Import Peano_dec.
Require Import Compare_dec.
Require Import Lt Le Gt Plus Minus.

Require Import base.
Require Import term.
Require Import env red.
Require Import typ_annot.
Require Import List.
Require Import ut_term ut_env ut_red.
Require Import strip.

Module Type glue_mod  (X:term_sig) (Y:pts_sig X) (TM:term_mod X) (EM: env_mod X TM) (RM: red_mod X TM)
                                            (UTM:ut_term_mod X) (UEM: ut_env_mod X UTM) (URM: ut_red_mod X UTM).
 Import X Y UTM UEM URM TM EM RM.
 Include (strip_mod X UTM TM UEM EM).
 Include (PTS_ATR_mod X Y TM EM RM).

Open Scope Typ_scope.

(** This lemma gives some partial information about a term, when its types are
not convertible, it will be usefull to prove that annotation in application
are safe.*)
Lemma weak_type_shape : forall Γ M N A, Γ ⊢ M ▹ N : A -> forall P B, Γ ⊢ M ▹ P : B ->
 Γ ⊢ A ≡' B \/ (exists U,exists V, Γ ⊢ M ▹ λ[U],V : A /\ Γ ⊢ M ▹ λ[U],V : B) \/
 (exists s, Γ ⊢ M ▹ !s : A /\ Γ ⊢ M ▹ !s : B) \/
 (exists U, exists V, Γ ⊢ M ▹ Π(U),V : A /\ Γ ⊢ M ▹ Π(U),V : B).
induction 1; intros.
apply pgen_var in H1. destruct H1 as ( _ & A' & ? & ? ).
left. replace A with A'. intuition. eapply fun_item_lift. apply H1. trivial.
(**)
apply pgen_sort in H1. destruct H1 as ( _ & t & ? & ? ).
right; right; left. exists s1; split.
eauto. destruct H2. subst; eauto. eapply typ_pcompat; eauto.
(**)
clear IHtyp1 IHtyp2. apply pgen_pi in H2 as (A'' & B'' & s & t & u & h); decompose [and] h; clear h.
right; right; right. exists A'; exists B'; split. eapply typ_pi; eauto.
destruct H7. subst. apply typ_pi with s t; trivial.
eapply relocate. apply H4. apply H0. eapply relocate. apply H3. apply H1. apply typ_pcompat with !u; intuition.
apply typ_pi with s t; trivial. eapply relocate. apply H4. apply H0. eapply relocate. apply H3. apply H1.
(**)
clear IHtyp1 IHtyp2 IHtyp3.
right; left. apply pgen_la in H3 as (A'' & M'' & D & s & t &u & h); decompose [and] h; clear h.
exists A'; exists M'; split. eapply typ_la. apply H. trivial. apply H1. trivial.
apply typ_pcompat with (Π(A),D). eapply typ_la. apply H3. eapply relocate. apply H5. apply H0.
apply H6. eapply relocate. apply H4. apply H2. trivial.
(**)
apply pgen_app in H4 as (C & C' &  D' & N'' & s & t & u & h). decompose [and] h; clear h.
left; trivial.
(**)
apply pgen_app in H7. destruct H7 as (C & C' & D' & N'' & s & t & u & h). decompose [and] h; clear h.
left; trivial.
(**)
destruct (IHtyp1 P B0 H1) as [ | [ | [ | ] ] ]. left; eauto.
destruct H2 as (U & V & ? & ?). right; left. exists U; exists V; split. eapply typ_pcompat with A; eauto. trivial.
destruct H2 as ( t & ? & ?). right; right; left. exists t; split. eapply typ_pcompat with A; eauto. trivial.
destruct H2 as (U & V & ? & ?). right; right; right. exists U; exists V; split. eapply typ_pcompat with A; eauto. trivial.
(**)
destruct (IHtyp1 P B0 H1) as [ | [ | [ | ] ] ]. left; eauto.
destruct H2 as (U & V & ? & ?). right; left. exists U; exists V; split. eapply typ_pcompat with B; eauto. trivial.
destruct H2 as ( t & ? & ?). right; right; left. exists t; split. eapply typ_pcompat with B; eauto. trivial.
destruct H2 as (U & V & ? & ?). right; right; right. exists U; exists V; split. eapply typ_pcompat with B; eauto. trivial.
Qed.

Lemma peq_not_Pi_sort : forall Γ A B S, ~(Γ ⊢ Π(A),B ≡' !S).
intros; intro. apply Confluence in H as (Z & ? & ?  &? & ?).
apply Sort_Reds in H0 as ( -> & ?& ?).
apply Pi_Reds in H as ( A' & B' & ? & ? & ? & ? & ? & _ ). discriminate.
Qed.

(** First step to prove the annotation valid: we need to find a path between two
different annotated version of a same "stripped" term. We don't care that [A] is not
equal to [B] here, since this results will mainly  be used for types, so both
[A] and [B] will be sorts, which is enough to build an equality.*)
(** This is the main point of proving annotations valid, and we need the full
power of confluence and type exchange to be able to prove it.*)

Lemma ErasedTermConfluence : forall M N Γ A B, strip M = strip N ->
  Γ ⊢ M ▹ M : A -> Γ ⊢ N ▹ N : B ->
  exists P,  Γ ⊢ M ▹▹ P : A /\ Γ ⊢ N ▹▹ P : B.
induction M; intros.
(**)
destruct N; simpl in H; try discriminate. injection H; intros; subst; clear H.
apply red_refl_lt in H1. apply red_refl_lt in H0. exists #v0; intuition.
(**)
destruct N; simpl in H; try discriminate. injection H; intros; subst; clear H.
apply red_refl_lt in H1. apply red_refl_lt in H0. exists !s0; intuition.
(**)
destruct N; simpl in H; try discriminate. injection H; intros; subst; clear H.
rename M1 into P. rename M4 into Q. rename M2 into An. rename M3 into D.
rename N1 into P'. rename N4 into Q'. rename N2 into An'. rename N3 into E.
apply pgen_app in H0 as (C & C1 & D' & Q1 & s1 & t1  & u1 & h). decompose [and] h ; clear h.
apply pgen_app in H1 as (C' & C'1 & E' & Q'1 & s2 & t2  & u2 & h). decompose [and] h ; clear h.
assert (exists PP, Γ ⊢ P ▹ PP : Π(C),D). destruct H8. destruct H8 as (P'' & ? & ? & ?). subst. exists P''; trivial.
destruct H8 as (U0 & K & K' & T & T' & ? & -> & ? & _). exists (La C1 T'). econstructor. subst. apply H. trivial. apply red_refl_lt in H0; apply H0.
trivial.
assert (exists PP', Γ ⊢ P' ▹ PP' : Π(C'),E). destruct H13. destruct H13 as (P'' & ? & ? & ?). subst. exists P''; trivial.
destruct H13 as (U0 & K & K' & T & T' & ? & -> & ?  & _ ). exists (La C'1 T'). subst. econstructor. apply H1. trivial.
apply red_refl_lt in H7; apply H7. trivial.
destruct H12 as (PP & ?). destruct H14 as (PP' & ?).
apply red_refl_lt in H5. apply red_refl_lt in H10.
destruct (IHM4 Q' Γ C C' H2 H5 H10) as (RQ & ? & ? ). clear IHM4.
apply red_refl_lt in H12. apply red_refl_lt in H14.
destruct (IHM1 P' Γ (Pi C D) (Pi C' E) H3 H12 H14) as (RP & ? & ? ). clear IHM1. clear IHM2 IHM3.
destruct (weak_type_shape Γ RP RP (Π(C),D)) with (P := RP) (B := Π(C'),E) as [ | [ | [ ] ] ].
apply reds_refl_rt in H17; trivial. apply reds_refl_rt in H18; trivial.
  (**  Phase 1 : Pi C D == Pi C' E **)
destruct (PiInj Γ C D C' E H19) as (? & ?).
  (** 1 / 4 **)
destruct H8.  destruct H8 as (? & _ & ? &  _ ). subst. clear x.  destruct H13.  destruct H8 as (? & _ & ? &  _ ). clear x. subst.
apply Confluence in H21 as (Z & d1 & d2 & ? & ?). destruct (Confluence Γ C C' H20) as (ZA & d3 & d4 & ? & ?).
rename H8 into HH8. assert (H8 : C::Γ ⊢ D ▹▹ Z : !t1). eapply typ_reds_relocate. apply HH8. apply red_refl_lt in H0; apply H0. clear HH8.
rename H13 into HH13. assert (H13 : C'::Γ ⊢ E ▹▹ Z : !t2). eapply typ_reds_relocate.  eapply conv_in_env_reds. apply HH13. eauto.
apply red_refl_lt in H7; apply  H7. clear HH13.
rename H21 into HH21. assert (H21 : Γ ⊢ C ▹▹ ZA : !s1). eapply typ_reds_relocate. apply HH21. apply red_refl_lt in H4; apply H4. clear HH21.
rename H22 into HH22. assert (H22 : Γ ⊢ C' ▹▹ ZA : !s2). eapply typ_reds_relocate. apply HH22. apply red_refl_lt in H9; apply H9. clear HH22.
clear d1 d2 d3 d4.
exists (App RP ZA Z RQ); split.
apply reds_typ_pcompat with (D [ ← Q]); trivial. eapply reds_App. trivial. trivial. apply H21. apply H8.
apply reds_typ_pcompat with (E [ ← Q']); trivial.  eapply reds_App. trivial. trivial. apply H22. apply H13.
 (**  2 / 4 **)
destruct H8 as (G0 & G & G' & ? & ? & ? & _ & _ & _ & HH2 & HH1 & HH0). clear x x0. subst.
apply Confluence in H21 as (Z & d1 & d2 & ? & ?). destruct (Confluence Γ C G) as (ZA & d3 & d4 & ? & ?). apply reds_to_conv in HH1. apply reds_to_conv in HH2.
apply typ_peq_trans with C'; intuition. apply typ_peq_trans with G0; intuition.
rename H8 into HH8. assert (H8 : C::Γ ⊢ D ▹▹ Z : !t1). eapply typ_reds_relocate. apply HH8. apply red_refl_lt in H0; apply H0. clear HH8.
rename H13 into HH13. assert (H13 : C'::Γ ⊢ E ▹▹ Z : !t2). eapply typ_reds_relocate.  eapply conv_in_env_reds. apply HH13. eauto.
apply red_refl_lt in H7; apply  H7. clear HH13.
rename H21 into HH21. assert (H21 : Γ ⊢ C ▹▹ ZA : !s1). eapply typ_reds_relocate. apply HH21. apply red_refl_lt in H4; apply H4. clear HH21.
rename H22 into HH22. assert (H22 : Γ ⊢ G ▹▹ ZA : !s2). eapply typ_reds_relocate. apply HH22. apply red_refl_lt in HH0; apply HH0. clear HH22.
clear d1 d2 d3 d4.
assert(HEQ1: Γ ⊢ C' ≡' G). apply reds_to_conv in HH1. apply reds_to_conv in HH2. eauto.
assert (HEQ2: Γ ⊢ Π(C'),E ≡' Π(G),E). apply typ_peq_trans with (Π(G0),E). apply typ_peq_sym.
apply reds_to_conv with u2. eapply reds_Pi. apply HH1.  constructor. eapply conv_in_env. apply red_refl_lt in H7; apply H7. eauto. trivial.
apply reds_to_conv with u2. eapply reds_Pi. apply HH2.  constructor. eapply conv_in_env. apply red_refl_lt in H7; apply H7. eauto. trivial.
exists (App RP ZA Z RQ); split.
apply reds_typ_pcompat with (D [ ← Q]); trivial. eapply reds_App. trivial. trivial. apply H21. apply H8.
apply reds_typ_pcompat with (E [ ← Q']); trivial.  eapply reds_App. apply reds_typ_pcompat with (Π(C'),E); trivial.  apply reds_typ_pcompat with C'; trivial.
apply H22. eapply conv_in_env_reds. apply H13. eauto.
  (**  3 / 4 **)
destruct H8 as (G0 & G & G' & ? & ? & ? & _ & _ & _ & HH2 & HH1 & HH0). subst. clear x x0. destruct H13.
destruct H8 as ( ? & _ & ? & _ ). subst. clear x.
assert(HEQ1: Γ ⊢ C' ≡' G). apply reds_to_conv in HH1. apply reds_to_conv in HH2. eauto.
assert (HEQ3: Γ ⊢ C ≡' G). eauto.
assert (HEQ2: Γ ⊢ Π(C),D ≡' Π(G),D). apply typ_peq_trans with (Π(G0),D). apply typ_peq_sym.
apply reds_to_conv with u1. eapply reds_Pi. apply HH1.  constructor. eapply conv_in_env. apply red_refl_lt in H0; apply H0. eauto. trivial.
apply reds_to_conv with u1. eapply reds_Pi. apply HH2.  constructor. eapply conv_in_env. apply red_refl_lt in H0; apply H0. eauto. trivial.
apply Confluence in H21 as (Z & d1 & d2 & ? & ?). destruct (Confluence Γ G C') as (ZA & d3 & d4 & ? & ?). intuition.
rename H8 into HH8. assert (H8 : G::Γ ⊢ D ▹▹ Z : !t1). eapply typ_reds_relocate. eapply conv_in_env_reds. apply HH8. eauto. eapply conv_in_env.
apply red_refl_lt in H0; apply  H0. eauto. clear HH8.
rename H13 into HH13. assert (H13 : C'::Γ ⊢ E ▹▹ Z : !t2). eapply typ_reds_relocate.  eapply conv_in_env_reds. apply HH13. eauto.
apply red_refl_lt in H7; apply  H7. clear HH13.
rename H21 into HH21. assert (H21 : Γ ⊢ G ▹▹ ZA : !s1). eapply typ_reds_relocate. apply HH21. apply reds_refl_rt in HH2; apply HH2. clear HH21.
rename H22 into HH22. assert (H22 : Γ ⊢ C' ▹▹ ZA : !s2). eapply typ_reds_relocate. apply HH22. apply red_refl_lt in H9; apply H9. clear HH22.
clear d1 d2 d3 d4.
exists (App RP ZA Z RQ); split.
apply reds_typ_pcompat with (D [ ← Q]); trivial. eapply reds_App. apply reds_typ_pcompat with (Π(C),D); trivial. apply reds_typ_pcompat with C; trivial. apply H21. apply H8.
apply reds_typ_pcompat with (E [ ← Q']); trivial.  eapply reds_App. trivial. trivial. apply H22. apply H13.
   (**  4 / 4 **)
destruct H8 as (F0 & F & F' & ? & ? & ? & _ & _ & _  & HH5 & HH4 & HH3). subst. clear x x0.
assert (HEQ1 : Γ ⊢ G ≡' C). apply reds_to_conv in HH1. apply reds_to_conv in HH2. eauto.
assert (HEQ2 : Γ ⊢ F ≡' C'). apply reds_to_conv in HH4. apply reds_to_conv in HH5. eauto.
assert (HEQ3 : Γ ⊢ G ≡' F). eauto.
assert (HEQ4: Γ ⊢ Π(C),D ≡' Π(G),D). apply typ_peq_trans with (Π(G0),D). apply typ_peq_sym.
apply reds_to_conv with u1. eapply reds_Pi. apply HH1.  constructor. eapply conv_in_env. apply red_refl_lt in H0; apply H0. eauto. trivial.
apply reds_to_conv with u1. eapply reds_Pi. apply HH2.  constructor. eapply conv_in_env. apply red_refl_lt in H0; apply H0. eauto. trivial.
assert (HEQ5: Γ ⊢ Π(C'),E ≡' Π(F),E). apply typ_peq_trans with (Π(F0),E). apply typ_peq_sym.
apply reds_to_conv with u2. eapply reds_Pi. apply HH4.  constructor. eapply conv_in_env. apply red_refl_lt in H7; apply H7. eauto. trivial.
apply reds_to_conv with u2. eapply reds_Pi. apply HH5.  constructor. eapply conv_in_env. apply red_refl_lt in H7; apply H7. eauto. trivial.
apply Confluence in H21 as (Z & d1 & d2 & ? & ?). destruct (Confluence Γ G F HEQ3) as (ZA & d3 & d4 & ? & ?).
rename H8 into HH8. assert (H8 : G::Γ ⊢ D ▹▹ Z : !t1). eapply typ_reds_relocate. eapply conv_in_env_reds. apply HH8. eauto. eapply conv_in_env.
apply red_refl_lt in H0; apply  H0. eauto. clear HH8.
rename H13 into HH13. assert (H13 : F::Γ ⊢ E ▹▹ Z : !t2). eapply typ_reds_relocate.  eapply conv_in_env_reds. apply HH13. eauto. eapply conv_in_env.
apply red_refl_lt in H7; apply H7. eauto. clear HH13.
rename H21 into HH21. assert (H21 : Γ ⊢ G ▹▹ ZA : !s1). eapply typ_reds_relocate. apply HH21. apply reds_refl_rt in HH2; apply HH2. clear HH21.
rename H22 into HH22. assert (H22 : Γ ⊢ F ▹▹ ZA : !s2). eapply typ_reds_relocate. apply HH22.  apply reds_refl_rt in HH5; apply HH5. clear HH22.
clear d1 d2 d3 d4.
exists (App RP ZA Z RQ); split.
apply reds_typ_pcompat with (D [ ← Q]); trivial. eapply reds_App. apply reds_typ_pcompat with (Π(C),D); trivial. apply reds_typ_pcompat with C; intuition. apply H21.  apply H8.
apply reds_typ_pcompat with (E [ ← Q']); trivial.  eapply reds_App. apply reds_typ_pcompat with (Π(C'),E); trivial. apply reds_typ_pcompat with C'; intuition. apply H22. apply H13.
  (** Phase 2 : RP -> λ **)
destruct H19 as (U & V & ? & ?).
destruct (pgen_la Γ U V (λ[U],V) (Π(C),D)) as (U' & V' & K & s & t & u & h).
apply red_refl_rt in H19; trivial. decompose [and] h; clear h. injection H25; intros; subst; clear H25.
destruct (pgen_la Γ U' V' (λ[U'],V') (Π(C'),E)) as (U'' & V'' & L & s' & t' & u' & h).
apply red_refl_rt in H20; trivial. decompose [and] h; clear h. injection H30; intros; subst; clear H30.
destruct (PiInj Γ U'' K C D H27) as ( ? & ?). destruct (PiInj Γ U'' L C' E H32) as ( ? & ?). exists (V''[← RQ]).
  (** 1 / 4 **)
destruct H8.  destruct H8 as (? & _ & ? &  _ ). subst. clear x.  destruct H13.  destruct H8 as (? & _ & ? &  _ ). clear x. subst.
split. apply reds_typ_pcompat with (D [ ← Q]); trivial.
destruct (Confluence (U''::Γ) K D H31) as (ZB & a & b & ? & ?). destruct (Confluence Γ U'' C H30) as (ZA & c & d & ? & ?).
rename H35 into HH35. assert (H35: Γ ⊢ U'' ▹▹ ZA : !s). eapply typ_reds_relocate. apply HH35. apply H23. clear HH35.
rename H36 into HH36. assert (H36: Γ ⊢ C ▹▹ ZA : !s1). eapply typ_reds_relocate. apply HH36. apply red_refl_lt in H4; apply H4. clear HH36.
rename H8 into HH8. assert (H8 : U''::Γ ⊢ K ▹▹ ZB : !t). eapply typ_reds_relocate. apply HH8. apply H24. clear HH8.
rename H13 into HH13. assert (H13 : C::Γ ⊢ D ▹▹ ZB : !t1). eapply typ_reds_relocate. eapply conv_in_env_reds. apply HH13. eauto.
apply red_refl_lt in H0; apply H0. clear HH13.
clear a b c d.
eapply typ_reds_trans. eapply reds_App. eapply typ_reds_trans. apply H17. constructor. apply H19.  constructor; apply red_refl_lt in H5; apply H5.  constructor; apply red_refl_lt in H4; apply H4.
constructor. apply red_refl_lt in H0; apply H0. eapply typ_reds_trans. eapply reds_App. constructor; apply red_refl_rt in H19; apply H19.  apply H15. apply H36. apply H13. constructor.
apply typ_pcompat with (ZB [← RQ]). eapply typ_beta. apply H21. apply H23. eapply reds_refl_rt. apply H35. constructor. apply H23.
trivial. apply reds_refl_rt in H8; apply H8. apply typ_pcompat with K. trivial. eapply reds_to_conv; apply H8. apply typ_pcompat with C. apply reds_refl_rt in H15; trivial. eauto.
apply typ_peq_sym. apply reds_to_conv with t1. change !t1 with (!t1[← Q]). eapply reds_subst_gen. apply H13.
apply reds_typ_pcompat with C; eauto. apply reds_typ_pcompat with (E [ ← Q']); trivial.
destruct (Confluence (U''::Γ) L E H34) as (ZB & a & b & ? & ?). destruct (Confluence Γ U'' C' H33) as (ZA & c & d & ? & ?).
rename H35 into HH35. assert (H35: Γ ⊢ U'' ▹▹ ZA : !s'). eapply typ_reds_relocate. apply HH35. apply H28. clear HH35.
rename H36 into HH36. assert (H36: Γ ⊢ C' ▹▹ ZA : !s2). eapply typ_reds_relocate. apply HH36. apply red_refl_lt in H9; apply H9. clear HH36.
rename H8 into HH8. assert (H8 : U''::Γ ⊢ L ▹▹ ZB : !t'). eapply typ_reds_relocate. apply HH8. apply H29. clear HH8.
rename H13 into HH13. assert (H13 : C'::Γ ⊢ E ▹▹ ZB : !t2). eapply typ_reds_relocate. eapply conv_in_env_reds. apply HH13. eauto.
apply red_refl_lt in H7; apply H7. clear HH13.
clear a b c d.
eapply typ_reds_trans. eapply reds_App. eapply typ_reds_trans. apply H18. constructor. apply H20.  constructor; apply red_refl_lt in H10; apply H10.
constructor; apply red_refl_lt in H9; apply H9. constructor; apply red_refl_lt in H7; apply H7.
eapply typ_reds_trans. eapply reds_App. constructor; apply red_refl_rt in H20; apply H20.  apply H16. apply H36. apply  H13. constructor.
apply typ_pcompat with (ZB [← RQ]). eapply typ_beta. apply H25. apply H28. eapply reds_refl_rt. apply  H35. constructor; apply H28.
trivial. eapply reds_refl_rt. apply H8. apply typ_pcompat with L. trivial. eapply reds_to_conv; apply H8. apply typ_pcompat with C. apply reds_refl_rt in H15; apply H15. eauto.
apply typ_peq_sym. apply reds_to_conv with t2. change !t2 with (!t2[← Q']). eapply reds_subst_gen. apply H13. apply reds_typ_pcompat with C'; eauto.
  (** 2 / 4 **)
destruct H8 as (G0 & G & G' & ? & ? & ? & _ & _ & _ & HH2 & HH1 & HH0). clear x x0. subst. split.
apply reds_typ_pcompat with (D [ ← Q]); trivial.
destruct (Confluence (U''::Γ) K D H31) as (ZB & a & b & ? & ?). destruct (Confluence Γ U'' C H30) as (ZA & c & d & ? & ?).
rename H35 into HH35. assert (H35: Γ ⊢ U'' ▹▹ ZA : !s). eapply typ_reds_relocate. apply HH35. apply H23. clear HH35.
rename H36 into HH36. assert (H36: Γ ⊢ C ▹▹ ZA : !s1). eapply typ_reds_relocate. apply HH36. apply red_refl_lt in H4; apply H4. clear HH36.
rename H8 into HH8. assert (H8 : U''::Γ ⊢ K ▹▹ ZB : !t). eapply typ_reds_relocate. apply HH8. apply H24. clear HH8.
rename H13 into HH13. assert (H13 : C::Γ ⊢ D ▹▹ ZB : !t1). eapply typ_reds_relocate. eapply conv_in_env_reds. apply HH13. eauto.
apply red_refl_lt in H0; apply H0. clear HH13.
clear a b c d.
eapply typ_reds_trans. eapply reds_App. eapply typ_reds_trans. apply H17. constructor. apply H19.  constructor; apply red_refl_lt in H5; apply H5.  constructor; apply red_refl_lt in H4; apply H4.
constructor. apply red_refl_lt in H0; apply H0. eapply typ_reds_trans. eapply reds_App. constructor; apply red_refl_rt in H19; apply H19.  apply H15. apply H36. apply H13. constructor.
apply typ_pcompat with (ZB [← RQ]). eapply typ_beta. apply H21. apply H23. eapply reds_refl_rt. apply H35. constructor. apply H23.
trivial. apply reds_refl_rt in H8; apply H8. apply typ_pcompat with K. trivial. eapply reds_to_conv; apply H8. apply typ_pcompat with C. apply reds_refl_rt in H15; trivial. eauto.
apply typ_peq_sym. apply reds_to_conv with t1. change !t1 with (!t1[← Q]). eapply reds_subst_gen. apply H13.
apply reds_typ_pcompat with C; eauto. apply reds_typ_pcompat with (E [ ← Q']); trivial.
destruct (Confluence (U''::Γ) L E H34) as (ZB & a & b & ? & ?). destruct (Confluence Γ U'' G) as (ZA & c & d & ? & ?).
apply typ_peq_trans with C'; trivial. apply typ_peq_trans with G0. apply reds_to_conv in HH1; eauto. apply reds_to_conv in HH2; eauto.
assert(HEQ1: Γ ⊢ C' ≡' G). apply reds_to_conv in HH1. apply reds_to_conv in HH2. eauto.
rename H35 into HH35. assert (H35: Γ ⊢ U'' ▹▹ ZA : !s'). eapply typ_reds_relocate. apply HH35. apply H28. clear HH35.
rename H36 into HH36. assert (H36: Γ ⊢ G ▹▹ ZA : !s2). eapply typ_reds_relocate. apply HH36. apply reds_refl_rt in HH2; apply HH2. clear HH36.
rename H8 into HH8. assert (H8 : U''::Γ ⊢ L ▹▹ ZB : !t'). eapply typ_reds_relocate. apply HH8. apply H29. clear HH8.
rename H13 into HH13. assert (H13 : G::Γ ⊢ E ▹▹ ZB : !t2). eapply typ_reds_relocate. eapply conv_in_env_reds. apply HH13. eauto. eapply conv_in_env.
apply red_refl_lt in H7; apply H7. eauto. clear HH13.
clear a b c d.
assert (HEQ2: Γ ⊢ Π(C'),E ≡' Π(G),E). apply typ_peq_trans with (Π(G0),E). apply typ_peq_sym.
apply reds_to_conv with u2. eapply reds_Pi. apply HH1.  constructor. eapply conv_in_env. apply red_refl_lt in H7; apply H7. eauto. trivial.
apply reds_to_conv with u2. eapply reds_Pi. apply HH2.  constructor. eapply conv_in_env. apply red_refl_lt in H7; apply H7. eauto. trivial.
eapply typ_reds_trans. eapply reds_App. eapply typ_reds_trans. eapply reds_typ_pcompat with (Π(C'),E). apply H18. trivial. constructor. apply typ_pcompat with (Π(C'),E). apply H20. trivial.
apply reds_typ_pcompat with C'; trivial. constructor; apply red_refl_lt in H10; apply H10.
constructor; apply reds_refl_rt in HH2; apply HH2. eapply conv_in_env_reds. constructor; apply red_refl_lt in H7; apply H7. eauto.
eapply typ_reds_trans. eapply reds_App. apply reds_typ_pcompat with (Π(C'),E); trivial. constructor; apply red_refl_rt in H20; apply H20. apply reds_typ_pcompat with C'; trivial.  apply H16. apply H36. apply  H13. constructor.
apply typ_pcompat with (ZB [← RQ]). eapply typ_beta. apply H25. apply H28. eapply reds_refl_rt. apply  H35. constructor; apply H28.
trivial. eapply reds_refl_rt. apply H8. apply typ_pcompat with L. trivial. eapply reds_to_conv; apply H8. apply typ_pcompat with C. apply reds_refl_rt in H15; apply H15. eauto.
apply typ_peq_sym. apply reds_to_conv with t2. change !t2 with (!t2[← Q']). eapply reds_subst_gen. apply H13. apply reds_typ_pcompat with C'; eauto.
 (** 3 / 4 **)
destruct H8 as (G0 & G & G' & ? & ? & ? & _ & _ & _ & HH2 & HH1 & HH0). subst. clear x x0. destruct H13.
destruct H8 as ( ? & _ & ? & _ ). subst. clear x.  split.
apply reds_typ_pcompat with (D [ ← Q]); trivial.
assert(HEQ1: Γ ⊢ C ≡' G). apply reds_to_conv in HH1. apply reds_to_conv in HH2. eauto.
assert (HEQ2: Γ ⊢ Π(C),D ≡' Π(G),D). apply typ_peq_trans with (Π(G0),D). apply typ_peq_sym.
apply reds_to_conv with u1. eapply reds_Pi. apply HH1.  constructor. eapply conv_in_env. apply red_refl_lt in H0; apply H0. eauto. trivial.
apply reds_to_conv with u1. eapply reds_Pi. apply HH2.  constructor. eapply conv_in_env. apply red_refl_lt in H0; apply H0. eauto. trivial.
assert (HEQ3: Γ ⊢ C' ≡' G). eauto.
destruct (Confluence (U''::Γ) K D H31) as (ZB & a & b & ? & ?). destruct (Confluence Γ U'' G ) as (ZA & c & d & ? & ?). eauto.
rename H35 into HH35. assert (H35: Γ ⊢ U'' ▹▹ ZA : !s). eapply typ_reds_relocate. apply HH35. apply H23. clear HH35.
rename H36 into HH36. assert (H36: Γ ⊢ G ▹▹ ZA : !s1). eapply typ_reds_relocate. apply HH36. apply reds_refl_rt in HH2; apply HH2. clear HH36.
rename H8 into HH8. assert (H8 : U''::Γ ⊢ K ▹▹ ZB : !t). eapply typ_reds_relocate. apply HH8. apply H24. clear HH8.
rename H13 into HH13. assert (H13 : G::Γ ⊢ D ▹▹ ZB : !t1). eapply typ_reds_relocate.  eapply conv_in_env_reds. apply HH13. eauto. eapply conv_in_env.
apply red_refl_lt in H0;  apply H0. eauto. clear HH13.
clear a b c d.
eapply typ_reds_trans. eapply reds_App. eapply typ_reds_trans. apply reds_typ_pcompat with (Π(C),D); trivial. apply H17. apply reds_typ_pcompat with (Π(C),D); trivial. constructor. apply H19. apply reds_typ_pcompat with C; trivial.
constructor; apply red_refl_lt in H5; apply H5.  constructor; apply reds_refl_rt in HH2; apply HH2.
constructor. eapply conv_in_env. apply red_refl_lt in H0; apply H0. eauto. eapply typ_reds_trans. eapply reds_App. apply reds_typ_pcompat with (Π(C),D);trivial.
constructor; apply red_refl_rt in H19; apply H19.  apply reds_typ_pcompat with C; trivial.  apply H15. apply H36. apply H13. constructor.
apply typ_pcompat with (ZB [← RQ]). eapply typ_beta. apply H21. apply H23. eapply reds_refl_rt. apply H35. constructor. apply H23.
trivial. apply reds_refl_rt in H8; apply H8. apply typ_pcompat with K. trivial. eapply reds_to_conv; apply H8. apply typ_pcompat with C. apply reds_refl_rt in H15; trivial. eauto.
apply typ_peq_sym. apply reds_to_conv with t1. change !t1 with (!t1[← Q]). eapply reds_subst_gen. apply H13.
apply reds_typ_pcompat with C; eauto. apply reds_typ_pcompat with (E [ ← Q']); trivial.
destruct (Confluence (U''::Γ) L E H34) as (ZB & a & b & ? & ?). destruct (Confluence Γ U'' C' H33) as (ZA & c & d & ? & ?).
rename H35 into HH35. assert (H35: Γ ⊢ U'' ▹▹ ZA : !s'). eapply typ_reds_relocate. apply HH35. apply H28. clear HH35.
rename H36 into HH36. assert (H36: Γ ⊢ C' ▹▹ ZA : !s2). eapply typ_reds_relocate. apply HH36. apply red_refl_lt in H9; apply H9. clear HH36.
rename H8 into HH8. assert (H8 : U''::Γ ⊢ L ▹▹ ZB : !t'). eapply typ_reds_relocate. apply HH8. apply H29. clear HH8.
rename H13 into HH13. assert (H13 : C'::Γ ⊢ E ▹▹ ZB : !t2). eapply typ_reds_relocate. eapply conv_in_env_reds. apply HH13. eauto.
apply red_refl_lt in H7; apply H7. clear HH13.
clear a b c d.
eapply typ_reds_trans. eapply reds_App. eapply typ_reds_trans. apply H18. constructor. apply H20.  constructor; apply red_refl_lt in H10; apply H10.
constructor; apply red_refl_lt in H9; apply H9. constructor; apply red_refl_lt in H7; apply H7.
eapply typ_reds_trans. eapply reds_App. constructor; apply red_refl_rt in H20; apply H20.  apply H16. apply H36. apply  H13. constructor.
apply typ_pcompat with (ZB [← RQ]). eapply typ_beta. apply H25. apply H28. eapply reds_refl_rt. apply  H35. constructor; apply H28.
trivial. eapply reds_refl_rt. apply H8. apply typ_pcompat with L. trivial. eapply reds_to_conv; apply H8. apply typ_pcompat with C. apply reds_refl_rt in H15; apply H15. eauto.
apply typ_peq_sym. apply reds_to_conv with t2. change !t2 with (!t2[← Q']). eapply reds_subst_gen. apply H13. apply reds_typ_pcompat with C'; eauto.
  (** 4 / 4 **)
destruct H8 as (F0 & F & F' & ? & ? & ? & _ & _ & _  & HH5 & HH4 & HH3). subst. clear x x0.
assert (HEQ1 : Γ ⊢ G ≡' C). apply reds_to_conv in HH1. apply reds_to_conv in HH2. eauto.
assert (HEQ2 : Γ ⊢ F ≡' C'). apply reds_to_conv in HH4. apply reds_to_conv in HH5. eauto.
assert (HEQ3 : Γ ⊢ G ≡' F). apply typ_peq_trans with U''. eauto. eauto.
assert (HEQ4: Γ ⊢ Π(C),D ≡' Π(G),D). apply typ_peq_trans with (Π(G0),D). apply typ_peq_sym.
apply reds_to_conv with u1. eapply reds_Pi. apply HH1.  constructor. eapply conv_in_env. apply red_refl_lt in H0; apply H0. eauto. trivial.
apply reds_to_conv with u1. eapply reds_Pi. apply HH2.  constructor. eapply conv_in_env. apply red_refl_lt in H0; apply H0. eauto. trivial.
assert (HEQ5: Γ ⊢ Π(C'),E ≡' Π(F),E). apply typ_peq_trans with (Π(F0),E). apply typ_peq_sym.
apply reds_to_conv with u2. eapply reds_Pi. apply HH4.  constructor. eapply conv_in_env. apply red_refl_lt in H7; apply H7. eauto. trivial.
apply reds_to_conv with u2. eapply reds_Pi. apply HH5.  constructor. eapply conv_in_env. apply red_refl_lt in H7; apply H7. eauto. trivial.
split. apply reds_typ_pcompat with (D [ ← Q]); trivial.
destruct (Confluence (U''::Γ) K D H31) as (ZB & a & b & ? & ?). destruct (Confluence Γ U'' G ) as (ZA & c & d & ? & ?). eauto.
rename H35 into HH35. assert (H35: Γ ⊢ U'' ▹▹ ZA : !s). eapply typ_reds_relocate. apply HH35. apply H23. clear HH35.
rename H36 into HH36. assert (H36: Γ ⊢ G ▹▹ ZA : !s1). eapply typ_reds_relocate. apply HH36. apply reds_refl_rt in HH2; apply HH2.  clear HH36.
rename H8 into HH8. assert (H8 : U''::Γ ⊢ K ▹▹ ZB : !t). eapply typ_reds_relocate. apply HH8. apply H24. clear HH8.
rename H13 into HH13. assert (H13 : G::Γ ⊢ D ▹▹ ZB : !t1). eapply typ_reds_relocate. eapply conv_in_env_reds. apply HH13. eauto. eapply conv_in_env.
apply red_refl_lt in H0; apply H0. eauto. clear HH13.
clear a b c d.
eapply typ_reds_trans. eapply reds_App. apply reds_typ_pcompat with (Π(C),D); intuition. eapply typ_reds_trans.  apply H17. constructor. apply H19. apply reds_typ_pcompat with C; intuition.  constructor; apply red_refl_lt in H5; apply H5.
constructor; apply reds_refl_rt in HH2; apply HH2. constructor. eapply conv_in_env. apply red_refl_lt in H0; apply H0. eauto. eapply typ_reds_trans. eapply reds_App.
apply reds_typ_pcompat with (Π(C),D).  constructor; apply red_refl_rt in H19; apply H19. intuition.  apply reds_typ_pcompat with C; intuition. apply H15. apply H36. apply H13. constructor.
apply typ_pcompat with (ZB [← RQ]). eapply typ_beta. apply H21. apply H23. eapply reds_refl_rt. apply H35. constructor. apply H23.
trivial. apply reds_refl_rt in H8; apply H8. apply typ_pcompat with K. trivial. eapply reds_to_conv; apply H8. apply typ_pcompat with C. apply reds_refl_rt in H15; trivial. eauto.
apply typ_peq_sym. apply reds_to_conv with t1. change !t1 with (!t1[← Q]). eapply reds_subst_gen. apply H13.
apply reds_typ_pcompat with C; eauto. apply reds_typ_pcompat with (E [ ← Q']); trivial.
destruct (Confluence (U''::Γ) L E H34) as (ZB & a & b & ? & ?). destruct (Confluence Γ U'' F ) as (ZA & c & d & ? & ?). eauto.
rename H35 into HH35. assert (H35: Γ ⊢ U'' ▹▹ ZA : !s'). eapply typ_reds_relocate. apply HH35. apply H28. clear HH35.
rename H36 into HH36. assert (H36: Γ ⊢ F ▹▹ ZA : !s2). eapply typ_reds_relocate. apply HH36. apply reds_refl_rt in HH5; apply HH5.  clear HH36.
rename H8 into HH8. assert (H8 : U''::Γ ⊢ L ▹▹ ZB : !t'). eapply typ_reds_relocate. apply HH8. apply H29. clear HH8.
rename H13 into HH13. assert (H13 : F::Γ ⊢ E ▹▹ ZB : !t2). eapply typ_reds_relocate. eapply conv_in_env_reds. apply HH13. eauto. eapply conv_in_env.
apply red_refl_lt in H7; apply H7. eauto. clear HH13.
clear a b c d.
eapply typ_reds_trans. eapply reds_App. apply reds_typ_pcompat with (Π(C'),E). eapply typ_reds_trans. apply H18. constructor. apply H20. intuition. apply reds_typ_pcompat with C'; intuition.  constructor; apply red_refl_lt in H10; apply H10.
constructor; apply reds_refl_rt in HH5; apply HH5. eapply conv_in_env_reds. constructor; apply red_refl_lt in H7; apply H7. eauto.
eapply typ_reds_trans. eapply reds_App. apply reds_typ_pcompat with (Π(C'),E). constructor; apply red_refl_rt in H20; apply H20. intuition. apply reds_typ_pcompat with C'; intuition.  apply H16. apply H36. apply  H13. constructor.
apply typ_pcompat with (ZB [← RQ]). eapply typ_beta. apply H25. apply H28. eapply reds_refl_rt. apply  H35. constructor; apply H28.
trivial. eapply reds_refl_rt. apply H8. apply typ_pcompat with L. trivial. eapply reds_to_conv; apply H8. apply typ_pcompat with C. apply reds_refl_rt in H15; apply H15. eauto.
apply typ_peq_sym. apply reds_to_conv with t2. change !t2 with (!t2[← Q']). eapply reds_subst_gen. apply H13. apply reds_typ_pcompat with C'; eauto.
  (** impossible cases **)
destruct H19 as (z & ? & ?). apply red_refl_rt in H19. apply pgen_sort in H19 as ( ? & ? & ? & ?).
destruct H22. discriminate. apply peq_not_Pi_sort in H22; elim H22.

destruct H19 as (U & V & ? & ?). apply red_refl_rt in H19. apply pgen_pi in H19 as ( U' & V' & s & t & u & h).
decompose [and] h; clear h. destruct H25. discriminate. apply peq_not_Pi_sort in H24; elim H24.
(**)
destruct N; simpl in H; try discriminate. injection H; intros; subst; clear H.
apply pgen_pi in H0. destruct H0 as (M1' & M2' & s1 & t1 & u1 & h). decompose [and] h; clear h.
apply pgen_pi in H1. destruct H1 as (N1' & N2' & s2 & t2 & u2 & h). decompose [and] h; clear h.
apply red_refl_lt in H4. apply red_refl_lt in H8.
destruct (IHM1 N1 Γ !s1 !s2 H3 H4 H8) as (R1 &  ? & ?).
assert (Γ ⊢ M1 ≡' N1). apply typ_peq_trans with R1. apply reds_to_conv in H10; trivial. apply reds_to_conv in H12; intuition.
apply red_refl_lt in H0.
destruct (IHM2 N2 (M1::Γ) !t1 !t2 H2 H0 ) as (R2 & ? & ?).
eapply conv_in_env. apply red_refl_lt in H6; apply H6.
eauto. exists (Pi R1 R2); split.
destruct H7. subst.  eapply reds_Pi. apply H10. apply H14. trivial.
apply reds_typ_pcompat with !u1. eapply reds_Pi.  apply H10. apply H14. trivial. intuition.
destruct H11. subst.  eapply reds_Pi. apply H12. eapply conv_in_env_reds. apply H15. eauto. trivial.
apply reds_typ_pcompat with !u2. eapply reds_Pi. apply H12. eapply conv_in_env_reds. apply H15. eauto. trivial. intuition.
(**)
destruct N; simpl in H; try discriminate. injection H; intros; subst; clear H.
apply pgen_la in H0. destruct H0 as (M1' & M2' & D & s1 & t1 & u1 & h). decompose [and] h; clear h.
apply pgen_la in H1. destruct H1 as (N1' & N2' & D2 & s2 & t2 & u2 & h). decompose [and] h; clear h.
apply red_refl_lt in H4. apply red_refl_lt in H9.
destruct (IHM1 N1 Γ !s1 !s2 H3 H4 H9) as (R1 & ? & ? ).
assert (Γ ⊢ M1 ≡' N1). apply typ_peq_trans with R1. apply reds_to_conv in H12; trivial. apply reds_to_conv in H14; intuition.
destruct (IHM2 N2 (M1::Γ) D D2 H2) as (R2 & ? & ? ); trivial.
eapply conv_in_env. apply red_refl_lt in H0; apply H0. eauto.
eapply conv_in_env. apply red_refl_lt in H7; apply H7. eauto.
exists (La R1 R2); split.
apply reds_typ_pcompat with (Π (M1), D); trivial. eapply reds_La.  apply H12. trivial. apply H5. apply H.
apply reds_typ_pcompat with (Π (N1), D2); trivial. eapply reds_La. apply H14. eapply conv_in_env_reds.  apply H17. eauto.
apply H10. apply H1.
Qed.

(** Next step: if there is a path for any term, there is path for types, so two
  version of a same "stripped" types are equivalent in PTS_{atr}.*)
Lemma ErasedTypeConversion : forall A B Γ s t, strip A = strip B -> Γ ⊢ A ▹ A : !s -> Γ ⊢ B ▹ B : !t ->
  Γ ⊢ A ≡' B.
intros.
destruct (ErasedTermConfluence A B Γ !s !t H H0 H1) as ( P & ?&  ?).
apply typ_peq_trans with P. apply reds_to_conv in H2; trivial. apply reds_to_conv in H3; intuition.
Qed.

(** And if it's true for types, its true for list of types, so for context.*)
Lemma L43_ : forall Γ Γ', strip_env Γ = strip_env Γ' -> wf Γ -> wf Γ' -> env_conv Γ Γ'.
induction Γ; intros. destruct Γ'; simpl in H.
intuition. discriminate. destruct Γ'; simpl in *. discriminate.
injection H; intros; subst; clear H. eapply c_trans with (a::Γ').
apply env_conv_cons. inversion H0; subst; clear H0. econstructor. apply red_refl_lt in H4; apply H4.
inversion H1; inversion H0; subst; clear H0 H1. apply wf_from_typ in H4. apply wf_from_typ in H7. intuition.
apply env_conv_cons.  inversion H1; inversion H0; subst; clear H0 H1.
eapply ErasedTypeConversion. trivial. eapply conv_in_env.
apply red_refl_lt in H7; apply H7.
apply IHΓ. trivial. apply wf_from_typ in H7; trivial.
apply wf_from_typ in H4; trivial. apply red_refl_lt in H4; apply H4.
inversion H1; inversion H0; subst; clear H0 H1.
apply wf_from_typ in H4. apply wf_from_typ in H7. intuition.
Qed.

(** Now that we know that two versions of a "stripped" context are equivalent,
we can chose to use both version to build our judgment. This well be usefull to
glue together the intermediate steps of the annotations process.*)
Lemma ErasedContextSwitch : (forall Γ M N T, Γ ⊢ M ▹ N : T -> forall  Γ', wf Γ' -> strip_env  Γ = strip_env  Γ' -> Γ' ⊢ M ▹ N : T) /\
  (forall Γ M N T, Γ ⊢ M ▹▹ N : T -> forall  Γ', wf Γ' -> strip_env  Γ = strip_env  Γ' -> Γ' ⊢ M ▹▹ N : T) /\
  (forall Γ, Γ ⊣ -> True).
apply typ_induc; simpl; intros; trivial.
(**)
apply conv_in_env with  Γ. intuition. apply L43_; trivial.
(**)
intuition.
(**)
apply typ_pi with s1 s2; intuition. eapply H0. econstructor. eapply H.
trivial. trivial. simpl; rewrite H2; trivial.
(**)
apply typ_la with s1 s2 s3; intuition. eapply H0. econstructor. eapply H.
trivial. trivial. simpl; rewrite H3; trivial. eapply H1. econstructor. eapply H.
trivial. trivial. simpl; rewrite H3; trivial.
(**)
eapply typ_app.  apply r.  eapply H; eauto.  eapply H0; eauto.  simpl. rewrite H4; intuition.
eapply H1; eauto. eapply H2; eauto.
(**)
eapply typ_beta. apply r. eapply H; eauto. eapply H0; eauto. eapply H1; eauto.
eapply H2; eauto. eapply H3; eauto. simpl; rewrite H7; trivial. eapply H4; eauto.
simpl; rewrite H7; trivial. eapply H5; eauto.
(**)
eauto.
(**)
eauto.
(* reds *)
eauto. eauto.
Qed.

(** Some property of the stripping process and reduction .*)
Lemma L33 : forall M N', URM.Beta (strip M) N' ->exists N, strip N = N' /\ Beta M N.
induction M; intros; simpl in *.
inversion H. inversion H.
inversion H; subst; clear H. destruct M1; simpl in *; try discriminate.
injection H1; intros; subst; clear H1.
exists ( M1_2 [ ← M4]); split. rewrite strip_subst. trivial. eauto.
destruct (IHM1 M' H3) as (n & ? & ?). exists (App n M2 M3 M4); split. simpl. subst. trivial.
intuition. destruct (IHM4 N'0 H3) as (n & ? & ?). exists (App M1 M2 M3 n); split. simpl. subst. trivial.
intuition. inversion H; subst; clear H.
destruct (IHM2 B' H3) as (n & ? & ?). exists (Pi M1 n); split. simpl. subst. trivial.
intuition. destruct (IHM1 A' H3) as (n & ? & ?). exists (Pi n M2); split. simpl. subst. trivial.
intuition.  inversion H; subst; clear H.
destruct (IHM2 M' H3) as (n & ? & ?). exists (La M1 n); split. simpl. subst. trivial.
intuition. destruct (IHM1 A' H3) as (n & ? & ?). exists (La n M2); split. simpl. subst. trivial.
intuition.
Qed.

Lemma L33' : forall M N', URM.Betas (strip M) N' ->exists N, strip N = N' /\ Betas M N.
intros. remember (strip M) as MM. revert M HeqMM. induction H; intros; subst.
exists M0; intuition. apply L33 in H as (N0 & ? & ?).
exists N0; intuition. destruct (IHBetas1 M0 ) as (N0 & ? & ?); trivial.
destruct (IHBetas2 N0) as (NN & ?& ?). intuition.
exists NN; intuition. eauto.
Qed.

End glue_mod.


(* -------------------------------------------------------------------- *)
From mathcomp Require Import all_ssreflect all_algebra.

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

Import Monoid GRing.Theory Num.Theory.

Local Open Scope ring_scope.

Delimit Scope order_scope with O.

(* -------------------------------------------------------------------- *)
Module POrder.
Section ClassDef.

Context {T : eqType}.

Definition axiom (le : T -> T -> bool) :=
  [/\ reflexive le, antisymmetric le & transitive le].

Structure relf (ph : phant (T -> T -> bool)) := Pack { apply; _ : axiom apply }.
Local Coercion apply : relf >-> Funclass.

Variables (ph : phant (T -> T -> bool)) (f g : (T -> T -> bool)) (cF : relf ph).
Definition class := let: Pack _ c as cF' := cF return axiom cF' in c.
Definition clone fA of phant_id g (apply cF) & phant_id fA class :=
  @Pack ph f fA.
End ClassDef.

Module Exports.
Notation porder le := (axiom le).
Coercion apply : relf >-> Funclass.
Notation POrder fO := (Pack (Phant _) fO).
Notation "{ 'porder' T }" := (relf (Phant (T -> T -> bool)))
  (at level 0, format "{ 'porder'  T }") : ring_scope.
Notation "[ 'porder' 'of' f 'as' g ]" := (@clone _ _ f g _ _ idfun id)
  (at level 0, format "[ 'porder'  'of'  f  'as'  g ]") : form_scope.
Notation "[ 'porder' 'of' f ]" := (@clone _ _ f f _ _ id id)
  (at level 0, format "[ 'porder'  'of'  f ]") : form_scope.
End Exports.
End POrder.

Include POrder.Exports.

(* -------------------------------------------------------------------- *)
Section POrderTheory.
Context {T : eqType} (le : {porder T}).

Lemma lexx : reflexive le.
Proof. by case: (POrder.class le). Qed.

Lemma le_asym : antisymmetric le.
Proof. by case: (POrder.class le). Qed.

Lemma le_trans : transitive le.
Proof. by case: (POrder.class le). Qed.

Lemma eq_le x y : (x == y) = (le x y && le y x).
Proof.
by apply/eqP/idP => [->|]; [rewrite lexx | apply/le_asym].
Qed.
End POrderTheory.

(* -------------------------------------------------------------------- *)
Module Order.
Section ClassDef.
Context {T : eqType}.

Definition mixin_of (le : T -> T -> bool) :=
  (forall x y, le x y || le y x).

Record class_of f : Prop := Class { base : porder f; mixin : mixin_of f }.
Local Coercion base : class_of >-> porder.

Structure relf (ph : phant (T -> T -> bool)) := Pack { apply; _ : class_of apply }.
Local Coercion apply : relf >-> Funclass.
Variables (ph : phant (T -> T -> bool)) (f g : rel T) (cF : relf ph).

Definition class := let: Pack _ c as cF' := cF return class_of cF' in c.

Definition clone fM of phant_id g (apply cF) & phant_id fM class :=
  @Pack ph f fM.

Definition pack (fM : mixin_of f) :=
  fun (bF : POrder.relf ph) fA & phant_id (POrder.class bF) fA =>
  Pack ph (Class fA fM).

Canonical porder := POrder.Pack ph class.
End ClassDef.

Module Exports.
Notation total f := (mixin_of f).
Notation order f := (class_of f).
Coercion base : order >-> POrder.axiom.
Coercion mixin : order >-> total.
Coercion apply : relf >-> Funclass.
Notation Order le := (Pack (Phant _) le).
Notation AddOrder le := (pack le id).
Notation "{ 'order' T }" := (relf (Phant (T -> T -> bool)))
  (at level 0, format "{ 'order'  T }") : ring_scope.
Notation "[ 'order' 'of' f 'as' g ]" := (@clone _ _ f g _ _ idfun id)
  (at level 0, format "[ 'order'  'of'  f  'as'  g ]") : form_scope.
Notation "[ 'order' 'of' f ]" := (@clone _ _ f f _ _ id id)
  (at level 0, format "[ 'order'  'of'  f ]") : form_scope.
Coercion porder : relf >-> POrder.relf.
Canonical porder.
End Exports.
End Order.

Include Order.Exports.

(* -------------------------------------------------------------------- *)
Section OrderTheory.
Context {T : eqType} (le : {order T}).

Lemma le_total : total le.
Proof. by case: (Order.class le). Qed.
End OrderTheory.

(* -------------------------------------------------------------------- *)
Section Extrema.
Context {R : realDomainType} {I : finType} (P : pred I) (F : I -> R).

Hypothesis hP : (exists i, P i).

Local Lemma arg_min_proof :
  exists i, P i && [forall (j | P j), (F i <= F j)%R].
Proof.
pose s := [seq i <- enum I | P i]; pose i0 := xchoose hP.
suff: exists2 i, i \in s & (forall j, j \in s -> (F i <= F j)%R).
+ case=> i; rewrite mem_filter => /andP[Pi _] mini; exists i.
  apply/andP; split=> //; apply/forall_inP => j Pj.
  by apply/mini; rewrite mem_filter Pj mem_enum.
have: s != [::]; first rewrite -has_filter.
+ by apply/hasP; exists i0; [rewrite mem_enum | apply/xchooseP].
elim: s => {i0} // i s ih _; case: (s =P [::]) => [{ih}->|].
+ by exists i => [|j]; rewrite mem_seq1 => // /eqP ->.
move/eqP=> /ih[{ih} j j_in_s ih]; case: (lerP (F i) (F j)).
+ move=> le_FiFj; exists i; first by rewrite mem_head.
  move=> k; rewrite in_cons => /orP[/eqP->//|/ih].
  by apply/(ler_trans le_FiFj).
+ move/ltrW=> le_FjFi; exists j; first by rewrite mem_behead.
  by move=> k; rewrite in_cons => /orP[/eqP->|/ih].
Qed.

Definition arg_minr := nosimpl (xchoose arg_min_proof).

CoInductive extremum_spec : I -> Type :=
  ExtremumSpec i of P i & (forall j, P j -> (F i <= F j)%R)
    : extremum_spec i.

Lemma arg_minrP : extremum_spec arg_minr.
Proof.
by have /andP[Px /forall_inP Plex] := xchooseP arg_min_proof.
Qed.
End Extrema.

(* -------------------------------------------------------------------- *)
Section PickRDomain.
Context {R : realFieldType} (s : seq R) (b1 b2 : R).

Hypothesis (lt_b1_b2 : b1 < b2).

Lemma pick_in_range : {x : R | x \notin s & b1 < x < b2}.
Proof.
pose P i := b1 < tnth (in_tuple s) i < b2; case: (pickP P) => /= [i Pi|].
+ pose r : 'I__ := arg_minr (tnth (in_tuple s)) (ex_intro P _ Pi).
  exists ((b1 + tnth (in_tuple s) r) / 2%:R); last first.
    rewrite {}/r; case: arg_minrP => /= j /andP[lt gt] _.
    by case: (midf_lt lt) => -> /ltr_trans; apply.
  rewrite {}/r; case: arg_minrP => /= j Pj min {i Pi}.
  apply/negP => /seq_tnthP[i] h; have Pi: P i.
    rewrite /P -h; case/andP: Pj => [lt gt].
    by case: (midf_lt lt) => -> /= /ltr_trans; apply.
  have := min _ Pi; rewrite -{}h; case/andP: Pj => lt _.
  by case/midf_lt: lt => _ h /(ltr_le_trans h); rewrite ltrr.
+ move=> h; exists ((b1 + b2) / 2%:R); last first.
    by case/midf_lt: lt_b1_b2 => -> ->.
  apply/negP => /seq_tnthP[i Pi]; move/(_ i): h.
  by case/midf_lt: lt_b1_b2; rewrite /P -Pi => -> ->.
Qed.
End PickRDomain.

(* -------------------------------------------------------------------- *)
Section LinOrderNat.
Context (le : {porder nat}).

Local Notation "x <= y" := (le x y) : order_scope.

Let P n (α : nat -> rat) := forall (i j : 'I_n), α i = α j -> i = j.
Let Q n (α : nat -> rat) := forall (i j : 'I_n), (i <= j)%O -> α i <= α j.
Let R n (α : nat -> rat) := forall i : 'I_n, -1 < α i < 1.

Section Extend.
Context (n : nat) (α : nat -> rat).

Hypothesis (Pα : P n α) (Qα : Q n α) (Rα : R n α).

Local Lemma extend : {β : nat -> rat |
  forall i : 'I_n, β i = α i & [/\ P n.+1 β, Q n.+1 β & R n.+1 β]}.
Proof.
pose En : {set 'I_n} := [set i in 'I_n | (i <= n)%O].
pose Ep : {set 'I_n} := [set i in 'I_n | (n <= i)%O].
have: { q : rat | -1 < q < 1 & [/\
          forall i : 'I_n, i \in Ep -> q < α i ,
          forall i : 'I_n, i \in En -> q > α i &
          forall i : 'I_n, q != α i ] }.
+ have: { q : rat | -1 <= q < 1 & [/\
          forall i : 'I_n, i \in En -> q >= α i &
          forall i : 'I_n, i \in Ep -> q <  α i ] }.
  - case: (set_0Vmem En) => /= [->|nz_En].
    * exists (-1) => //; split=> i; first by rewrite in_set0.
      by move=> _; case/andP: (Rα i).
    have h: exists x, x \in En by case: nz_En => x ?; exists x.
    exists (α (arg_minr (-%R \o α \o val) h)); last split.
    * case: arg_minrP => /= i _ _; case/andP: (Rα i).
      by move/ltrW=> -> ->.
    * move=> i i_En; case: arg_minrP => /= j _.
      by move/(_ _ i_En); rewrite ler_opp2.
    * move=> i i_Ep; case: arg_minrP => /= j j_En _.
      rewrite ltr_neqAle Qα ?andbT; last first.
        move: i_Ep; rewrite in_set => /andP[_ le_ni].
        move: j_En; rewrite in_set => /andP[_ le_jn].
        by apply/(le_trans le_jn le_ni).
      apply/eqP => /Pα eq_ji.
      have {eq_ji} j_Ep: j \in Ep by rewrite eq_ji.
      move: j_Ep j_En; rewrite !in_set => /andP[_ le1] /andP[_ le2].
      have: (val j == n) by rewrite (eq_le le) /= !(le1, le2).
      by rewrite ltn_eqF // ltn_ord.
  case=> qn /andP[ge_qn le_qn] [qn_En qn_Ep].
  have: { q : rat | -1 < q <= 1 & [/\ q > qn &
          forall i : 'I_n, i \in Ep -> q <= α i ] }.
  - case: (set_0Vmem Ep) => /= [->|nz_Ep].
    * by exists 1 => //; split => // i; rewrite in_set0.
    have h: exists x, x \in Ep by case: nz_Ep => x ?; exists x.
    exists (α (arg_minr (α \o val) h)); last split.
    * case: arg_minrP => /= i _ _; case/andP: (Rα i).
      by move=> -> /ltrW ->.
    * by case: arg_minrP => /= i /qn_Ep.
    by move=> i i_Ep; case: arg_minrP => /= j _ /(_ _ i_Ep).
  case=> qp /andP[ge_qp le_qp] [lt_qn_qp] qp_Ep.
  have qp_En (i : 'I_n): i \in En -> α i < qp.
  - by move=> i_En; apply/(ler_lt_trans (qn_En _ i_En)).
  have: { q : rat | qn < q < qp & forall i : 'I_n, q != α i }.
  - pose s := [seq α i | i : 'I_n]; case: (pick_in_range s lt_qn_qp).
    move=> /= q /mapP h cmp_q; exists q => // i.
    by apply/negP=> /eqP qE; apply: h; exists i => //; rewrite mem_enum.
  case=> q /andP[lt_q gt_q] fresh_q; exists q; last split => //.
  - by rewrite (ler_lt_trans ge_qn lt_q) (ltr_le_trans gt_q le_qp).
  - by move=> i Epi; apply/(ltr_le_trans gt_q (qp_Ep _ Epi)).
  - by move=> i Eni; apply(ler_lt_trans (qn_En _ Eni) lt_q).
case=> q cmp_q [Ep_q En_q fresh_q].
pose β k := if k == n then q else α k.
exists β => [[i /= lt_in]|]; [by rewrite /β ltn_eqF | split].
+ rewrite /P => i j; wlog: i j / (i <= j)%N => [wlog|].
  - case/orP: (leq_total i j) => /wlog //.
    by move=> h1 h2; apply/esym/h1/esym.
  rewrite [i = j](rwP val_eqP); move: i j.
  rewrite -![n.+1]addn1 => i j; case: (splitP j).
  - move=> kj => /= ->; case: (splitP i) => ki; last first.
    * by rewrite ord1 addn0 => ->; rewrite leqNgt ltn_ord.
    by move=> /= ->; rewrite /β ![_ == n]ltn_eqF // => _ /Pα ->.
  move=> /= k; rewrite ord1 addn0 => -> {k} _.
  case: (splitP i) => k /= ->; last by rewrite ord1 addn0.
  by rewrite /β eqxx ltn_eqF // => /esym; apply/contra_eq.
+ rewrite /Q; rewrite -[n.+1]addn1 => i j; case: (splitP j).
  - move=> kj ->; rewrite {2}/β ltn_eqF //; case: (splitP i).
      by move=> ki ->; rewrite /β ltn_eqF //; apply/Qα.
    move=> k; rewrite ord1 addn0 => -> {k}.
    by rewrite /β eqxx => h; apply/ltrW/Ep_q; rewrite inE.
  - move=> k; rewrite ord1 addn0 => -> {k}; rewrite /β eqxx.
    case: (splitP i); last first.
      by move=> k; rewrite ord1 addn0 => ->; rewrite eqxx.
    move=> k -> h; rewrite ltn_eqF //.
    by apply/ltrW/En_q; rewrite inE.
+ rewrite /R; rewrite -addn1 => i; case: (splitP i); last first.
  - by move=> k; rewrite ord1 addn0 => ->; rewrite /β eqxx.
  by move=> j ->; rewrite /β ltn_eqF.
Qed.
End Extend.

(* -------------------------------------------------------------------- *)
Definition ext0 : nat -> rat := fun _ => 0.

Local Lemma ext0_proof : [/\ P 0 ext0, Q 0 ext0 & R 0 ext0].
Proof. by split; case. Qed.

Fixpoint extn_r (n : nat) {struct n}
  : { α : nat -> rat & [/\ P n α, Q n α & R n α] }
:=
  if n is p.+1 then
    let: existT α (And3 p1 p2 p3) := extn_r p in
    let: exist2 β _ w := @extend p α p1 p2 p3 in
    Tagged _ w
  else Tagged _ ext0_proof.

Definition extn (n : nat) := tag (extn_r n.+1) n.

(* -------------------------------------------------------------------- *)
Definition linop : rel nat := [rel n p | extn n <= extn p].

(* -------------------------------------------------------------------- *)
Local Lemma extn_monoS n p :
  (p < n)%N -> tag (extn_r n) p = tag (extn_r n.+1) p.
Proof.
move=> lt_pn /=; case: extn_r => α [w1 w2 w3] /=.
by case: extend => β eq _ /=; apply/esym/(eq (Ordinal lt_pn)).
Qed.

(* -------------------------------------------------------------------- *)
Local Lemma extn_mono n p : (n < p)%N -> extn n = tag (extn_r p) n.
Proof.
elim: p => [|p ih] //; rewrite ltnS leq_eqVlt.
by case/orP => [/eqP<-//|lt_np]; rewrite ih // extn_monoS.
Qed.

(* -------------------------------------------------------------------- *)
Local Lemma extn_inj : injective extn.
Proof. move=> m n.
have h1: (m < (maxn m n).+1)%N by rewrite ltnS leq_maxl.
have h2: (n < (maxn m n).+1)%N by rewrite ltnS leq_maxr.
rewrite (extn_mono h1) (extn_mono h2) /=.
case: extn_r => /= α [p1 p2 p3] /=; case: extend => β _ /=.
case=> [h _ _] /(h (Ordinal h1) (Ordinal h2)).
by move/val_eqP => /= /eqP; apply/pcan_inj/pickleK_inv.
Qed.

(* -------------------------------------------------------------------- *)
Lemma linop_is_porder : POrder.axiom linop.
Proof. split.
+ by move=> x; apply/lerr.
+ by move=> x y => /ler_asym; apply/extn_inj.
+ by move=> x y z; apply/ler_trans.
Qed.

(* -------------------------------------------------------------------- *)
Lemma linop_extend n p : (n <= p)%O -> linop n p.
Proof.
move=> lo_np; rewrite /linop /=; pose r := (maxn n p).+1.
have h1: (n < r)%N by rewrite ltnS leq_maxl.
have h2: (p < r)%N by rewrite ltnS leq_maxr.
rewrite (extn_mono h1) (extn_mono h2); case: extn_r => /= α.
by case=> [_ /(_ (Ordinal h1) (Ordinal h2)) h _]; apply/h.
Qed.

(* -------------------------------------------------------------------- *)
Lemma linop_total : total linop.
Proof. by move=> x y; apply/ler_total. Qed.

(* -------------------------------------------------------------------- *)
Canonical linop_porder := POrder linop_is_porder.
Canonical linop_order  := AddOrder linop_total.
End LinOrderNat.

(* -------------------------------------------------------------------- *)
Section LinOrderGen.
Context {T : countType} (le : {porder T}).

Local Notation "x <= y" := (le x y) : order_scope.

Definition cntop (m n : nat) :=
  if m == n then true else
    if   (pickle_inv T m, pickle_inv T n) is (Some m, Some n)
    then (m <= n)%O
    else false.

Lemma cntop_is_porder : POrder.axiom cntop.
Proof. split.
+ by move=> x; rewrite /cntop; rewrite eqxx.
+ move=> x y; rewrite /cntop eq_sym; case: eqP => // _.
  case Ea: pickle_inv => [xa|];
    case Eb: pickle_inv => [xb|] => //; move/le_asym => h.
  by rewrite -[x](@pickle_invK T) -[y](@pickle_invK T) Ea Eb /= h.
+ move=> x y z; rewrite /cntop; case: eqP => [<-|].
    by case: eqP.
  move=> /eqP ne_yx; case: eqP => // [<-|].
    by rewrite (negbTE ne_yx).
  move=> /eqP ne_xz; case: eqP => // /eqP ne_yz.
  case Ey: (pickle_inv _ y) => [py|] //;
    case Ez: (pickle_inv _ z) => [pz|] //;
    case Ex: (pickle_inv _ x) => [px|] //.
  by apply/le_trans.
Qed.

Canonical cntop_porder := POrder cntop_is_porder.

(* -------------------------------------------------------------------- *)
Definition linopg (x y : T) :=
  linop [porder of cntop] (pickle x) (pickle y).

(* -------------------------------------------------------------------- *)
Lemma linopg_is_porder : POrder.axiom linopg.
Proof. split.
+ by move=> x /=; apply/lexx.
+ move=> x y /le_asym; set m := pickle x; set n := pickle y.
  by move/(congr1 (pickle_inv T)); rewrite !pickleK_inv; case.
+ by move=> x y z /=; apply/le_trans.
Qed.

(* -------------------------------------------------------------------- *)
Lemma linopg_is_total : total linopg.
Proof. by move=> x y; apply/le_total. Qed.

(* -------------------------------------------------------------------- *)
Canonical linopg_porder := POrder linopg_is_porder.
Canonical linopg_order  := AddOrder linopg_is_total.

(* -------------------------------------------------------------------- *)
Lemma linopg_extend : subrel le linopg.
Proof.
move=> x y h; apply/linop_extend => /=; rewrite /cntop.
by case: eqP => // _; rewrite !pickleK_inv.
Qed.
End LinOrderGen.


(*
Require Export LNat LOptions LTactics.

Section PartialFunctions.

Variable F : term.
Hypothesis proc_F : proc F.

Variable X : Type.
Variable in_enc : X -> term.

Variable Y : Type.
Variable out_enc : Y -> term.

Hypothesis in_enc_proc : forall x, proc (in_enc x).
Hypothesis out_enc_proc : forall x, proc (out_enc x).

#[export] Hint Resolve in_enc_proc out_enc_proc: LProc.

Hypothesis total_F : forall t n, (exists v, F (enc n) (in_enc t) == oenc out_enc (Some v)) \/ F (enc n) (in_enc t) == (none out_enc).

Definition S' := rho (.\"S'", "n", "F", "t"; ("F" "n" "t")
                                               !K
                                               ((.\"Sn","x"; "S'" "Sn" "F" "x") (!Succ "n")) "t").

Lemma S'_proc : recProc S'.
Proof.
  cLproc.
Qed.

#[export] Hint Resolve S'_proc : LProc.

#[export] Hint Unfold S' : cbv.
(*
Lemma S'_rec n t : S' (enc n) F (tenc t) ==  (F (enc n) (tenc t)) K (lam ( S' (Succ (enc n)) F (tenc t))) I.
Proof.
  Lsimpl.
Qed.*)

Hypothesis mono_F : forall n t v, F (enc n) (in_enc t) == oenc out_enc (Some v) -> F (enc (S n)) (in_enc t) == oenc out_enc (Some v).

Lemma S'_n_Sn n t : S' (enc n) F (in_enc t)  == S' (enc (S n)) F (in_enc t).
Proof.
  repeat recStep S'. destruct (@total_F t n) as [[v Hv] | H].
  -assert (H := mono_F Hv). Lsimpl.
  -Lsimpl. rewrite none_correct with (enc:=in_enc). Lsimpl. recStep S'. Lsimpl.
Qed.

Lemma S'_n_Sn_none n t : F (enc n) (in_enc t) == oenc out_enc None ->( lam (S' (enc n) F 0)) (in_enc t)  >* (lam (S' (enc (S n)) F 0) )(in_enc t).
Proof.
  intros R. wLsimpl. subst. recStep S'. wLsimpl. subst.  apply star_step_app_proper;[|reflexivity]. apply equiv_lambda. Lsimpl.
Qed.

Definition Se F :term := .\"x"; !(S' (enc 0)) !F "x".

Lemma Se_proc : proc (Se F).
Proof.
  unfold Se;simpl. wLproc.
Qed.

#[export] Hint Resolve Se_proc : LProc.

Lemma S'_0_n n t : Se F (in_enc t) == S' (enc n) F (in_enc t).
Proof.
  unfold Se;simpl. Lsimpl. induction n.
  -Lsimpl.
  -Lsimpl. apply S'_n_Sn.
Qed.

Lemma Se_converges t v : Se F (in_enc t) == lam v -> closed (lam v).
Proof.
  intros eq. apply equiv_lambda' in eq;[|Lproc]. apply closed_star in eq;Lproc.
Qed.

Lemma Se_correct' t (v : term) : proc v ->
                                    ( Se F (in_enc t) == v <-> exists n, F (enc n) (in_enc t) == some v ).
Proof.
  intros proc_v; split...
  - unfold Se;simpl; generalize 0 at 1; intros n H.
    eapply equiv_lambda' in H;Lproc... assert (R:=H). rewrite star_pow in H. destruct H as [k H].
    revert n R H.
    eapply complete_induction with (x := k). clear k.
    intros k IHn n R H.
    destruct (total_F t n) as [[v' H'] | HH]...
    + assert (out_enc v' = v). {
        apply unique_normal_forms;Lproc. rewrite <- R. Lsimpl. recStep S'. Lsimpl.
      }
      subst.
      exists n. Lsimpl.
    + assert (R':= S'_n_Sn_none HH).
      apply star_pow in R' as [k' R']. destruct k'.
      *inversion R'. apply enc_injective in H1. lia.
      *destruct proc_v as [? [? ?]]. subst v. destruct (pow_trans_lam H R') as [k'' [le R'']].
       assert (R1 : (λ ((S' (enc (S n))) F) 0) (in_enc t) >* (λ x)) by (rewrite star_pow; eauto).
       specialize (IHn _ le _ R1 R''). auto.
  - intros [m Hm]. rewrite S'_0_n with (n := m). recStep S'. Lsimpl. unfold some. simpl. Lsimpl.
Qed.

(* TODO *)

Ltac standardizeHypo _n:=
match goal with
  | eq : ?s == ?t |- _=>
    revert eq;try standardizeHypo _n; intros eq;
    try (progress (let R:= fresh "R" in
                   standardize R _n s;apply (stHypo R) in eq;clear R ));
      try (progress (let R':= fresh "R'" in
                     symmetry;standardize R' _n s;
                     apply (stHypo R') in eq;symmetry;clear R' ))
end.

Corollary Se_correct t (v : term) : lambda v -> (Se F (in_enc t) == v <-> exists n, F (enc n) (in_enc t) == some v).
Proof.
  intros lam_v; split.
  - intros. destruct lam_v; subst.
    eapply Se_correct' in H. firstorder.
    eapply Se_converges in H. split;auto.
  - intros [n H].
    assert (closed v).
    { destruct (total_F t n) as [[v' Hv'] | Hv'].
      + rewrite H in Hv'. Lsimpl. cbv in Hv'. inv lam_v.

        clear H. revert Hv'. try standardizeHypo 10. intros Hv'. rewrite !(eqStep (stepApp _ _)) in Hv'. cbv in Hv'. apply unique_normal_forms in Hv';[|Lproc..]. rewrite oenc_def_eq in Hv'. injection Hv'. intros;subst. rewrite H. Lproc.
      + rewrite H in Hv'. symmetry in Hv'. cbv in Hv'. inv lam_v. rewrite (eqStep (stepApp _ _)) in Hv'. simpl in Hv'. apply unique_normal_forms in Hv';[|Lproc..]. discriminate Hv'.
    }
    rewrite Se_correct';[|Lproc].
    eauto.
Qed.

End PartialFunctions.

#[export] Hint Resolve S'_proc : LProc.

#[export] Hint Resolve Se_proc : LProc.
*)


(** * Finite maps  *)

Require Import FMaps FMapWeakList.
Require Import String Basics.
Require Import List.
Require Import PeanoNat.
Import ListNotations.
From MetaCoq.Template Require Import All.

From ConCert Require Import Ast Notations CustomTactics PCUICTranslate PCUICtoTemplate EvalE.

Import MonadNotation.
Import BaseTypes.
Import StdLib.
Open Scope list.
Open Scope nat.

Definition expr_to_tc Σ := compose trans (expr_to_term Σ).
Definition type_to_tc := compose trans type_to_term.
Definition global_to_tc := compose trans_minductive_entry trans_global_dec.

(** Implementing a simple finite map data type using our embedding. We pick a simple representation of finite maps which is isomorphic to lists of key-value pairs *)

(** Generation of string constants using MetaCoq. We use these string constants to make the embedding more readable. *)

Fixpoint mkNames (ns : list string) (suffix : string) :=
  match ns with
  | [] => tmPrint "Done."
  | n :: ns' => n' <- tmEval all (n ++ suffix)%string ;;
                  str <- tmQuote n';;
                  tmMkDefinition n str;;
                  mkNames ns' suffix
  end.

(** ** The deep embedding of data structures for finite maps *)

(** We generate names for inductives and constructors *)
Run TemplateProgram
      (mkNames ["Maybe";"Nothing";"Just"; "Map"; "MNil"; "MCons" ] "Acorn").

(** Now we can use [Maybe] as a name for a data type in our deep embedding. [Maybe] contains a string "MaybeAcorn" *)

Print Maybe.
(* Maybe = "MaybeAcorn" *)
(*      : string *)

(** Now, we define an AST (a deep embedding) for [MaybeAcorn] data type. [MaybeAcorn] is the same as [option] of Coq and [Maybe] of Haskell. First, we define a new datatype without using notations *)

Definition maybe_syn :=
  gdInd Maybe 1 [(Nothing, []);  (Just, [(None,tyRel 0)])] false.

Make Inductive (global_to_tc maybe_syn).

(** Now, we define a type of finite maps using notations based on Custom Entries *)
Definition map_syn :=
  [\ data Map # 2 =
       MNil [_]
     | MCons [^1, ^0, (Map ^1 ^0), _]  \].

Make Inductive (global_to_tc map_syn).

Definition Σ' :=
  Σ ++ [ maybe_syn; map_syn ].

(** We generate string constants for variable names as well to make our examples look nicer *)
Run TemplateProgram
      (mkNames ["A"; "B"; "C"; "f"; "a"; "b"; "c"; "m"; "n"; "k" ; "v"; "w"; "x"; "y"; "z"; "lookup"; "add" ] "_coq").

Notation " ' x " := (eTy (tyVar x))
                    (in custom expr at level 1,
                        x constr at level 2).

(** [if .. then .. else] is just a shortcut for [case] of a boolean expression *)
Notation "'if' cond 'then' b1 'else' b2 : ty" :=
    (eCase (Bool,[]) ty cond
           [(pConstr true_name [],b1);(pConstr false_name [],b2)])
      (in custom expr at level 2,
          cond custom expr at level 4,
          ty custom type at level 4,
          b1 custom expr at level 4,
          b2 custom expr at level 4).

(** ** Functions on finite maps *)

(** AST for lookup function *)
Definition lookup_syn :=
  [| \\A => \\B =>
     \f : 'A -> 'A -> Bool =>
     \k : 'A =>
     fix lookup (m : Map 'A 'B) : Maybe 'B :=
     case m : Map 'A ,'B return Maybe 'B of
     | MNil -> $Nothing$Maybe 'B
     | MCons x y z -> if (f k x) then
                       $Just$Maybe 'B y
                       else lookup z : Maybe 'B |].

Compute (indexify [] lookup_syn).

(** Unquoting the [lookup_syn] to produce a Coq function *)
Make Definition lookup_map := (expr_to_tc Σ' (indexify [] lookup_syn)).

(** AST for a function that adds an element to a map *)
Definition add_map_syn :=
    [| \\A => \\B =>
     \f : 'A -> 'A -> Bool =>
     \k : 'A =>
     \v : 'B =>
     fix add (m : Map 'A 'B) : Map 'A 'B :=
     case m : Map 'A , 'B return Map 'A 'B of
     | MNil -> $MCons$Map 'A 'B k v ($MNil$Map 'A 'B)
     | MCons x y z -> if (f k x) then
                       $MCons$Map 'A 'B k v z
                     else $MCons$Map 'A 'B x y (add z) : Map 'A 'B |].

Compute (expr_to_term Σ' (indexify [] add_map_syn)).

Make Definition add_map := (expr_to_tc Σ' (indexify [] add_map_syn)).

(** ** Correctness *)

(** We can prove correctness of "library" definitions like finite maps by comparing the to Coq's standard library definitions *)

(** Since Coq's [FMap] is a module, we fix the type of keys to be [nat] *)
Module NatMap := FMapWeakList.Make Nat_as_OT.

(** Conversion function from our type of finite maps to the one in the standard library *)
Fixpoint from_amap {A} (m : MapAcorn nat A) : NatMap.Raw.t A :=
  match m with
  | MNilAcorn  => []
  | MConsAcorn k v m' => (k,v) :: from_amap m'
  end.

Import PeanoNat.Nat.

(** Showing that [add] function on Acorn finite maps are behaves the same way as one of the Coq's Stdlib implementations (up to converting the results) *)
Lemma add_map_eq_stdlib {A : Set} k v m :
  NatMap.Raw.add k v (from_amap m) = from_amap (add_map _ A PeanoNat.Nat.eqb k v m).
Proof.
  induction m.
  + reflexivity.
  + simpl in *.
    destruct (Nat_as_OT.eq_dec k a0). subst. rewrite eqb_refl.
    reflexivity. rewrite <- eqb_neq in n0. rewrite n0.
    simpl. now f_equal.
Qed.

(** * Computing with the interpreter *)

Section MapEval.

  Definition tyNat := eTy (tyInd Nat).

  (** Boolean equality of two natural numbers in Acorn *)
  Definition eqb_syn : expr :=
    [| (fix "eqb" (n : Nat) : Nat ->  Bool :=
           case n : Nat return Nat -> Bool of
           | Zero -> \m : Nat => (case m : Nat return Bool of
                   | Zero -> True
                   | Suc z -> False)
           | Suc a ->
             \m : Nat =>
             (case m : Nat return Bool of
                   | Zero -> False
                   | Suc b -> "eqb" a b))
     |].

  Make Definition nat_eqb :=
    (expr_to_tc Σ' (indexify [] eqb_syn)).

  (** Showing that Acorn boolean equality is in fact the same as [Nat.eqb] *)
  Lemma nat_eqb_correct n m : nat_eqb n m = Nat.eqb n m.
  Proof.
    revert m.
    induction n;intros m; now destruct m.
  Qed.

  (** The syntactic representation of the following map [1 ~> 1; 0 ~> 0] *)
  Definition aMap :=
    [| $MCons$Map {tyNat} {tyNat} 1 1 ($MCons$Map {tyNat} {tyNat} 0 0 ($MNil$Map {tyNat} {tyNat})) |].

  (** Computing boolean equality with the interpreter *)
  Example compute_eqb_true :
    (expr_eval_i Σ' 10 [] (indexify [] [|{eqb_syn} 1 1 |])) =
    Ok (vConstr Bool true_name []).
  Proof. reflexivity. Qed.

  Example compute_eqb_false :
    (expr_eval_i Σ' 10 [] (indexify [] [|{eqb_syn} 1 0 |])) =
    Ok (vConstr Bool false_name []).
  Proof. reflexivity. Qed.

  (** Computing lookup with using the interpreter for the named representation of variables *)
  Example compute_lookup_named :
    (expr_eval_n Σ' 10 []
                 [| {lookup_syn} {tyNat} {tyNat} {eqb_syn} 0 {aMap} |]) =
  Ok (vConstr Maybe "JustAcorn" [vTy (tyInd Nat); vConstr Nat "Z" []]).
  Proof. compute. reflexivity. Qed.

  (** Computing lookup with using the interpreter for variables represented with De Bruijn indices *)
  Example compute_lookup_debruijn :
    (expr_eval_i Σ' 10 []
                 (indexify []
                           [| {lookup_syn} {tyNat} {tyNat} {eqb_syn} 0 {aMap} |])) =
  Ok (vConstr Maybe "JustAcorn" [vTy (tyInd Nat); vConstr Nat "Z" []]).
  Proof. compute. reflexivity. Qed.

End MapEval.


Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.
Local Open Scope logic.

Lemma wand_frame_intro {A} {ND: NatDed A} {SL: SepLog A}: forall (P Q: A),
  Q |-- P -* P * Q.
Proof.
  intros.
  apply wand_sepcon_adjoint.
  rewrite sepcon_comm; auto.
Qed.

Lemma wand_frame_elim {A} {ND: NatDed A} {SL: SepLog A}: forall (P Q: A),
  P * (P -* Q) |-- Q.
Proof.
  intros.
  rewrite sepcon_comm.
  apply wand_sepcon_adjoint; auto.
Qed.

Lemma wand_frame_ver {A} {ND: NatDed A} {SL: SepLog A}: forall (P Q R: A),
  (P -* Q) * (Q -* R) |-- P -* R.
Proof.
  intros.
  apply -> wand_sepcon_adjoint.
  rewrite (sepcon_comm _ P), <- sepcon_assoc.
  eapply derives_trans.
  + eapply sepcon_derives; [apply wand_frame_elim | apply derives_refl].
  + apply wand_frame_elim.
Qed.

Lemma wand_frame_hor {A} {ND: NatDed A} {SL: SepLog A}: forall (P1 P2 Q1 Q2: A),
  (P1 -* Q1) * (P2 -* Q2) |-- P1 * P2 -* Q1 * Q2.
Proof.
  intros.
  apply -> wand_sepcon_adjoint.
  rewrite <- (sepcon_assoc _ P1), (sepcon_comm _ P1), <- (sepcon_assoc P1), (sepcon_assoc _ _ P2), (sepcon_comm _ P2).
  apply sepcon_derives; apply wand_frame_elim.
Qed.

Lemma wand_frame_frame {A} {ND: NatDed A} {SL: SepLog A}: forall (P Q F: A),
  P -* Q |-- P * F -* Q * F.
Proof.
  intros.
  apply -> wand_sepcon_adjoint.
  rewrite <- sepcon_assoc, (sepcon_comm _ P).
  apply sepcon_derives; [apply wand_frame_elim | auto].
Qed.