(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

From Coq Require Export List.
From Coq Require Import Arith Inclusion Inverse_Image Wf_nat Relation_Definitions.
From Coq Require Import Relation_Operators Lexicographic_Product.
From Buchberger Require Import Relation_Operators_compat LetP.
From Buchberger Require Export WfR0.

Set Default Proof Using "Type".

Section Buch.
Load hCoefStructure.
Load hOrderStructure.
Load hWfRO.

Inductive stable :
list (poly A0 eqA ltM) -> list (poly A0 eqA ltM) -> Prop :=
    stable0 :
      forall P Q : list (poly A0 eqA ltM),
      (forall a : poly A0 eqA ltM,
       Cb A A0 eqA plusA multA eqA_dec n ltM ltM_dec a P ->
       Cb A A0 eqA plusA multA eqA_dec n ltM ltM_dec a Q) ->
      (forall a : poly A0 eqA ltM,
       Cb A A0 eqA plusA multA eqA_dec n ltM ltM_dec a Q ->
       Cb A A0 eqA plusA multA eqA_dec n ltM ltM_dec a P) ->
      stable P Q.

Local Hint Resolve stable0 : core.

Theorem stable_refl : forall Q : list (poly A0 eqA ltM), stable Q Q.
Proof.
auto.
Qed.

Theorem stable_trans :
 forall Q y R : list (poly A0 eqA ltM),
 stable Q y -> stable y R -> stable Q R.
Proof.
intros Q y R H' H'0; inversion H'; inversion H'0; auto.
Qed.

Theorem stable_sym :
 forall Q R : list (poly A0 eqA ltM), stable R Q -> stable Q R.
Proof.
intros Q R H'; elim H'; auto.
Qed.

Local Hint Resolve (Cb_in _ _ _ _ _ _ _ _ _ cs eqA_dec _ _ ltM_dec os) : core.

Theorem Cb_stable :
 forall (a : poly A0 eqA ltM) (Q : list (poly A0 eqA ltM)),
 Cb A A0 eqA plusA multA eqA_dec n ltM ltM_dec a Q ->
 stable Q (addEnd A A0 eqA n ltM a Q).
Proof using os minusA invA divA cs A1.
intros a Q H'0; apply stable0; auto.
intros a0 H'1.
apply Cb_trans with (b := a) (1 := cs); auto.
Qed.

Theorem in_incl :
 forall (A : Type) (p q : list A) (a b : A), incl p q -> In a p -> In a q.
Proof.
auto.
Qed.

Inductive reds :
poly A0 eqA ltM -> poly A0 eqA ltM -> list (poly A0 eqA ltM) -> Prop :=
  | reds0 :
      forall (P : list (poly A0 eqA ltM)) (a b : poly A0 eqA ltM),
      red A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec
        (spolyp A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
           ltM_dec os a b) P -> reds a b P
  | reds1 :
      forall (P : list (poly A0 eqA ltM)) (a b c : poly A0 eqA ltM),
      In c P ->
      reds a c P ->
      reds c b P ->
      divp A A0 eqA multA divA n ltM
        (ppcp A A0 A1 eqA plusA invA minusA multA divA cs n ltM a b) c ->
      reds a b P.

Theorem reds_com :
 forall (P : list (poly A0 eqA ltM)) (a b : poly A0 eqA ltM),
 reds a b P -> reds b a P.
Proof.
intros P a b H'; elim H'; simpl in |- *; auto.
intros P0 a0 b0 H'0.
apply reds0; auto.
apply red_com; auto.
intros P0 a0 b0 c H'0 H'1 H'2 H'3 H'4 H'5.
apply reds1 with (c := c); auto.
apply divp_ppc; auto.
Qed.

(* Now we are ready!! We start with the definition of genCpC *)

Inductive cpRes : Type :=
  | Keep : forall P : list (poly A0 eqA ltM), cpRes
  | DontKeep : forall P : list (poly A0 eqA ltM), cpRes.

Definition getRes : cpRes -> list (poly A0 eqA ltM).
intros H'; case H'; auto.
Defined.

Definition addRes : poly A0 eqA ltM -> cpRes -> cpRes.
intros i H'; case H'.
intros H'0; exact (Keep (i :: H'0)).
intros H'0; exact (DontKeep (i :: H'0)).
Defined.

Definition slice :
  poly A0 eqA ltM -> poly A0 eqA ltM -> list (poly A0 eqA ltM) -> cpRes.
intros i a q; elim q; clear q.
case (foreigner_dec A A0 A1 eqA multA n ltM i a).
intros H; exact (DontKeep nil).
intros H; exact (Keep nil).
intros b q1 Rec.
case
 (divp_dec _ _ _ _ _ _ _ _ _ cs n ltM
    (ppcp A A0 A1 eqA plusA invA minusA multA divA cs n ltM i a) b).
intros divp10; exact (DontKeep (b :: q1)).
intros divp10.
case
 (divp_dec _ _ _ _ _ _ _ _ _ cs n ltM
    (ppcp A A0 A1 eqA plusA invA minusA multA divA cs n ltM i b) a).
intros divp11; exact Rec.
intros divp11; exact (addRes b Rec).
Defined.

Definition slicef :
  poly A0 eqA ltM ->
  poly A0 eqA ltM -> list (poly A0 eqA ltM) -> list (poly A0 eqA ltM).
intros i a q; case (slice i a q); auto.
Defined.

Theorem slicef_incl :
 forall (a b : poly A0 eqA ltM) (P : list (poly A0 eqA ltM)),
 incl (slicef a b P) P.
Proof.
intros a b P; elim P; simpl in |- *; auto.
unfold slicef in |- *; simpl in |- *; auto.
case (foreigner_dec A A0 A1 eqA multA n ltM a b); intros H; apply incl_refl;
 auto with datatypes.
intros c; unfold slicef in |- *; simpl in |- *.
case
 (divp_dec _ _ _ _ _ _ _ _ _ cs n ltM
    (ppcp A A0 A1 eqA plusA invA minusA multA divA cs n ltM a b) c);
 auto with datatypes.
case
 (divp_dec _ _ _ _ _ _ _ _ _ cs n ltM
    (ppcp A A0 A1 eqA plusA invA minusA multA divA cs n ltM a c) b);
 auto with datatypes.
intros H' H'0 l; case (slice a b l); simpl in |- *; auto with datatypes.
Qed.

Theorem slice_inv :
 forall (a b : poly A0 eqA ltM) (P : list (poly A0 eqA ltM))
   (c : poly A0 eqA ltM),
 In c P ->
 In c (getRes (slice a b P)) \/
 divp A A0 eqA multA divA n ltM
   (ppcp A A0 A1 eqA plusA invA minusA multA divA cs n ltM a c) b.
Proof.
intros a b P; elim P; simpl in |- *; auto.
intros c H'; elim H'.
intros p aP1;
 case
  (divp_dec _ _ _ _ _ _ _ _ _ cs n ltM
     (ppcp A A0 A1 eqA plusA invA minusA multA divA cs n ltM a b) p);
 simpl in |- *; auto.
case
 (divp_dec _ _ _ _ _ _ _ _ _ cs n ltM
    (ppcp A A0 A1 eqA plusA invA minusA multA divA cs n ltM a p) b);
 auto.
intros H' H'0 H'1 c H'2; elim H'2;
 [ intros H'3; rewrite <- H'3; clear H'2 | intros H'3; clear H'2 ];
 auto.
case (slice a b aP1); simpl in |- *; auto.
intros P0 H' H'0 H'1 c H'2; elim H'2;
 [ intros H'3; rewrite <- H'3; clear H'2 | intros H'3; clear H'2 ];
 auto.
elim (H'1 c); [ intros H'5; try exact H'5 | intros H'5 | idtac ]; auto.
intros P0 H' H'0 H'1 c H'2; elim H'2;
 [ intros H'3; rewrite <- H'3; clear H'2 | intros H'3; clear H'2 ];
 auto.
elim (H'1 c); [ intros H'5; try exact H'5 | intros H'5 | idtac ]; auto.
Qed.

Theorem slice_cons :
 forall (i a : poly A0 eqA ltM) (aP Q : list (poly A0 eqA ltM)),
 slice i a aP = DontKeep Q ->
 (exists c : poly A0 eqA ltM,
    In c Q /\
    divp A A0 eqA multA divA n ltM
      (ppcp A A0 A1 eqA plusA invA minusA multA divA cs n ltM i a) c) \/
 foreigner A A0 A1 eqA multA n ltM i a.
Proof.
intros i a aP; elim aP.
simpl in |- *; case (foreigner_dec A A0 A1 eqA multA n ltM i a); auto.
intros H' Q H'0; inversion H'0.
intros a0 l H' Q; simpl in |- *.
case
 (divp_dec _ _ _ _ _ _ _ _ _ cs n ltM
    (ppcp A A0 A1 eqA plusA invA minusA multA divA cs n ltM i a) a0);
 auto.
intros H'0 H'1; inversion H'1; auto.
left; exists a0; split; simpl in |- *; auto.
case
 (divp_dec _ _ _ _ _ _ _ _ _ cs n ltM
    (ppcp A A0 A1 eqA plusA invA minusA multA divA cs n ltM i a0) a);
 auto.
generalize H'; clear H'; case (slice i a l); simpl in |- *; auto.
intros P H' H'0 H'1 H'2; inversion H'2.
intros P H' H'0 H'1 H'2; inversion H'2.
elim (H' P);
 [ intros H'5; elim H'5; intros c E; elim E; intros H'6 H'7; clear E H'5
 | intros H'5
 | idtac ]; auto.
left; exists c; split; simpl in |- *; auto.
Qed.

Definition Tl : list (poly A0 eqA ltM) -> list (poly A0 eqA ltM) -> Prop.
exact (fun x y : list (poly A0 eqA ltM) => length x < length y).
Defined.

Theorem wf_Tl : well_founded Tl.
Proof.
apply (wf_inverse_image _ _ lt (length (A:=poly A0 eqA ltM))); auto.
generalize lt_wf; auto.
Qed.

Scheme Sdep := Induction for prod Sort Prop.

Theorem slice_Tl :
 forall (a ia : poly A0 eqA ltM) (L : list (poly A0 eqA ltM)),
 Tl (slicef a ia L) (a :: L).
Proof.
intros a b P; elim P; simpl in |- *; auto.
unfold slicef in |- *; simpl in |- *; auto.
case (foreigner_dec A A0 A1 eqA multA n ltM a b); unfold Tl in |- *;
 simpl in |- *; auto.
intros c l.
unfold slicef in |- *; simpl in |- *; auto.
case
 (divp_dec _ _ _ _ _ _ _ _ _ cs n ltM
    (ppcp A A0 A1 eqA plusA invA minusA multA divA cs n ltM a b) c);
 auto.
unfold Tl in |- *; simpl in |- *; auto.
case
 (divp_dec _ _ _ _ _ _ _ _ _ cs n ltM
    (ppcp A A0 A1 eqA plusA invA minusA multA divA cs n ltM a c) b);
 auto.
intros H' H'0; case (slice a b l); simpl in |- *; auto.
unfold Tl in |- *; simpl in |- *; auto.
unfold Tl in |- *; simpl in |- *; auto.
unfold Tl in |- *; intros H' H'0; case (slice a b l); simpl in |- *;
 auto with arith.
Qed.

Inductive genPcP :
poly A0 eqA ltM ->
list (poly A0 eqA ltM) ->
list (poly A0 eqA ltM) -> list (poly A0 eqA ltM) -> Prop :=
  | genPcP0 :
      forall (i : poly A0 eqA ltM) (L : list (poly A0 eqA ltM)),
      genPcP i nil L L
  | genPcP1 :
      forall (L L1 L2 L3 : list _) (a i : poly A0 eqA ltM),
      slice i a L1 = Keep L2 ->
      genPcP i L2 L L3 ->
      genPcP i (a :: L1) L
        (addEnd A A0 eqA n ltM
           (spolyp A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
              ltM_dec os i a) L3)
  | genPcP2 :
      forall (L L1 L2 L3 : list _) (a i : poly A0 eqA ltM),
      slice i a L1 = DontKeep L2 ->
      genPcP i L2 L L3 -> genPcP i (a :: L1) L L3.

Local Hint Resolve genPcP0 : core.

Theorem genPcP_spolyp1 :
 forall (i : poly A0 eqA ltM) (L L1 L2 : list _),
 genPcP i L1 L L2 ->
 forall a : poly A0 eqA ltM,
 In a L2 ->
 (exists b : poly A0 eqA ltM,
    In b L1 /\
    a =
    spolyp A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
      os i b) \/ In a L.
Proof.
intros i L L1 L2 H'; elim H'; clear H'; simpl in |- *; auto.
intros L0 L3 L4 L5 a i0 H' H'0 H'1 a0 H'2.
case (addEnd_cons A A0 eqA n ltM) with (1 := H'2); auto; intros H'7.
rewrite H'7; auto.
left; exists a; split; simpl in |- *; auto.
elim (H'1 a0); auto.
intros H'3; case H'3; intros b E; case E; intros H'4 H'5; rewrite H'5;
 clear E H'3.
left; exists b; split; auto.
right; try assumption.
generalize (slicef_incl i0 a L3); unfold slicef in |- *; rewrite H'; auto.
intros L0 L3 L4 L5 a i0 H' H'0 H'1 a0 H'2.
elim (H'1 a0);
 [ intros H'5; elim H'5; intros b E; elim E; intros H'6 H'7; rewrite H'7;
    clear E H'5
 | intros H'5
 | idtac ]; auto.
left; exists b; split; [ right | idtac ]; auto.
generalize (slicef_incl i0 a L3); unfold slicef in |- *; rewrite H'; auto.
Qed.

Local Hint Resolve (addEnd_id2 A A0 eqA n ltM) : core.
Local Hint Resolve (addEnd_id1 A A0 eqA n ltM) : core.

Theorem genPcP_incl :
 forall (i : poly A0 eqA ltM) (L L1 L2 : list _),
 genPcP i L1 L L2 -> incl L L2.
Proof.
intros i L L1 L2 H'; elim H'; simpl in |- *; auto with datatypes.
intros L0 L3 L4 L5 a i0 H'0 H'1 H'2.
unfold incl in |- *; simpl in |- *; auto.
Qed.

Lemma spolyp_cons_genPcP0 :
 forall (aP R Q : list _) (i : poly A0 eqA ltM),
 genPcP i aP R Q ->
 ~ BuchAux.zerop A A0 eqA n ltM i ->
 forall b : poly A0 eqA ltM,
 In b aP ->
 ~ BuchAux.zerop A A0 eqA n ltM b ->
 exists c : poly A0 eqA ltM,
   In c aP /\
   (In
      (spolyp A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
         ltM_dec os i c) Q \/ foreigner A A0 A1 eqA multA n ltM i c) /\
   divp A A0 eqA multA divA n ltM
     (ppcp A A0 A1 eqA plusA invA minusA multA divA cs n ltM i b) c.
Proof.
intros aP R Q i H'; elim H'; clear H' i aP R Q; simpl in |- *; auto.
intros i L H' b H'0; elim H'0.
intros L L1 L2 L3 a i H' H'0 H'1 H'2 b H'3 H'4.
cut (incl L2 L1);
 [ intros incl0
 | generalize (slicef_incl i a L1); unfold slicef in |- *; rewrite H' ];
 auto.
elim H'3; [ intros H'5; rewrite <- H'5; clear H'3 | intros H'5; clear H'3 ];
 auto.
exists a; split; [ idtac | split; [ left | idtac ] ]; auto.
rewrite H'5; auto.
apply zerop_ddivp_ppc; auto.
elim (slice_inv i a L1 b); [ intros H'10 | intros H'10 | idtac ]; auto.
rewrite H' in H'10; simpl in H'10; auto.
lapply H'1;
 [ intros H'3; elim (H'3 b);
    [ intros c E; elim E; intros H'9 H'11; elim H'11; intros H'12 H'13;
       elim H'12;
       [ intros H'14; clear H'12 H'11 E H'1
       | intros H'14; clear H'12 H'11 E H'1 ]
    | clear H'1
    | clear H'1 ]
 | clear H'1 ]; auto.
exists c; split; [ right | idtac ]; auto.
exists c; split; [ idtac | split; [ right | idtac ] ]; auto.
exists a; split; [ idtac | split ]; auto.
intros L L1 L2 L3 a i H' H'0 H'1 H'2 b H'3 H'4.
cut (incl L2 L1);
 [ intros incl0
 | generalize (slicef_incl i a L1); unfold slicef in |- *; rewrite H' ];
 auto.
elim H'3; [ intros H'5; rewrite <- H'5; clear H'3 | intros H'5; clear H'3 ];
 auto.
elim (slice_cons i a L1 L2);
 [ intros H'8; elim H'8; intros c E; elim E; intros H'9 H'10; clear E H'8
 | intros H'8
 | idtac ]; auto.
lapply H'1;
 [ intros H'3; elim (H'3 c);
    [ intros c0 E; elim E; intros H'11 H'12; elim H'12; intros H'13 H'14;
       elim H'13;
       [ intros H'15; clear H'13 H'12 E H'1
       | intros H'15; clear H'13 H'12 E H'1 ]
    | clear H'1
    | clear H'1 ]
 | clear H'1 ]; auto.
exists c0; split; [ idtac | split; [ left | idtac ] ]; auto.
apply
 (divp_trans _ _ _ _ _ _ _ _ _ cs n ltM)
  with (y := ppcp A A0 A1 eqA plusA invA minusA multA divA cs n ltM i c);
 auto.
apply divP_ppc; auto.
apply divp_ppc; auto.
apply zerop_ddivp_ppc; auto.
rewrite H'5; auto.
exists c0; split; [ idtac | split; [ right | idtac ] ]; auto.
apply
 (divp_trans _ _ _ _ _ _ _ _ _ cs n ltM)
  with (y := ppcp A A0 A1 eqA plusA invA minusA multA divA cs n ltM i c);
 auto.
rewrite H'5; auto.
apply divP_ppc; auto.
apply divp_ppc; auto.
apply zerop_ddivp_ppc; auto.
rewrite <- H'5; auto.
apply divp_nzeropr with (1 := H'10); auto.
exists a; split; [ idtac | split; [ right | idtac ] ]; auto.
rewrite H'5; auto.
apply zerop_ddivp_ppc; auto.
elim (slice_inv i a L1 b); [ intros H'10 | intros H'10 | idtac ]; auto.
rewrite H' in H'10; simpl in H'10; auto.
lapply H'1;
 [ intros H'3; elim (H'3 b);
    [ intros c E; elim E; intros H'9 H'11; elim H'11; intros H'12 H'13;
       elim H'12;
       [ intros H'14; clear H'12 H'11 E H'1
       | intros H'14; clear H'12 H'11 E H'1 ]
    | clear H'1
    | clear H'1 ]
 | clear H'1 ]; auto.
exists c; split; [ right | idtac ]; auto.
exists c; split; [ idtac | split; [ right | idtac ] ]; auto.
elim (slice_cons i a L1 L2);
 [ intros H'8; elim H'8; intros c E; elim E; intros H'9 H'11; clear E H'8
 | intros H'8
 | idtac ]; auto.
lapply H'1;
 [ intros H'3; elim (H'3 c);
    [ intros c0 E; elim E; intros H'12 H'13; elim H'13; intros H'14 H'15;
       elim H'14;
       [ intros H'16; clear H'14 H'13 E H'1
       | intros H'16; clear H'14 H'13 E H'1 ]
    | clear H'1
    | clear H'1 ]
 | clear H'1 ]; auto.
exists c0; split; [ idtac | split; [ left | idtac ] ]; auto.
apply
 (divp_trans _ _ _ _ _ _ _ _ _ cs n ltM)
  with (y := ppcp A A0 A1 eqA plusA invA minusA multA divA cs n ltM i c);
 auto.
apply
 (divp_trans _ _ _ _ _ _ _ _ _ cs n ltM)
  with (y := ppcp A A0 A1 eqA plusA invA minusA multA divA cs n ltM i a);
 auto.
apply divP_ppc; auto.
apply divp_ppc; auto.
apply zerop_ddivp_ppc; auto.
apply divP_ppc; auto.
apply divp_ppc; auto.
apply zerop_ddivp_ppc; auto.
apply divp_nzeropr with (1 := H'10); auto.
exists c0; split; [ idtac | split; [ right | idtac ] ]; auto.
apply
 (divp_trans _ _ _ _ _ _ _ _ _ cs n ltM)
  with (y := ppcp A A0 A1 eqA plusA invA minusA multA divA cs n ltM i a);
 auto.
apply divP_ppc; auto.
apply divp_ppc; auto.
apply zerop_ddivp_ppc; auto.
apply
 (divp_trans _ _ _ _ _ _ _ _ _ cs n ltM)
  with (y := ppcp A A0 A1 eqA plusA invA minusA multA divA cs n ltM i c);
 auto.
apply divP_ppc; auto.
apply divp_ppc; auto.
apply zerop_ddivp_ppc; auto.
apply divp_nzeropr with (1 := H'10); auto.
apply divp_nzeropr with (1 := H'11); auto.
exists a; split; [ idtac | split; [ right | idtac ] ]; auto.
Qed.

Lemma spolyp_cons_genPcP :
 forall (aP R Q : list _) (i : poly A0 eqA ltM),
 genPcP i aP R Q ->
 ~ BuchAux.zerop A A0 eqA n ltM i ->
 forall b : poly A0 eqA ltM,
 In b aP ->
 ~ BuchAux.zerop A A0 eqA n ltM b ->
 exists c : poly A0 eqA ltM,
   In c aP /\
   (In
      (spolyp A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
         ltM_dec os i c) Q \/
    red A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec
      (spolyp A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
         ltM_dec os i c) (addEnd A A0 eqA n ltM i aP)) /\
   divp A A0 eqA multA divA n ltM
     (ppcp A A0 A1 eqA plusA invA minusA multA divA cs n ltM i b) c.
Proof.
intros aP R Q i H' H'0 b H'1 H'2.
lapply (spolyp_cons_genPcP0 aP R Q i);
 [ intros H'7; lapply H'7;
    [ intros H'8; elim (H'8 b);
       [ intros c E; elim E; intros H'12 H'13; elim H'13; intros H'14 H'15;
          elim H'14;
          [ intros H'16; clear H'14 H'13 E H'7
          | intros H'16; clear H'14 H'13 E H'7 ]
       | clear H'7
       | clear H'7 ]
    | clear H'7 ]
 | idtac ]; auto.
exists c; split; [ idtac | split; [ left | idtac ] ]; auto.
exists c; split; [ idtac | split; [ right | idtac ] ]; auto.
apply foreigner_red; auto.
Qed.

Theorem Cb_genPcP :
 forall (i : poly A0 eqA ltM) (P Q R S : list (poly A0 eqA ltM)),
 genPcP i P R Q ->
 Cb A A0 eqA plusA multA eqA_dec n ltM ltM_dec i S ->
 (forall a : poly A0 eqA ltM,
  In a P -> Cb A A0 eqA plusA multA eqA_dec n ltM ltM_dec a S) ->
 (forall a : poly A0 eqA ltM,
  In a R -> Cb A A0 eqA plusA multA eqA_dec n ltM ltM_dec a S) ->
 forall a : poly A0 eqA ltM,
 In a Q -> Cb A A0 eqA plusA multA eqA_dec n ltM ltM_dec a S.
Proof.
intros i P Q R S H'; elim H'; simpl in |- *; auto.
intros L L1 L2 L3 a i0 H'0 H'1 H'2 H'3 H'4 H'5 a0 H'6.
case (addEnd_cons A A0 eqA n ltM) with (1 := H'6); auto; intros H'7.
rewrite H'7; auto.
apply Cb_sp; auto.
apply H'2; auto.
intros a1 H'8.
apply H'4; auto.
right.
generalize (slicef_incl i0 a L1); unfold slicef in |- *; rewrite H'0; auto.
intros L L1 L2 L3 a i0 H'0 H'1 H'2 H'3 H'4 H'5 a0 H'6; auto.
apply H'2; auto.
intros a1 H'7.
apply H'4; auto.
generalize (slicef_incl i0 a L1); unfold slicef in |- *; rewrite H'0; auto.
Qed.

Definition genPcPf0 :
  forall (i : poly A0 eqA ltM) (aP R : list (poly A0 eqA ltM)),
  {Q : list (poly A0 eqA ltM) | genPcP i aP R Q}.
intros i aP; pattern aP in |- *.
apply well_founded_induction_type with (A := list (poly A0 eqA ltM)) (R := Tl);
 clear aP; auto.
try exact wf_Tl.
intros aP; case aP.
intros H' R; exists R; auto.
intros a L1 Rec L; generalize (@refl_equal _ (slice i a L1));
 pattern (slice i a L1) at 2 in |- *; case (slice i a L1).
intros L2 H'.
lapply (Rec L2); [ intros H'1; elim (H'1 L); intros L3 E | idtac ]; auto.
exists
 (addEnd A A0 eqA n ltM
    (spolyp A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
       os i a) L3); auto.
apply genPcP1 with (L2 := L2); auto.
generalize (slice_Tl i a L1); unfold slicef in |- *; rewrite H';
 simpl in |- *; auto.
intros L2 H'.
lapply (Rec L2); [ intros H'1; elim (H'1 L); intros L3 E | idtac ]; auto.
exists L3; auto.
apply genPcP2 with (L2 := L2); auto.
generalize (slice_Tl i a L1); unfold slicef in |- *; rewrite H';
 simpl in |- *; auto.
Defined.

Definition genPcPf :
  poly A0 eqA ltM ->
  list (poly A0 eqA ltM) -> list (poly A0 eqA ltM) -> list (poly A0 eqA ltM).
intros i aP Q; case (genPcPf0 i aP Q).
intros x H'; exact x.
Defined.

(* The proof will carry on if we have the following 3 properties for
   the function genPcPf *)

Theorem Cb_genPcPf :
 forall (b : poly A0 eqA ltM) (P Q R : list (poly A0 eqA ltM)),
 Cb A A0 eqA plusA multA eqA_dec n ltM ltM_dec b R ->
 (forall a : poly A0 eqA ltM,
  In a P -> Cb A A0 eqA plusA multA eqA_dec n ltM ltM_dec a R) ->
 (forall a : poly A0 eqA ltM,
  In a Q -> Cb A A0 eqA plusA multA eqA_dec n ltM ltM_dec a R) ->
 forall a : poly A0 eqA ltM,
 In a (genPcPf b P Q) -> Cb A A0 eqA plusA multA eqA_dec n ltM ltM_dec a R.
Proof.
intros b P Q R; unfold genPcPf in |- *; case (genPcPf0 b P Q).
intros x H' H'0 H'1 H'2 a H'3.
apply Cb_genPcP with (i := b) (P := P) (Q := x) (R := Q); auto.
Qed.

Theorem genPcPf_incl :
 forall (a : poly A0 eqA ltM) (aL Q : list (poly A0 eqA ltM)),
 incl Q (genPcPf a aL Q).
Proof.
intros a aL Q; unfold genPcPf in |- *; case (genPcPf0 a aL Q).
intros x H'.
apply genPcP_incl with (i := a) (L1 := aL); auto.
Qed.

Local Hint Resolve genPcPf_incl : core.

Theorem spolyp_addEnd_genPcPf :
 forall (aP R Q : list (poly A0 eqA ltM)) (a b : poly A0 eqA ltM),
 ~ BuchAux.zerop A A0 eqA n ltM a ->
 ~ BuchAux.zerop A A0 eqA n ltM b ->
 In b aP ->
 exists c : poly A0 eqA ltM,
   In c aP /\
   (In
      (spolyp A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
         ltM_dec os a c) (genPcPf a aP Q) \/
    red A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec
      (spolyp A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
         ltM_dec os a c) (addEnd A A0 eqA n ltM a aP)) /\
   divp A A0 eqA multA divA n ltM
     (ppcp A A0 A1 eqA plusA invA minusA multA divA cs n ltM a b) c.
Proof.
intros aP H' Q a b H'0 H'1 H'2.
unfold genPcPf in |- *.
case (genPcPf0 a aP Q).
intros x H'3.
apply spolyp_cons_genPcP with (R := Q); auto.
Qed.

(* Now we can define the optimized version of Buchberger *)

Definition genOCPf : list (poly A0 eqA ltM) -> list (poly A0 eqA ltM).
intros H'; elim H'.
exact (nil (A:=poly A0 eqA ltM)).
intros a l rec; exact (genPcPf a l rec).
Defined.

(* Now we can define the optimized version of Buchberger *)

Theorem genOCPf_stable :
 forall (a : poly A0 eqA ltM) (P : list (poly A0 eqA ltM)),
 In a (genOCPf P) -> Cb A A0 eqA plusA multA eqA_dec n ltM ltM_dec a P.
Proof.
intros a P; generalize a; elim P; clear a P; simpl in |- *; auto.
intros a H; elim H.
intros a l H' a0 H'0.
apply Cb_genPcPf with (b := a) (P := l) (Q := genOCPf l); auto with datatypes.
apply Cb_id with (1 := cs); auto with datatypes.
intros; apply Cb_in1 with (1 := cs); auto.
apply Cb_id with (1 := cs); auto with datatypes.
intros; apply Cb_in1 with (1 := cs); auto.
Qed.

Inductive OBuch :
list (poly A0 eqA ltM) ->
list (poly A0 eqA ltM) -> list (poly A0 eqA ltM) -> Prop :=
  | OBuch0 : forall aL : list (poly A0 eqA ltM), OBuch aL nil aL
  | OBuch1 :
      forall (a : poly A0 eqA ltM) (aP Q R : list (poly A0 eqA ltM)),
      OBuch
        (addEnd A A0 eqA n ltM
           (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
              ltM_dec os a aP) aP)
        (genPcPf
           (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
              ltM_dec os a aP) aP Q) R ->
      ~
      BuchAux.zerop A A0 eqA n ltM
        (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
           os a aP) -> OBuch aP (a :: Q) R
  | OBuch2 :
      forall (a : poly A0 eqA ltM) (aP Q R : list (poly A0 eqA ltM)),
      OBuch aP Q R ->
      BuchAux.zerop A A0 eqA n ltM
        (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
           os a aP) -> OBuch aP (a :: Q) R.

Local Hint Resolve OBuch0 OBuch2 : core.
Local Hint Resolve incl_refl incl_tl : core.

Theorem incl_addEnd1 :
 forall (a : poly A0 eqA ltM) (L1 L2 : list (poly A0 eqA ltM)),
 incl (addEnd A A0 eqA n ltM a L1) L2 -> incl (a :: L1) L2.
Proof.
unfold incl in |- *; simpl in |- *; auto.
intros a L1 L2 H' a0 H'0; case H'0;
 [ intros H'1; rewrite <- H'1; clear H'0 | intros H'1; clear H'0 ];
 auto.
Qed.

Theorem ObuchPincl :
 forall aP R Q : list (poly A0 eqA ltM), OBuch aP Q R -> incl aP R.
Proof.
intros aP R Q H'; elim H'; simpl in |- *; auto.
intros a aP0 Q0 R0 H'0 H'1 H'2; try assumption.
apply
 incl_tran
  with
    (m := nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
            ltM_dec os a aP0 :: aP0); simpl in |- *;
 auto.
apply incl_addEnd1; auto.
Qed.

Theorem ObuchPred :
 forall aP R Q : list (poly A0 eqA ltM),
 OBuch aP Q R ->
 forall a : poly A0 eqA ltM,
 In a aP -> red A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a R.
Proof.
intros aP R Q H'; elim H'; simpl in |- *; auto.
intros; apply red_cons with (1 := cs); auto.
Qed.

Theorem ObuchQred :
 forall aP R Q : list (poly A0 eqA ltM),
 OBuch aP Q R ->
 forall a : poly A0 eqA ltM,
 In a Q -> red A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a R.
Proof.
intros aP R Q H'; elim H'; simpl in |- *; auto.
intros aL a H'0; elim H'0.
intros a aP0 Q0 R0 H'0 H'1 H'2 a0 H'3; elim H'3;
 [ intros H'4; rewrite <- H'4; clear H'3 | intros H'4; clear H'3 ];
 auto.
apply
 red_incl
  with
    (1 := cs)
    (p := addEnd A A0 eqA n ltM
            (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
               ltM_dec os a aP0) aP0); auto.
apply
 ObuchPincl
  with
    (Q := genPcPf
            (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
               ltM_dec os a aP0) aP0 Q0); auto.
apply nf_red with (cs := cs) (os := os) (aP := aP0); simpl in |- *; auto.
unfold incl in |- *; auto.
apply red_cons with (1 := cs); auto.
apply H'1; auto.
apply
 (genPcPf_incl
    (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec os
       a aP0) aP0 Q0); auto.
intros a aP0 Q0 R0 H'0 H'1 H'2 a0 H'3; elim H'3;
 [ intros H'4; rewrite <- H'4; clear H'3 | intros H'4; clear H'3 ];
 auto.
apply red_incl with (1 := cs) (p := aP0); auto.
apply ObuchPincl with (Q := Q0); auto.
apply zerop_red with (cs := cs) (os := os); auto.
Qed.

Theorem OBuch_Stable :
 forall P Q R : list (poly A0 eqA ltM),
 OBuch P Q R ->
 (forall a : poly A0 eqA ltM,
  In a Q -> Cb A A0 eqA plusA multA eqA_dec n ltM ltM_dec a P) ->
 stable P R.
Proof.
intros P Q R H'; elim H'; simpl in |- *; auto.
intros a aP Q0 R0 H'0 H'1 H'2 H'3.
apply
 stable_trans
  with
    (y := addEnd A A0 eqA n ltM
            (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
               ltM_dec os a aP) aP); auto.
apply stable0; auto.
intros a0 H'4.
apply
 Cb_trans
  with
    (1 := cs)
    (b := nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
            ltM_dec os a aP); auto.
apply nf_Cb; auto.
apply H'1; auto.
intros a0 H'4.
apply
 Cb_genPcPf
  with
    (b := nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
            ltM_dec os a aP)
    (P := aP)
    (Q := Q0); auto.
apply Cb_id with (1 := cs); auto.
intros; apply Cb_in with (1 := cs); auto.
apply Cb_id with (1 := cs); auto.
Qed.

Inductive redIn :
poly A0 eqA ltM ->
poly A0 eqA ltM ->
list (poly A0 eqA ltM) ->
list (poly A0 eqA ltM) -> list (poly A0 eqA ltM) -> Prop :=
  | redIn0b :
      forall (P Q R : list (poly A0 eqA ltM)) (a b : poly A0 eqA ltM),
      redIn b a P Q R -> redIn a b P Q R
  | redIn0 :
      forall (P Q R : list (poly A0 eqA ltM)) (a b : poly A0 eqA ltM),
      In
        (spolyp A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
           ltM_dec os a b) Q -> redIn a b P Q R
  | redIn1 :
      forall (P Q R : list (poly A0 eqA ltM)) (a b : poly A0 eqA ltM),
      red A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec
        (spolyp A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
           ltM_dec os a b) R -> redIn a b P Q R
  | redIn2 :
      forall (P Q R : list (poly A0 eqA ltM)) (a b c : poly A0 eqA ltM),
      In c P ->
      redIn a c P Q R ->
      redIn b c P Q R ->
      divp A A0 eqA multA divA n ltM
        (ppcp A A0 A1 eqA plusA invA minusA multA divA cs n ltM a b) c ->
      redIn a b P Q R.

Local Hint Resolve redIn1 redIn0 : core.

Remark lem_redIn_nil :
 forall (aP Q R : list (poly A0 eqA ltM)) (a b : poly A0 eqA ltM),
 In a R -> In b R -> redIn a b aP Q R -> Q = nil -> aP = R -> reds a b R.
Proof.
intros aP Q R a b H' H'0 H'1; elim H'1; auto.
intros P Q0 R0 a0 b0 H'2 H'3 H'4 H'5.
apply reds_com; auto.
intros P Q0 R0 a0 b0 H'2 H'3 H'4.
rewrite H'3 in H'2; elim H'2.
intros P Q0 R0 a0 b0 H'2 H'3 H'4; rewrite <- H'4.
rewrite H'4.
apply reds0; auto.
intros P Q0 R0 a0 b0 c H'2 H'3 H'4 H'5 H'6 H'7 H'8 H'9.
apply reds1 with (c := c); auto.
rewrite <- H'9; auto.
apply reds_com; auto.
Qed.

Theorem redIn_nil :
 forall (R : list (poly A0 eqA ltM)) (a b : poly A0 eqA ltM),
 In a R -> In b R -> redIn a b R nil R -> reds a b R.
Proof.
intros R a b H' H'0 H'1.
apply lem_redIn_nil with (aP := R) (Q := nil (A:=poly A0 eqA ltM)); auto.
Qed.

Remark lem_redln_cons :
 forall (aP R Q : list (poly A0 eqA ltM)) (a b : poly A0 eqA ltM),
 In a aP ->
 In b aP ->
 redIn a b aP Q R ->
 forall (c : poly A0 eqA ltM) (Q1 : list (poly A0 eqA ltM)),
 Q = c :: Q1 ->
 red A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec c R ->
 redIn a b aP Q1 R.
Proof.
intros aP R Q a b H' H'0 H'1; elim H'1; auto.
intros P Q0 R0 a0 b0 H'2 H'3 c Q1 H'4 H'5.
apply redIn0b; auto.
apply H'3 with (c := c); auto.
intros P Q0 R0 a0 b0 H'2 c Q1 H'3 H'4.
rewrite H'3 in H'2; elim H'2; auto.
intros H'5; rewrite H'5 in H'4; auto.
intros P Q0 R0 a0 b0 c H'2 H'3 H'4 H'5 H'6 H'7 c0 Q1 H'8 H'9.
apply redIn2 with (c := c); auto.
apply (H'4 c0); auto.
apply (H'6 c0); auto.
Qed.

Theorem redln_cons :
 forall (aP R Q : list (poly A0 eqA ltM)) (a b c : poly A0 eqA ltM),
 In a aP ->
 In b aP ->
 redIn a b aP (c :: Q) R ->
 red A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec c R ->
 redIn a b aP Q R.
Proof.
intros aP R Q a b c H' H'0 H'1 H'2; try assumption.
apply lem_redln_cons with (Q := c :: Q) (c := c); auto.
Qed.

Theorem redInclP :
 forall (P Q R : list (poly A0 eqA ltM)) (a b : poly A0 eqA ltM),
 redIn a b P Q R ->
 forall P1 : list (poly A0 eqA ltM), incl P P1 -> redIn a b P1 Q R.
Proof.
intros P Q R a b H'; elim H'; auto.
intros P0 Q0 R0 a0 b0 H'0 H'1 P1 H'2.
apply redIn0b; auto.
intros P0 Q0 R0 a0 b0 c H'0 H'1 H'2 H'3 H'4 H'5 Q1 H'6.
apply redIn2 with (c := c); auto.
Qed.

Theorem redInInclQ :
 forall (P Q R : list (poly A0 eqA ltM)) (a b : poly A0 eqA ltM),
 redIn a b P Q R ->
 forall Q1 : list (poly A0 eqA ltM), incl Q Q1 -> redIn a b P Q1 R.
Proof.
intros P Q R a b H'; elim H'; auto.
intros P0 Q0 R0 a0 b0 H'0 H'1 Q1 H'2; try assumption.
apply redIn0b; auto.
intros P0 Q0 R0 a0 b0 c H'0 H'1 H'2 H'3 H'4 H'5 Q1 H'6; try assumption.
apply redIn2 with (c := c); auto.
Qed.

Theorem redInclR :
 forall (P Q R : list (poly A0 eqA ltM)) (a b : poly A0 eqA ltM),
 redIn a b P Q R ->
 forall R1 : list (poly A0 eqA ltM), incl R R1 -> redIn a b P Q R1.
Proof.
intros P Q R a b H'; elim H'; simpl in |- *; auto.
intros P0 Q0 R0 a0 b0 H'0 H'1 R1 H'2; try assumption.
apply redIn0b; auto.
intros P0 Q0 R0 a0 b0 H'0 R1 H'1; try assumption.
apply redIn1; auto.
apply red_incl with (1 := cs) (p := R0); auto.
intros P0 Q0 R0 a0 b0 c H'0 H'1 H'2 H'3 H'4 H'5 R1 H'6.
apply redIn2 with (c := c); auto.
Qed.

Remark lem_redln_cons_gen :
 forall (aP R Q : list (poly A0 eqA ltM)) (a b : poly A0 eqA ltM),
 In a aP ->
 In b aP ->
 redIn a b aP Q R ->
 forall (c : poly A0 eqA ltM) (Q1 : list (poly A0 eqA ltM)),
 incl
   (addEnd A A0 eqA n ltM
      (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
         os c aP) aP) R ->
 Q = c :: Q1 ->
 redIn a b
   (addEnd A A0 eqA n ltM
      (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
         os c aP) aP) Q1 R.
Proof.
intros aP R Q a b H' H'0 H'1; elim H'1; auto.
intros P Q0 R0 a0 b0 H'2 H'3 c Q1 H'4 H'5.
apply redIn0b; auto.
intros P Q0 R0 a0 b0 H'2 c Q1 H'3 H'4.
rewrite H'4 in H'2; elim H'2; auto.
intros H'5; rewrite H'5.
apply redIn1; auto.
apply nf_red with (aP := P) (cs := cs) (os := os); auto.
apply
 incl_tran
  with
    (m := nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
            ltM_dec os c P :: P); simpl in |- *; auto.
apply incl_addEnd1; auto.
apply red_cons with (1 := cs); auto.
apply
 in_incl
  with
    (p := nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
            ltM_dec os c P :: P); auto.
apply incl_addEnd1; auto.
rewrite H'5; simpl in |- *; auto.
intros P Q0 R0 a0 b0 c H'2 H'3 H'4 H'5 H'6 H'7 c0 Q1 H'8 H'9.
apply redIn2 with (c := c); auto.
Qed.

Theorem redln_cons_gen :
 forall (aP R Q : list (poly A0 eqA ltM)) (a b c : poly A0 eqA ltM),
 In a aP ->
 In b aP ->
 redIn a b aP (c :: Q) R ->
 incl
   (addEnd A A0 eqA n ltM
      (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
         os c aP) aP) R ->
 redIn a b
   (addEnd A A0 eqA n ltM
      (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
         os c aP) aP) Q R.
Proof.
intros aP R Q a b c H' H'0 H'1 H'2.
apply lem_redln_cons_gen with (Q := c :: Q); auto.
Qed.

Local Hint Resolve redln_cons_gen : core.

Theorem red_gen_in :
 forall (a : poly A0 eqA ltM) (aP R Q : list (poly A0 eqA ltM)),
 ~
 BuchAux.zerop A A0 eqA n ltM
   (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec os a
      aP) ->
 OBuch
   (addEnd A A0 eqA n ltM
      (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
         os a aP) aP)
   (genPcPf
      (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
         os a aP) aP Q) R ->
 (forall b c : poly A0 eqA ltM, In b aP -> In c aP -> redIn b c aP (a :: Q) R) ->
 forall b : poly A0 eqA ltM,
 In b aP ->
 ~ BuchAux.zerop A A0 eqA n ltM b ->
 redIn
   (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec os a
      aP) b
   (addEnd A A0 eqA n ltM
      (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
         os a aP) aP)
   (genPcPf
      (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
         os a aP) aP Q) R.
Proof.
intros a aP R Q H' H'0 H'1 b H'2 H'3.
lapply (spolyp_addEnd_genPcPf aP);
 [ intros H'5;
    elim
     (H'5 Q
        (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec
           os a aP) b);
    [ intros c E; elim E; intros H'12 H'13; elim H'13; intros H'14 H'15;
       elim H'14;
       [ intros H'16; clear H'14 H'13 E | intros H'16; clear H'14 H'13 E ]
    | idtac
    | idtac
    | idtac ]
 | idtac ]; auto.
apply redIn2 with (c := c); simpl in |- *; auto.
apply redln_cons_gen; auto.
apply redInInclQ with (Q := a :: Q); auto with datatypes.
apply
 ObuchPincl
  with
    (Q := genPcPf
            (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
               ltM_dec os a aP) aP Q); auto.
apply redIn2 with (c := c); simpl in |- *; auto.
apply redIn1.
apply
 red_incl
  with
    (p := addEnd A A0 eqA n ltM
            (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
               ltM_dec os a aP) aP)
    (1 := cs); auto.
apply
 ObuchPincl
  with
    (Q := genPcPf
            (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
               ltM_dec os a aP) aP Q); auto.
apply redln_cons_gen; auto.
apply redInInclQ with (Q := a :: Q); auto with datatypes.
apply
 ObuchPincl
  with
    (Q := genPcPf
            (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
               ltM_dec os a aP) aP Q); auto.
Qed.

Theorem OBuch_Inv :
 forall aP R Q : list (poly A0 eqA ltM),
 OBuch aP Q R ->
 (forall a b : poly A0 eqA ltM, In a aP -> In b aP -> redIn a b aP Q R) ->
 forall a b : poly A0 eqA ltM, In a R -> In b R -> reds a b R.
Proof.
intros aP R Q H'; elim H'; simpl in |- *; auto.
intros aL H'0 a b H'1 H'2; try assumption.
apply redIn_nil; auto.
intros a aP0 Q0 R0 H'0 H'1 H'2 H'3 a0 b H'4 H'5.
apply H'1; auto.
intros a1 b0 H'6.
case (addEnd_cons A A0 eqA n ltM) with (1 := H'6); auto.
intros H'7; rewrite <- H'7; auto.
intros H'8.
case (addEnd_cons A A0 eqA n ltM) with (1 := H'8); auto.
intros H'9; rewrite <- H'9; auto.
apply redIn1; auto.
apply red_id; auto.
intros H'9.
case (zerop_dec A A0 eqA n ltM b0); intros Z; auto.
apply redIn1; auto.
apply zerop_red_spoly_r; auto.
rewrite H'7; auto.
apply red_gen_in; auto.
intros H'7 H'8.
case (addEnd_cons A A0 eqA n ltM) with (1 := H'8); auto.
intros H'9; rewrite <- H'9; auto.
apply redIn0b.
case (zerop_dec A A0 eqA n ltM a1); intros Z.
apply redIn1; auto.
apply zerop_red_spoly_r; auto.
rewrite H'9.
apply red_gen_in; auto.
intros H'9.
apply redln_cons with (c := a); simpl in |- *; auto.
apply redInclP with (P := aP0); auto.
apply redInInclQ with (Q := a :: Q0); auto with datatypes.
unfold incl in |- *; auto.
apply nf_red with (aP := aP0) (cs := cs) (os := os); auto.
apply
 incl_tran
  with
    (m := addEnd A A0 eqA n ltM
            (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
               ltM_dec os a aP0) aP0); auto.
unfold incl in |- *; auto.
apply
 ObuchPincl
  with
    (Q := genPcPf
            (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
               ltM_dec os a aP0) aP0 Q0); auto.
apply red_cons with (1 := cs); auto.
apply
 in_incl
  with
    (p := addEnd A A0 eqA n ltM
            (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
               ltM_dec os a aP0) aP0); simpl in |- *;
 auto.
apply
 ObuchPincl
  with
    (Q := genPcPf
            (nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
               ltM_dec os a aP0) aP0 Q0); auto.
intros a aP0 Q0 R0 H'0 H'1 H'2 H'3 a0 b H'4 H'5.
apply H'1; auto.
intros a1 b0 H'6 H'7.
apply redln_cons with (c := a); auto.
apply red_incl with (p := aP0) (1 := cs); auto.
apply ObuchPincl with (Q := Q0); auto.
apply zerop_red with (cs := cs) (os := os); auto.
Qed.

Theorem addEnd_incl :
 forall (a : poly A0 eqA ltM) (L1 L2 : list (poly A0 eqA ltM)),
 incl (a :: L1) L2 -> incl (addEnd A A0 eqA n ltM a L1) L2.
Proof.
unfold incl in |- *; simpl in |- *; auto.
intros a L1 L2 H' a0 H'0.
case (addEnd_cons A A0 eqA n ltM) with (1 := H'0); auto.
Qed.

Theorem genOCp_redln :
 forall aL1 R : list (poly A0 eqA ltM),
 incl aL1 R ->
 forall a b : poly A0 eqA ltM,
 In a aL1 -> In b aL1 -> redIn a b aL1 (genOCPf aL1) R.
Proof.
intros aL1; elim aL1; simpl in |- *; auto.
intros a l H' R H'0 a0 b H'1 H'2.
elim H'2; [ intros H'3; rewrite <- H'3; clear H'2 | intros H'3; clear H'2 ];
 auto.
elim H'1; [ intros H'2; rewrite <- H'2; clear H'1 | intros H'2; clear H'1 ];
 auto.
apply redIn1; auto.
apply red_id; auto.
apply redIn0b.
case (zerop_dec A A0 eqA n ltM a); intros Z; auto.
apply redIn1; auto.
apply zerop_red_spoly_l; auto.
case (zerop_dec A A0 eqA n ltM a0); intros Z1; auto.
apply redIn1; auto.
apply zerop_red_spoly_r; auto.
lapply (spolyp_addEnd_genPcPf l);
 [ intros H'4; elim (H'4 (genOCPf l) a a0);
    [ intros c E; elim E; intros H'11 H'12; elim H'12; intros H'13 H'14;
       elim H'13;
       [ intros H'15; clear H'13 H'12 E | intros H'15; clear H'13 H'12 E ]
    | idtac
    | idtac
    | idtac ]
 | idtac ]; auto.
apply redIn2 with (c := c); auto.
simpl in |- *; auto.
apply redInInclQ with (Q := genOCPf l); auto.
apply redInclP with (P := l); auto.
apply H'; auto.
apply incl_tran with (m := a :: l); simpl in |- *; auto.
apply redIn2 with (c := c); auto.
simpl in |- *; auto.
apply redIn1; auto.
apply red_incl with (p := addEnd A A0 eqA n ltM a l) (1 := cs); auto.
apply addEnd_incl; auto.
apply redInclP with (P := l); auto.
apply redInInclQ with (Q := genOCPf l); auto.
apply H'; auto.
apply incl_tran with (m := a :: l); auto.
elim H'1; [ intros H'2; rewrite <- H'2; clear H'1 | intros H'2; clear H'1 ];
 auto.
case (zerop_dec A A0 eqA n ltM a); intros Z; auto.
apply redIn1; auto.
apply zerop_red_spoly_l; auto.
case (zerop_dec A A0 eqA n ltM b); intros Z1; auto.
apply redIn1; auto.
apply zerop_red_spoly_r; auto.
lapply (spolyp_addEnd_genPcPf l);
 [ intros H'4; elim (H'4 (genOCPf l) a b);
    [ intros c E; elim E; intros H'11 H'12; elim H'12; intros H'13 H'14;
       elim H'13;
       [ intros H'15; clear H'13 H'12 E | intros H'15; clear H'13 H'12 E ]
    | idtac
    | idtac
    | idtac ]
 | idtac ]; auto.
apply redIn2 with (c := c); simpl in |- *; auto.
apply redInInclQ with (Q := genOCPf l); auto.
apply redInclP with (P := l); auto.
apply H'; auto.
apply incl_tran with (m := a :: l); simpl in |- *; auto.
apply redIn2 with (c := c); simpl in |- *; auto.
apply redIn1; auto.
apply red_incl with (1 := cs) (p := addEnd A A0 eqA n ltM a l); auto.
apply addEnd_incl; auto.
apply redInclP with (P := l); auto.
apply redInInclQ with (Q := genOCPf l); auto.
apply H'; auto.
apply incl_tran with (m := a :: l); auto.
apply redInclP with (P := l); auto.
apply redInInclQ with (Q := genOCPf l); auto.
apply H'; auto.
apply incl_tran with (m := a :: l); auto.
Qed.

Theorem OBuch_Stable_f :
 forall P Q : list (poly A0 eqA ltM), OBuch P (genOCPf P) Q -> stable P Q.
Proof.
intros P Q H'; try assumption.
apply OBuch_Stable with (Q := genOCPf P); auto.
intros a H'0; try assumption.
apply genOCPf_stable; auto.
Qed.

Theorem OBuch_Inv_f :
 forall P Q : list (poly A0 eqA ltM),
 OBuch P (genOCPf P) Q ->
 forall a b : poly A0 eqA ltM, In a Q -> In b Q -> reds a b Q.
Proof.
intros P Q H' a b H'0 H'1; try assumption.
apply OBuch_Inv with (aP := P) (Q := genOCPf P); auto.
intros a0 b0 H'3 H'4.
apply genOCp_redln; auto.
apply ObuchPincl with (Q := genOCPf P); auto.
Qed.

Let FPset (A : list (poly A0 eqA ltM)) := list (poly A0 eqA ltM).

Definition Fl : forall x : list (poly A0 eqA ltM), FPset x -> FPset x -> Prop.
unfold FPset in |- *; simpl in |- *.
intros H' P1 P2.
exact (Tl P1 P2).
Defined.

Theorem wf_Fl : forall x : list (poly A0 eqA ltM), well_founded (Fl x).
Proof.
unfold FPset in |- *; simpl in |- *.
intros x; generalize wf_Tl; auto.
Qed.

Let Co :=
  @lexprod (list (poly A0 eqA ltM)) FPset
    (RO A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec os)
    Fl.

Theorem wf_Co : well_founded Co.
Proof.
unfold Co in |- *; apply wf_lexprod.
apply wf_incl.
exact wf_Fl.
Qed.

Definition PtoS :
  list (poly A0 eqA ltM) * list (poly A0 eqA ltM) -> sigT FPset.
intros H'; case H'.
intros P1 P2.
exact (existT FPset P1 P2).
Defined.

Definition RL (x y : list (poly A0 eqA ltM) * list (poly A0 eqA ltM)) :
  Prop := Co (PtoS x) (PtoS y).

Theorem wf_RL : well_founded RL.
Proof.
apply (wf_inverse_image _ _ Co PtoS); auto.
try exact wf_Co.
Qed.

Definition pbuchf :
  forall PQ : list (poly A0 eqA ltM) * list (poly A0 eqA ltM),
  {R : list (poly A0 eqA ltM) | OBuch (fst PQ) (snd PQ) R}.
intros pq; pattern pq in |- *.
apply
 well_founded_induction_type
  with
    (A := (list (poly A0 eqA ltM) * list (poly A0 eqA ltM))%type)
    (R := RL).
try exact wf_RL.
intros x; elim x.
intros P Q; case Q; simpl in |- *.
intros H'; exists P; auto.
intros a Q2 Rec.
apply
 LetP
  with
    (A := poly A0 eqA ltM)
    (h := nf A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
            ltM_dec os a P).
intros a0 H'.
case (zerop_dec A A0 eqA n ltM a0); intros red10.
elim (Rec (P, Q2)); simpl in |- *; [ intros R E | idtac ]; auto.
exists R; auto.
apply OBuch2; auto.
rewrite <- H'; auto.
red in |- *; unfold Co in |- *; unfold PtoS in |- *.
apply
 (right_lex _ _
    (RO A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec os)
    Fl); auto.
red in |- *; red in |- *; simpl in |- *; auto.
elim (Rec (addEnd A A0 eqA n ltM a0 P, genPcPf a0 P Q2)); simpl in |- *;
 [ intros R E0; try exact E0 | idtac ].
exists R; auto.
apply OBuch1; auto.
rewrite <- H'; auto.
rewrite <- H'; auto.
rewrite H'.
red in |- *; unfold Co in |- *; unfold PtoS in |- *.
apply
 (left_lex _ _
    (RO A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM ltM_dec os)
    Fl); auto.
apply RO_lem; auto.
rewrite <- H'; auto.
Defined.

Definition strip :
  forall P : list (poly A0 eqA ltM) -> Prop, sig P -> list (poly A0 eqA ltM).
intros P H'; case H'.
intros x H'0; try assumption.
Defined.

Theorem pbuchf_Stable :
 forall P R : list (poly A0 eqA ltM),
 R = strip _ (pbuchf (P, genOCPf P)) -> stable P R.
Proof.
simpl in |- *.
intros P R H'; try assumption.
apply OBuch_Stable_f; auto.
rewrite H'.
case (pbuchf (pair P (genOCPf P))); simpl in |- *; auto.
Qed.

Theorem pbuchf_Inv :
 forall P R : list (poly A0 eqA ltM),
 R = strip _ (pbuchf (P, genOCPf P)) ->
 forall a b : poly A0 eqA ltM, In a R -> In b R -> reds a b R.
Proof.
intros P R H' a b H'0 H'1; simpl in |- *.
apply OBuch_Inv_f with (P := P); auto.
rewrite H'; simpl in |- *; auto.
case (pbuchf (P, genOCPf P)); simpl in |- *; auto.
Qed.

Definition buch : list (poly A0 eqA ltM) -> list (poly A0 eqA ltM).
intros P; exact (strip _ (pbuchf (P, genOCPf P))).
Defined.

Theorem buch_Stable : forall P : list (poly A0 eqA ltM), stable P (buch P).
Proof.
intros P; apply pbuchf_Stable; auto.
Qed.

Theorem buch_reds :
 forall (P : list (poly A0 eqA ltM)) (a b : poly A0 eqA ltM),
 In a (buch P) -> In b (buch P) -> reds a b (buch P).
Proof.
intros P a b H' H'0.
apply pbuchf_Inv with (P := P); auto.
Qed.

Theorem reds_SpolyQ :
 forall (P : list (poly A0 eqA ltM)) (a b : poly A0 eqA ltM),
 reds a b P ->
 Spoly_1 A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec P
   (s2p A A0 eqA n ltM a) (s2p A A0 eqA n ltM b).
Proof.
intros P a b H'; elim H'; auto.
intros P0 a0 b0 H'0;
 cut
  (red A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec
     (spolyp A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
        ltM_dec os b0 a0) P0); auto.
case a0; case b0; unfold red in |- *; simpl in |- *; auto.
intros x H'1 x0 H'2 H'3; inversion H'3.
apply Spoly_10 with (Cp := H'2) (Cq := H'1); auto.
apply red_com; auto.
intros P0 a0 b0 c.
case c; case b0; case a0; simpl in |- *.
intros x; case x; simpl in |- *; auto.
intros c0 x0 c1 x1 c2 H'0 H'1 H'2 H'3 H'4 H'5; elim H'5.
intros a1 l c0 x0; case x0; simpl in |- *.
intros c1 x1 c2 H'0 H'1 H'2 H'3 H'4 H'5; elim H'5.
intros a2 l0 c1 x1; case x1; simpl in |- *.
intros c2 H'0 H'1 H'2 H'3 H'4 H'5; elim H'5.
intros a3 l1 c2 H'0 H'1 H'2 H'3 H'4 H'5.
change
  (Spoly_1 A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec P0
     (pX a1 l) (pX a2 l0)) in |- *.
apply Spoly_11 with (d := a3) (t := l1); auto.
change
  (inPolySet A A0 eqA n ltM
     (s2p A A0 eqA n ltM (mks A A0 eqA n ltM (pX a3 l1) c2)) P0)
 in |- *.
apply in_inPolySet; simpl in |- *; auto.
red in |- *; intros H; inversion H.
Qed.

Theorem imp_in :
 forall (P : list (poly A0 eqA ltM)) (a : list (Term A n)),
 inPolySet A A0 eqA n ltM a P ->
 exists b : poly A0 eqA ltM, In b P /\ a = s2p A A0 eqA n ltM b.
Proof.
intros P a H'; elim H'; auto.
intros a0 p H P0;
 exists
  (exist (fun l0 : list (Term A n) => canonical A0 eqA ltM l0) (pX a0 p) H);
 split; auto.
simpl in |- *; auto.
intros a0 p P0 H'0 H'1; elim H'1; intros b E; elim E; intros H'2 H'3;
 clear E H'1; auto.
exists b; split; auto with datatypes.
Qed.

Theorem reds_SpolyQ1 :
 forall P : list (poly A0 eqA ltM),
 (forall a b : poly A0 eqA ltM, In a P -> In b P -> reds a b P) ->
 SpolyQ A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec P.
Proof.
intros P H'.
apply SpolyQ0; auto.
intros p q H'0 H'1 H'2 H'3.
elim (imp_in P p); [ intros b E; elim E; intros H'7 H'8; clear E | idtac ];
 auto.
rewrite H'8.
elim (imp_in P q); [ intros b0 E; elim E; intros H'9 H'10; clear E | idtac ];
 auto.
rewrite H'10.
apply reds_SpolyQ; auto.
Qed.

Theorem buch_spolyQ :
 forall P : list (poly A0 eqA ltM),
 SpolyQ A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec (buch P).
Proof.
intros P.
apply reds_SpolyQ1; auto.
intros; apply buch_reds; auto.
Qed.

Theorem buch_Grobner :
 forall P : list (poly A0 eqA ltM),
 Grobner A A0 A1 eqA plusA invA minusA multA divA eqA_dec n ltM ltM_dec
   (buch P).
Proof.
intros P.
apply ConfluentReduce_imp_Grobner; auto.
apply SpolyQ_imp_ConfluentReduce with (1 := cs); auto.
apply buch_spolyQ; auto.
Qed.

End Buch.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2013 Sylvie Boldo
#<br />#
Copyright (C) 2010-2013 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Floating-point format without underflow *)
Require Import Fcore_Raux.
Require Import Fcore_defs.
Require Import Fcore_rnd.
Require Import Fcore_generic_fmt.
Require Import Fcore_float_prop.
Require Import Fcore_FIX.
Require Import Fcore_ulp.
Require Import Fcore_rnd_ne.

Section RND_FLX.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable prec : Z.

Class Prec_gt_0 :=
  prec_gt_0 : (0 < prec)%Z.

Context { prec_gt_0_ : Prec_gt_0 }.

(* unbounded floating-point format *)
Definition FLX_format (x : R) :=
  exists f : float beta,
  x = F2R f /\ (Z.abs (Fnum f) < Zpower beta prec)%Z.

Definition FLX_exp (e : Z) := (e - prec)%Z.

(** Properties of the FLX format *)

Global Instance FLX_exp_valid : Valid_exp FLX_exp.
Proof.
intros k.
unfold FLX_exp.
generalize prec_gt_0.
repeat split ; intros ; omega.
Qed.

Theorem FIX_format_FLX :
  forall x e,
  (bpow (e - 1) <= Rabs x <= bpow e)%R ->
  FLX_format x ->
  FIX_format beta (e - prec) x.
Proof.
clear prec_gt_0_.
intros x e Hx ((xm, xe), (H1, H2)).
rewrite H1, (F2R_prec_normalize beta xm xe e prec).
now eexists.
exact H2.
now rewrite <- H1.
Qed.

Theorem FLX_format_generic :
  forall x, generic_format beta FLX_exp x -> FLX_format x.
Proof.
intros x H.
rewrite H.
unfold FLX_format.
eexists ; repeat split.
simpl.
apply lt_Z2R.
rewrite Z2R_abs.
rewrite <- scaled_mantissa_generic with (1 := H).
rewrite <- scaled_mantissa_abs.
apply Rmult_lt_reg_r with (bpow (canonic_exp beta FLX_exp (Rabs x))).
apply bpow_gt_0.
rewrite scaled_mantissa_mult_bpow.
rewrite Z2R_Zpower, <- bpow_plus.
2: now apply Zlt_le_weak.
unfold canonic_exp, FLX_exp.
ring_simplify (prec + (ln_beta beta (Rabs x) - prec))%Z.
rewrite ln_beta_abs.
destruct (Req_dec x 0) as [Hx|Hx].
rewrite Hx, Rabs_R0.
apply bpow_gt_0.
destruct (ln_beta beta x) as (ex, Ex).
now apply Ex.
Qed.

Theorem generic_format_FLX :
  forall x, FLX_format x -> generic_format beta FLX_exp x.
Proof.
clear prec_gt_0_.
intros x ((mx,ex),(H1,H2)).
simpl in H2.
rewrite H1.
apply generic_format_F2R.
intros Zmx.
unfold canonic_exp, FLX_exp.
rewrite ln_beta_F2R with (1 := Zmx).
apply Zplus_le_reg_r with (prec - ex)%Z.
ring_simplify.
now apply ln_beta_le_Zpower.
Qed.

Theorem FLX_format_satisfies_any :
  satisfies_any FLX_format.
Proof.
refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLX_exp)).
intros x.
split.
apply FLX_format_generic.
apply generic_format_FLX.
Qed.

Theorem FLX_format_FIX :
  forall x e,
  (bpow (e - 1) <= Rabs x <= bpow e)%R ->
  FIX_format beta (e - prec) x ->
  FLX_format x.
Proof with auto with typeclass_instances.
intros x e Hx Fx.
apply FLX_format_generic.
apply generic_format_FIX in Fx.
revert Fx.
apply generic_inclusion with (e := e)...
apply Z.le_refl.
Qed.

(** unbounded floating-point format with normal mantissas *)
Definition FLXN_format (x : R) :=
  exists f : float beta,
  x = F2R f /\ (x <> R0 ->
  Zpower beta (prec - 1) <= Z.abs (Fnum f) < Zpower beta prec)%Z.

Theorem generic_format_FLXN :
  forall x, FLXN_format x -> generic_format beta FLX_exp x.
Proof.
intros x ((xm,ex),(H1,H2)).
destruct (Req_dec x 0) as [Zx|Zx].
rewrite Zx.
apply generic_format_0.
specialize (H2 Zx).
apply generic_format_FLX.
rewrite H1.
eexists ; repeat split.
apply H2.
Qed.

Theorem FLXN_format_generic :
  forall x, generic_format beta FLX_exp x -> FLXN_format x.
Proof.
intros x Hx.
rewrite Hx.
simpl.
eexists ; split. split.
simpl.
rewrite <- Hx.
intros Zx.
split.
(* *)
apply le_Z2R.
rewrite Z2R_Zpower.
2: now apply Zlt_0_le_0_pred.
rewrite Z2R_abs, <- scaled_mantissa_generic with (1 := Hx).
apply Rmult_le_reg_r with (bpow (canonic_exp beta FLX_exp x)).
apply bpow_gt_0.
rewrite <- bpow_plus.
rewrite <- scaled_mantissa_abs.
rewrite <- canonic_exp_abs.
rewrite scaled_mantissa_mult_bpow.
unfold canonic_exp, FLX_exp.
rewrite ln_beta_abs.
ring_simplify (prec - 1 + (ln_beta beta x - prec))%Z.
destruct (ln_beta beta x) as (ex,Ex).
now apply Ex.
(* *)
apply lt_Z2R.
rewrite Z2R_Zpower.
2: now apply Zlt_le_weak.
rewrite Z2R_abs, <- scaled_mantissa_generic with (1 := Hx).
apply Rmult_lt_reg_r with (bpow (canonic_exp beta FLX_exp x)).
apply bpow_gt_0.
rewrite <- bpow_plus.
rewrite <- scaled_mantissa_abs.
rewrite <- canonic_exp_abs.
rewrite scaled_mantissa_mult_bpow.
unfold canonic_exp, FLX_exp.
rewrite ln_beta_abs.
ring_simplify (prec + (ln_beta beta x - prec))%Z.
destruct (ln_beta beta x) as (ex,Ex).
now apply Ex.
Qed.

Theorem FLXN_format_satisfies_any :
  satisfies_any FLXN_format.
Proof.
refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLX_exp)).
split ; intros H.
now apply FLXN_format_generic.
now apply generic_format_FLXN.
Qed.

Theorem ulp_FLX_0: (ulp beta FLX_exp 0 = 0)%R.
Proof.
unfold ulp; rewrite Req_bool_true; trivial.
case (negligible_exp_spec FLX_exp).
intros _; reflexivity.
intros n H2; contradict H2.
unfold FLX_exp; unfold Prec_gt_0 in prec_gt_0_; omega.
Qed.

Theorem ulp_FLX_le: forall x, (ulp beta FLX_exp x <= Rabs x * bpow (1-prec))%R.
Proof.
intros x; case (Req_dec x 0); intros Hx.
rewrite Hx, ulp_FLX_0, Rabs_R0.
right; ring.
rewrite ulp_neq_0; try exact Hx.
unfold canonic_exp, FLX_exp.
replace (ln_beta beta x - prec)%Z with ((ln_beta beta x - 1) + (1-prec))%Z by ring.
rewrite bpow_plus.
apply Rmult_le_compat_r.
apply bpow_ge_0.
now apply bpow_ln_beta_le.
Qed.

Theorem ulp_FLX_ge: forall x, (Rabs x * bpow (-prec) <= ulp beta FLX_exp x)%R.
Proof.
intros x; case (Req_dec x 0); intros Hx.
rewrite Hx, ulp_FLX_0, Rabs_R0.
right; ring.
rewrite ulp_neq_0; try exact Hx.
unfold canonic_exp, FLX_exp.
unfold Zminus; rewrite bpow_plus.
apply Rmult_le_compat_r.
apply bpow_ge_0.
left; now apply bpow_ln_beta_gt.
Qed.

(** FLX is a nice format: it has a monotone exponent... *)
Global Instance FLX_exp_monotone : Monotone_exp FLX_exp.
Proof.
intros ex ey Hxy.
now apply Zplus_le_compat_r.
Qed.

(** and it allows a rounding to nearest, ties to even. *)
Hypothesis NE_prop : Zeven beta = false \/ (1 < prec)%Z.

Global Instance exists_NE_FLX : Exists_NE beta FLX_exp.
Proof.
destruct NE_prop as [H|H].
now left.
right.
unfold FLX_exp.
split ; omega.
Qed.

End RND_FLX.


Require Import FP.Core.
Require Import FP.Data.Nat.
Require Import FP.Data.String.
Require Import FP.Data.ListSet.
Require Import FP.Data.Bool.
Require Import FP.Data.WF.
Require Import FP.Data.Unit.
Require Import FP.Data.Prop.
Require Import FP.Data.PSet.
Require Import FP.Classes.Lattice.
Require Import FP.Classes.Monad.
Require Import FP.Classes.MGalois.

Inductive v_lang :=
  | v_Halt : v_lang
  | v_Times : dom nat -> v_lang -> v_lang.
Definition lang := lib v_lang.
Definition Halt : dom lang := v_Halt.
Definition Times : dom (nat ⇒ lang ⇒ lang) := λ n l → (v_Times : dom nat -> dom lang -> dom lang) n l.
Fixpoint _lang_elim {A} (l:dom lang) : dom (A ⇒ (nat ⇒ A ⇒ A) ⇒ A) := λ h t →
  match l with
  | v_Halt => h
  | v_Times n l => t ∙ n ∙ (_lang_elim l ∙ h ∙ t)
  end.
Definition lang_elim {A} : dom (lang ⇒ A ⇒ (nat ⇒ A ⇒ A) ⇒ A) := λ l → _lang_elim l.
Global Opaque Halt.
Global Opaque Times.
Global Opaque lang_elim.
Ltac lang_induction e :=
  induction e ;
  repeat
    match goal with
    | H : context [v_Halt] |- _ => change v_Halt with Halt in H
    | H : context [v_Times ?n ?l] |- _ => change (v_Times n l) with (Times ∙ n ∙ l) in H
    | |- context [v_Halt] => change v_Halt with Halt
    | |- context [v_Times ?n ?l] => change (v_Times n l) with (Times ∙ n ∙ l)
    end.
Definition lang_elim_beta_Halt {A} (h:dom A) (t:dom (nat ⇒ A ⇒ A))
: lang_elim ∙ Halt ∙ h ∙ t ≃ h := libReflexivity.
Definition lang_elim_beta_Times {A} (h:dom A) (t:dom (nat ⇒ A ⇒ A)) n l
: lang_elim ∙ (Times ∙ n ∙ l) ∙ h ∙ t ≃ t ∙ n ∙ (lang_elim ∙ l ∙ h ∙ t) := libReflexivity.
Definition lang_elim_eta (e:dom lang) : lang_elim ∙ e ∙ Halt ∙ Times ≃ e.
Proof.
  lang_induction e.
  - LibReflexivity.
  - change (Times ∙ d ∙ (lang_elim ∙ e ∙ Halt ∙ Times) ≃ Times ∙ d ∙ e).
    qproper_elim.
Qed.
Ltac LangRewrite :=
  match goal with
  | |- ⟨ lang_elim ∙ Halt ∙ ?h ∙ ?t IN _ |_| _ ⟩ => ReplaceBy (lang_elim_beta_Halt h t)
  | |- ⟨ lang_elim ∙ (Times ∙ ?n ∙ ?l) ∙ ?h ∙ ?t IN _ |_| _ ⟩ => ReplaceBy (lang_elim_beta_Times h t n l)
  | |- ⟨ lang_elim ∙ ?e ∙ Halt ∙ Times IN _ |_| _ ⟩ => ReplaceBy (lang_elim_eta e)
  end.

Inductive v_abstract :=
  | v_Top
  | v_Even
  | v_Odd
  | v_Bot.
Inductive v_abstract_lte : relation v_abstract :=
  | BotLte : forall a, v_abstract_lte v_Bot a
  | TopLte : forall a, v_abstract_lte a v_Top.
Instance : Eqv v_abstract := lib_Eqv.
Instance : Lte v_abstract := { lte := v_abstract_lte }.
Admitted.
Definition abstract := {| qdom := v_abstract |}.
Definition Top : dom abstract := v_Top.
Definition Even : dom abstract := v_Even.
Definition Odd : dom abstract := v_Odd.
Definition Bot : dom abstract := v_Bot.
Definition abstract_elim {A}
: dom (abstract ⇒ (unit ⇒ A) ⇒ (unit ⇒ A) ⇒ (unit ⇒ A) ⇒ (unit ⇒ A) ⇒ A) := λ a t e o b →
    match a : dom abstract with
    | v_Top => t ∙ tt
    | v_Even => e ∙ tt
    | v_Odd => o ∙ tt
    | v_Bot => b ∙ tt
    end.
Global Opaque Top.
Global Opaque Even.
Global Opaque Odd.
Global Opaque Bot.
Global Opaque abstract_elim.
Ltac abstract_induction e :=
  induction e ;
  repeat
    match goal with
    | H : context [v_Top] |- _ => change v_Top with Top in H
    | H : context [v_Even] |- _ => change v_Even with Even in H
    | H : context [v_Odd] |- _ => change v_Odd with Odd in H
    | H : context [v_Bot] |- _ => change v_Bot with Bot in H
    | |- context [v_Top] => change v_Top with Top
    | |- context [v_Even] => change v_Even with Even
    | |- context [v_Odd] => change v_Odd with Odd
    | |- context [v_Bot] => change v_Bot with Bot
    end.
Definition abstract_elim_beta_Top {A} t e o b
: abstract_elim (A:=A) ∙ Top ∙ t ∙ e ∙ o ∙ b ≃ t ∙ tt := libReflexivity.
Definition abstract_elim_beta_Even {A} t e o b
: abstract_elim (A:=A) ∙ Even ∙ t ∙ e ∙ o ∙ b ≃ e ∙ tt := libReflexivity.
Definition abstract_elim_beta_Odd {A} t e o b
: abstract_elim (A:=A) ∙ Odd ∙ t ∙ e ∙ o ∙ b ≃ o ∙ tt := libReflexivity.
Definition abstract_elim_beta_Bot {A} t e o b
: abstract_elim (A:=A) ∙ Bot ∙ t ∙ e ∙ o ∙ b ≃ b ∙ tt := libReflexivity.
Ltac AbstractRewrite :=
  match goal with
  | |- ⟨ abstract_elim ∙ Top ∙ ?t ∙ ?e ∙ ?o ∙ ?b IN _ |_| _ ⟩ => ReplaceBy (abstract_elim_beta_Top t e o b)
  | |- ⟨ abstract_elim ∙ Even ∙ ?t ∙ ?e ∙ ?o ∙ ?b IN _ |_| _ ⟩ => ReplaceBy (abstract_elim_beta_Even t e o b)
  | |- ⟨ abstract_elim ∙ Odd ∙ ?t ∙ ?e ∙ ?o ∙ ?b IN _ |_| _ ⟩ => ReplaceBy (abstract_elim_beta_Odd t e o b)
  | |- ⟨ abstract_elim ∙ Bot ∙ ?t ∙ ?e ∙ ?o ∙ ?b IN _ |_| _ ⟩ => ReplaceBy (abstract_elim_beta_Bot t e o b)
  end.

Inductive v_alang :=
  | v_AHalt : v_alang
  | v_ATimes : dom abstract -> v_alang -> v_alang.
Inductive v_alang_lte : relation v_alang :=
  | AHaltLte : v_alang_lte v_AHalt v_AHalt
  | ATimesLte : forall a₁ a₂ l, a₁ ⊑ a₂ -> v_alang_lte (v_ATimes a₁ l) (v_ATimes a₂ l).
Instance : Eqv v_alang := lib_Eqv.
Instance : Lte v_alang := { lte := v_alang_lte }.
Admitted.
Definition alang := {| qdom := v_alang |}.
Definition AHalt : dom alang := v_AHalt.
Definition ATimes : dom (abstract ⇒ alang ⇒ alang) := λ a al →
  (v_ATimes : dom abstract -> dom alang -> dom alang) a al.
Fixpoint _alang_elim {A} (al:dom alang)  : dom (A ⇒ (abstract ⇒ A ⇒ A) ⇒ A) := λ hp fp →
  match al with
  | v_AHalt => hp
  | v_ATimes a al => fp ∙ a $ _alang_elim al ∙ hp ∙ fp
  end.
Definition alang_elim {A} : dom (alang ⇒ A ⇒ (abstract ⇒ A ⇒ A) ⇒ A) := λ a → _alang_elim a.
Global Opaque AHalt.
Global Opaque ATimes.
Global Opaque alang_elim.
Ltac alang_induction e :=
  induction e ;
  repeat
    match goal with
    | H : context [v_AHalt] |- _ => change v_AHalt with AHalt in H
    | H : context [v_ATimes ?a ?al] |- _ => change (v_ATimes a al) with (ATimes ∙ a ∙ al) in H
    | |- context [v_AHalt] => change v_AHalt with AHalt
    | |- context [v_ATimes ?a ?al] => change (v_ATimes a al) with (ATimes ∙ a ∙ al)
    end.
Definition alang_elimM {m A} `{! Monad m } : dom (alang ⇒ A ⇒ (abstract ⇒ A ⇒ m A) ⇒ m A) := λ a hp tp →
  alang_elim ∙ a ∙ (ret ∙ hp) ∙ (λ a r → tp ∙ a =<< r).
Definition alang_elim_beta_AHalt {A} (h:dom A) (f:dom (abstract ⇒ A ⇒ A))
: alang_elim ∙ AHalt ∙ h ∙ f ≃ h := libReflexivity.
Definition alang_elim_beta_ATimes {A} (h:dom A) (f:dom (abstract ⇒ A ⇒ A)) a al
: alang_elim ∙ (ATimes ∙ a ∙ al) ∙ h ∙ f ≃ f ∙ a ∙ (alang_elim ∙ al ∙ h ∙ f) := libReflexivity.
Definition alang_elim_eta (e:dom alang) : alang_elim ∙ e ∙ AHalt ∙ ATimes ≃ e.
Proof.
  alang_induction e.
  - LibReflexivity.
  - change (ATimes ∙ d ∙ (alang_elim ∙ e ∙ AHalt ∙ ATimes) ≃ ATimes ∙ d ∙ e).
    qproper_elim.
Qed.
Ltac AlangRewrite :=
  match goal with
  | |- ⟨ alang_elim ∙ AHalt ∙ ?h ∙ ?f IN _ |_| _ ⟩ => ReplaceBy (alang_elim_beta_AHalt h f)
  | |- ⟨ alang_elim ∙ (ATimes ∙ ?a ∙ ?al) ∙ ?h ∙ ?f IN _ |_| _ ⟩ => ReplaceBy (alang_elim_beta_ATimes h f a al)
  | |- ⟨ alang_elim ∙ ?e ∙ AHalt ∙ ATimes IN _ |_| _ ⟩ => ReplaceBy (alang_elim_eta e)
  end.

Instance : Lattice alang.
Admitted.

Definition decEven : dom (nat ⇒ bool) := undefined.

Inductive v_isEven : dom nat -> Prop :=
  | ZEven : v_isEven vZ
  | SEven : forall n, v_isEven n -> v_isEven (vS (vS n)).
Inductive v_isOdd : dom nat -> Prop :=
  | ZOdd : v_isOdd (vS vZ)
  | SOdd : forall n, v_isOdd n -> v_isOdd (vS (vS n)).

Definition isEven : dom (nat ⇒ prop) := λ n → v_isEven n : dom prop.
Definition isOdd : dom (nat ⇒ prop) := λ n → v_isOdd n : dom prop.

Definition αnat : dom (nat ⇒ abstract) := λ n →
  case ∙ (decEven ∙ n) ∙ (λ _ → Even) ∙ (λ _ → Odd).
Definition γTop : dom (wfT listSet nat) := wfT_fix $ λ γTop →
  ret ∙ Z m+ ret ∙ (S ∙ γTop).
Definition γTop2 : dom (pset nat) := suniversal.

Definition γEven : dom (wfT listSet nat) := wfT_fix $ λ γEven →
  ret ∙ Z m+ ret ∙ (S $ S ∙ γEven).
Definition γEven2 : dom (pset nat) := PSet ∙ isEven.

Definition γOdd : dom (wfT listSet nat) := wfT_fix $ λ γOdd →
  ret ∙ (S ∙ Z) m+ ret ∙ (S $ S ∙ γOdd).
Definition γOdd2 : dom (pset nat) := PSet ∙ isOdd.

Definition γnat : dom (abstract ⇒ wfT listSet nat) := λ a →
  abstract_elim ∙ a
    ∙ (λ _ → γTop)
    ∙ (λ _ → γEven)
    ∙ (λ _ → γOdd)
    ∙ (λ _ → mzero).

Instance : MGalois (wfT listSet) nat abstract :=
  { mgaloisα := kret ∙ αnat
  ; mgaloisγ := γnat
  }.
Proof.
  - qproper_elim.
    Re fail || match goal with |- ⟨ y IN _ |_| _ ⟩ => StrengthenBy H end.
    clear H y.
    abstract_induction x ; Re fail || AbstractRewrite.
    + admit.
    + unfold γEven.
      EnterLeft ; PushFun ; PushArg.
      match goal with |- ⟨ wfT_fix ∙ ?f IN _ |_| _ ⟩ => ReplaceBy (wfT_fix_beta f) end.
      PopArg ; PopFun ; ExitLeft.
      Re fail || MonadRewrite.
      simpl.
    + admit.
    + admit.
  - admit.
Defined.

(* (nat -> Prop) -> nat -> anat

     abs : nat -> anat
     conc : anat -> nat -> Prop

     forall n, conc (abs n) n     (soundness)
     forall a, (forall n, (conc a) n -> abs n = a)

     step_conc : nat -> nat
     step_abs  : anat -> anat

     1. forall n, abs (step_conc n) <= step_abs (abs n)
     2. forall a, (forall n, conc a n ->
                      abs (conc_step n) <= abs_step a)
*)

Definition αlang : dom (lang ⇒ alang) := λ l →
  lang_elim ∙ l ∙ AHalt $ λ n al → ATimes ∙ (αnat ∙ n) ∙ al.
Definition αlangM : dom (lang ⇒ wfT listSet alang) := kret ∙ αlang.
Definition γlangM : dom (alang ⇒ wfT listSet lang) := λ a →
  alang_elimM ∙ a ∙ Halt $ λ a l →
    n ← γnat ∙ a ;;
    ret $ Times ∙ n ∙ l.

Section MGalois.
  Instance : MGalois (wfT listSet) lang alang :=
    { mgaloisα := αlangM
    ; mgaloisγ := γlangM
    }.
  Proof.
    - Local Opaque αnat.
      Local Opaque γnat.
      Local Opaque γlangM.
      apply qmonotonic_intro ; unfold "⇉" ; intros ; simpl.
      Re fail || match goal with |- ⟨ y IN _ |_| _ ⟩ => StrengthenBy H end.
      clear H y.
      alang_induction x ; Re fail || LangRewrite || AlangRewrite || MonadRewrite.
      EnterLeft.
 Admitted.
End MGalois.
      (*
      ReplaceBy (bind_associativity (A:=abstract) (alang_elim ∙  _ αlangM).
      MonadRewrite.
      PushFun.
      PushArg.
      apply (lte_replace_lte IHx).
      WeakenBy IHx.
      Re fail || WeakenBy IHx.
      idtac.
      match goal with
      | IHx : ?t |- _ => assert t
      end.
      Re fail || LangRewrite || AlangRewrite || MonadRewrite.
      epose (_=IHx).
      eapply IHx.
      + simpl.
      match goal with
      | |- context E[ alang_elimM ∙ ?e ∙ _ ∙ _ ] => eapply alang_indM (typeof E) _ _
      Re fail || MonadRewrite.
      Re fail || match goal with |- ⟨ x IN _ |LTE| _ ⟩ => WeakenBy H end.
      EnterLeft.
      PushFun.
      PushArg.
      PushFun.
      PushFun.
      PushArg.
      apply (replaceBy H).
      simpl.
*)


(**************************************************************************
* TLC: A library for Coq                                                  *
* Equality                                                                  *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibAxioms.
Generalizable Variables A.

(* ********************************************************************** *)
(** * Partial application of Leibnitz' equality *)

(** [= x] is a unary predicate which holds of values equal to [x].
    It simply denotes the partial application of equality.
    [= x :> A] allows to specify the type. *)

Notation "'=' x :> A" := (fun y => y = x :> A)
  (at level 71, x at next level).
Notation "'=' x" := (fun y => y = x)
  (at level 71).

(** [<> x] is a unary predicate which holds of values disequal to [x].
    It simply denotes the partial application of disequality.
    [<> x :> A] allows to specify the type. *)

Notation "'<>' x :> A" := (fun y => y <> x :> A)
  (at level 71, x at next level).
Notation "'<>' x" := (fun y => y <> x)
  (at level 71).

(* ********************************************************************** *)
(** * Functional extensionality *)

(* ---------------------------------------------------------------------- *)
(** ** Dependent functional extensionality *)

Section FuncExtDep.
Variables
  (A1 : Type)
  (A2 : forall (x1 : A1), Type)
  (A3 : forall (x1 : A1) (x2 : A2 x1), Type)
  (A4 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2), Type)
  (A5 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3), Type)
  (A6 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3) (x5 : A5 x4), Type).

Lemma func_ext_dep_1 : forall (f g : forall (x1:A1), A2 x1),
  (forall x1, f x1 = g x1) -> f = g.
Proof. repeat (intros; apply func_ext_dep). auto. Qed.

Lemma func_ext_dep_2 : forall (f g : forall (x1:A1) (x2:A2 x1), A3 x2),
  (forall x1 x2, f x1 x2 = g x1 x2) -> f = g.
Proof. repeat (intros; apply func_ext_dep). auto. Qed.

Lemma func_ext_dep_3 : forall (f g : forall (x1:A1) (x2:A2 x1) (x3:A3 x2), A4 x3),
  (forall x1 x2 x3, f x1 x2 x3 = g x1 x2 x3) -> f = g.
Proof. repeat (intros; apply func_ext_dep). auto. Qed.

Lemma func_ext_dep_4 : forall (f g: forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3), A5 x4),
  (forall x1 x2 x3 x4, f x1 x2 x3 x4 = g x1 x2 x3 x4) -> f = g.
Proof. repeat (intros; apply func_ext_dep). auto. Qed.

End FuncExtDep.

(* ---------------------------------------------------------------------- *)
(** ** Non-dependent functional extensionality *)

Lemma func_ext_1 : forall A1 B (f g : A1 -> B),
  (forall x1, f x1 = g x1) -> f = g.
Proof. intros. apply~ func_ext_dep_1. Qed.

Lemma func_ext_2 : forall A1 A2 B (f g : A1 -> A2 -> B),
  (forall x1 x2, f x1 x2 = g x1 x2) -> f = g.
Proof. intros. apply~ func_ext_dep_2. Qed.

Lemma func_ext_3 : forall A1 A2 A3 B (f g : A1 -> A2 -> A3 -> B),
  (forall x1 x2 x3, f x1 x2 x3 = g x1 x2 x3) -> f = g.
Proof. intros. apply~ func_ext_dep_3. Qed.

Lemma func_ext_4 : forall A1 A2 A3 A4 B (f g : A1 -> A2 -> A3 -> A4 -> B),
  (forall x1 x2 x3 x4, f x1 x2 x3 x4 = g x1 x2 x3 x4) -> f = g.
Proof. intros. apply~ func_ext_dep_4. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Eta-conversion *)

Lemma func_eta_dep : forall (A:Type) (B:A->Type) (f : forall x, B x),
  (fun x1 => f x1) = f.
Proof. intros. apply~ func_ext_dep. Qed.

Lemma func_eta_1 : forall A1 B (f : A1 -> B),
  (fun x1 => f x1) = f.
Proof. intros. apply~ func_ext_1. Qed.

Lemma func_eta_2 : forall A1 A2 B (f : A1 -> A2 -> B),
  (fun x1 x2 => f x1 x2) = f.
Proof. intros. apply~ func_ext_2. Qed.

Lemma func_eta_3 : forall A1 A2 A3 B (f : A1 -> A2 -> A3 -> B),
  (fun x1 x2 x3 => f x1 x2 x3) = f.
Proof. intros. apply~ func_ext_3. Qed.

Lemma func_eta_4 : forall A1 A2 A3 A4 B (f : A1 -> A2 -> A3 -> A4 -> B),
  (fun x1 x2 x3 x4 => f x1 x2 x3 x4) = f.
Proof. intros. apply~ func_ext_4. Qed.

Hint Rewrite func_eta_1 func_eta_2 func_eta_3 func_eta_4 : rew_eta.

(* ********************************************************************** *)
(** * Predicate extensionality *)

(* ---------------------------------------------------------------------- *)
(** ** Dependend predicates *)

Section PropExt.
Variables
  (A1 : Type)
  (A2 : forall (x1 : A1), Type)
  (A3 : forall (x1 : A1) (x2 : A2 x1), Type)
  (A4 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2), Type)
  (A5 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3), Type)
  (A6 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3) (x5 : A5 x4), Type).

Lemma prop_ext_1 : forall (P Q : forall (x1:A1), Prop),
  (forall x1, P x1 <-> Q x1) -> P = Q.
Proof. repeat (intros; apply func_ext_dep). intros. apply~ prop_ext. Qed.

Lemma prop_ext_2 : forall (P Q : forall (x1:A1) (x2:A2 x1), Prop),
  (forall x1 x2, P x1 x2 <-> Q x1 x2) -> P = Q.
Proof. repeat (intros; apply func_ext_dep). intros. apply~ prop_ext. Qed.

Lemma prop_ext_3 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2), Prop),
  (forall x1 x2 x3, P x1 x2 x3 <-> Q x1 x2 x3) -> P = Q.
Proof. repeat (intros; apply func_ext_dep). intros. apply~ prop_ext. Qed.

Lemma prop_ext_4 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3), Prop),
  (forall x1 x2 x3 x4, P x1 x2 x3 x4 <-> Q x1 x2 x3 x4) -> P = Q.
Proof. repeat (intros; apply func_ext_dep). intros. apply~ prop_ext. Qed.

Lemma prop_ext_5 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3) (x5:A5 x4), Prop),
  (forall x1 x2 x3 x4 x5, P x1 x2 x3 x4 x5 <-> Q x1 x2 x3 x4 x5) -> P = Q.
Proof. repeat (intros; apply func_ext_dep). intros. apply~ prop_ext. Qed.

Lemma prop_ext_6 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3) (x5:A5 x4) (x6:A6 x5), Prop),
  (forall x1 x2 x3 x4 x5 x6, P x1 x2 x3 x4 x5 x6 <-> Q x1 x2 x3 x4 x5 x6) -> P = Q.
Proof. repeat (intros; apply func_ext_dep). intros. apply~ prop_ext. Qed.

End PropExt.

(* ---------------------------------------------------------------------- *)
(** ** Non-dependend predicates *)

Lemma prop_ext_nd_1 : forall A1 (P Q : A1 -> Prop),
  (forall x1, P x1 <-> Q x1) -> P = Q.
Proof. intros. apply~ prop_ext_1. Qed.

Lemma prop_ext_nd_2 : forall A1 A2 (P Q : A1 -> A2 -> Prop),
  (forall x1 x2, P x1 x2 <-> Q x1 x2) -> P = Q.
Proof. intros. apply~ prop_ext_2. Qed.

Lemma prop_ext_nd_3 : forall A1 A2 A3 (P Q : A1 -> A2 -> A3 -> Prop),
  (forall x1 x2 x3, P x1 x2 x3 <-> Q x1 x2 x3) -> P = Q.
Proof. intros. apply~ prop_ext_3. Qed.

Lemma prop_ext_nd_4 : forall A1 A2 A3 A4 (P Q : A1 -> A2 -> A3 -> A4 -> Prop),
  (forall x1 x2 x3 x4, P x1 x2 x3 x4 <-> Q x1 x2 x3 x4) -> P = Q.
Proof. intros. apply~ prop_ext_4. Qed.

(* ********************************************************************** *)
(** * Proof Irrelevance *)

(** The proof irrelevance lemma states that two proofs of a same
    proposition are always equal. *)

(* ---------------------------------------------------------------------- *)
(** ** Proof of the proof-irrelevance result *)

(** Proof irrelevance is a consequence of propositional extensionality. *)

(* TODO: simplify and beautify the proof *)

Module PIfromExt.
  Notation Local inhabited A := A (only parsing).

  Lemma prop_ext_to_eq_arrow :
    forall (A:Prop), inhabited A -> (A -> A) = A.
  Proof. intros. apply* prop_ext. Qed.

  Record retract (A B : Prop) : Prop :=
  { retract_f1 : A -> B;
    retract_f2 : B -> A;
    retract_comp : forall x, retract_f1 (retract_f2 x) = x }.

  Lemma prop_ext_retract_A_A_imp_A :
    forall (A:Prop), inhabited A -> retract A (A -> A).
  Proof.
  intros A a. rewrite (prop_ext_to_eq_arrow a).
  apply~ (@Build_retract A A (fun x => x) (fun x => x)).
  Qed.

  Record has_fixpoint (A:Prop) : Prop :=
    { has_fixpoint_F : (A -> A) -> A;
      has_fixpoint_fix : forall f, has_fixpoint_F f = f (has_fixpoint_F f) }.

  Lemma ext_prop_fixpoint :
    forall (A:Prop), inhabited A -> has_fixpoint A.
  Proof.
  intros A a. destruct (prop_ext_retract_A_A_imp_A a) as [g1 g2 Fix].
  set (Y := fun f => (fun x => f (g1 x x)) (g2 (fun x => f (g1 x x)))).
  exists Y. intros f. unfold Y at 1. rewrite~ Fix.
  Qed.

 Inductive boolP : Prop :=
    | trueP : boolP
    | falseP : boolP.
  Definition boolP_elim_redl (C:Prop) (c1 c2:C) :
    c1 = boolP_ind c1 c2 trueP := refl_equal c1.
  Definition boolP_elim_redr (C:Prop) (c1 c2:C) :
    c2 = boolP_ind c1 c2 falseP := refl_equal c2.
  Scheme boolP_indd := Induction for boolP Sort Prop.

 Lemma aux : trueP = falseP.
  Proof.
    case (@ext_prop_fixpoint boolP trueP); intros G Gfix.
    set (neg := fun b:boolP => @boolP_ind boolP falseP trueP b).
    generalize (refl_equal (G neg)).
    pattern (G neg) at 1 in |- *.
    apply boolP_indd with (b := G neg); intro Heq.
    rewrite (boolP_elim_redl falseP trueP).
    change (trueP = neg trueP) in |- *. rewrite Heq. apply Gfix.
    rewrite (boolP_elim_redr falseP trueP).
    change (neg falseP = falseP) in |- *; rewrite Heq; symmetry  in |- *;
      apply Gfix.
  Qed.

  Lemma proof_irrelevance :
    forall (P : Prop) (p q : P), p = q.
  Proof.
  intros A a1 a2.
  set (f := fun b:boolP => match b with trueP => a1 | _ => a2 end).
  (* set (f := fun b:boolP => boolP_ind a1 a2 b). *)
  rewrite (boolP_elim_redl a1 a2).
  change (f trueP = a2) in |- *.
  rewrite (boolP_elim_redr a1 a2).
  change (f trueP = f falseP) in |- *.
  rewrite (aux).
    reflexivity.
  Qed.

End PIfromExt.

Lemma proof_irrelevance :
  forall (P : Prop) (p q : P), p = q.
Proof. exact PIfromExt.proof_irrelevance. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Consequences of proof irrelevance *)

(** Uniqueness of identity proofs *)

Lemma identity_proofs_unique :
  forall (A : Type) (x y : A) (p q : x = y), p = q.
Proof. intros. apply proof_irrelevance. Qed.

(** Uniqueness of reflexive identity proofs *)

Lemma refl_identity_proofs_unique :
  forall (A : Type) (x : A) (p : x = x),
  p = refl_equal x.
Proof. intros. apply proof_irrelevance. Qed.

(** Invariance by substitution of reflexive equality proofs *)

Lemma eq_rect_eq :
  forall (A : Type) (p : A) (Q : A -> Type) (x : Q p) (h : p = p),
  eq_rect p Q x p h = x.
Proof. intros. rewrite~ (refl_identity_proofs_unique h). Qed.

(** Streicher's axiom K *)

Lemma streicher_K : forall (A : Type) (x : A) (P : x = x -> Prop),
  P (refl_equal x) -> forall (p : x = x), P p.
Proof. intros. rewrite~ (refl_identity_proofs_unique p). Qed.

(* ---------------------------------------------------------------------- *)
(** ** Injectivity of equality on dependent pairs *)

(** This section establishes that [existT P p x = existT P p y] implies
    that [x] is equal to [y]. It indirectly results from the proof
    irrelevance property. *)

(** Definition of dependent equality, with non-dependent return type *)

Inductive eq_dep_nd (A : Type) (P : A -> Type)
    (p : A) (x : P p) (q : A) (y : P q) : Prop :=
 | eq_dep_nd_intro : forall (h : q = p),
    x = eq_rect q P y p h -> eq_dep_nd P p x q y.

Implicit Arguments eq_dep_nd [A P p q].
Implicit Arguments eq_dep_nd_intro [A P p q x y].

(** Reflexivity of [eq_dep_nd] *)

Lemma eq_dep_nd_direct : forall (A : Type) (P : A -> Type) (p : A) (x : P p),
  eq_dep_nd x x.
Proof. intros. apply (eq_dep_nd_intro (refl_equal p)). auto. Qed.

(** Injectivity of [eq_dep_nd] *)

Lemma eq_dep_nd_eq :
  forall (A : Type) (P : A -> Type) (p : A) (x y : P p),
  eq_dep_nd x y -> x = y.
Proof. introv H. inversions H. rewrite~ eq_rect_eq. Qed.

(** Equality on dependent pairs implies [eq_dep_nd] *)

Lemma eq_sigT_eq_dep_nd :
  forall (A : Type) (P : A -> Type) (p q : A) (x : P p) (y : P q),
  existT P p x = existT P q y -> eq_dep_nd x y.
Proof. introv E. dependent rewrite E. simpl. apply eq_dep_nd_direct. Qed.

(** Injectivity of equality on dependent pairs *)

Lemma eq_sigT_to_eq :
  forall (A : Type) (P : A -> Type) (p : A) (x y : P p),
  existT P p x = existT P p y -> x = y.
Proof. intros. apply eq_dep_nd_eq. apply~ eq_sigT_eq_dep_nd. Qed.

(* ---------------------------------------------------------------------- *)
(** Irrelevance of the membership property for subsets types *)

(** This is another consequence of proof irrelevance *)

Scheme eq_indd := Induction for eq Sort Prop.

Lemma exist_eq :
  forall (A : Type) (P : A->Prop) (x y : A) (p : P x) (q : P y),
    x = y -> exist P x p = exist P y q.
Proof.
  intros. rewrite (proof_irrelevance q (eq_rect x P p y H)).
  elim H using eq_indd. reflexivity.
Qed.

Lemma existT_eq :
  forall (U:Type) (P:U->Prop) (x y:U) (p:P x) (q:P y),
    x = y -> existT P x p = existT P y q.
Proof.
  intros. rewrite (proof_irrelevance q (eq_rect x P p y H)).
  elim H using eq_indd. reflexivity.
Qed.

(* ********************************************************************** *)
(** * Dependent equality *)

(** In this section, we prove that [eq_dep x y] implies [x = y]. *)

(** Definition of [eq_dep] (copied from the LibPrelude) *)

Inductive eq_dep (A : Type) (P : A -> Type) (p : A) (x : P p)
  : forall q, P q -> Prop :=
  | eq_dep_refl : eq_dep P p x p x.

Implicit Arguments eq_dep [A P p q].

(** Symmetry of [eq_dep] *)

Lemma eq_dep_sym : forall (A : Type) (P : A -> Type)
 (p q : A) (x : P p) (y : P q),
  eq_dep x y -> eq_dep y x.
Proof. introv E. destruct E. constructor. Qed.

(** Transitivity of [eq_dep] *)

Lemma eq_dep_trans : forall (A : Type) (P : A -> Type)
 (p q r : A) (y : P q) (x : P p) (z : P r),
  eq_dep x y -> eq_dep y z -> eq_dep x z.
Proof. introv E F. destruct~ E. Qed.

(** Proof of equivalence between [eq_dep_nd] and [eq_dep] *)

Scheme eq_induction := Induction for eq Sort Prop.

Lemma eq_dep_nd_to_eq_dep :
  forall (A : Type) (P : A -> Type) (p q : A) (x : P p) (y : P q),
  eq_dep_nd x y -> eq_dep x y.
Proof.
  introv E. destruct E as (h,H).
  destruct h using eq_induction. subst~. constructor.
Qed.

Lemma eq_dep_to_eq_dep_nd :
  forall (A : Type) (P : A -> Type) (p q : A) (x : P p) (y : P q),
  eq_dep x y -> eq_dep_nd x y.
Proof. introv H. destruct H. apply (eq_dep_nd_intro (refl_equal p)); auto. Qed.

(** Injectivity of dependent equality *)

Lemma eq_dep_eq :
  forall (A : Type) (P : A -> Type) (p : A) (x y : P p),
  eq_dep x y -> x = y.
Proof. introv R. inversion R. apply eq_dep_nd_eq. apply~ eq_dep_to_eq_dep_nd. Qed.

(** Equality on dependent pairs implies dependent equality *)

Lemma eq_sigT_eq_dep :
  forall (A : Type) (P : A -> Type) (p q : A) (x : P p) (y : P q),
  existT P p x = existT P q y -> eq_dep x y.
Proof. introv E. dependent rewrite E. simple~. constructor. Qed.

(* ********************************************************************** *)
(** * John Major's equality *)

(** In this section, we prove that [JMeq x y] implies [x = y]
    when both [x] and [y] have the same type. *)

Require Import JMeq.

(** Symmetry, transitivity of [JMeq] *)

Lemma JMeq_sym : forall (A B : Type) (x : A) (y : B),
  JMeq x y -> JMeq y x.
Proof. introv E. destruct~ E. Qed.

Lemma JMeq_trans : forall (A B C : Type) (y : B) (x : A) (z : C),
  JMeq x y -> JMeq y z -> JMeq x z.
Proof. introv E F. destruct~ E. Qed.

Local Hint Immediate JMeq_sym.

(** Relation between [JMeq] and [eq_dep] *)

Lemma JMeq_to_eq_dep : forall (A B : Type) (x : A) (y : B),
  JMeq x y -> @eq_dep Type (fun T => T) A x B y.
Proof. introv E. destruct E. constructor. Qed.

Lemma eq_dep_to_JMeq : forall (A B : Type) (x : A) (y : B),
  @eq_dep Type (fun T => T) A x B y -> JMeq x y.
Proof. introv E. destruct~ E. Qed.

(** Injectivity of [JMeq] *)

Lemma JMeq_eq : forall (A : Type) (x y : A),
  JMeq x y -> x = y.
Proof.
  introv E. apply (@eq_dep_eq Type (fun T => T)).
  apply~ JMeq_to_eq_dep.
Qed.

(* ********************************************************************** *)
(** * Properties of equality *)

(** This section contains a reformulation of the lemmas provided by
    the standard library concerning equality. *)

Implicit Arguments eq [[A]].

(* ---------------------------------------------------------------------- *)
(** ** Equality as an equivalence relation *)

Section EqualityProp.
Variable A : Type.
Implicit Types x y z : A.

(** Reflexivity is captured by the constructor [eq_refl]. *)

(** Symmetry *)

Lemma eq_sym : forall x y,
  x = y -> y = x.
Proof. introv H. destruct~ H. Qed.

(** Transitivity *)

Lemma eq_trans : forall y x z,
  x = y -> y = z -> x = z.
Proof. introv H1 H2. destruct~ H2. Qed.

Lemma eq_trans' : forall y x z,
  y = x -> y = z -> x = z.
Proof. introv H1 H2. destruct~ H2. Qed.

End EqualityProp.

Implicit Arguments eq_trans [A].
Implicit Arguments eq_trans' [A].

(* TODO: two other versions of eq_trans *)

(* ---------------------------------------------------------------------- *)
(** ** Properties of disequality *)

Section DisequalityProp.
Variable A : Type.
Implicit Types x y z : A.

(** Symmetry *)

Lemma neq_sym : forall x y,
  x <> y -> y <> x.
Proof. introv H K. destruct~ K. Qed.

End DisequalityProp.

(* ---------------------------------------------------------------------- *)
(** ** Symmetrized induction principles *)

(* TODO: is this really needed ?*)

Section EqInductionSym.
Variables (A : Type) (x : A).

Definition eq_ind_r : forall (P:A -> Prop),
  P x -> forall y, y = x -> P y.
Proof. introv Px H. elim (sym_eq H). auto. Qed.

Definition eq_rec_r : forall (P:A -> Set),
  P x -> forall y, y = x -> P y.
Proof. introv Px H. elim (sym_eq H). auto. Qed.

Definition eq_rect_r : forall (P:A -> Type),
  P x -> forall y, y = x -> P y.
Proof. introv Px H. elim (sym_eq H). auto. Qed.

End EqInductionSym.

(* ********************************************************************** *)
(** * Equality between function applications *)

(* ---------------------------------------------------------------------- *)
(** ** A same function applied to equal arguments yield equal result *)

Section FuncEq.
Variables (A1 A2 A3 A4 A5 B : Type).

Lemma func_eq_1 : forall (f:A1->B) x1 y1,
  x1 = y1 ->
  f x1 = f y1.
Proof. intros. subst~. Qed.

Lemma func_eq_2 : forall (f:A1->A2->B) x1 y1 x2 y2,
  x1 = y1 -> x2 = y2 ->
  f x1 x2 = f y1 y2.
Proof. intros. subst~. Qed.

Lemma func_eq_3 : forall (f:A1->A2->A3->B) x1 y1 x2 y2 x3 y3,
  x1 = y1 -> x2 = y2 -> x3 = y3 ->
  f x1 x2 x3 = f y1 y2 y3.
Proof. intros. subst~. Qed.

Lemma func_eq_4 : forall (f:A1->A2->A3->A4->B) x1 y1 x2 y2 x3 y3 x4 y4,
  x1 = y1 -> x2 = y2 -> x3 = y3 -> x4 = y4 ->
  f x1 x2 x3 x4 = f y1 y2 y3 y4.
Proof. intros. subst~. Qed.

Lemma func_eq_5 : forall (f:A1->A2->A3->A4->A5->B) x1 y1 x2 y2 x3 y3 x4 y4 x5 y5,
  x1 = y1 -> x2 = y2 -> x3 = y3 -> x4 = y4 -> x5 = y5 ->
  f x1 x2 x3 x4 x5 = f y1 y2 y3 y4 y5.
Proof. intros. subst~. Qed.

End FuncEq.

(* TODO: generalize to dependent functions *)

(* ---------------------------------------------------------------------- *)
(** ** Equal functions return equal results *)

Section FuncSame.
Variables (A1 A2 A3 A4 A5 B:Type).
Variables (x1:A1) (x2:A2) (x3:A3) (x4:A4) (x5:A5).

Lemma func_same_1 : forall f g,
  f = g -> f x1 = g x1 :> B.
Proof. intros. subst~. Qed.

Lemma func_same_2 : forall f g,
  f = g -> f x1 x2 = g x1 x2 :> B.
Proof. intros. subst~. Qed.

Lemma func_same_3 : forall f g,
  f = g -> f x1 x2 x3 = g x1 x2 x3 :> B.
Proof. intros. subst~. Qed.

Lemma func_same_4 : forall f g,
  f = g -> f x1 x2 x3 x4 = g x1 x2 x3 x4 :> B.
Proof. intros. subst~. Qed.

Lemma func_same_5 : forall f g,
  f = g -> f x1 x2 x3 x4 x5 = g x1 x2 x3 x4 x5 :> B.
Proof. intros. subst~. Qed.

End FuncSame.

(* ********************************************************************** *)
(** * General definition of extensionality *)

(** The property [Extensional A] captures the fact that the type [A]
    features an extensional equality, in the sense that to prove the
    equality between two values of type [A] it suffices to prove that
    those two values are related by some binary relation. *)

Class Extensional (A:Type) := {
  extensional_hyp : A -> A -> Prop;
  extensional : forall x y : A, extensional_hyp x y -> x = y }.

(* ---------------------------------------------------------------------- *)
(** ** Tactic to exploit extensionality *)

(** [extens] is a tactic that can be applied to exploit extensionality
    on any goal of the form [x = y] when [x] and [y] are functions, or
    predicates, or have a type [A] satisfying [Extensional A].
    Note: the tactic [extens] automatically calls [intros] if needed. *)

Ltac extens_core :=
  hnf;
  match goal with
  | |- _ = _ :> ?T =>
  match T with
  | Prop => apply prop_ext
  | forall _, Prop => apply prop_ext_1
  | forall _ _, Prop => apply prop_ext_2
  | forall _ _ _, Prop => apply prop_ext_3
  | forall _ _ _ _, Prop => apply prop_ext_4
  | forall _ _ _ _ _, Prop => apply prop_ext_5
  | forall _ _ _ _ _ _, Prop => apply prop_ext_6
  | forall _,_ =>
     first [ apply func_ext_dep_4
           | apply func_ext_dep_3
           | apply func_ext_dep_2
           | apply func_ext_dep_1 ]
  | _ => apply extensional; try unfold extensional_hyp; simpl
  end end.

Ltac extens_base :=
  first [ extens_core | intros; extens_core ].

Tactic Notation "extens" :=
  extens_base.
Tactic Notation "extens" "~" :=
  extens; auto_tilde.
Tactic Notation "extens" "*" :=
  extens; auto_star.


(** * Associativity of adjunction composition *)
Require Import Category.Core Functor.Core.
Require Import Adjoint.Composition.Core Adjoint.Core.
Require Adjoint.Composition.LawsTactic.
Require Import Types.Sigma Types.Prod.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope adjunction_scope.
Local Open Scope morphism_scope.

Section composition_lemmas.
  Local Notation AdjunctionWithFunctors C D :=
    { fg : Functor C D * Functor D C
    | fst fg -| snd fg }.

  Context `{H0 : Funext}.

  Variables B C D E : PreCategory.

  Variable F : Functor B C.
  Variable F' : Functor C B.
  Variable G : Functor C D.
  Variable G' : Functor D C.
  Variable H : Functor D E.
  Variable H' : Functor E D.

  Variable AF : F -| F'.
  Variable AG : G -| G'.
  Variable AH : H -| H'.

  Local Open Scope adjunction_scope.

  Lemma associativity
  : ((_, _); (AH o AG) o AF) = ((_, _); AH o (AG o AF)) :> AdjunctionWithFunctors B E.
  Proof.
    apply path_sigma_uncurried; simpl.
    (exists (path_prod'
               (Functor.Composition.Laws.associativity _ _ _)
               (symmetry _ _ (Functor.Composition.Laws.associativity _ _ _))));
      Adjoint.Composition.LawsTactic.law_t.
  Qed.
End composition_lemmas.

#[export]
Hint Resolve associativity : category.


Require Import Rbase Ranalysis Rfunctions Rfunction_def.
Require Import MyRIneq.
Require Import Rinterval Ranalysis_def Ranalysis_def_simpl Ranalysis_facts.

Local Open Scope R_scope.

(** * Derivability (thus continuity) of usual functions. *)

(** * Identity *)

Lemma derivable_pt_lim_in_id: forall D x,
  derivable_pt_lim_in D id x 1.
Proof.
intros D x eps eps_pos ; exists eps ; intros ; split.
 assumption.
 intros y [[_ Hneq] _] ; unfold growth_rate, id ; simpl.
  apply Rle_lt_trans with (Rabs 0) ; [| rewrite Rabs_R0 ; assumption].
  right ; apply Rabs_eq_compat ; field ; apply Rminus_eq_contra ;
  symmetry ; assumption.
Qed.

Lemma derivable_pt_in_id: forall (D : R -> Prop) (x : R),
  derivable_pt_in D id x.
Proof.
intros ; eexists ; eapply derivable_pt_lim_in_id.
Qed.

Lemma derivable_in_id: forall (D : R -> Prop),
  derivable_in D id.
Proof.
intros D x x_in ; eapply derivable_pt_in_id.
Qed.

Lemma derive_pt_open_interval_id : forall a b x pr,
  open_interval a b x ->
 (derive_pt_in (open_interval a b) id x pr = 1)%R.
intros a b x pr x_in ; rewrite derive_open_interval_pt with (pr' := derivable_pt_id x).
 apply derive_pt_id.
 assumption.
Qed.

(** Powers *)

Definition Dpow (n : nat) := match n with
  | O   => fun _ => 0
  | S m => fun x => (INR (S m)) * pow x m
end.

(*
Lemma derivable_pt_lim_in_pow: forall D x n,
  derivable_pt_lim_in (fun x => pow x n) D x (Dpow n x).
Proof.
intros D x n ; induction n.
 eapply derivable_pt_lim_in_ext with (fun _ => 1).
  intro ; reflexivity.
  apply derivable_pt_lim_in_const.
 eapply derivable_pt_lim_in_ext with (id * (fun x => pow x n))%F.
  intro ; reflexivity.
*)

(** Monomials *)

(** Inverse *)

(** Negative powers *)


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C P Pprime : Universe, ((wd_ B A /\ (wd_ A C /\ (wd_ B C /\ (wd_ B P /\ (wd_ A P /\ (wd_ P Pprime /\ (wd_ B Pprime /\ (col_ B A Pprime /\ col_ B P Pprime)))))))) -> col_ A B P)).
Proof.
  time tac.
Qed.

End FOFProblem.