Require Export PropLang.
Require Export List.
Require Export Subcontext.
Require Export RelationClasses.
Require Export Morphisms.
Require Export NaturalDeduction.

Section Hilbert.

Context {atom : Type}.

Inductive hilbert_axiom : prop atom -> Prop :=
| hilbert_axiom_I {P} : hilbert_axiom (P ⊃ P)
| hilbert_axiom_K {P Q} : hilbert_axiom (P ⊃ Q ⊃ P)
| hilbert_axiom_S {P Q R} : hilbert_axiom ((P ⊃ Q ⊃ R) ⊃ (P ⊃ Q) ⊃ P ⊃ R)
| hilbert_axiom_bot_elim {P} : hilbert_axiom (⊥ ⊃ P)
| hilbert_axiom_top_intro : hilbert_axiom ⊤
| hilbert_axiom_and_intro {P Q} : hilbert_axiom (P ⊃ Q ⊃ P ∧ Q)
| hilbert_axiom_and_elim {P Q R} : hilbert_axiom ((P ⊃ Q ⊃ R) ⊃ P ∧ Q ⊃ R)
| hilbert_axiom_or_introl {P Q} : hilbert_axiom (P ⊃ P ∨ Q)
| hilbert_axiom_or_intror {P Q} : hilbert_axiom (Q ⊃ P ∨ Q)
| hilbert_axiom_or_elim {P Q R} : hilbert_axiom ((P ⊃ R) ⊃ (Q ⊃ R) ⊃ P ∨ Q ⊃ R).

Reserved Notation "Γ ≤h Γ'" (no associativity, at level 61).

(* Γ ≤h Γ' means that there is a valid sequence of steps starting
   from Γ with the additional steps along with Γ giving Γ'.
   Note that for convenience we add each step at the front of the
   list instead of the back. *)
Inductive hilbert_derivation : list (prop atom) -> list (prop atom) -> Prop :=
| hilbert_empty {Γ} : Γ ≤h Γ
| hilbert_axiom_derivation {Γ Γ' P} : Γ ≤h Γ' -> hilbert_axiom P ->
  Γ ≤h P :: Γ'
| hilbert_modus_ponens {Γ Γ' P Q} : Γ ≤h Γ' -> In P Γ' -> In (P ⊃ Q) Γ' ->
  Γ ≤h Q :: Γ'
where "Γ ≤h Γ'" := (hilbert_derivation Γ Γ').

Global Instance hilbert_derivation_preord : PreOrder hilbert_derivation.
Proof.
constructor.
+ intro Γ; constructor.
+ intros Γ Γ' Γ'' H H0. induction H0.
  - assumption.
  - constructor 2; auto.
  - constructor 3 with (P := P); eauto.
Qed.

Lemma hilbert_derivation_tail : forall Γ Γ', Γ ≤h Γ' ->
  exists Γ'', Γ' = Γ'' ++ Γ.
Proof.
induction 1.
+ exists nil; reflexivity.
+ destruct IHhilbert_derivation as [Γ'']. exists (P :: Γ'').
  rewrite H1. reflexivity.
+ destruct IHhilbert_derivation as [Γ'']. exists (Q :: Γ'').
  rewrite H2. reflexivity.
Qed.

Lemma hilbert_derivation_context_extension :
  forall Γ Γ' Γ'', Γ ⊆ Γ' -> Γ ≤h Γ'' ++ Γ ->
  Γ' ≤h Γ'' ++ Γ'.
Proof.
intros. remember (Γ'' ++ Γ) as Γ₀. revert Γ'' HeqΓ₀. induction H0.
+ intros. change (nil ++ Γ = Γ'' ++ Γ) in HeqΓ₀.
  apply app_inv_tail in HeqΓ₀. subst; simpl. constructor.
+ intros. destruct (hilbert_derivation_tail _ _ H0) as [Γh]. subst.
  pose proof (IHhilbert_derivation H Γh eq_refl).
  change ((P :: Γh) ++ Γ = Γ'' ++ Γ) in HeqΓ₀.
  apply app_inv_tail in HeqΓ₀. subst. simpl. constructor 2; auto.
+ intros. destruct (hilbert_derivation_tail _ _ H0) as [Γh]. subst.
  pose proof (IHhilbert_derivation H Γh eq_refl).
  change ((Q :: Γh) ++ Γ = Γ'' ++ Γ) in HeqΓ₀.
  apply app_inv_tail in HeqΓ₀. subst. simpl.
  constructor 3 with (P := P); auto.
  - destruct (in_app_or _ _ _ H1).
    * apply in_or_app; left; assumption.
    * apply in_or_app; right; auto.
  - destruct (in_app_or _ _ _ H2).
    * apply in_or_app; left; assumption.
    * apply in_or_app; right; auto.
Qed.

Inductive hilbert_proves (Γ : list (prop atom)) (P : prop atom) : Prop :=
| hilbert_derivation_proves : forall Γ', Γ ≤h (P :: Γ') -> hilbert_proves Γ P.
Notation "Γ ⊢h P" := (hilbert_proves Γ P) (no associativity, at level 61).

Proposition hilbert_assumption {Γ P} : In P Γ -> Γ ⊢h P.
Proof.
intros. apply hilbert_derivation_proves with (Γ' := P ⊃ P :: Γ).
apply @hilbert_modus_ponens with (P := P).
+ apply hilbert_axiom_derivation.
  - constructor.
  - constructor.
+ right; assumption.
+ left; reflexivity.
Qed.

Global Instance hilbert_context_extension :
  Proper (subcontext ++> eq ==> Basics.impl) hilbert_proves.
Proof.
intros Γ Γ' ? P Q [] ?. destruct H0. destruct (hilbert_derivation_tail _ _ H0).
destruct x.
+ simpl in H1. subst. apply hilbert_assumption. apply H. prove_In.
+ injection H1; intros; subst. change (Γ ≤h (p :: x) ++ Γ) in H0.
  pose proof (hilbert_derivation_context_extension _ _ _ H H0).
  eauto using hilbert_derivation_proves.
Qed.

Proposition hilbert_cut {Γ P Q} :
  Γ ⊢h P -> P :: Γ ⊢h Q -> Γ ⊢h Q.
Proof.
destruct 1. intros.
simple refine (let H1 := hilbert_context_extension (P :: Γ) (P :: Γ') _ _ _ eq_refl H0 in _).
+ rewrite subcontext_cons; split.
  - prove_In.
  - destruct (hilbert_derivation_tail _ _ H). red; intros.
    rewrite H1. apply in_or_app; right; assumption.
+ destruct H1. rewrite <- H in H1. eauto using hilbert_derivation_proves.
Qed.

Inductive hilbert_impl_lift (Γ Γ' : list (prop atom)) (P : prop atom) : Prop :=
| hilbert_impl_lift_intro : forall Γ'', Γ ≤h Γ'' ->
  (forall Q, In Q Γ' -> In (P ⊃ Q) Γ'') -> hilbert_impl_lift Γ Γ' P.

Lemma hilbert_cond_derivation : forall Γ Γ' P, P :: Γ ≤h Γ' ->
  hilbert_impl_lift Γ Γ' P.
Proof.
intros. remember (P :: Γ) as PΓ. revert P Γ HeqPΓ.
induction H; intros; subst.
+ assert (forall Γ, Γ ⊆ Γ0 -> hilbert_impl_lift Γ0 Γ P).
  - induction Γ.
    * exists Γ0.
      { constructor. }
      { destruct 1. }
    * rewrite subcontext_cons. destruct 1. destruct (IHΓ H0).
      assert (Γ0 ≤h a ⊃ P ⊃ a :: Γ'') by
        eauto using hilbert_derivation, hilbert_axiom_K.
      assert (Γ0 ≤h P ⊃ a :: a ⊃ P ⊃ a :: Γ'').
      { apply @hilbert_modus_ponens with (P := a); auto; try prove_In.
        right. destruct (hilbert_derivation_tail _ _ H1).
        rewrite H4. apply in_or_app; right; assumption. }
      { apply hilbert_impl_lift_intro with (1 := H4).
        destruct 1; subst; (prove_In || (do 2 right; auto)). }
  - destruct (H Γ0); try reflexivity.
    assert (Γ0 ≤h P ⊃ P :: Γ'') by
      eauto using hilbert_derivation, hilbert_axiom_I.
    apply hilbert_impl_lift_intro with (1 := H2).
    destruct 1; subst; (prove_In || (right; auto)).
+ destruct (IHhilbert_derivation _ _ eq_refl).
  assert (Γ0 ≤h P :: Γ'') by eauto using hilbert_derivation.
  assert (Γ0 ≤h P ⊃ P0 ⊃ P :: P :: Γ'') by eauto using
    hilbert_derivation, hilbert_axiom_K.
  assert (Γ0 ≤h P0 ⊃ P :: P ⊃ P0 ⊃ P :: P :: Γ'') by
    (apply @hilbert_modus_ponens with (P := P); auto; prove_In).
  apply hilbert_impl_lift_intro with (1 := H5).
  destruct 1; subst; (prove_In || (do 3 right; auto)).
+ destruct (IHhilbert_derivation _ _ eq_refl).
  pose proof (H3 _ H0); pose proof (H3 _ H1).
  assert (Γ0 ≤h (P0 ⊃ P ⊃ Q) ⊃ (P0 ⊃ P) ⊃ (P0 ⊃ Q) :: Γ'') by
    eauto using hilbert_derivation, hilbert_axiom_S.
  assert (Γ0 ≤h (P0 ⊃ P) ⊃ P0 ⊃ Q ::
          (P0 ⊃ P ⊃ Q) ⊃ (P0 ⊃ P) ⊃ (P0 ⊃ Q) :: Γ'') by
    (apply @hilbert_modus_ponens with (P := P0 ⊃ P ⊃ Q); auto;
     (prove_In || (right; auto))).
  assert (Γ0 ≤h P0 ⊃ Q :: (P0 ⊃ P) ⊃ P0 ⊃ Q ::
          (P0 ⊃ P ⊃ Q) ⊃ (P0 ⊃ P) ⊃ (P0 ⊃ Q) :: Γ'') by
    (apply @hilbert_modus_ponens with (P := P0 ⊃ P); auto;
     (prove_In || (right; right; auto))).
  apply hilbert_impl_lift_intro with (1 := H8).
  destruct 1; subst; (prove_In || (do 3 right; auto)).
Qed.

Theorem hilbert_cond_proof {P Q Γ} :
  P :: Γ ⊢h Q -> Γ ⊢h P ⊃ Q.
Proof.
intros. destruct H. destruct (hilbert_cond_derivation _ _ _ H).
assert (In (P ⊃ Q) Γ'') by (apply H1; prove_In).
destruct (hilbert_assumption H2). rewrite <- H0 in H3.
eauto using hilbert_derivation_proves.
Qed.

Proposition hilbert_axiom_soundness {Γ P} :
  hilbert_axiom P -> Γ ⊢ P.
Proof.
destruct 1.
+ apply ND_cond_proof. apply ND_assumption. prove_In.
+ apply ND_cond_proof. apply ND_cond_proof. apply ND_assumption. prove_In.
+ do 3 apply ND_cond_proof. apply @ND_modus_ponens with (P := Q).
  - apply @ND_modus_ponens with (P := P); apply ND_assumption; prove_In.
  - apply @ND_modus_ponens with (P := P); apply ND_assumption; prove_In.
+ apply ND_cond_proof. apply ND_exfalso_quodlibet.
  apply ND_assumption; prove_In.
+ apply ND_True_intro.
+ do 2 apply ND_cond_proof. apply ND_and_intro; apply ND_assumption; prove_In.
+ do 2 apply ND_cond_proof. apply @ND_and_elim with (P := P) (Q := Q).
  - apply ND_assumption; prove_In.
  - apply @ND_modus_ponens with (P := Q).
    * apply @ND_modus_ponens with (P := P); apply ND_assumption; prove_In.
    * apply ND_assumption; prove_In.
+ apply ND_cond_proof. apply ND_or_introl; apply ND_assumption; prove_In.
+ apply ND_cond_proof. apply ND_or_intror; apply ND_assumption; prove_In.
+ do 3 apply ND_cond_proof. apply @ND_proof_by_cases with (P := P) (Q := Q).
  - apply ND_assumption; prove_In.
  - apply @ND_modus_ponens with (P := P); apply ND_assumption; prove_In.
  - apply @ND_modus_ponens with (P := Q); apply ND_assumption; prove_In.
Qed.

Proposition hilbert_derivation_soundness {Γ Γ'} :
  Γ ≤h Γ' -> forall P, In P Γ' -> Γ ⊢ P.
Proof.
induction 1.
+ apply @ND_assumption.
+ destruct 1; subst; auto using hilbert_axiom_soundness.
+ destruct 1; subst; auto.
  apply @ND_modus_ponens with (P := P); auto.
Qed.

Theorem hilbert_soundness {Γ P} : Γ ⊢h P -> Γ ⊢ P.
Proof.
destruct 1. refine (hilbert_derivation_soundness H _ _). prove_In.
Qed.

Proposition hilbert_proves_axiom {Γ P} : hilbert_axiom P -> Γ ⊢h P.
Proof.
intros. exists Γ. eauto using hilbert_derivation.
Qed.

Theorem hilbert_completeness {Γ P} : Γ ⊢ P -> Γ ⊢h P.
Proof.
induction 1.
+ destruct IHND_proves. assert (Γ ≤h ⊥ ⊃ P :: ⊥ :: Γ') by
    eauto using hilbert_derivation, hilbert_axiom_bot_elim.
  assert (Γ ≤h P :: ⊥ ⊃ P :: ⊥ :: Γ') by
    (apply @hilbert_modus_ponens with (P := ⊥); auto; prove_In).
  eauto using hilbert_derivation_proves.
+ apply hilbert_proves_axiom. constructor.
+ destruct IHND_proves. assert (Γ ≤h P ⊃ P ∨ Q :: P :: Γ') by
    eauto using hilbert_derivation, hilbert_axiom_or_introl.
  assert (Γ ≤h P ∨ Q :: P ⊃ P ∨ Q :: P :: Γ') by
    (apply @hilbert_modus_ponens with (P := P); auto; prove_In).
  eauto using hilbert_derivation_proves.
+ destruct IHND_proves. assert (Γ ≤h Q ⊃ P ∨ Q :: Q :: Γ') by
    eauto using hilbert_derivation, hilbert_axiom_or_intror.
  assert (Γ ≤h P ∨ Q :: Q ⊃ P ∨ Q :: Q :: Γ') by
    (apply @hilbert_modus_ponens with (P := Q); auto; prove_In).
  eauto using hilbert_derivation_proves.
+ apply hilbert_cond_proof in IHND_proves2;
  apply hilbert_cond_proof in IHND_proves3.
  apply (hilbert_cut IHND_proves1).
  apply @hilbert_cut with (P := P ⊃ R).
  - refine (hilbert_context_extension _ _ _ _ _ eq_refl IHND_proves2).
    prove_subcontext.
  - apply @hilbert_cut with (P := Q ⊃ R).
    * refine (hilbert_context_extension _ _ _ _ _ eq_refl IHND_proves3).
      prove_subcontext.
    * set (Γ' := Q ⊃ R :: P ⊃ R :: P ∨ Q :: Γ).
      assert (Γ' ≤h (P ⊃ R) ⊃ (Q ⊃ R) ⊃ P ∨ Q ⊃ R :: Γ') by
        eauto using hilbert_derivation, hilbert_axiom_or_elim.
      assert (Γ' ≤h (Q ⊃ R) ⊃ P ∨ Q ⊃ R :: (P ⊃ R) ⊃ (Q ⊃ R) ⊃ P ∨ Q ⊃ R :: Γ') by
        (apply @hilbert_modus_ponens with (P := P ⊃ R); auto;
         unfold Γ'; prove_In).
      assert (Γ' ≤h P ∨ Q ⊃ R :: (Q ⊃ R) ⊃ P ∨ Q ⊃ R ::
        (P ⊃ R) ⊃ (Q ⊃ R) ⊃ P ∨ Q ⊃ R :: Γ') by
        (apply @hilbert_modus_ponens with (P := Q ⊃ R); auto;
        unfold Γ'; prove_In).
      assert (Γ' ≤h R :: P ∨ Q ⊃ R :: (Q ⊃ R) ⊃ P ∨ Q ⊃ R ::
        (P ⊃ R) ⊃ (Q ⊃ R) ⊃ P ∨ Q ⊃ R :: Γ') by
        (apply @hilbert_modus_ponens with (P := P ∨ Q); auto;
        unfold Γ'; prove_In).
      eauto using hilbert_derivation_proves.
+ apply (hilbert_cut IHND_proves1).
  apply @hilbert_cut with (P := Q).
  - refine (hilbert_context_extension _ _ _ _ _ eq_refl IHND_proves2).
    prove_subcontext.
  - set (Γ' := Q :: P :: Γ).
    assert (Γ' ≤h P ⊃ Q ⊃ P ∧ Q :: Γ') by
      eauto using hilbert_derivation, hilbert_axiom_and_intro.
    assert (Γ' ≤h Q ⊃ P ∧ Q :: P ⊃ Q ⊃ P ∧ Q :: Γ') by
      (apply @hilbert_modus_ponens with (P := P); auto;
      unfold Γ'; prove_In).
    assert (Γ' ≤h P ∧ Q :: Q ⊃ P ∧ Q :: P ⊃ Q ⊃ P ∧ Q :: Γ') by
      (apply @hilbert_modus_ponens with (P := Q); auto;
      unfold Γ'; prove_In).
    eauto using hilbert_derivation_proves.
+ apply (hilbert_cut IHND_proves1).
  apply @hilbert_cut with (P := P ⊃ Q ⊃ R).
  - do 2 apply hilbert_cond_proof.
    refine (hilbert_context_extension _ _ _ _ _ eq_refl IHND_proves2).
    prove_subcontext.
  - set (Γ' := P ⊃ Q ⊃ R :: P ∧ Q :: Γ).
    assert (Γ' ≤h (P ⊃ Q ⊃ R) ⊃ P ∧ Q ⊃ R :: Γ') by
      eauto using hilbert_derivation, hilbert_axiom_and_elim.
    assert (Γ' ≤h P ∧ Q ⊃ R :: (P ⊃ Q ⊃ R) ⊃ P ∧ Q ⊃ R :: Γ') by
      (apply @hilbert_modus_ponens with (P := P ⊃ Q ⊃ R); auto;
       unfold Γ'; prove_In).
    assert (Γ' ≤h R :: P ∧ Q ⊃ R :: (P ⊃ Q ⊃ R) ⊃ P ∧ Q ⊃ R :: Γ') by
      (apply @hilbert_modus_ponens with (P := P ∧ Q); auto;
      unfold Γ'; prove_In).
    eauto using hilbert_derivation_proves.
+ auto using hilbert_cond_proof.
+ apply (hilbert_cut IHND_proves1).
  apply @hilbert_cut with (P := P).
  - refine (hilbert_context_extension _ _ _ _ _ eq_refl IHND_proves2).
    prove_subcontext.
  - set (Γ' := P :: P ⊃ Q :: Γ). exists Γ'.
    apply @hilbert_modus_ponens with (P := P); (apply hilbert_empty ||
      (unfold Γ'; prove_In)).
+ auto using hilbert_assumption.
+ eauto using hilbert_cut.
Qed.

Theorem ND_hilbert_equiv : forall Γ P, Γ ⊢ P <-> Γ ⊢h P.
Proof.
split; [ apply hilbert_completeness | apply hilbert_soundness ].
Qed.

End Hilbert.

Notation "Γ ≤h Γ'" := (hilbert_derivation Γ Γ') (no associativity, at level 61).
Notation "Γ ⊢h P" := (hilbert_proves Γ P) (no associativity, at level 61).


(**
System F

examples/ssr/POPLmark.v をもとに作成した。

@suharahiromichi 2014_07_23
 *)

Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import AutosubstSsr Context.

(** **** Syntax *)

Inductive type : Type :=
| TyVar (x : var)
| Arr (A1 A2 : type)
| All (A2 : {bind type}).

Inductive term :=
| TeVar (x : var)
| Abs (A : type) (s : {bind term})
| App (s t : term)
| TAbs (s : {bind type in term})
| TApp (s : term) (A : type).

(** **** Substitutions *)

Instance Ids_type : Ids type. derive. Defined.
Instance Rename_type : Rename type. derive. Defined.
Instance Subst_type : Subst type. derive. Defined.
Instance SubstLemmas_type : SubstLemmas type. derive. Qed.
Instance HSubst_term : HSubst type term. derive. Defined.
Instance Ids_term : Ids term. derive. Defined.
Instance Rename_term : Rename term. derive. Defined.
Instance Subst_term : Subst term. derive. Defined.
Instance HSubstLemmas_term : HSubstLemmas type term. derive. Qed.
Instance SubstHSubstComp_type_term : SubstHSubstComp type term. derive. Qed.
Instance SubstLemmas_term : SubstLemmas term. derive. Qed.

(** **** Subtyping *)

Notation "Gamma `_ x" := (dget Gamma x).    (* not used *)
Notation "Gamma ``_ x" := (get Gamma x) (at level 3, x at level 2,
  left associativity, format "Gamma ``_ x").

(** **** Typing *)

Reserved Notation "'TY' Gamma |- A : B"
  (at level 68, A at level 99, no associativity,
   format "'TY'  Gamma  |-  A  :  B").
Inductive ty (Gamma : list type) : term -> type -> Prop :=
| ty_var x :
    x < size Gamma ->
    TY Gamma |- TeVar x : Gamma``_x
| ty_abs A B s :
    TY A::Gamma |- s : B ->
    TY Gamma |- Abs A s : Arr A B
| ty_app A B s t:
    TY Gamma |- s : Arr A B ->
    TY Gamma |- t : A ->
    TY Gamma |- App s t : B
| ty_tabs A s :
    TY Gamma..[ren (+1)] |- s : A ->
    TY Gamma |- TAbs s : All A
| ty_tapp A B s :
    TY Gamma |- s : All A ->
    TY Gamma |- TApp s B : A.[B/]
where "'TY' Gamma |- s : A" := (ty Gamma s A).

Definition value (s : term) : bool :=
  match s with Abs _ _ | TAbs _ => true | _ => false end.

Reserved Notation "'EV' s => t"
  (at level 68, s at level 80, no associativity, format "'EV'   s  =>  t").
Inductive eval : term -> term -> Prop :=
| E_AppAbs A s t : EV App (Abs A s) t => s.[t/]
| E_TAppTAbs s B : EV TApp (TAbs s) B => s.|[B/]
| E_AppFun s s' t :
     EV s => s' ->
     EV App s t => App s' t
| E_AppArg s s' v:
     EV s => s' -> value v ->
     EV App v s => App v s'
| E_TypeFun s s' A :
     EV s => s' ->
     EV TApp s A => TApp s' A
where "'EV' s => t" := (eval s t).

(** **** Preservation *)

Lemma ty_ren Gamma1 Gamma2 s A xi :
  (forall x, x < size Gamma1 -> xi x < size Gamma2) ->
  (forall x, x < size Gamma1 -> Gamma2``_(xi x) = Gamma1``_x) ->
  TY Gamma1 |- s : A ->
  TY Gamma2 |- s.[ren xi] : A.
Proof with eauto using ty.
  move=> h1 h2 ty.
  elim: ty Gamma2 xi h1 h2 => {Gamma1 s A} /=...
  - move=> Gamma1 x lt Gamma2 xi h1 h2.
    rewrite -h2 //.
    apply: ty_var...
  - move=> Gamma1 A B s _ ih Gamma2 xi h1 h2.
    asimpl.
    apply: ty_abs.
    by apply: ih => [[|x/h1]|[|x/h2]].
  - move=> Gamma1 A B s ih Gamma2 xi h1 h2.
    apply: ty_tabs.
    apply: ih => x.
    + by rewrite !size_map => /h1.
    + rewrite !size_map => lt.
      rewrite !get_map ?h2 //.
      exact: h1.
Qed.

Lemma ty_evar Gamma x A :
  A = Gamma``_x ->
  x < size Gamma ->
  TY Gamma |- TeVar x : A.
Proof.
  move ->.
  exact: ty_var.
Qed.

Lemma ty_etapp Gamma A C D s :
  D = A.[C/] ->
  TY Gamma |- s : All A ->
  TY Gamma |- TApp s C : D.
Proof.
  move->.
  exact: ty_tapp.
Qed.

Lemma ty_weak Gamma s A B :
  TY Gamma |- s : A ->
  TY B::Gamma |- s.[ren (+1)] : A.
Proof.
  exact: ty_ren.
Qed.

Lemma ty_hsubst Gamma s A sigma :
  TY Gamma |- s : A ->
  TY Gamma..[sigma] |- s.|[sigma] : A.[sigma].
Proof with eauto using ty.
  move=> ty.
  elim: ty sigma => {Gamma s A} /=...
  - move=> Gamma x lt sigma.
    apply: ty_evar.
    + by rewrite get_map.
    + by rewrite size_map.
  - move=> Gamma A s ty ih sigma.
    apply ty_tabs.
    specialize (ih (up sigma)).
    move: ih.
    asimpl.
    by apply.
  - move=> Gamma A B s ty ih sigma.
    asimpl.
    Check ty_etapp.
    eapply (ty_etapp _ (A.[up sigma]) _ _ (s.|[sigma])).
    + by autosubst.
    + by eapply ih.
Qed.

Lemma ty_tweak Gamma s A :
  TY Gamma |- s : A ->
  TY Gamma..[ren (+1)] |- s.|[ren (+1)] : A.[ren (+1)].
Proof.
  by apply: ty_hsubst.
Qed.

Lemma ty_subst Gamma1 Gamma2 s A sigma :
  (forall x, x < size Gamma1 -> TY Gamma2 |- sigma x : Gamma1``_x) ->
  TY Gamma1 |- s : A ->
  TY Gamma2 |- s.[sigma] : A.
Proof with eauto using ty.
  move=> h ty.
  elim: ty Gamma2 sigma h => {Gamma1 s A} /=...
  - move=> Gamma1 A B s _ ih Gamma2 sigma h /=.
    apply: ty_abs.
    move: ih.
    apply; move=> [/= | x /h /ty_weak].
    + move=> Hsz.
      by apply: ty_var.
    + autosubst.
  - move=> Gamma1 A B s ih Gamma2 sigma h.
    apply: ty_tabs.
    apply: ih.
    move=> x.
    rewrite size_map => lt.
    rewrite get_map //=.
    exact/ty_tweak/h.                       (* by apply ty_tweak; apply h *)
Qed.

(* ***** *)

Lemma ty_beta Gamma s t A B :
  TY Gamma |- t : A ->
  TY A::Gamma |- s : B ->
  TY Gamma |- s.[t/] : B.
Proof.
  move=> ty.
  apply: ty_subst => -[|n lt] //=.
  exact: ty_var.
Qed.

Lemma ty_betaT' Gamma s B C :
  TY Gamma..[ren (+1)]..[C/] |- s.|[C/] : B.[C/] ->
  TY Gamma |- s.|[C/] : B.[C/].
Proof.
  autosubst.
Qed.

Lemma ty_betaT Gamma s A B C :
  C = A ->
  TY Gamma..[ren (+1)] |- s : B ->
  TY Gamma |- s.|[C/] : B.[C/].
Proof.
  move=> subt ty.
  apply ty_betaT'.
  apply: ty_hsubst ty.
Qed.

(* ***** *)

Lemma eqn_abs : forall A A' s s', Abs A s = Abs A' s' -> A = A' /\ s = s'.
Proof.
  move=> A A' s s' H.
  inversion H.
  by [].
Qed.

Lemma eqn_arr : forall A A' B B', Arr A B = Arr A' B' -> A = A' /\ B = B'.
Proof.
  move=> A A' B B' H.
  by inv H.
Qed.

Lemma eqn_tabs : forall s s', TAbs s = TAbs s' -> s = s'.
Proof.
  move=> s s' H.
  inversion H.
  by [].
Qed.

Lemma eqn_all : forall s s', All s = All s' -> s = s'.
Proof.
  move=> s s' H.
  inversion H.
  by [].
Qed.

Lemma ty_inv_abs' Gamma A A' B T s :
  TY Gamma |- Abs A s : T ->
  T = Arr A' B ->
  TY A'::Gamma |- s : B.
Proof.
  move e: (Abs A s) => t ty.
  elim: ty A A' B s e; move => {Gamma t T} //.
 - move=> Gamma A B s h ih A' A'' B' s' eqn sub2.
   apply eqn_abs in eqn. destruct eqn as [eqn1 eqn2].
   apply eqn_arr in sub2. destruct sub2 as [sub21 sub22].
   subst.
   by apply h.
Qed.

Lemma ty_inv_abs Gamma A A' B s :
  TY Gamma |- Abs A s : Arr A' B ->
  TY A'::Gamma |- s : B.
Proof.
  move=> ty. apply: ty_inv_abs'.
  - by apply ty.
  - by [].
Qed.

(* ***** *)

Lemma ty_inv_tabs' Gamma B T s :
  TY Gamma |- TAbs s : T ->
  T = All B ->
  TY Gamma..[ren(+1)] |- s : B.
Proof.
  move e: (TAbs s) => t ty.
  elim: ty B s e => {Gamma t T} //.
  move=> Gamma A s ty ih A' s' e1 e2.
  apply eqn_tabs in e1.
  apply eqn_all in e2.
  subst.
  by apply: ty0.
Qed.

Lemma ty_inv_tabs Gamma B s :
  TY Gamma |- TAbs s : All B ->
  TY Gamma..[ren(+1)] |- s : B.
Proof.
  move=> ty.
  apply: (ty_inv_tabs' _ _ (All B)).
    - by apply ty.
    - by [].
Qed.

(* ***** *)

Theorem preservation Gamma s t A :
  TY Gamma |- s : A -> EV s => t -> TY Gamma |- t : A.
Proof with eauto using ty.
  move=> ty. elim: ty t => {Gamma s A}...
  - move=> Gamma x _ t ev. by inv ev.
  - move=> Gamma A B s _ i t ev. by inv ev.
  - move=> Gamma A B s t ty1 ih1 ty2 ih2 u ev.
    inversion ev.               (* inv ev *)
    subst.
    Check ty_inv_abs.
    (* move: ty1. move/ty_inv_abs. exact: ty_beta. *)
    apply ty_inv_abs in ty1. move: ty1. exact: ty_beta.
    eauto using ty.
    eauto using ty.
  - move=> Gamma A B s _ t ev. by inv ev.
  - move=> Gamma A B s ty ih t ev. inv ev.
      Check E_TAppTAbs.
      Check ty_tapp Gamma A B s0.
    + apply ty_inv_tabs in ty0. move: ty0.
    (* move: ty0 => /ty_inv_tabs H. *)
      apply: (ty_betaT _ s0 _ _)...
    + apply: ty_tapp...
Qed.

(** **** Progress *)

Definition is_abs s := if s is Abs _ _ then true else false.
Definition is_tabs s := if s is TAbs _ then true else false.

Lemma canonical_arr Gamma s A B :
  TY Gamma |- s : Arr A B -> value s -> is_abs s.
Proof.
  move=> ty.
  by inv ty.
Qed.

Lemma canonical_all Gamma s A :
  TY Gamma |- s : All A -> value s -> is_tabs s.
Proof.
  move=> ty.
  by inv ty.
Qed.

Lemma ev_progress' Gamma s A :
  TY Gamma |- s : A -> Gamma = [::] -> value s \/ exists t, EV s => t.
Proof with eauto using eval.
  elim=> {Gamma s A} /=; try solve [intuition].
  - move=> Gamma x lt eqn. by subst.
  - move=> Gamma A B s t ty1 ih1 _ ih2 eqn. right.
    case: (ih1 eqn) => {ih1} [vs|[s' h1]]...
    case: (ih2 eqn) => {ih2 eqn} [vt|[t' h2]]...
    case: s {ty1 vs} (canonical_arr _ _ _ _ ty1 vs) => //...
  - move=> Gamma A B s ty ih eqn. right.
    case: (ih eqn) => {ih eqn}[vs|[s' h]]...
    case: s {ty vs} (canonical_all _ _ _ ty vs) => //.
    move=> s H.
    exists s.|[B/].
    apply E_TAppTAbs.
Qed.

Theorem ev_progress s A:
  TY nil |- s : A -> value s \/ exists t,  EV s => t.
Proof.
  move=> ty.
  exact: ev_progress' ty _.
Qed.

(* Local Variables: *)
(* coq-load-path: (("." "Ssr")) *)
(* End: *)


(***************************************************************************
* Safety for STLC in Wright & Felleisen style - Definitions                *
* Arthur Charguéraud, July 2007                                            *
***************************************************************************)

Set Implicit Arguments.
Require Import LibLN.

(** Grammar of types. *)

Inductive typ : Set :=
  | typ_var   : var -> typ
  | typ_arrow : typ -> typ -> typ.

(** Grammar of pre-terms. *)

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : trm -> trm
  | trm_app  : trm -> trm -> trm.

(** Opening up abstractions *)

Fixpoint open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => If k = i then u else (trm_bvar i)
  | trm_fvar x    => trm_fvar x
  | trm_abs t1    => trm_abs (open_rec (S k) u t1)
  | trm_app t1 t2 => trm_app (open_rec k u t1) (open_rec k u t2)
  end.

Definition open t u := open_rec 0 u t.

Notation "{ k ~> u } t" := (open_rec k u t) (at level 67).
Notation "t ^^ u" := (open t u) (at level 67).
Notation "t ^ x" := (open t (trm_fvar x)).

(** Terms are locally-closed pre-terms *)

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_abs : forall L t1,
      (forall x, x \notin L -> term (t1 ^ x)) ->
      term (trm_abs t1)
  | term_app : forall t1 t2,
      term t1 ->
      term t2 ->
      term (trm_app t1 t2).

(** Environment is an associative list mapping variables to types. *)

Definition env := LibEnv.env typ.

(** Typing relation *)

Reserved Notation "E |= t ~: T" (at level 69).

Inductive typing : env -> trm -> typ -> Prop :=
  | typing_var : forall E x T,
      ok E ->
      binds x T E ->
      E |= (trm_fvar x) ~: T
  | typing_abs : forall L E U T t1,
      (forall x, x \notin L ->
        (E & x ~ U) |= t1 ^ x ~: T) ->
      E |= (trm_abs t1) ~: (typ_arrow U T)
  | typing_app : forall S T E t1 t2,
      E |= t1 ~: (typ_arrow S T) ->
      E |= t2 ~: S ->
      E |= (trm_app t1 t2) ~: T

where "E |= t ~: T" := (typing E t T).

(** Definition of values (only abstractions are values) *)

Inductive value : trm -> Prop :=
  | value_abs : forall t1,
      term (trm_abs t1) -> value (trm_abs t1).

(** Reduction contexts *)

Inductive ctx : Set :=
  | ctx_hole : ctx
  | ctx_app_1 : forall (C : ctx) t2,
      term t2 -> ctx
  | ctx_app_2 : forall t1 (C : ctx),
      value t1 -> ctx.

Fixpoint ctx_of (C : ctx) (t : trm) {struct C} : trm :=
  match C with
  | ctx_hole         => t
  | ctx_app_1 C t2 _ => trm_app (ctx_of C t) t2
  | ctx_app_2 t1 C _ => trm_app t1 (ctx_of C t)
  end.

(** Reduction relation - one step in call-by-value *)

Inductive red : trm -> trm -> Prop :=
  | red_beta : forall t1 t2,
      term (trm_abs t1) ->
      value t2 ->
      red (trm_app (trm_abs t1) t2) (t1 ^^ t2)
  | red_ctx : forall C t t',
      red t t' ->
      red (ctx_of C t) (ctx_of C t').

Notation "t --> t'" := (red t t') (at level 68).

(** Goal is to prove preservation and progress *)

Definition preservation := forall E t t' T,
  E |= t ~: T ->
  t --> t' ->
  E |= t' ~: T.

Definition progress := forall t T,
  empty |= t ~: T ->
     value t
  \/ exists t', t --> t'.


(* 1- Naive *)
Require Import ZArith.
Require Import Toy.Naive.lib.
Require Import Coq.Lists.List.
Require Import Toy.Naive.usl.implementation.
Import T.
Open Scope Z.

Inductive aexp : Type :=
  | ANum (n : Z)
  | AId (X : var)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp)
  | ADiv (a1 a2 : aexp)
  | ADeref (a : aexp).

Module Denote_Aexp.

Definition add_sem (da1 da2 : state -> option Z) : state -> option Z :=
  fun st =>
    match da1 st, da2 st with
      | Some v1, Some v2 => Some (v1 + v2)
      | _, _ => None
    end.

Definition sub_sem (da1 da2 : state -> option Z) : state -> option Z :=
  fun st =>
    match da1 st, da2 st with
      | Some v1, Some v2 => Some (v1 - v2)
      | _, _ => None
    end.

Definition mul_sem (da1 da2 : state -> option Z) : state -> option Z :=
  fun st =>
    match da1 st, da2 st with
      | Some v1, Some v2 => Some (v1 * v2)
      | _, _ => None
    end.

Definition div_sem (da1 da2 : state -> option Z) : state -> option Z :=
  fun st =>
    match da1 st, da2 st with
      | Some v1, Some v2 =>
          if Z.eq_dec v2 0 then None else Some (v1 / v2)
      | _, _ => None
    end.

Definition deref_sem (da : state -> option Z) : state -> option Z :=
  fun st =>
    match da st with
      | Some v => match snd st v with
        | Some v' => Some v'
        | _ => None
      end
      | _ => None
    end.

Fixpoint aeval (a : aexp) : state -> option Z :=
  match a with
    | ANum n => fun _ =>  Some n
    | AId X => fun st => Some (fst st X)
    | APlus a1 a2 => add_sem (aeval a1) (aeval a2)
    | AMinus a1 a2 => sub_sem (aeval a1) (aeval a2)
    | AMult a1 a2 => mul_sem (aeval a1) (aeval a2)
    | ADiv a1 a2 => div_sem (aeval a1) (aeval a2)
    | ADeref a => deref_sem (aeval a)
  end.

End Denote_Aexp.

Inductive bexp : Type :=
  | BTrue
  | BFalse
  | BEq (a1 a2 : aexp)
  | BLe (a1 a2 : aexp)
  | BNot (b : bexp)
  | BAnd (b1 b2 : bexp).

Record bexp_denote : Type := {
  true_set : state -> Prop;
  false_set : state -> Prop;
  error_set : state -> Prop; }.

Definition opt_test (R : Z -> Z -> Prop) (X Y : state -> option Z) : bexp_denote :=
{|
  true_set := fun st =>
    match X st, Y st with
      | Some n1, Some n2 => R n1 n2
      | _, _ => False
    end;
  false_set := fun st =>
    match X st, Y st with
      | Some n1, Some n2 => ~ R n1 n2
      | _, _ => False
    end;
  error_set := fun st =>
    match X st, Y st with
      | Some n1, Some n2 => False
      | _, _ => True
    end; |}.

Module Denote_Bexp.
Import Denote_Aexp.

Fixpoint beval (b : bexp) : bexp_denote :=
  match b with
    | BTrue =>
        {| true_set := Sets.full;
           false_set := Sets.empty;
           error_set := Sets.empty; |}
    | BFalse =>
        {| true_set := Sets.empty;
           false_set := Sets.full;
           error_set := Sets.empty; |}
    | BEq a1 a2 =>
        opt_test Z.eq (aeval a1) (aeval a2)
    | BLe a1 a2 =>
        opt_test Z.le (aeval a1) (aeval a2)
    | BNot b =>
        {| true_set := false_set (beval b);
           false_set := true_set (beval b);
           error_set := error_set (beval b); |}
    | BAnd b1 b2 =>
        {| true_set := Sets.intersect (true_set (beval b1)) (true_set (beval b2));
           false_set := Sets.union (false_set (beval b1))
                                   (Sets.intersect (true_set (beval b1))
                                                   (false_set (beval b2)));
           error_set := Sets.union (error_set (beval b1))
                                   (Sets.intersect (true_set (beval b1))
                                                   (error_set (beval b2))); |}
       end.

End Denote_Bexp.

Inductive com : Type :=
  | CSkip
  | CBreak
  | CCont
  | CAss_load (X : var) (a : aexp)
  | CAss_store (a1 : aexp) (a2 : aexp)
  | CSeq (c1 c2 : com)
  | CIf (b : bexp) (c1 c2 : com)
  | CFor (c1 c2 : com).

Record com_denote : Type := {
  com_normal : state -> state -> Prop;
  com_break : state -> state -> Prop;
  com_cont : state -> state -> Prop;
  com_error : state -> Prop }.

Module Denote_Com.
Import Denote_Aexp.
Import Denote_Bexp.

Definition skip_sem : com_denote := {|
  com_normal := BinRel.id;
  com_break := BinRel.empty;
  com_cont := BinRel.empty;
  com_error := Sets.empty |}.

Definition break_sem : com_denote := {|
  com_normal := BinRel.empty;
  com_break := BinRel.id;
  com_cont := BinRel.empty;
  com_error := Sets.empty |}.

Definition cont_sem : com_denote := {|
  com_normal := BinRel.empty;
  com_break := BinRel.empty;
  com_cont := BinRel.id;
  com_error := Sets.empty |}.

Definition load_sem (X : var) (DA : state -> option Z) : com_denote := {|
  com_normal := fun st1 st2 => match DA st1 with
    | Some n => (fst st2 X = n) /\ (forall Y, Y <> X -> fst st2 Y = fst st1 Y) /\ (snd st1 = snd st2)
    | None => False
  end;
  com_break := BinRel.empty;
  com_cont := BinRel.empty;
  com_error := fun st => (DA st) = None; |}.

Definition store_sem (DAL DAR : state -> option Z) : com_denote := {|
  com_normal := fun st1 st2 => match DAL st1, DAR st1 with
    | Some p, Some v => (snd st1 p <> None) /\ (snd st2 p = Some v) /\
        (forall p', p <> p' -> snd st2 p' = snd st1 p') /\ (fst st1 = fst st2)
    | _, _ => False
  end;
  com_break := BinRel.empty;
  com_cont := BinRel.empty;
  com_error := fun st => match DAL st, DAR st with
    | Some p, Some v => snd st p = None
    | _, _ => True
  end; |}.

Definition seq_sem (DC1 DC2 : com_denote) : com_denote := {|
  com_normal := BinRel.concat (com_normal DC1) (com_normal DC2);
    (* exists st3, com_normal DC1 st1 st3 /\ com_normal DC2 st3 st2; *)
  com_break := BinRel.union (com_break DC1) (BinRel.concat (com_normal DC1) (com_break DC2));
    (* (com_break DC1 st1 st2) \/
    (exists st3, com_normal DC1 st1 st3 /\ com_break DC2 st3 st2); *)
  com_cont := BinRel.union (com_cont DC1) (BinRel.concat (com_normal DC1) (com_cont DC2));
    (* (com_cont DC1 st1 st2) \/
    (exists st3, com_normal DC1 st1 st3 /\ com_cont DC2 st3 st2); *)
  com_error := Sets.union (com_error DC1) (BinRel.dia (com_normal DC1) (com_error DC2)) |}.
    (* (com_error DC1 st) \/ (exists st', com_normal DC1 st st' /\ com_error DC2 st'); |}. *)

Definition if_sem (DB : bexp_denote) (DC1 DC2 : com_denote) : com_denote := {|
  com_normal := BinRel.union (BinRel.concat (BinRel.testrel (true_set DB)) (com_normal DC1))
    (BinRel.concat (BinRel.testrel (false_set DB)) (com_normal DC2));
  com_break := BinRel.union (BinRel.concat (BinRel.testrel (true_set DB)) (com_break DC1))
    (BinRel.concat (BinRel.testrel (false_set DB)) (com_break DC2));
  com_cont := BinRel.union (BinRel.concat (BinRel.testrel (true_set DB)) (com_cont DC1))
    (BinRel.concat (BinRel.testrel (false_set DB)) (com_cont DC2));
  com_error := Sets.union (error_set DB)
    (Sets.union (Sets.intersect (true_set DB) (com_error DC1)) (Sets.intersect (false_set DB) (com_error DC2)))|}.

(* Definition if_sem (DB : bexp_denote) (DC1 DC2 : com_denote) : com_denote := {|
  com_normal := fun st1 st2 =>
    (true_set DB st1 /\ com_normal DC1 st1 st2) \/
    (false_set DB st1 /\ com_normal DC2 st1 st2);
  com_break := fun st1 st2 =>
    (true_set DB st1 /\ com_break DC1 st1 st2) \/
    (false_set DB st1 /\ com_break DC2 st1 st2);
  com_cont := fun st1 st2 =>
    (true_set DB st1 /\ com_cont DC1 st1 st2) \/
    (false_set DB st1 /\ com_cont DC2 st1 st2);
  com_error := fun st =>
    (error_set DB st) \/
    (true_set DB st /\ com_error DC1 st) \/
    (false_set DB st /\ com_error DC2 st); |}. *)

Fixpoint iter_loop_body (DC1 DC2 : com_denote) (n : nat) : com_denote := match n with
  | O => {|
      com_normal := BinRel.union (com_break DC1) (BinRel.concat (com_normal DC1) (com_break DC2));
      com_break := BinRel.empty;
      com_cont := BinRel.empty;
      com_error := Sets.union (com_error DC1) (BinRel.dia (com_normal DC1) (com_error DC2)) |}
  | S n' => {|
      com_normal := BinRel.concat
        (BinRel.union (BinRel.concat (com_normal DC1) (com_normal DC2))
          (BinRel.concat (com_cont DC1) (com_normal DC2)))
        (com_normal (iter_loop_body DC1 DC2 n'));
      com_break := BinRel.empty;
      com_cont := BinRel.empty;
      com_error := BinRel.dia
        (BinRel.union (BinRel.concat (com_normal DC1) (com_normal DC2))
          (BinRel.concat (com_cont DC1) (com_normal DC2)))
        (com_error (iter_loop_body DC1 DC2 n')) |}
end.

Definition for_sem (DC1 DC2 : com_denote) : com_denote := {|
  com_normal := BinRel.omega_union (fun n => com_normal (iter_loop_body DC1 DC2 n));
  com_break := BinRel.empty;
  com_cont := BinRel.empty;
  com_error := Sets.omega_union (fun n => com_error (iter_loop_body DC1 DC2 n)) |}.

(* Fixpoint iter_loop_body (DC1 DC2 : com_denote) (n : nat) : com_denote :=
  match n with
  | O => {|
      com_normal := fun st1 st2 =>
        (com_break DC1 st1 st2) \/
        (exists st3, com_normal DC1 st1 st3 /\ com_break DC2 st3 st2);
      com_break := fun st1 st2 => False;
      com_cont := fun st1 st2 => False;
      com_error := fun st =>
        (com_error DC1 st) \/
        (exists st', com_normal DC1 st st' /\ com_error DC2 st') |}
  | S n' => {|
      com_normal := fun st1 st2 => exists st3,
        ((exists st4, com_normal DC1 st1 st4 /\ com_normal DC2 st4 st3) \/
        (exists st4, com_cont DC1 st1 st4 /\ com_normal DC2 st4 st3)) /\
        (com_normal (iter_loop_body DC1 DC2 n') st3 st2);
      com_break := fun st1 st2 => False;
      com_cont := fun st1 st2 => False;
      com_error := fun st => exists st',
        ((exists st2, com_normal DC1 st st2 /\ com_normal DC2 st2 st') \/
        (exists st2, com_cont DC1 st st2 /\ com_normal DC2 st2 st')) /\
        (com_error (iter_loop_body DC1 DC2 n') st') |}
  end.

Definition for_sem (DC1 DC2 : com_denote) : com_denote := {|
  com_normal := fun st1 st2 =>
    exists n, com_normal (iter_loop_body DC1 DC2 n) st1 st2;
  com_break := fun st1 st2 => False;
  com_cont := fun st1 st2 => False;
  com_error := fun st =>
    exists n, com_error (iter_loop_body DC1 DC2 n) st |}. *)

Fixpoint ceval (c : com) : com_denote :=
  match c with
  | CSkip => skip_sem
  | CBreak => break_sem
  | CCont => cont_sem
  | CAss_load X a => load_sem X (aeval a)
  | CAss_store a1 a2 => store_sem (aeval a1) (aeval a2)
  | CSeq c1 c2 => seq_sem (ceval c1) (ceval c2)
  | CIf b c1 c2 => if_sem (beval b) (ceval c1) (ceval c2)
  | CFor c1 c2 => for_sem (ceval c1) (ceval c2)
  end.

End Denote_Com.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(* F. Besson: to evaluate polynomials, the original code is using a list.
   For big polynomials, this is inefficient -- linear access.
   I have modified the code to use binary trees -- logarithmic access.  *)

Set Implicit Arguments.
Require Import Setoid Morphisms Env BinPos BinNat BinInt.
Require Export Ring_theory.

Local Open Scope positive_scope.
Import RingSyntax.

Section MakeRingPol.

 (* Ring elements *)
 Variable R:Type.
 Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R).
 Variable req : R -> R -> Prop.

 (* Ring properties *)
 Variable Rsth : Equivalence req.
 Variable Reqe : ring_eq_ext radd rmul ropp req.
 Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req.

 (* Coefficients *)
 Variable C: Type.
 Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C).
 Variable ceqb : C->C->bool.
 Variable phi : C -> R.
 Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req
                                cO cI cadd cmul csub copp ceqb phi.

 (* Power coefficients *)
 Variable Cpow : Type.
 Variable Cp_phi : N -> Cpow.
 Variable rpow : R -> Cpow -> R.
 Variable pow_th : power_theory rI rmul req Cp_phi rpow.

 (* R notations *)
 Notation "0" := rO. Notation "1" := rI.
 Infix "+" := radd. Infix "*" := rmul.
 Infix "-" := rsub. Notation "- x" := (ropp x).
 Infix "==" := req.
 Infix "^" := (pow_pos rmul).

 (* C notations *)
 Infix "+!" := cadd. Infix "*!" := cmul.
 Infix "-! " := csub. Notation "-! x" := (copp x).
 Infix "?=!" := ceqb. Notation "[ x ]" := (phi x).

 (* Useful tactics *)
 Add Morphism radd with signature (req ==> req ==> req) as radd_ext.
 Proof. exact (Radd_ext Reqe). Qed.

 Add Morphism rmul with signature (req ==> req ==> req) as rmul_ext.
 Proof. exact (Rmul_ext Reqe). Qed.

 Add Morphism ropp with signature (req ==> req) as ropp_ext.
 Proof. exact (Ropp_ext Reqe). Qed.

 Add Morphism rsub with signature (req ==> req ==> req) as rsub_ext.
 Proof. exact (ARsub_ext Rsth Reqe ARth). Qed.

 Ltac rsimpl := gen_srewrite Rsth Reqe ARth.

 Ltac add_push := gen_add_push radd Rsth Reqe ARth.
 Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth.

 Ltac add_permut_rec t :=
   match t with
   | ?x + ?y => add_permut_rec y || add_permut_rec x
   | _ => add_push t; apply (Radd_ext Reqe); [|reflexivity]
   end.

 Ltac add_permut :=
  repeat (reflexivity ||
    match goal with |- ?t == _ => add_permut_rec t end).

 Ltac mul_permut_rec t :=
   match t with
   | ?x * ?y => mul_permut_rec y || mul_permut_rec x
   | _ => mul_push t; apply (Rmul_ext Reqe); [|reflexivity]
   end.

 Ltac mul_permut :=
  repeat (reflexivity ||
    match goal with |- ?t == _ => mul_permut_rec t end).

 (* Definition of multivariable polynomials with coefficients in C :
    Type [Pol] represents [X1 ... Xn].
    The representation is Horner's where a [n] variable polynomial
    (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients
    are polynomials with [n-1] variables (C[X2..Xn]).
    There are several optimisations to make the repr compacter:
    - [Pc c] is the constant polynomial of value c
       == c*X1^0*..*Xn^0
    - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables.
        variable indices are shifted of j in Q.
       == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn}
    - [PX P i Q] is an optimised Horner form of P*X^i + Q
        with P not the null polynomial
       == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn}

    In addition:
    - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden
      since they can be represented by the simpler form (PX P (i+j) Q)
    - (Pinj i (Pinj j P)) is (Pinj (i+j) P)
    - (Pinj i (Pc c)) is (Pc c)
 *)

 Inductive Pol : Type :=
  | Pc : C -> Pol
  | Pinj : positive -> Pol -> Pol
  | PX : Pol -> positive -> Pol -> Pol.

 Definition P0 := Pc cO.
 Definition P1 := Pc cI.

 Fixpoint Peq (P P' : Pol) {struct P'} : bool :=
  match P, P' with
  | Pc c, Pc c' => c ?=! c'
  | Pinj j Q, Pinj j' Q' =>
    match j ?= j' with
    | Eq => Peq Q Q'
    | _ => false
    end
  | PX P i Q, PX P' i' Q' =>
    match i ?= i' with
    | Eq => if Peq P P' then Peq Q Q' else false
    | _ => false
    end
  | _, _ => false
  end.

 Infix "?==" := Peq.

 Definition mkPinj j P :=
  match P with
  | Pc _ => P
  | Pinj j' Q => Pinj (j + j') Q
  | _ => Pinj j P
  end.

 Definition mkPinj_pred j P:=
  match j with
  | xH => P
  | xO j => Pinj (Pos.pred_double j) P
  | xI j => Pinj (xO j) P
  end.

 Definition mkPX P i Q :=
  match P with
  | Pc c => if c ?=! cO then mkPinj xH Q else PX P i Q
  | Pinj _ _ => PX P i Q
  | PX P' i' Q' => if Q' ?== P0 then PX P' (i' + i) Q else PX P i Q
  end.

 Definition mkXi i := PX P1 i P0.

 Definition mkX := mkXi 1.

 (** Opposite of addition *)

 Fixpoint Popp (P:Pol) : Pol :=
  match P with
  | Pc c => Pc (-! c)
  | Pinj j Q => Pinj j (Popp Q)
  | PX P i Q => PX (Popp P) i (Popp Q)
  end.

 Notation "-- P" := (Popp P).

 (** Addition et subtraction *)

 Fixpoint PaddC (P:Pol) (c:C) : Pol :=
  match P with
  | Pc c1 => Pc (c1 +! c)
  | Pinj j Q => Pinj j (PaddC Q c)
  | PX P i Q => PX P i (PaddC Q c)
  end.

 Fixpoint PsubC (P:Pol) (c:C) : Pol :=
  match P with
  | Pc c1 => Pc (c1 -! c)
  | Pinj j Q => Pinj j (PsubC Q c)
  | PX P i Q => PX P i (PsubC Q c)
  end.

 Section PopI.

  Variable Pop : Pol -> Pol -> Pol.
  Variable Q : Pol.

  Fixpoint PaddI (j:positive) (P:Pol) : Pol :=
   match P with
   | Pc c => mkPinj j (PaddC Q c)
   | Pinj j' Q' =>
     match Z.pos_sub j' j with
     | Zpos k =>  mkPinj j (Pop (Pinj k Q') Q)
     | Z0 => mkPinj j (Pop Q' Q)
     | Zneg k => mkPinj j' (PaddI k Q')
     end
   | PX P i Q' =>
     match j with
     | xH => PX P i (Pop Q' Q)
     | xO j => PX P i (PaddI (Pos.pred_double j) Q')
     | xI j => PX P i (PaddI (xO j) Q')
     end
   end.

  Fixpoint PsubI (j:positive) (P:Pol) : Pol :=
   match P with
   | Pc c => mkPinj j (PaddC (--Q) c)
   | Pinj j' Q' =>
     match Z.pos_sub j' j with
     | Zpos k =>  mkPinj j (Pop (Pinj k Q') Q)
     | Z0 => mkPinj j (Pop Q' Q)
     | Zneg k => mkPinj j' (PsubI k Q')
     end
   | PX P i Q' =>
     match j with
     | xH => PX P i (Pop Q' Q)
     | xO j => PX P i (PsubI (Pos.pred_double j) Q')
     | xI j => PX P i (PsubI (xO j) Q')
     end
   end.

 Variable P' : Pol.

 Fixpoint PaddX (i':positive) (P:Pol) : Pol :=
  match P with
  | Pc c => PX P' i' P
  | Pinj j Q' =>
    match j with
    | xH =>  PX P' i' Q'
    | xO j => PX P' i' (Pinj (Pos.pred_double j) Q')
    | xI j => PX P' i' (Pinj (xO j) Q')
    end
  | PX P i Q' =>
    match Z.pos_sub i i' with
    | Zpos k => mkPX (Pop (PX P k P0) P') i' Q'
    | Z0 => mkPX (Pop P P') i Q'
    | Zneg k => mkPX (PaddX k P) i Q'
    end
  end.

 Fixpoint PsubX (i':positive) (P:Pol) : Pol :=
  match P with
  | Pc c => PX (--P') i' P
  | Pinj j Q' =>
    match j with
    | xH =>  PX (--P') i' Q'
    | xO j => PX (--P') i' (Pinj (Pos.pred_double j) Q')
    | xI j => PX (--P') i' (Pinj (xO j) Q')
    end
  | PX P i Q' =>
    match Z.pos_sub i i' with
    | Zpos k => mkPX (Pop (PX P k P0) P') i' Q'
    | Z0 => mkPX (Pop P P') i Q'
    | Zneg k => mkPX (PsubX k P) i Q'
    end
  end.

 End PopI.

 Fixpoint Padd (P P': Pol) {struct P'} : Pol :=
  match P' with
  | Pc c' => PaddC P c'
  | Pinj j' Q' => PaddI Padd Q' j' P
  | PX P' i' Q' =>
    match P with
    | Pc c => PX P' i' (PaddC Q' c)
    | Pinj j Q =>
      match j with
      | xH => PX P' i' (Padd Q Q')
      | xO j => PX P' i' (Padd (Pinj (Pos.pred_double j) Q) Q')
      | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q')
      end
    | PX P i Q =>
      match Z.pos_sub i i' with
      | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q')
      | Z0 => mkPX (Padd P P') i (Padd Q Q')
      | Zneg k => mkPX (PaddX Padd P' k P) i (Padd Q Q')
      end
    end
  end.
 Infix "++" := Padd.

 Fixpoint Psub (P P': Pol) {struct P'} : Pol :=
  match P' with
  | Pc c' => PsubC P c'
  | Pinj j' Q' => PsubI Psub Q' j' P
  | PX P' i' Q' =>
    match P with
    | Pc c => PX (--P') i' (*(--(PsubC Q' c))*) (PaddC (--Q') c)
    | Pinj j Q =>
      match j with
      | xH => PX (--P') i' (Psub Q Q')
      | xO j => PX (--P') i' (Psub (Pinj (Pos.pred_double j) Q) Q')
      | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q')
      end
    | PX P i Q =>
      match Z.pos_sub i i' with
      | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q')
      | Z0 => mkPX (Psub P P') i (Psub Q Q')
      | Zneg k => mkPX (PsubX Psub P' k P) i (Psub Q Q')
      end
    end
  end.
 Infix "--" := Psub.

 (** Multiplication *)

 Fixpoint PmulC_aux (P:Pol) (c:C) : Pol :=
  match P with
  | Pc c' => Pc (c' *! c)
  | Pinj j Q => mkPinj j (PmulC_aux Q c)
  | PX P i Q => mkPX (PmulC_aux P c) i (PmulC_aux Q c)
  end.

 Definition PmulC P c :=
  if c ?=! cO then P0 else
  if c ?=! cI then P else PmulC_aux P c.

 Section PmulI.
  Variable Pmul : Pol -> Pol -> Pol.
  Variable Q : Pol.
  Fixpoint PmulI (j:positive) (P:Pol) : Pol :=
   match P with
   | Pc c => mkPinj j (PmulC Q c)
   | Pinj j' Q' =>
     match Z.pos_sub j' j with
     | Zpos k => mkPinj j (Pmul (Pinj k Q') Q)
     | Z0 => mkPinj j (Pmul Q' Q)
     | Zneg k => mkPinj j' (PmulI k Q')
     end
   | PX P' i' Q' =>
     match j with
     | xH => mkPX (PmulI xH P') i' (Pmul Q' Q)
     | xO j' => mkPX (PmulI j P') i' (PmulI (Pos.pred_double j') Q')
     | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q')
     end
   end.

 End PmulI.

 Fixpoint Pmul (P P'' : Pol) {struct P''} : Pol :=
   match P'' with
   | Pc c => PmulC P c
   | Pinj j' Q' => PmulI Pmul Q' j' P
   | PX P' i' Q' =>
     match P with
     | Pc c => PmulC P'' c
     | Pinj j Q =>
       let QQ' :=
         match j with
         | xH => Pmul Q Q'
         | xO j => Pmul (Pinj (Pos.pred_double j) Q) Q'
         | xI j => Pmul (Pinj (xO j) Q) Q'
         end in
       mkPX (Pmul P P') i' QQ'
     | PX P i Q=>
       let QQ' := Pmul Q Q' in
       let PQ' := PmulI Pmul Q' xH P in
       let QP' := Pmul (mkPinj xH Q) P' in
       let PP' := Pmul P P' in
       (mkPX (mkPX PP' i P0 ++ QP') i' P0) ++ mkPX PQ' i QQ'
     end
  end.

 Infix "**" := Pmul.

 Fixpoint Psquare (P:Pol) : Pol :=
   match P with
   | Pc c => Pc (c *! c)
   | Pinj j Q => Pinj j (Psquare Q)
   | PX P i Q =>
     let twoPQ := Pmul P (mkPinj xH (PmulC Q (cI +! cI))) in
     let Q2 := Psquare Q in
     let P2 := Psquare P in
     mkPX (mkPX P2 i P0 ++ twoPQ) i Q2
   end.

 (** Monomial **)

 (** A monomial is X1^k1...Xi^ki. Its representation
     is a simplified version of the polynomial representation:

     - [mon0] correspond to the polynom [P1].
     - [(zmon j M)] corresponds to [(Pinj j ...)],
       i.e. skip j variable indices.
     - [(vmon i M)] is X^i*M with X the current variable,
       its corresponds to (PX P1 i ...)]
 *)

  Inductive Mon: Set :=
  | mon0: Mon
  | zmon: positive -> Mon -> Mon
  | vmon: positive -> Mon -> Mon.

 Definition mkZmon j M :=
   match M with mon0 => mon0 | _ => zmon j M end.

 Definition zmon_pred j M :=
   match j with xH => M | _ => mkZmon (Pos.pred j) M end.

 Definition mkVmon i M :=
   match M with
   | mon0 => vmon i mon0
   | zmon j m => vmon i (zmon_pred j m)
   | vmon i' m => vmon (i+i') m
   end.

 Fixpoint MFactor (P: Pol) (M: Mon) : Pol * Pol :=
   match P, M with
        _, mon0 => (Pc cO, P)
   | Pc _, _    => (P, Pc cO)
   | Pinj j1 P1, zmon j2 M1 =>
      match (j1 ?= j2) with
        Eq => let (R,S) := MFactor P1 M1 in
                 (mkPinj j1 R, mkPinj j1 S)
      | Lt => let (R,S) := MFactor P1 (zmon (j2 - j1) M1) in
                 (mkPinj j1 R, mkPinj j1 S)
      | Gt => (P, Pc cO)
      end
  | Pinj _ _, vmon _ _ => (P, Pc cO)
  | PX P1 i Q1, zmon j M1 =>
             let M2 := zmon_pred j M1 in
             let (R1, S1) := MFactor P1 M in
             let (R2, S2) := MFactor Q1 M2 in
               (mkPX R1 i R2, mkPX S1 i S2)
  | PX P1 i Q1, vmon j M1 =>
      match (i ?= j) with
        Eq => let (R1,S1) := MFactor P1 (mkZmon xH M1) in
                 (mkPX R1 i Q1, S1)
      | Lt => let (R1,S1) := MFactor P1 (vmon (j - i) M1) in
                 (mkPX R1 i Q1, S1)
      | Gt => let (R1,S1) := MFactor P1 (mkZmon xH M1) in
                 (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO))
      end
   end.

  Definition POneSubst (P1: Pol) (M1: Mon) (P2: Pol): option Pol :=
    let (Q1,R1) := MFactor P1 M1 in
    match R1 with
     (Pc c) => if c ?=! cO then None
               else Some (Padd Q1 (Pmul P2 R1))
    | _ => Some (Padd Q1 (Pmul P2 R1))
    end.

  Fixpoint PNSubst1 (P1: Pol) (M1: Mon) (P2: Pol) (n: nat) : Pol :=
    match POneSubst P1 M1 P2 with
     Some P3 => match n with S n1 => PNSubst1 P3 M1 P2 n1 | _ => P3 end
    | _ => P1
    end.

  Definition PNSubst (P1: Pol) (M1: Mon) (P2: Pol) (n: nat): option Pol :=
    match POneSubst P1 M1 P2 with
     Some P3 => match n with S n1 => Some (PNSubst1 P3 M1 P2 n1) | _ => None end
    | _ => None
    end.

  Fixpoint PSubstL1 (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) : Pol :=
    match LM1 with
     cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n
    | _ => P1
    end.

  Fixpoint PSubstL (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) : option Pol :=
    match LM1 with
     cons (M1,P2) LM2 =>
      match PNSubst P1 M1 P2 n with
        Some P3 => Some (PSubstL1 P3 LM2 n)
     |  None => PSubstL P1 LM2 n
     end
    | _ => None
    end.

  Fixpoint PNSubstL (P1: Pol) (LM1: list (Mon * Pol)) (m n: nat) : Pol :=
    match PSubstL P1 LM1 n with
     Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end
    | _ => P1
    end.

 (** Evaluation of a polynomial towards R *)

 Fixpoint Pphi(l:Env R) (P:Pol) : R :=
  match P with
  | Pc c => [c]
  | Pinj j Q => Pphi (jump j l) Q
  | PX P i Q => Pphi l P * (hd l) ^ i + Pphi (tail l) Q
  end.

 Reserved Notation "P @ l " (at level 10, no associativity).
 Notation "P @ l " := (Pphi l P).

 (** Evaluation of a monomial towards R *)

 Fixpoint Mphi(l:Env R) (M: Mon) : R :=
  match M with
  | mon0 => rI
  | zmon j M1 => Mphi (jump j l) M1
  | vmon i M1 => Mphi (tail l) M1 * (hd l) ^ i
  end.

 Notation "M @@ l" := (Mphi l M) (at level 10, no associativity).

 (** Proofs *)

 Ltac destr_pos_sub :=
  match goal with |- context [Z.pos_sub ?x ?y] =>
   generalize (Z.pos_sub_discr x y); destruct (Z.pos_sub x y)
  end.

 Lemma Peq_ok P P' : (P ?== P') = true -> forall l, P@l == P'@ l.
 Proof.
  revert P';induction P;destruct P';simpl; intros H l; try easy.
  - now apply (morph_eq CRmorph).
  - destruct (Pos.compare_spec p p0); [ subst | easy | easy ].
    now rewrite IHP.
  - specialize (IHP1 P'1); specialize (IHP2 P'2).
    destruct (Pos.compare_spec p p0); [ subst | easy | easy ].
    destruct (P2 ?== P'1); [|easy].
    rewrite H in *.
    now rewrite IHP1, IHP2.
 Qed.

 Lemma Peq_spec P P' :
   BoolSpec (forall l, P@l == P'@l) True (P ?== P').
 Proof.
  generalize (Peq_ok P P'). destruct (P ?== P'); auto.
 Qed.

 Lemma Pphi0 l : P0@l == 0.
 Proof.
  simpl;apply (morph0 CRmorph).
 Qed.

 Lemma Pphi1 l : P1@l == 1.
 Proof.
  simpl;apply (morph1 CRmorph).
 Qed.

Lemma env_morph p e1 e2 :
  (forall x, e1 x = e2 x) -> p @ e1 = p @ e2.
Proof.
  revert e1 e2. induction p ; simpl.
  - reflexivity.
  - intros e1 e2 EQ. apply IHp. intros. apply EQ.
  - intros e1 e2 EQ. f_equal; [f_equal|].
    + now apply IHp1.
    + f_equal. apply EQ.
    + apply IHp2. intros; apply EQ.
Qed.

Lemma Pjump_add P i j l :
  P @ (jump (i + j) l) = P @ (jump j (jump i l)).
Proof.
  apply env_morph. intros. rewrite <- jump_add. f_equal.
  apply Pos.add_comm.
Qed.

Lemma Pjump_xO_tail P p l :
  P @ (jump (xO p) (tail l)) = P @ (jump (xI p) l).
Proof.
  apply env_morph. intros. now jump_simpl.
Qed.

Lemma Pjump_pred_double P p l :
  P @ (jump (Pos.pred_double p) (tail l)) = P @ (jump (xO p) l).
Proof.
  apply env_morph. intros.
  rewrite jump_pred_double. now jump_simpl.
Qed.

 Lemma mkPinj_ok j l P : (mkPinj j P)@l == P@(jump j l).
 Proof.
  destruct P;simpl;rsimpl.
  now rewrite Pjump_add.
 Qed.

 Lemma pow_pos_add x i j : x^(j + i) == x^i * x^j.
 Proof.
  rewrite Pos.add_comm.
  apply (pow_pos_add Rsth Reqe.(Rmul_ext) ARth.(ARmul_assoc)).
 Qed.

 Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c ?=! c').
 Proof.
  generalize (morph_eq CRmorph c c').
  destruct (c ?=! c'); auto.
 Qed.

 Lemma mkPX_ok l P i Q :
  (mkPX P i Q)@l == P@l * (hd l)^i + Q@(tail l).
 Proof.
  unfold mkPX. destruct P.
  - case ceqb_spec; intros H; simpl; try reflexivity.
    rewrite H, (morph0 CRmorph), mkPinj_ok; rsimpl.
  - reflexivity.
  - case Peq_spec; intros H; simpl; try reflexivity.
    rewrite H, Pphi0, Pos.add_comm, pow_pos_add; rsimpl.
 Qed.

 Hint Rewrite
  Pphi0
  Pphi1
  mkPinj_ok
  mkPX_ok
  (morph0 CRmorph)
  (morph1 CRmorph)
  (morph0 CRmorph)
  (morph_add CRmorph)
  (morph_mul CRmorph)
  (morph_sub CRmorph)
  (morph_opp CRmorph)
  : Esimpl.

 (* Quicker than autorewrite with Esimpl :-) *)
 Ltac Esimpl := try rewrite_db Esimpl; rsimpl; simpl.

 Lemma PaddC_ok c P l : (PaddC P c)@l == P@l + [c].
 Proof.
  revert l;induction P;simpl;intros;Esimpl;trivial.
  rewrite IHP2;rsimpl.
 Qed.

 Lemma PsubC_ok c P l : (PsubC P c)@l == P@l - [c].
 Proof.
  revert l;induction P;simpl;intros.
  - Esimpl.
  - rewrite IHP;rsimpl.
  - rewrite IHP2;rsimpl.
 Qed.

 Lemma PmulC_aux_ok c P l : (PmulC_aux P c)@l == P@l * [c].
 Proof.
  revert l;induction P;simpl;intros;Esimpl;trivial.
  rewrite IHP1, IHP2;rsimpl. add_permut. mul_permut.
 Qed.

 Lemma PmulC_ok c P l : (PmulC P c)@l == P@l * [c].
 Proof.
  unfold PmulC.
  case ceqb_spec; intros H.
  - rewrite H; Esimpl.
  - case ceqb_spec; intros H'.
    + rewrite H'; Esimpl.
    + apply PmulC_aux_ok.
 Qed.

 Lemma Popp_ok P l : (--P)@l == - P@l.
 Proof.
  revert l;induction P;simpl;intros.
  - Esimpl.
  - apply IHP.
  - rewrite IHP1, IHP2;rsimpl.
 Qed.

 Hint Rewrite PaddC_ok PsubC_ok PmulC_ok Popp_ok : Esimpl.

 Lemma PaddX_ok P' P k l :
  (forall P l, (P++P')@l == P@l + P'@l) ->
  (PaddX Padd P' k P) @ l == P@l + P'@l * (hd l)^k.
 Proof.
  intros IHP'.
  revert k l. induction P;simpl;intros.
  - add_permut.
  - destruct p; simpl;
    rewrite ?Pjump_xO_tail, ?Pjump_pred_double; add_permut.
  - destr_pos_sub; intros ->;Esimpl.
    + rewrite IHP';rsimpl. add_permut.
    + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut.
    + rewrite IHP1, pow_pos_add;rsimpl. add_permut.
 Qed.

 Lemma Padd_ok P' P l : (P ++ P')@l == P@l + P'@l.
 Proof.
  revert P l; induction P';simpl;intros;Esimpl.
  - revert p l; induction P;simpl;intros.
    + Esimpl; add_permut.
    + destr_pos_sub; intros ->;Esimpl.
      * now rewrite IHP'.
      * rewrite IHP';Esimpl. now rewrite Pjump_add.
      * rewrite IHP. now rewrite Pjump_add.
    + destruct p0;simpl.
      * rewrite IHP2;simpl. rsimpl. rewrite Pjump_xO_tail. Esimpl.
      * rewrite IHP2;simpl. rewrite Pjump_pred_double. rsimpl.
      * rewrite IHP'. rsimpl.
  - destruct P;simpl.
    + Esimpl. add_permut.
    + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl.
      * rewrite Pjump_xO_tail. rsimpl. add_permut.
      * rewrite Pjump_pred_double. rsimpl. add_permut.
      * rsimpl. unfold tail. add_permut.
    + destr_pos_sub; intros ->; Esimpl.
      * rewrite IHP'1, IHP'2;rsimpl. add_permut.
      * rewrite IHP'1, IHP'2;simpl;Esimpl.
        rewrite pow_pos_add;rsimpl. add_permut.
      * rewrite PaddX_ok by trivial; rsimpl.
        rewrite IHP'2, pow_pos_add; rsimpl. add_permut.
 Qed.

 Lemma PsubX_ok P' P k l :
  (forall P l, (P--P')@l == P@l - P'@l) ->
  (PsubX Psub P' k P) @ l == P@l - P'@l * (hd l)^k.
 Proof.
  intros IHP'.
  revert k l. induction P;simpl;intros.
  - rewrite Popp_ok;rsimpl; add_permut.
  - destruct p; simpl;
    rewrite Popp_ok;rsimpl;
    rewrite ?Pjump_xO_tail, ?Pjump_pred_double; add_permut.
  - destr_pos_sub; intros ->; Esimpl.
    + rewrite IHP';rsimpl. add_permut.
    + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut.
    + rewrite IHP1, pow_pos_add;rsimpl. add_permut.
 Qed.

 Lemma Psub_ok P' P l : (P -- P')@l == P@l - P'@l.
 Proof.
  revert P l; induction P';simpl;intros;Esimpl.
  - revert p l; induction P;simpl;intros.
    + Esimpl; add_permut.
    + destr_pos_sub; intros ->;Esimpl.
      * rewrite IHP';rsimpl.
      * rewrite IHP';Esimpl. now rewrite Pjump_add.
      * rewrite IHP. now rewrite Pjump_add.
    + destruct p0;simpl.
      * rewrite IHP2;simpl. rsimpl. rewrite Pjump_xO_tail. Esimpl.
      * rewrite IHP2;simpl. rewrite Pjump_pred_double. rsimpl.
      * rewrite IHP'. rsimpl.
  - destruct P;simpl.
    + Esimpl; add_permut.
    + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl.
      * rewrite Pjump_xO_tail. rsimpl. add_permut.
      * rewrite Pjump_pred_double. rsimpl. add_permut.
      * rsimpl. unfold tail. add_permut.
    + destr_pos_sub; intros ->; Esimpl.
      * rewrite IHP'1, IHP'2;rsimpl. add_permut.
      * rewrite IHP'1, IHP'2;simpl;Esimpl.
        rewrite pow_pos_add;rsimpl. add_permut.
      * rewrite PsubX_ok by trivial;rsimpl.
        rewrite IHP'2, pow_pos_add;rsimpl. add_permut.
 Qed.

 Lemma PmulI_ok P' :
   (forall P l, (Pmul P P') @ l == P @ l * P' @ l) ->
   forall P p l, (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l).
 Proof.
  intros IHP'.
  induction P;simpl;intros.
  - Esimpl; mul_permut.
  - destr_pos_sub; intros ->;Esimpl.
    + now rewrite IHP'.
    + now rewrite IHP', Pjump_add.
    + now rewrite IHP, Pjump_add.
  - destruct p0;Esimpl; rewrite ?IHP1, ?IHP2; rsimpl.
    + rewrite Pjump_xO_tail. f_equiv. mul_permut.
    + rewrite Pjump_pred_double. f_equiv. mul_permut.
    + rewrite IHP'. f_equiv. mul_permut.
 Qed.

 Lemma Pmul_ok P P' l : (P**P')@l == P@l * P'@l.
 Proof.
  revert P l;induction P';simpl;intros.
  - apply PmulC_ok.
  - apply PmulI_ok;trivial.
  - destruct P.
    + rewrite (ARmul_comm ARth). Esimpl.
    + Esimpl. rewrite IHP'1;Esimpl. f_equiv.
      destruct p0;rewrite IHP'2;Esimpl.
      * now rewrite Pjump_xO_tail.
      * rewrite Pjump_pred_double; Esimpl.
    + rewrite Padd_ok, !mkPX_ok, Padd_ok, !mkPX_ok,
       !IHP'1, !IHP'2, PmulI_ok; trivial. simpl. Esimpl.
      unfold tail.
      add_permut; f_equiv; mul_permut.
 Qed.

 Lemma Psquare_ok P l : (Psquare P)@l == P@l * P@l.
 Proof.
  revert l;induction P;simpl;intros;Esimpl.
  - apply IHP.
  - rewrite Padd_ok, Pmul_ok;Esimpl.
    rewrite IHP1, IHP2.
    mul_push ((hd l)^p). now mul_push (P2@l).
 Qed.

 Lemma Mphi_morph M e1 e2 :
  (forall x, e1 x = e2 x) -> M @@ e1 = M @@ e2.
 Proof.
   revert e1 e2; induction M; simpl; intros e1 e2 EQ; trivial.
   - apply IHM. intros; apply EQ.
   - f_equal.
     * apply IHM. intros; apply EQ.
     * f_equal. apply EQ.
 Qed.

Lemma Mjump_xO_tail M p l :
  M @@ (jump (xO p) (tail l)) = M @@ (jump (xI p) l).
Proof.
  apply Mphi_morph. intros. now jump_simpl.
Qed.

Lemma Mjump_pred_double M p l :
  M @@ (jump (Pos.pred_double p) (tail l)) = M @@ (jump (xO p) l).
Proof.
  apply Mphi_morph. intros.
  rewrite jump_pred_double. now jump_simpl.
Qed.

Lemma Mjump_add M i j l :
  M @@ (jump (i + j) l) = M @@ (jump j (jump i l)).
Proof.
  apply Mphi_morph. intros. now rewrite <- jump_add, Pos.add_comm.
Qed.

 Lemma mkZmon_ok M j l :
   (mkZmon j M) @@ l == (zmon j M) @@ l.
 Proof.
 destruct M; simpl; rsimpl.
 Qed.

 Lemma zmon_pred_ok M j l :
   (zmon_pred j M) @@ (tail l) == (zmon j M) @@ l.
 Proof.
   destruct j; simpl; rewrite ?mkZmon_ok; simpl; rsimpl.
   - now rewrite Mjump_xO_tail.
   - rewrite Mjump_pred_double; rsimpl.
 Qed.

 Lemma mkVmon_ok M i l :
   (mkVmon i M)@@l == M@@l * (hd l)^i.
 Proof.
  destruct M;simpl;intros;rsimpl.
  - rewrite zmon_pred_ok;simpl;rsimpl.
  - rewrite pow_pos_add;rsimpl.
 Qed.

 Ltac destr_mfactor R S := match goal with
  | H : context [MFactor ?P _] |- context [MFactor ?P ?M] =>
    specialize (H M); destruct MFactor as (R,S)
 end.

 Lemma Mphi_ok P M l :
   let (Q,R) := MFactor P M in
     P@l == Q@l + M@@l * R@l.
 Proof.
 revert M l; induction P; destruct M; intros l; simpl; auto; Esimpl.
 - case Pos.compare_spec; intros He; simpl.
   * destr_mfactor R1 S1. now rewrite IHP, He, !mkPinj_ok.
   * destr_mfactor R1 S1. rewrite IHP; simpl.
     now rewrite !mkPinj_ok, <- Mjump_add, Pos.add_comm, Pos.sub_add.
   * Esimpl.
 - destr_mfactor R1 S1. destr_mfactor R2 S2.
   rewrite IHP1, IHP2, !mkPX_ok, zmon_pred_ok; simpl; rsimpl.
   add_permut.
 - case Pos.compare_spec; intros He; simpl; destr_mfactor R1 S1;
   rewrite ?He, IHP1, mkPX_ok, ?mkZmon_ok; simpl; rsimpl;
   unfold tail; add_permut; mul_permut.
   * rewrite <- pow_pos_add, Pos.add_comm, Pos.sub_add by trivial; rsimpl.
   * rewrite mkPX_ok. simpl. Esimpl. mul_permut.
     rewrite <- pow_pos_add, Pos.sub_add by trivial; rsimpl.
 Qed.

 Lemma POneSubst_ok P1 M1 P2 P3 l :
   POneSubst P1 M1 P2 = Some P3 -> M1@@l == P2@l ->
   P1@l == P3@l.
 Proof.
 unfold POneSubst.
 assert (H := Mphi_ok P1). destr_mfactor R1 S1. rewrite H; clear H.
 intros EQ EQ'. replace P3 with (R1 ++ P2 ** S1).
 - rewrite EQ', Padd_ok, Pmul_ok; rsimpl.
 - revert EQ. destruct S1; try now injection 1.
   case ceqb_spec; now inversion 2.
 Qed.

 Lemma PNSubst1_ok n P1 M1 P2 l :
    M1@@l == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l.
 Proof.
 revert P1. induction n; simpl; intros P1;
 generalize (POneSubst_ok P1 M1 P2); destruct POneSubst;
   intros; rewrite <- ?IHn; auto; reflexivity.
 Qed.

 Lemma PNSubst_ok n P1 M1 P2 l P3 :
    PNSubst P1 M1 P2 n = Some P3 -> M1@@l == P2@l -> P1@l == P3@l.
 Proof.
 unfold PNSubst.
 assert (H := POneSubst_ok P1 M1 P2); destruct POneSubst; try discriminate.
 destruct n; inversion_clear 1.
 intros. rewrite <- PNSubst1_ok; auto.
 Qed.

 Fixpoint MPcond (LM1: list (Mon * Pol)) (l: Env R) : Prop :=
   match LM1 with
   | cons (M1,P2) LM2 => (M1@@l == P2@l) /\ MPcond LM2 l
   | _ => True
   end.

 Lemma PSubstL1_ok n LM1 P1 l :
   MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l.
 Proof.
 revert P1; induction LM1 as [|(M2,P2) LM2 IH]; simpl; intros.
 - reflexivity.
 - rewrite <- IH by intuition. now apply PNSubst1_ok.
 Qed.

 Lemma PSubstL_ok n LM1 P1 P2 l :
   PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l.
 Proof.
 revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros.
 - discriminate.
 - assert (H':=PNSubst_ok n P3 M2 P2'). destruct PNSubst.
   * injection H as <-. rewrite <- PSubstL1_ok; intuition.
   * now apply IH.
 Qed.

 Lemma PNSubstL_ok m n LM1 P1 l :
    MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l.
 Proof.
 revert LM1 P1. induction m; simpl; intros;
 assert (H' := PSubstL_ok n LM1 P2); destruct PSubstL;
 auto; try reflexivity.
 rewrite <- IHm; auto.
 Qed.

 (** Definition of polynomial expressions *)

 Inductive PExpr : Type :=
  | PEc : C -> PExpr
  | PEX : positive -> PExpr
  | PEadd : PExpr -> PExpr -> PExpr
  | PEsub : PExpr -> PExpr -> PExpr
  | PEmul : PExpr -> PExpr -> PExpr
  | PEopp : PExpr -> PExpr
  | PEpow : PExpr -> N -> PExpr.

 (** evaluation of polynomial expressions towards R *)
 Definition mk_X j := mkPinj_pred j mkX.

 (** evaluation of polynomial expressions towards R *)

 Fixpoint PEeval (l:Env R) (pe:PExpr) : R :=
   match pe with
   | PEc c => phi c
   | PEX j => nth j l
   | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2)
   | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2)
   | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2)
   | PEopp pe1 => - (PEeval l pe1)
   | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n)
   end.

 (** Correctness proofs *)

 Lemma mkX_ok p l : nth p l == (mk_X p) @ l.
 Proof.
  destruct p;simpl;intros;Esimpl;trivial.
  rewrite nth_spec ; auto.
  unfold hd.
  now rewrite <- nth_pred_double, nth_jump.
 Qed.

 Hint Rewrite Padd_ok Psub_ok : Esimpl.

Section POWER.
  Variable subst_l : Pol -> Pol.
  Fixpoint Ppow_pos (res P:Pol) (p:positive) : Pol :=
   match p with
   | xH => subst_l (res ** P)
   | xO p => Ppow_pos (Ppow_pos res P p) P p
   | xI p => subst_l ((Ppow_pos (Ppow_pos res P p) P p) ** P)
   end.

  Definition Ppow_N P n :=
   match n with
   | N0 => P1
   | Npos p => Ppow_pos P1 P p
   end.

  Lemma Ppow_pos_ok l :
    (forall P, subst_l P@l == P@l) ->
    forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l.
  Proof.
   intros subst_l_ok res P p. revert res.
   induction p;simpl;intros; rewrite ?subst_l_ok, ?Pmul_ok, ?IHp;
    mul_permut.
  Qed.

  Lemma Ppow_N_ok l :
    (forall P, subst_l P@l == P@l) ->
    forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l.
  Proof.
  destruct n;simpl.
  - reflexivity.
  - rewrite Ppow_pos_ok by trivial. Esimpl.
  Qed.

 End POWER.

 (** Normalization and rewriting *)

 Section NORM_SUBST_REC.
  Variable n : nat.
  Variable lmp:list (Mon*Pol).
  Let subst_l P := PNSubstL P lmp n n.
  Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2).
  Let Ppow_subst := Ppow_N subst_l.

  Fixpoint norm_aux (pe:PExpr) : Pol :=
   match pe with
   | PEc c => Pc c
   | PEX j => mk_X j
   | PEadd (PEopp pe1) pe2 => Psub (norm_aux pe2) (norm_aux pe1)
   | PEadd pe1 (PEopp pe2) =>
     Psub (norm_aux pe1) (norm_aux pe2)
   | PEadd pe1 pe2 => Padd (norm_aux  pe1) (norm_aux pe2)
   | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2)
   | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2)
   | PEopp pe1 => Popp (norm_aux pe1)
   | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n
   end.

  Definition norm_subst pe := subst_l (norm_aux pe).

  (** Internally, [norm_aux] is expanded in a large number of cases.
      To speed-up proofs, we use an alternative definition. *)

  Definition get_PEopp pe :=
   match pe with
   | PEopp pe' => Some pe'
   | _ => None
   end.

  Lemma norm_aux_PEadd pe1 pe2 :
    norm_aux (PEadd pe1 pe2) =
    match get_PEopp pe1, get_PEopp pe2 with
    | Some pe1', _ => (norm_aux pe2) -- (norm_aux pe1')
    | None, Some pe2' => (norm_aux pe1) -- (norm_aux pe2')
    | None, None => (norm_aux pe1) ++ (norm_aux pe2)
    end.
  Proof.
  simpl (norm_aux (PEadd _ _)).
  destruct pe1; [ | | | | | reflexivity | ];
   destruct pe2; simpl get_PEopp; reflexivity.
  Qed.

  Lemma norm_aux_PEopp pe :
    match get_PEopp pe with
    | Some pe' => norm_aux pe = -- (norm_aux pe')
    | None => True
    end.
  Proof.
  now destruct pe.
  Qed.

  Lemma norm_aux_spec l pe :
    PEeval l pe == (norm_aux pe)@l.
  Proof.
   intros.
   induction pe.
   - reflexivity.
   - apply mkX_ok.
   - simpl PEeval. rewrite IHpe1, IHpe2.
     assert (H1 := norm_aux_PEopp pe1).
     assert (H2 := norm_aux_PEopp pe2).
     rewrite norm_aux_PEadd.
     do 2 destruct get_PEopp; rewrite ?H1, ?H2; Esimpl; add_permut.
   - simpl. rewrite IHpe1, IHpe2. Esimpl.
   - simpl. rewrite IHpe1, IHpe2. now rewrite Pmul_ok.
   - simpl. rewrite IHpe. Esimpl.
   - simpl. rewrite Ppow_N_ok by reflexivity.
     rewrite pow_th.(rpow_pow_N). destruct n0; simpl; Esimpl.
     induction p;simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok.
  Qed.

 End NORM_SUBST_REC.

End MakeRingPol.


Inductive Exp :=
| number : nat -> Exp
| plus : Exp -> Exp -> Exp.

Compute (number 0).
Compute (plus (number 0) (number 7)).

Coercion number : nat >-> Exp.

Compute (plus 0 7).

Notation "A +' B" := (plus A B) (at level 50).
Compute (0 +' 7 +' 6).


Require Import Notation.
Require Import Axioms.
Require Import GeneralTactics.

Require Import Coq.Logic.FinFun.
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Sets.Ensembles.
Require Import Coq.Program.Basics.

(* Require Export Coq.Sets.Ensembles. *)

Open Scope program_scope.

(* This representation of equivalent-class predicates is inspired by
   the presentation in the HoTT book (section 6.10)
 *)

Section Quotient.

Context {A} (R: relation A) {equivR: Equivalence R}.

Notation "x ∼ y" := (R x y) (at level 70, no associativity).

Definition In {U} A x := In U A x.

Definition equiv_class (e: Ensemble A) :=
  exists x, forall y, x ∼ y <-> In e y.

Theorem ec_all_in_related : forall e,
  equiv_class e ->
  forall x y, In e x -> In e y -> x ∼ y.
Proof using A R equivR.
  intros * H * Hx Hy.
  destruct H as [a H].
  transitivity a.
  - symmetry.
    now apply H.
  - now apply H.
Qed.

Theorem ec_all_related_in : forall e,
  equiv_class e ->
  forall x y, x ∼ y -> In e x -> In e y.
Proof using A R equivR.
  intros * H * Heq Hx.
  destruct H as [a H].
  apply H.
  transitivity x.
  - now apply H.
  - assumption.
Qed.

Definition quotient := {e | equiv_class e}.

Definition class_to_ensemble (c: quotient) : Ensemble A := proj1_sig c.
Coercion class_to_ensemble : quotient >-> Ensemble.

Definition qclass (a: A) : quotient.
  (* refine (exist _ (λ x, a ∼ x) _). *)
  refine (exist _ (R a) _).
Proof.
  now exists a.
Defined.

Theorem in_qclass : forall a,
  In (qclass a) a.
Proof using A R equivR.
  intros *.
  cbn.
  reflexivity.
Qed.

Theorem qclass_eq : forall a (c: quotient),
  In c a ->
  c = qclass a.
Proof using A R equivR.
  intros * Hin.
  destruct c as [e p].
  simpl in Hin.
  apply exist_eq.
  extensionality x.
  extensionality H.
  - follows eapply ec_all_in_related.
  - follows eapply ec_all_related_in.
Qed.

Lemma in_some_class : forall a,
  exists c: quotient, In c a.
Proof using A R equivR.
  intros *.
  exists (qclass a).
  apply in_qclass.
Qed.

Theorem class_nonempty : forall c: quotient,
  exists x, In c x.
Proof using A R equivR.
  intros *.
  destruct c as (? & a & p).
  exists a.
  apply p.
  reflexivity.
Qed.

Lemma classes_partition : forall a,
  exists! c: quotient, In c a.
Proof using A R equivR.
  intros *.
  exists (qclass a).
  split.
  - apply in_qclass.
  - intros * Hin.
    symmetry.
    now apply qclass_eq.
Qed.

Lemma class_unique : forall (c1 c2: quotient) a,
  In c1 a ->
  In c2 a ->
  c1 = c2.
Proof using A R equivR.
  intros * Hin Hin'.
  apply qclass_eq in Hin, Hin'.
  now subst.
Qed.

Lemma classes_disjoint : forall (c1 c2: quotient) a,
  c1 <> c2 ->
  In c1 a -> ~ In c2 a.
Proof using A R equivR.
  intros * Hneq Hin Hin'.
  applyc Hneq.
  follows eapply class_unique.
Qed.

Theorem qclass_surjective : Surjective qclass.
Proof using A R equivR.
  intros c.
  destruct (class_nonempty c) as [a ?].
  exists a.
  symmetry.
  now apply qclass_eq.
Qed.

Theorem qclass_spec : forall x y,
  (qclass x = qclass y) = (x ∼ y).
Proof using A R equivR.
  intros *.
  extensionality H.
  - apply eq_sig_fst in H.
    symmetry.
    pattern x.
    induction H.
    reflexivity.
  - apply exist_eq.
    extensionality a.
    extensionality H'.
    + now transitivity x.
    + now transitivity y.
Qed.

Definition quotient_rect :
  forall (P: quotient -> Type),
    (forall Q p, P (exist _ Q p)) ->
    forall c, P c.
Proof using.
  intros * H *.
  destruct c.
  apply H.
Defined.

Definition quotient_rec :
  forall (P: quotient -> Set),
    (forall Q p, P (exist _ Q p)) ->
    forall c, P c
  := quotient_rect.

(* Our inductive principle is more pleasant, because we can reflect arbitrary
   classes to the canonical qclass representation
 *)
Theorem quotient_ind :
  forall (P: quotient -> Prop),
    (forall a, P (qclass a)) ->
    forall c, P c.
Proof using A R equivR.
  intros * H *.
  destruct c as [Q p].
  eta.
  destruct (qclass_surjective (exist _ Q p)) as [? <-].
  assumption!.
Qed.

Definition respects_equiv (f: A -> A) :=
  forall x y, x ∼ y -> (f x) ∼ (f y).

Definition respects_equiv2 (f: A -> A -> A) :=
  forall x x' y y', x ∼ x' -> y ∼ y' -> (f x y) ∼ (f x' y').

Definition liftQ (f: A -> A) (re: respects_equiv f) : quotient -> quotient.
Proof using A R equivR.
  intros [P p].
  refine (exist _ (λ a, ∃ x, (f x) ∼ a /\ P x) _).
  destruct p as [a p].
  exists (f a).
  intros *.
  split; intro H.
  - exists a.
    split.
    + assumption.
    + apply p.
      reflexivity.
  - destruct H as (? & <- & ?).
    apply re.
    now apply p.
Defined.

Theorem liftQ_qclass : forall (f: A -> A) (re: respects_equiv f) a,
  liftQ f re (qclass a) = qclass (f a).
Proof using.
  intros *.
  apply exist_eq'.
  simpl.
  extensionality x.
  extensionality; split.
  - intros (? & <- & ?).
    now apply re.
  - intros ?.
    now exists a.
Qed.

Definition liftQ2 (f: A -> A -> A) (re: respects_equiv2 f) :
  quotient -> quotient -> quotient.
Proof using A R equivR.
  intros [P p] [Q q].
  refine (exist _ (λ a, ∃ x y, (f x y) ∼ a /\ P x /\ Q y) _).
  destruct p as [a p], q as [a' q].
  exists (f a a').
  intros *.
  split; intro H.
  - exists a a'.
    max split.
    + assumption.
    + now apply p.
    + now apply q.
  - destruct H as (? & ? & <- & ? & ?).
    apply re.
    + now apply p.
    + now apply q.
Defined.

Theorem liftQ2_qclass : forall (f: A -> A -> A) (re: respects_equiv2 f) x y,
  liftQ2 f re (qclass x) (qclass y) = qclass (f x y).
Proof using.
  intros *.
  apply exist_eq'.
  simpl.
  extensionality a.
  extensionality; split.
  - intros (x' & y' & <- & H & H').
    now apply re.
  - intros ?.
    now exists x y.
Qed.

End Quotient.

Arguments quotient A R : clear implicits.
Notation "A / R" := (quotient A R) : type_scope.

Notation "f 'respects' R"  := (respects_equiv  R f) (at level 50).
Notation "f 'respects2' R" := (respects_equiv2 R f) (at level 50).

Close Scope program_scope.


Require Export GeoCoq.Tarski_dev.Ch04_col.

Section T5.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma l5_1 : forall A B C D,
  A <> B -> Bet A B C -> Bet A B D -> Bet A C D \/ Bet A D C.
Proof.
    intros.
    prolong A D C' C D.
    prolong A C D' C D.
    prolong A C' B' C B.
    prolong A D' B'' D B.
    assert (Cong B C' B'' C).
      apply (l2_11 B D C' B'' D' C).
        apply between_exchange3 with A; Between.
        apply between_inner_transitivity with A; Between.
        Cong.
      apply cong_transitivity with C D; Cong.
    assert (Cong B B' B'' B).
      {
      apply (l2_11 B C' B' B'' C B); Cong.

        {
        assert (Bet A B C'); [|eBetween].
        induction (eq_dec_points B D); [treat_equalities; auto|].
        apply between_symmetry.
        apply outer_transitivity_between2 with D; eBetween.
        }

        {
        induction (eq_dec_points C D'); [treat_equalities; eBetween|].
        apply outer_transitivity_between2 with D'; eBetween.
        }
      }
    assert(B'' =  B').
      apply (construction_uniqueness A B B B''); Cong.
        apply between_exchange4 with D'; Between;
        apply between_exchange4 with C; Between.
      apply between_exchange4 with C'; Between;
      apply between_exchange4 with D; Between.
    subst B''.
    assert (Bet B C D') by (apply between_exchange3 with A; assumption).
    assert (FSC B C D' C' B' C' D C).
      repeat split; Cong.
        left; apply between_exchange3 with A; Between.
        apply (l2_11 B C D' B' C' D); Cong.
          apply between_symmetry.
          apply between_exchange3 with A; assumption.
        apply cong_transitivity with C D; Cong.
      apply cong_transitivity with C D; Cong.
    induction (eq_dec_points B C).
      subst C; auto.
    assert (Cong D' C' D C) by (eapply l4_16; try apply H13; assumption).
    assert (exists E, Bet C E C' /\ Bet D E D') by (apply inner_pasch with A; Between).
    ex_and H16 E.
    assert (IFSC D E D' C D E D' C') by (unfold IFSC; repeat split; Cong; apply cong_transitivity with C D; Cong).
    assert (IFSC C E C' D C E C' D') by (unfold IFSC; repeat split; Cong; apply cong_transitivity with C D; Cong).
    assert (Cong E C E C') by (eapply l4_2; try apply H18; auto).
    assert (Cong E D E D') by (eapply l4_2; try apply H19; auto).
    induction (eq_dec_points C C').
      subst C'; right; assumption.
    show_distinct C D'.
      auto.
    prolong C' C P C D'.
    prolong D' C R C E.
    prolong P R Q R P.
    assert (FSC D' C R P P C E D').
      repeat split; Col; Cong.
      apply l2_11 with C C; Cong.
      apply between_inner_transitivity with C'; Between.
    assert (Cong R P E D') by (eauto using l4_16).
    assert (Cong R Q E D).
      eapply cong_transitivity.
        apply cong_transitivity with R P; Cong.
      apply cong_transitivity with E D'; Cong.
    assert (FSC D' E D C P R Q C).
      repeat split; Col; Cong.
      eapply (l2_11 D' E D P R Q); Between; Cong.
    assert (Cong D C Q C).
      induction (eq_dec_points D' E).
        unfold IFSC, Cong_3 in *; spliter; treat_equalities; Cong.
      apply l4_16 with D' E P R; assumption.
    assert (Cong C P C Q).
      unfold FSC, Cong_3 in *; spliter.
      apply cong_transitivity with C D; Cong.
      apply cong_transitivity with C D'; Cong.
    show_distinct R C.
      auto.
    assert (Cong D' P D' Q) by (apply (l4_17 R C); unfold Col; Between; Cong).
    assert (Cong B P B Q).
      apply l4_17 with C D'; Col.
    assert (Cong B' P B' Q).
      apply (l4_17 C D'); Cong.
      left.
      apply between_exchange3 with A; assumption.
    assert (Cong C' P C' Q).
      assert (Bet B C' B').
        apply between_exchange3 with A; try assumption.
        apply between_exchange4 with D; try assumption.
      eapply l4_17 with B B'; Cong; Col.
      intro; treat_equalities; auto.
    assert (Cong P P P Q).
      apply l4_17 with C C'; Col.
    treat_equalities.
    left; assumption.
Qed.

Lemma l5_2 : forall A B C D,
  A <> B -> Bet A B C -> Bet A B D -> Bet B C D \/ Bet B D C.
Proof.
    intros.
    assert (Bet A C D \/ Bet A D C) by (eapply l5_1; eauto).
    induction H2.
    left; eBetween.
    right; eBetween.
Qed.

Lemma segment_construction_2 :
  forall A Q B C, A <> Q -> exists X, (Bet Q A X \/ Bet Q X A) /\ Cong Q X B C.
Proof.
    intros.
    prolong A Q A' A Q.
    prolong A' Q X B C.
    exists X.
    show_distinct A' Q.
    solve [intuition].
    split; try assumption.
    eapply (l5_2 A' Q); Between.
Qed.

Lemma l5_3 : forall A B C D,
 Bet A B D -> Bet A C D -> Bet A B C \/ Bet A C B.
Proof.
    intros.
    assert (exists P, Bet D A P /\ A<>P) by  (apply point_construction_different).
    ex_and H1 P.
    assert (Bet P A B) by eBetween.
    assert (Bet P A C) by eBetween.
    apply (l5_2 P);auto.
Qed.

Lemma bet3__bet : forall A B C D E, Bet A B E -> Bet A D E -> Bet B C D -> Bet A C E.
Proof.
    intros.
    destruct (l5_3 A B D E H H0).
      apply between_exchange4 with D; trivial.
      apply between_exchange2 with B; assumption.
    apply between_exchange4 with B; trivial.
    apply between_exchange2 with D; Between.
Qed.

Lemma le_bet : forall A B C D, Le C D A B -> exists X, Bet A X B /\ Cong A X C D.
Proof.
    intros.
    unfold Le in H.
    ex_and H Y.
    exists Y;split;Cong.
Qed.

Lemma l5_5_1 : forall A B C D,
  Le A B C D -> exists x, Bet A B x /\ Cong A x C D.
Proof.
    unfold Le.
    intros.
    ex_and H P.
    prolong A B x P D.
    exists x.
    split.
      assumption.
    eapply l2_11;eauto.
Qed.

Lemma l5_5_2 : forall A B C D,
 (exists x, Bet A B x /\ Cong A x C D) -> Le A B C D.
Proof.
    intros.
    ex_and H P.
    unfold Le.
    assert (exists B' : Tpoint, Bet C B' D /\ Cong_3 A B P C B' D) by (eapply l4_5;auto).
    ex_and H1 y.
    exists y.
    unfold Cong_3 in *;intuition.
Qed.

Lemma l5_6 : forall A B C D A' B' C' D',
 Le A B C D -> Cong A B A' B' -> Cong C D C' D' -> Le A' B' C' D'.
Proof.
    unfold Le.
    intros.
    spliter.
    ex_and H y.
    assert (exists z : Tpoint, Bet C' z D' /\ Cong_3 C y D C' z D') by (eapply l4_5;auto).
    ex_and H3 z.
    exists z.
    split.
      assumption.
    unfold Cong_3 in *; spliter.
    apply cong_transitivity with A B; Cong.
    apply cong_transitivity with C y; assumption.
Qed.

Lemma le_reflexivity : forall A B, Le A B A B.
Proof.
    unfold Le.
    intros.
    exists B.
    split; Between; Cong.
Qed.

Lemma le_transitivity : forall A B C D E F, Le A B C D -> Le C D E F -> Le A B E F.
Proof.
    unfold Le.
    intros.
    ex_and H y.
    ex_and H0 z.
    assert (exists P : Tpoint, Bet E P z /\ Cong_3 C y D E P z) by (eapply l4_5;assumption).
    ex_and H3 P.
    exists P.
    split.
      eBetween.
    unfold Cong_3 in H4; spliter; apply cong_transitivity with C y; Cong.
Qed.

Lemma between_cong : forall A B C, Bet A C B -> Cong A C A B -> C = B.
Proof.
    intros.
    assert (Bet A B C).
    eapply l4_6 with A C B; unfold Cong_3; repeat split; Cong.
    eapply between_equality; eBetween.
Qed.

Lemma cong3_symmetry : forall A B C A' B' C' : Tpoint , Cong_3 A B C A' B' C' -> Cong_3 A' B' C' A B C.
Proof.
    unfold Cong_3.
    intros.
    intuition.
Qed.

Lemma between_cong_2 : forall A B D E, Bet A D B -> Bet A E B -> Cong A D A E -> D = E.
Proof.
    intros.
    apply cong3_bet_eq with A B; unfold Cong_3; repeat split; Cong.
    eapply (l4_2 B E A B B D A B).
    unfold IFSC; repeat split; Cong; Between.
Qed.

Lemma between_cong_3 :
  forall A B D E, A <> B -> Bet A B D -> Bet A B E -> Cong B D B E -> D = E.
Proof.
    intros.
    assert (T:=l5_2 A B D E H H0 H1).
    elim T; intro; clear T.
    apply between_cong with B; Cong.
    symmetry; apply between_cong with B; Cong.
Qed.

Lemma le_anti_symmetry : forall A B C D, Le A B C D -> Le C D A B -> Cong A B C D.
Proof.
    intros.
    assert (exists T, Bet C D T /\ Cong C T A B) by (apply l5_5_1;assumption).
    unfold Le in H.
    ex_and H Y.
    ex_and H1 T.
    assert (Cong C Y C T) by eCong.
    assert (Bet C Y T) by eBetween.
    assert (Y=T) by (eapply between_cong;eauto).
    subst Y.
    assert (T=D) by (eapply between_equality;eBetween).
    subst T.
    Cong.
Qed.

Lemma cong_dec : forall A B C D,
  Cong A B C D \/ ~ Cong A B C D.
Proof.
    intros.
    elim (eq_dec_points A B); intro; subst; elim (eq_dec_points C D); intro; subst.
    left; Cong.
    right; intro; apply H; apply cong_identity with B; Cong.
    right; intro; apply H; apply cong_identity with D; Cong.
    elim (segment_construction_2 B A C D).
    intros D' HD'.
    spliter.
    elim (eq_dec_points B D');intro.
    subst; left; assumption.
    right; intro.
    assert (Cong A D' A B) by CongR.
    elim H1; intro; clear H1.
    assert (B = D') by (apply (between_cong A D' B); Cong).
    subst;intuition.
    assert (D'=B) by (apply (between_cong A B D');assumption).
    subst;intuition.
    intuition.
Qed.

Lemma bet_dec : forall A B C, Bet A B C  \/  ~ Bet A B C.
Proof.
    intros.
    elim (segment_construction A B B C); intros C' HC'.
    spliter.
    elim (eq_dec_points C C'); intro.
    subst; tauto.
    elim (eq_dec_points A B);intro.
    left; subst; Between.
    right; intro; apply H1; apply between_cong_3 with A B; Cong.
Qed.

Lemma col_dec : forall A B C, Col A B C \/ ~ Col A B C.
Proof.
    intros.
    unfold Col.
    elim (bet_dec A B C); intro; elim (bet_dec B C A); intro; elim (bet_dec C A B); intro; tauto.
Qed.

Lemma le_trivial : forall A C D, Le A A C D .
Proof.
    intros.
    unfold Le.
    exists C.
    split; Between; Cong.
Qed.

Lemma le_cases : forall A B C D, Le A B C D \/ Le C D A B.
Proof.
    intros.
    induction(eq_dec_points A B).
      subst B; left; apply le_trivial.
    assert (exists X : Tpoint, (Bet A B X \/ Bet A X B) /\ Cong A X C D) by (eapply (segment_construction_2 B A C D);auto).
    ex_and H0 X.
    induction H0.
      left; apply l5_5_2; exists X; split; assumption.
    right; unfold Le; exists X; split; Cong.
Qed.

Lemma le_zero : forall A B C, Le A B C C -> A=B.
Proof.
    intros.
    assert (Le C C A B) by apply le_trivial.
    assert (Cong A B C C) by (apply le_anti_symmetry;assumption).
    treat_equalities;auto.
Qed.

Lemma le_diff : forall A B C D, A <> B -> Le A B C D -> C <> D.
Proof.
  intros A B C D HAB HLe Heq.
  subst D; apply HAB, le_zero with C; assumption.
Qed.

Lemma lt_diff : forall A B C D, Lt A B C D -> C <> D.
Proof.
  intros A B C D HLt Heq.
  subst D.
  destruct HLt as [HLe HNCong].
  assert (A = B) by (apply le_zero with C; assumption).
  subst B; Cong.
Qed.

Lemma bet_cong_eq :
 forall A B C D,
  Bet A B C ->
  Bet A C D ->
  Cong B C A D ->
  C = D /\ A = B.
Proof.
    intros.
    assert(C = D).
      assert(Le A C A D) by (eapply l5_5_2; exists D; split; Cong).
      assert(Le C B C A) by (eapply l5_5_2; exists A; split; Between; Cong).
      assert(Cong A C A D) by (eapply le_anti_symmetry; try assumption; apply l5_6 with C B C A; Cong).
      apply between_cong with A; assumption.
    split; try assumption.
    subst D; apply sym_equal.
    eapply (between_cong C); Between; Cong.
Qed.

Lemma cong__le : forall A B C D, Cong A B C D -> Le A B C D.
Proof.
  intros A B C D H.
  exists D.
  split.
  Between.
  Cong.
Qed.

Lemma cong__le3412 : forall A B C D, Cong A B C D -> Le C D A B.
Proof.
  intros A B C D HCong.
  apply cong__le.
  Cong.
Qed.

Lemma le1221 : forall A B, Le A B B A.
Proof.
  intros A B.
  apply cong__le; Cong.
Qed.

Lemma le_left_comm : forall A B C D, Le A B C D -> Le B A C D.
Proof.
  intros A B C D Hle.
  apply (le_transitivity _ _ A B); auto.
  apply le1221; auto.
Qed.

Lemma le_right_comm : forall A B C D, Le A B C D -> Le A B D C.
Proof.
  intros A B C D Hle.
  apply (le_transitivity _ _ C D); auto.
  apply le1221; auto.
Qed.

Lemma le_comm : forall A B C D, Le A B C D -> Le B A D C.
Proof.
  intros.
  apply le_left_comm.
  apply le_right_comm.
  assumption.
Qed.

Lemma ge_left_comm : forall A B C D, Ge A B C D -> Ge B A C D.
Proof.
    intros.
    unfold Ge in *.
    apply le_right_comm.
    assumption.
Qed.

Lemma ge_right_comm : forall A B C D, Ge A B C D -> Ge A B D C.
Proof.
    intros.
    unfold Ge in *.
    apply le_left_comm.
    assumption.
Qed.

Lemma ge_comm :  forall A B C D, Ge A B C D -> Ge B A D C.
Proof.
    intros.
    apply ge_left_comm.
    apply ge_right_comm.
    assumption.
Qed.

Lemma lt_right_comm : forall A B C D, Lt A B C D -> Lt A B D C.
Proof.
    intros.
    unfold Lt in *.
    spliter.
    split.
      apply le_right_comm.
      assumption.
    intro.
    apply H0.
    apply cong_right_commutativity.
    assumption.
Qed.

Lemma lt_left_comm : forall A B  C D, Lt A B C D -> Lt B A C D.
Proof.
    intros.
    unfold Lt in *.
    spliter.
    split.
      unfold Le in *.
      ex_and H P.
      exists P.
      apply cong_left_commutativity in H1.
      split; assumption.
    intro.
    apply H0.
    apply cong_left_commutativity.
    assumption.
Qed.

Lemma lt_comm : forall A B  C D, Lt A B C D -> Lt B A D C.
Proof.
    intros.
    apply lt_left_comm.
    apply lt_right_comm.
    assumption.
Qed.

Lemma gt_left_comm : forall A B C D, Gt A B C D -> Gt B A C D.
Proof.
    intros.
    unfold Gt in *.
    apply lt_right_comm.
    assumption.
Qed.

Lemma gt_right_comm : forall A B C D, Gt A B C D -> Gt A B D C.
Proof.
    intros.
    unfold Gt in *.
    apply lt_left_comm.
    assumption.
Qed.

Lemma gt_comm : forall A B C D, Gt A B C D -> Gt B A D C.
Proof.
    intros.
    apply gt_left_comm.
    apply gt_right_comm.
    assumption.
Qed.

Lemma cong2_lt__lt : forall A B C D A' B' C' D',
 Lt A B C D -> Cong A B A' B' -> Cong C D C' D' -> Lt A' B' C' D'.
Proof.
  intros A B C D A' B' C' D' Hlt HCong1 HCong2.
  destruct Hlt as [Hle HNCong].
  split.
  apply (l5_6 A B C D); auto.
  intro.
  apply HNCong.
  apply (cong_transitivity _ _ A' B'); auto.
  apply (cong_transitivity _ _ C' D'); Cong.
Qed.

Lemma fourth_point : forall A B C P, A <> B -> B <> C -> Col A B P -> Bet A B C ->
  Bet P A B \/ Bet A P B \/ Bet B P C \/ Bet B C P.
Proof.
    intros.
    induction H1.
      assert(HH:= l5_2 A B C P H H2 H1).
      right; right.
      induction HH.
        right; auto.
      left; auto.
    induction H1.
      right; left.
      Between.
    left; auto.
Qed.

Lemma third_point : forall A B P, Col A B P -> Bet P A B \/ Bet A P B \/ Bet A B P.
Proof.
    intros.
    induction H.
      right; right.
      auto.
    induction H.
      right; left.
      Between.
    left.
    auto.
Qed.

Lemma l5_12_a : forall A B C, Bet A B C -> Le A B A C /\ Le B C A C.
Proof.
    intros.
    split.
      unfold Le.
      exists B; split.
        assumption.
      apply cong_reflexivity.
    apply le_comm.
    unfold Le.
    exists B.
    split.
      apply between_symmetry.
      assumption.
    apply cong_reflexivity.
Qed.

Lemma bet__le1213 : forall A B C, Bet A B C -> Le A B A C.
Proof.
    intros A B C HBet.
    destruct (l5_12_a A B C HBet); trivial.
Qed.

Lemma bet__le2313 : forall A B C, Bet A B C -> Le B C A C.
Proof.
    intros A B C HBet.
    destruct (l5_12_a A B C HBet); trivial.
Qed.

Lemma bet__lt1213 : forall A B C, B <> C -> Bet A B C -> Lt A B A C.
Proof.
    intros A B C HBC HBet.
    split.
      apply bet__le1213; trivial.
    intro.
    apply HBC, between_cong with A; trivial.
Qed.

Lemma bet__lt2313 : forall A B C, A <> B -> Bet A B C -> Lt B C A C.
Proof.
    intros; apply lt_comm, bet__lt1213; Between.
Qed.

Lemma l5_12_b : forall A B C, Col A B C -> Le A B A C -> Le B C A C -> Bet A B C.
Proof.
    intros.
    unfold Col in H.
    induction H.
      assumption.
    induction H.
      assert(Le B C B A /\ Le C A B A).
        apply l5_12_a.
          assumption.
      spliter.
      assert(Cong A B A C).
        apply le_anti_symmetry.
          assumption.
        apply le_comm.
        assumption.
      assert(C = B).
        eapply between_cong.
          apply between_symmetry.
          apply H.
        apply cong_symmetry.
        assumption.
      subst B.
      apply between_trivial.
    assert(Le B A B C /\ Le A C B C).
      apply l5_12_a.
        apply between_symmetry.
        assumption.
    spliter.
    assert(Cong B C A C).
      apply le_anti_symmetry.
        assumption.
      assumption.
    assert(A = B).
      eapply between_cong.
        apply H.
      apply cong_symmetry.
      apply cong_commutativity.
      assumption.
    subst A.
    apply between_symmetry.
    apply between_trivial.
Qed.

Lemma bet_le_eq : forall A B C, Bet A B C -> Le A C B C -> A = B.
Proof.
    intros.
    assert(Le C B C A).
      eapply l5_5_2.
      exists A.
      split.
        apply between_symmetry.
        assumption.
      apply cong_reflexivity.
    assert(Cong A C B C).
      apply le_anti_symmetry.
        assumption.
      apply le_comm.
      assumption.
    apply sym_equal.
    eapply between_cong.
      apply between_symmetry.
      apply H.
    apply cong_commutativity.
    apply cong_symmetry.
    assumption.
Qed.

Lemma or_lt_cong_gt : forall A B C D, Lt A B C D \/ Gt A B C D \/ Cong A B C D.
Proof.
    intros.
    assert(HH:= le_cases A B C D).
    induction HH.
      induction(cong_dec A B C D).
        right; right.
        assumption.
      left.
      unfold Lt.
      split; assumption.
    induction(cong_dec A B C D).
      right; right.
      assumption.
    right; left.
    unfold Gt.
    unfold Lt.
    split.
      assumption.
    intro.
    apply H0.
    apply cong_symmetry.
    assumption.
Qed.

Lemma lt__le : forall A B C D, Lt A B C D -> Le A B C D.
Proof.
    intros A B C D Hlt.
    destruct Hlt.
    assumption.
Qed.

Lemma le1234_lt__lt : forall A B C D E F, Le A B C D -> Lt C D E F -> Lt A B E F.
Proof.
    intros A B C D E F Hle Hlt.
    destruct Hlt as [Hle' HNCong].
    split.
      apply (le_transitivity _ _ C D); auto.
    intro.
    apply HNCong.
    apply le_anti_symmetry; auto.
    apply (l5_6 A B C D); Cong.
Qed.

Lemma le3456_lt__lt : forall A B C D E F, Lt A B C D -> Le C D E F -> Lt A B E F.
Proof.
    intros A B C D E F Hlt Hle.
    destruct Hlt as [Hle' HNCong].
    split.
      apply (le_transitivity _ _ C D); auto.
    intro.
    apply HNCong.
    apply le_anti_symmetry; auto.
    apply (l5_6 C D E F); Cong.
Qed.

Lemma lt_transitivity : forall A B C D E F, Lt A B C D -> Lt C D E F -> Lt A B E F.
Proof.
    intros A B C D E F HLt1 HLt2.
    apply le1234_lt__lt with C D; try (apply lt__le); assumption.
Qed.

Lemma not_and_lt : forall A B C D, ~ (Lt A B C D /\ Lt C D A B).
Proof.
    intros A B C D.
    intro HInter.
    destruct HInter as [[Hle HNCong] []].
    apply HNCong.
    apply le_anti_symmetry; assumption.
Qed.

Lemma nlt : forall A B, ~ Lt A B A B.
Proof.
    intros A B Hlt.
    apply (not_and_lt A B A B).
    split; assumption.
Qed.

Lemma le__nlt : forall A B C D, Le A B C D -> ~ Lt C D A B.
Proof.
    intros A B C D HLe HLt.
    apply (not_and_lt A B C D); split; auto.
    split; auto.
    unfold Lt in *; spliter; auto with cong.
Qed.

Lemma cong__nlt : forall A B C D,
 Cong A B C D -> ~ Lt A B C D.
Proof.
    intros P Q R S H.
    apply le__nlt.
    unfold Le.
    exists Q; split; Cong; Between.
Qed.

Lemma nlt__le : forall A B C D, ~ Lt A B C D -> Le C D A B.
Proof.
    intros A B C D HNLt.
    destruct (le_cases A B C D); trivial.
    destruct (cong_dec C D A B).
      apply cong__le; assumption.
    exfalso.
    apply HNLt.
    split; Cong.
Qed.

Lemma lt__nle : forall A B C D, Lt A B C D -> ~ Le C D A B.
Proof.
    intros A B C D HLt HLe.
    revert HLt.
    apply le__nlt; assumption.
Qed.

Lemma nle__lt : forall A B C D, ~ Le A B C D -> Lt C D A B.
Proof.
    intros A B C D HNLe.
    destruct (le_cases A B C D).
      contradiction.
    split; trivial.
    intro.
    apply HNLe.
    apply cong__le; Cong.
Qed.

Lemma lt1123 : forall A B C, B<>C -> Lt A A B C.
Proof.
intros.
split.
apply le_trivial.
intro.
treat_equalities.
intuition.
Qed.

Lemma bet2_le2__le : forall O o A B a b, Bet a o b -> Bet A O B -> Le o a O A -> Le o b O B -> Le a b A B.
Proof.
intros.
induction(eq_dec_points A O).
treat_equalities; auto.
assert (o=a).
apply le_zero with A;auto.
subst;auto.
induction(eq_dec_points B O).
treat_equalities;auto.
assert (o=b).
apply le_zero with B;auto.
subst;auto using le_left_comm, le_right_comm.

assert(HH:= segment_construction A O b o).
ex_and HH b'.
assert(HH:= segment_construction B O a o).
ex_and HH a'.

unfold Le in H1.
ex_and H1 a''.

assert(a' = a'').
{
  apply(construction_uniqueness B O a o a' a'' H4);
  eBetween.
  Cong.
}
treat_equalities.

assert(Le B a' B A).
{
  unfold Le.
  exists a'.
  split; eBetween; Cong.
}

unfold Le in H2.
ex_and H2 b''.

assert(b' = b'').
{
  apply(construction_uniqueness A O b o b' b'' H3);
  eBetween.
  Cong.
}

treat_equalities.

assert(Le a' b' a' B).
{
  unfold Le.
  exists b'.
  split; eBetween; Cong.
}

assert(Le a' b' A B).
{
  apply(le_transitivity a' b' a' B A B); auto using le_left_comm, le_right_comm.
}

apply(l5_6 a' b' A B a b A B); Cong.
apply (l2_11 a' O b' a o b);
eBetween; Cong.
Qed.

Lemma Le_cases : forall A B C D, Le A B C D \/ Le B A C D \/ Le A B D C \/ Le B A D C -> Le A B C D.
Proof.
    intros A B C D [|[|[|]]]; [|apply le_left_comm|apply le_right_comm|apply le_comm]; assumption.
Qed.

Lemma Lt_cases : forall A B C D, Lt A B C D \/ Lt B A C D \/ Lt A B D C \/ Lt B A D C -> Lt A B C D.
Proof.
    intros A B C D [|[|[|]]]; [|apply lt_left_comm|apply lt_right_comm|apply lt_comm]; assumption.
Qed.

End T5.

#[global]
Hint Resolve le_reflexivity le_anti_symmetry le_trivial le_zero cong__le cong__le3412
             le1221 le_left_comm le_right_comm le_comm lt__le bet__le1213 bet__le2313
             lt_left_comm lt_right_comm lt_comm bet__lt1213 bet__lt2313 lt1123 : le.

Ltac Le := auto with le.