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

Require Export Preducestar.
Require Export LetP.
Section Pspoly.
Load "hCoefStructure".
Load "hOrderStructure".
Load "hReducestar".

Definition spolyf :
  forall (p q : list (Term A n)) (Cp : canonical A0 eqA ltM p)
    (Cq : canonical A0 eqA ltM q), list (Term A n).
intros p1; case p1.
intros p2 H' H'0; exact (pO A n).
intros a p11 p2; case p2.
intros H' H'0; exact (pO A n).
intros b p22 H' H'0.
apply LetP with (A := Term A n) (h := ppc (A:=A) A1 (n:=n) a b).
intros u H'1.
cut (~ zeroP (A:=A) A0 eqA (n:=n) a);
 [ intros nZa | apply canonical_nzeroP with (ltM := ltM) (p := p11); auto ].
cut (~ zeroP (A:=A) A0 eqA (n:=n) b);
 [ intros nZb | apply canonical_nzeroP with (ltM := ltM) (p := p22); auto ].
exact
 (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec
    (mults (A:=A) multA (n:=n)
       (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) u (b:=a) nZa) p11)
    (mults (A:=A) multA (n:=n)
       (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) u (b:=b) nZb) p22)).
Defined.

Theorem spolyf_canonical :
 forall (p q : list (Term A n)) (Cp : canonical A0 eqA ltM p)
   (Cq : canonical A0 eqA ltM q), canonical A0 eqA ltM (spolyf p q Cp Cq).
intros p; case p; simpl in |- *; auto.
intros a l q; case q; unfold LetP in |- *; simpl in |- *; auto.
intros a0 l0 H' H'0.
cut (canonical A0 eqA ltM l0);
 [ intros Op1 | apply canonical_imp_canonical with (a := a0) ];
 auto.
cut (canonical A0 eqA ltM l);
 [ intros Op2 | apply canonical_imp_canonical with (a := a) ];
 auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) a);
 [ intros Z0 | apply canonical_nzeroP with (ltM := ltM) (p := l); auto ].
cut (~ zeroP (A:=A) A0 eqA (n:=n) a0);
 [ intros Z1 | apply canonical_nzeroP with (ltM := ltM) (p := l0) ];
 auto.
Qed.
Hint Resolve spolyf_canonical.

Theorem spolyf_pO :
 forall (a : list (Term A n)) (Ca : canonical A0 eqA ltM a),
 eqP A eqA n (spolyf a a Ca Ca) (pO A n).
intros a; case a; simpl in |- *; unfold LetP in |- *; auto.
intros; apply minuspf_refl with (1 := cs); auto.
Qed.

Theorem spolyf_com :
 forall (a b : list (Term A n)) (Ca : canonical A0 eqA ltM a)
   (Cb : canonical A0 eqA ltM b),
 eqP A eqA n (spolyf a b Ca Cb)
   (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
      (spolyf b a Cb Ca)).
intros a b; case a; case b; simpl in |- *; auto.
intros a0 l a1 l0 Cpxa0 Cpxa1.
cut (~ zeroP (A:=A) A0 eqA (n:=n) a0);
 [ intros nZa0 | apply canonical_nzeroP with (ltM := ltM) (p := l); auto ].
cut (~ zeroP (A:=A) A0 eqA (n:=n) a1);
 [ intros nZa1 | apply canonical_nzeroP with (ltM := ltM) (p := l0); auto ].
change
  (eqP A eqA n
     (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec
        (mults (A:=A) multA (n:=n)
           (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
              (ppc (A:=A) A1 (n:=n) a1 a0) (b:=a1)
              (canonical_nzeroP A A0 eqA n ltM a1 l0 Cpxa0)) l0)
        (mults (A:=A) multA (n:=n)
           (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
              (ppc (A:=A) A1 (n:=n) a1 a0) (b:=a0)
              (canonical_nzeroP A A0 eqA n ltM a0 l Cpxa1)) l))
     (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
        (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec
           (mults (A:=A) multA (n:=n)
              (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                 (ppc (A:=A) A1 (n:=n) a0 a1) (b:=a0)
                 (canonical_nzeroP A A0 eqA n ltM a0 l Cpxa1)) l)
           (mults (A:=A) multA (n:=n)
              (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                 (ppc (A:=A) A1 (n:=n) a0 a1) (b:=a1)
                 (canonical_nzeroP A A0 eqA n ltM a1 l0 Cpxa0)) l0))))
 in |- *.
cut (canonical A0 eqA ltM l);
 [ intros Op1 | apply canonical_imp_canonical with (a := a0); auto ].
cut (canonical A0 eqA ltM l0);
 [ intros Op2 | apply canonical_imp_canonical with (a := a1); auto ].
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n)
               (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                  (ppc (A:=A) A1 (n:=n) a1 a0) (b:=a1)
                  (canonical_nzeroP A A0 eqA n ltM a1 l0 Cpxa0)) l0)
            (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a1 a0) (b:=a0)
                     (canonical_nzeroP A A0 eqA n ltM a0 l Cpxa1)) l)));
 [ auto | idtac ].
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n) (T1 A1 n)
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a1 a0) (b:=a1)
                     (canonical_nzeroP A A0 eqA n ltM a1 l0 Cpxa0)) l0))
            (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a1 a0) (b:=a0)
                     (canonical_nzeroP A A0 eqA n ltM a0 l Cpxa1)) l))).
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); apply eqp_pluspf_com with (1 := cs);
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n)
               (invTerm (A:=A) invA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n)))
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a1 a0) (b:=a1)
                     (canonical_nzeroP A A0 eqA n ltM a1 l0 Cpxa0)) l0))
            (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a1 a0) (b:=a0)
                     (canonical_nzeroP A A0 eqA n ltM a0 l Cpxa1)) l)));
 [ apply eqp_pluspf_com with (1 := cs); auto | idtac ].
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n)
               (invTerm (A:=A) invA (n:=n)
                  (multTerm (A:=A) multA (n:=n) (T1 A1 n)
                     (invTerm (A:=A) invA (n:=n) (T1 A1 n))))
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a1 a0) (b:=a1)
                     (canonical_nzeroP A A0 eqA n ltM a1 l0 Cpxa0)) l0))
            (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a1 a0) (b:=a0)
                     (canonical_nzeroP A A0 eqA n ltM a0 l Cpxa1)) l)));
 [ apply eqp_pluspf_com with (1 := cs); auto | idtac ].
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n)
               (multTerm (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n))
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n)))
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a1 a0) (b:=a1)
                     (canonical_nzeroP A A0 eqA n ltM a1 l0 Cpxa0)) l0))
            (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a1 a0) (b:=a0)
                     (canonical_nzeroP A A0 eqA n ltM a0 l Cpxa1)) l)));
 [ apply eqp_pluspf_com with (1 := cs); auto;
    apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto
 | idtac ].
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n))
                  (mults (A:=A) multA (n:=n)
                     (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                        (ppc (A:=A) A1 (n:=n) a1 a0) (b:=a1)
                        (canonical_nzeroP A A0 eqA n ltM a1 l0 Cpxa0)) l0)))
            (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a1 a0) (b:=a0)
                     (canonical_nzeroP A A0 eqA n ltM a0 l Cpxa1)) l)));
 [ apply eqp_pluspf_com with (1 := cs); auto | idtac ].
apply canonical_mults with (1 := cs); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n))
                  (mults (A:=A) multA (n:=n)
                     (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                        (ppc (A:=A) A1 (n:=n) a1 a0) (b:=a1)
                        (canonical_nzeroP A A0 eqA n ltM a1 l0 Cpxa0)) l0))
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a1 a0) (b:=a0)
                     (canonical_nzeroP A A0 eqA n ltM a0 l Cpxa1)) l))).
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply mults_dist_pluspf with (1 := cs); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a1 a0) (b:=a0)
                     (canonical_nzeroP A A0 eqA n ltM a0 l Cpxa1)) l)
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n))
                  (mults (A:=A) multA (n:=n)
                     (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                        (ppc (A:=A) A1 (n:=n) a1 a0) (b:=a1)
                        (canonical_nzeroP A A0 eqA n ltM a1 l0 Cpxa0)) l0)))).
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply mults_comp with (1 := cs); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n)
               (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                  (ppc (A:=A) A1 (n:=n) a0 a1) (b:=a0)
                  (canonical_nzeroP A A0 eqA n ltM a0 l Cpxa1)) l)
            (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a0 a1) (b:=a1)
                     (canonical_nzeroP A A0 eqA n ltM a1 l0 Cpxa0)) l0)));
 auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply eqp_pluspf_com with (1 := cs); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
Qed.

Theorem spolyf_def :
 forall (a b : Term A n) (nZa : ~ zeroP (A:=A) A0 eqA (n:=n) a)
   (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b) (p q : list (Term A n))
   (Cpxa : canonical A0 eqA ltM (pX a p))
   (Cpxb : canonical A0 eqA ltM (pX b q)),
 eqP A eqA n (spolyf (pX a p) (pX b q) Cpxa Cpxb)
   (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec
      (mults (A:=A) multA (n:=n)
         (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
            (ppc (A:=A) A1 (n:=n) a b) (b:=a) nZa) p)
      (mults (A:=A) multA (n:=n)
         (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
            (ppc (A:=A) A1 (n:=n) a b) (b:=b) nZb) q)).
intros a b nZa nZb p q Cpxa Cpxb; simpl in |- *; auto.
cut (canonical A0 eqA ltM p); [ intros Op1 | auto ]; auto.
cut (canonical A0 eqA ltM q); [ intros Op2 | auto ]; unfold LetP in |- *;
 simpl in |- *; auto.
apply canonical_imp_canonical with (a := b); auto.
apply canonical_imp_canonical with (a := a); auto.
Qed.
Hint Resolve spolyf_def.

Theorem eqTerm_spolyf_red2 :
 forall (a b c : Term A n) (nZa : ~ zeroP (A:=A) A0 eqA (n:=n) a)
   (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b)
   (nZppab : ~ zeroP (A:=A) A0 eqA (n:=n) (ppc (A:=A) A1 (n:=n) a b)),
 divP A A0 eqA multA divA n c a ->
 divP A A0 eqA multA divA n c b ->
 forall (p q r : list (Term A n)) (Cpxa : canonical A0 eqA ltM (pX a p))
   (Cpxb : canonical A0 eqA ltM (pX b q)),
 canonical A0 eqA ltM r ->
 eqP A eqA n
   (mults (A:=A) multA (n:=n)
      (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c
         (b:=ppc (A:=A) A1 (n:=n) a b) nZppab)
      (spolyf (pX a p) (pX b q) Cpxa Cpxb))
   (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec
      (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec c b
         nZb r q)
      (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec c a
         nZa r p)).
intros a b c nZa nZb nZppab H' H'0 p q r Cpxa Cpxb H'4.
cut (canonical A0 eqA ltM p);
 [ intros Op | apply canonical_imp_canonical with (a := a); auto ].
cut (canonical A0 eqA ltM q);
 [ intros Oq | apply canonical_imp_canonical with (a := b); auto ].
cut (divP A A0 eqA multA divA n (ppc (A:=A) A1 (n:=n) a b) a);
 [ intros div1 | apply divP_ppcl with (1 := cs); auto ].
cut (divP A A0 eqA multA divA n (ppc (A:=A) A1 (n:=n) a b) b);
 [ intros div2 | apply divP_ppcr with (1 := cs); auto ].
cut (divP A A0 eqA multA divA n c (ppc (A:=A) A1 (n:=n) a b));
 [ intros div3 | elim ppc_is_ppcm with (1 := cs); auto ].
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := mults (A:=A) multA (n:=n)
            (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c
               (b:=ppc (A:=A) A1 (n:=n) a b) nZppab)
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a b) (b:=a) nZa) p)
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n))
                  (mults (A:=A) multA (n:=n)
                     (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                        (ppc (A:=A) A1 (n:=n) a b) (b:=b) nZb) q)))).
apply mults_comp with (1 := cs); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec
            (mults (A:=A) multA (n:=n)
               (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                  (ppc (A:=A) A1 (n:=n) a b) (b:=a) nZa) p)
            (mults (A:=A) multA (n:=n)
               (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                  (ppc (A:=A) A1 (n:=n) a b) (b:=b) nZb) q));
 auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) c);
 [ intros Z2 | inversion_clear H'0; auto ].
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n)
               (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c
                  (b:=ppc (A:=A) A1 (n:=n) a b) nZppab)
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a b) (b:=a) nZa) p))
            (mults (A:=A) multA (n:=n)
               (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c
                  (b:=ppc (A:=A) A1 (n:=n) a b) nZppab)
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n))
                  (mults (A:=A) multA (n:=n)
                     (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                        (ppc (A:=A) A1 (n:=n) a b) (b:=b) nZb) q))));
 [ auto | idtac ].
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n)
               (multTerm (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c
                     (b:=ppc (A:=A) A1 (n:=n) a b) nZppab)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a b) (b:=a) nZa)) p)
            (mults (A:=A) multA (n:=n)
               (multTerm (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c
                     (b:=ppc (A:=A) A1 (n:=n) a b) nZppab)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n)))
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a b) (b:=b) nZb) q))).
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply eqp_pluspf_com with (1 := cs); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n)
               (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=a) nZa)
               p)
            (mults (A:=A) multA (n:=n)
               (multTerm (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n))
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c
                     (b:=ppc (A:=A) A1 (n:=n) a b) nZppab))
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a b) (b:=b) nZb) q)));
 [ auto | idtac ].
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply eqp_pluspf_com with (1 := cs); auto.
apply mults_comp with (1 := cs); auto.
apply divTerm_compo with (1 := cs); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n)
               (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=a) nZa)
               p)
            (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c
                     (b:=ppc (A:=A) A1 (n:=n) a b) nZppab)
                  (mults (A:=A) multA (n:=n)
                     (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                        (ppc (A:=A) A1 (n:=n) a b) (b:=b) nZb) q)))).
apply eqp_pluspf_com with (1 := cs); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n)
               (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=a) nZa)
               p)
            (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               (mults (A:=A) multA (n:=n)
                  (multTerm (A:=A) multA (n:=n)
                     (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c
                        (b:=ppc (A:=A) A1 (n:=n) a b) nZppab)
                     (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                        (ppc (A:=A) A1 (n:=n) a b) (b:=b) nZb)) q))).
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); apply eqp_pluspf_com with (1 := cs);
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n)
               (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=a) nZa)
               p)
            (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=b)
                     nZb) q))).
apply eqp_pluspf_com with (1 := cs); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply mults_comp with (1 := cs); auto.
apply mults_comp with (1 := cs); auto.
apply divTerm_compo with (1 := cs); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=b)
                     nZb) q))
            (mults (A:=A) multA (n:=n)
               (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=a) nZa)
               p)); [ auto | idtac ].
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=b)
                     nZb) q))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec (pO A n)
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=a)
                     nZa) p))).
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=b)
                     nZb) q))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec
               (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec r
                  r)
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=a)
                     nZa) p))).
apply eqp_pluspf_com with (1 := cs); auto.
apply eqp_pluspf_com with (1 := cs); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); apply minuspf_refl with (1 := cs);
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=b)
                     nZb) q))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec
               (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
                  ltM_dec r
                  (mults (A:=A) multA (n:=n)
                     (invTerm (A:=A) invA (n:=n) (T1 A1 n)) r))
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=a)
                     nZa) p))).
apply eqp_pluspf_com with (1 := cs); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=b)
                     nZb) q))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec r
               (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
                  ltM_dec
                  (mults (A:=A) multA (n:=n)
                     (invTerm (A:=A) invA (n:=n) (T1 A1 n)) r)
                  (mults (A:=A) multA (n:=n)
                     (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=a)
                        nZa) p)))).
apply eqp_pluspf_com with (1 := cs); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n))
                  (mults (A:=A) multA (n:=n)
                     (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=b)
                        nZb) q)) r)
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n)) r)
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=a)
                     nZa) p))).
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec r
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n))
                  (mults (A:=A) multA (n:=n)
                     (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=b)
                        nZb) q)))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n)) r)
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=a)
                     nZa) p))).
apply eqp_pluspf_com with (1 := cs); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec r
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=b)
                     nZb) q))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n)) r)
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=a)
                     nZa) p))).
apply eqp_pluspf_com with (1 := cs); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec r
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=b)
                     nZb) q))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n)) r)
               (mults (A:=A) multA (n:=n) (T1 A1 n)
                  (mults (A:=A) multA (n:=n)
                     (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=a)
                        nZa) p)))).
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply eqp_pluspf_com with (1 := cs); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec r
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=b)
                     nZb) q))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n)) r)
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n)
                     (invTerm (A:=A) invA (n:=n) (T1 A1 n)))
                  (mults (A:=A) multA (n:=n)
                     (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=a)
                        nZa) p)))).
apply eqp_pluspf_com with (1 := cs); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec r
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=b)
                     nZb) q))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n)) r)
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n)
                     (multTerm (A:=A) multA (n:=n)
                        (T1 A1 n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))))
                  (mults (A:=A) multA (n:=n)
                     (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=a)
                        nZa) p)))); auto.
apply eqp_pluspf_com with (1 := cs); auto.
apply canonical_pluspf; auto.
apply eqp_pluspf_com with (1 := cs); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec r
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=b)
                     nZb) q))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n)) r)
               (mults (A:=A) multA (n:=n)
                  (multTerm (A:=A) multA (n:=n)
                     (invTerm (A:=A) invA (n:=n) (T1 A1 n))
                     (invTerm (A:=A) invA (n:=n) (T1 A1 n)))
                  (mults (A:=A) multA (n:=n)
                     (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=a)
                        nZa) p)))).
apply eqp_pluspf_com with (1 := cs); auto.
apply canonical_pluspf; auto.
apply eqp_pluspf_com with (1 := cs); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec r
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=b)
                     nZb) q))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n)) r)
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n))
                  (mults (A:=A) multA (n:=n)
                     (invTerm (A:=A) invA (n:=n) (T1 A1 n))
                     (mults (A:=A) multA (n:=n)
                        (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c
                           (b:=a) nZa) p))))).
apply eqp_pluspf_com with (1 := cs); auto.
apply canonical_pluspf; auto.
apply eqp_pluspf_com with (1 := cs); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec r
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=b)
                     nZb) q))
            (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
                  ltM_dec r
                  (mults (A:=A) multA (n:=n)
                     (invTerm (A:=A) invA (n:=n) (T1 A1 n))
                     (mults (A:=A) multA (n:=n)
                        (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c
                           (b:=a) nZa) p))))).
apply eqp_pluspf_com with (1 := cs); auto.
apply canonical_pluspf; auto.
apply canonical_mults with (1 := cs); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec r
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=b)
                     nZb) q))
            (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec r
                  (mults (A:=A) multA (n:=n)
                     (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=a)
                        nZa) p)))).
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply eqp_pluspf_com with (1 := cs); auto.
apply canonical_mults with (1 := cs); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec
            (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec r
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=b)
                     nZb) q))
            (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec r
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=a)
                     nZa) p))); auto; apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n);
 auto.
Qed.

Theorem eqTerm_spolyf_red3 :
 forall (a b : Term A n) (nZa : ~ zeroP (A:=A) A0 eqA (n:=n) a)
   (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b) (p q r : list (Term A n))
   (Cpxa : canonical A0 eqA ltM (pX a p))
   (Cpxb : canonical A0 eqA ltM (pX b q)),
 canonical A0 eqA ltM r ->
 eqP A eqA n (spolyf (pX a p) (pX b q) Cpxa Cpxb)
   (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec
      (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec
         (ppc (A:=A) A1 (n:=n) a b) b nZb r q)
      (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec
         (ppc (A:=A) A1 (n:=n) a b) a nZa r p)).
intros a b nZa nZb p q r Cpxa Cpxb H'1.
cut (~ zeroP (A:=A) A0 eqA (n:=n) (ppc (A:=A) A1 (n:=n) a b));
 [ intros nZppab | auto ].
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := mults (A:=A) multA (n:=n) (T1 A1 n)
            (spolyf (pX a p) (pX b q) Cpxa Cpxb)).
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := mults (A:=A) multA (n:=n)
            (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
               (ppc (A:=A) A1 (n:=n) a b) (b:=ppc (A:=A) A1 (n:=n) a b)
               nZppab) (spolyf (pX a p) (pX b q) Cpxa Cpxb)).
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply eqTerm_spolyf_red2; auto.
Qed.

Theorem spoly_is_minus :
 forall (a b : Term A n) (nZa : ~ zeroP (A:=A) A0 eqA (n:=n) a)
   (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b) (p q : list (Term A n))
   (Cpxa : canonical A0 eqA ltM (pX a p))
   (Cpxb : canonical A0 eqA ltM (pX b q)),
 eqP A eqA n (spolyf (pX a p) (pX b q) Cpxa Cpxb)
   (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec
      (mults (A:=A) multA (n:=n)
         (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
            (ppc (A:=A) A1 (n:=n) a b) (b:=a) nZa)
         (pX a p))
      (mults (A:=A) multA (n:=n)
         (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
            (ppc (A:=A) A1 (n:=n) a b) (b:=b) nZb)
         (pX b q))).
simpl in |- *; unfold LetP in |- *; simpl in |- *.
intros a b nZa nZb p q Cpxa Cpxb.
cut (canonical A0 eqA ltM p);
 [ intros Op | apply canonical_imp_canonical with (a := a); auto ].
cut (canonical A0 eqA ltM q);
 [ intros Oq | apply canonical_imp_canonical with (a := b); auto ].
cut (~ zeroP (A:=A) A0 eqA (n:=n) (ppc (A:=A) A1 (n:=n) a b));
 [ intros nZppab | auto ].
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec
       (mults (A:=A) multA (n:=n)
          (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
             (ppc (A:=A) A1 (n:=n) a b) (b:=a) nZa) p)
       (mults (A:=A) multA (n:=n)
          (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
             (ppc (A:=A) A1 (n:=n) a b) (b:=b) nZb) q));
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec
            (pX (ppc (A:=A) A1 (n:=n) a b)
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a b) (b:=a) nZa) p))
            (pX (ppc (A:=A) A1 (n:=n) a b)
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a b) (b:=b) nZb) q))).
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n).
apply minuspf_zero with (1 := cs); auto.
cut
 (eqTerm (A:=A) eqA (n:=n) (ppc (A:=A) A1 (n:=n) a b)
    (multTerm (A:=A) multA (n:=n)
       (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
          (ppc (A:=A) A1 (n:=n) a b) (b:=a) nZa) a));
 [ intros Z2 | auto ].
cut
 (eqTerm (A:=A) eqA (n:=n) (ppc (A:=A) A1 (n:=n) a b)
    (multTerm (A:=A) multA (n:=n)
       (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
          (ppc (A:=A) A1 (n:=n) a b) (b:=b) nZb) b));
 [ intros Z3 | auto ].
apply minuspf_comp with (1 := cs); auto.
apply
 canonical_pX_eqT
  with
    (a := multTerm (A:=A) multA (n:=n)
            (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
               (ppc (A:=A) A1 (n:=n) a b) (b:=a) nZa) a);
 auto.
change
  (canonical A0 eqA ltM
     (mults (A:=A) multA (n:=n)
        (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
           (ppc (A:=A) A1 (n:=n) a b) (b:=a) nZa) (pX a p)))
 in |- *; auto.
apply (eqT_sym A n); apply (eqTerm_imp_eqT A eqA n); auto.
apply
 canonical_pX_eqT
  with
    (a := multTerm (A:=A) multA (n:=n)
            (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
               (ppc (A:=A) A1 (n:=n) a b) (b:=b) nZb) b);
 auto.
change
  (canonical A0 eqA ltM
     (mults (A:=A) multA (n:=n)
        (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
           (ppc (A:=A) A1 (n:=n) a b) (b:=b) nZb) (pX b q)))
 in |- *; auto.
apply (eqT_sym A n); apply (eqTerm_imp_eqT A eqA n); auto.
change
  (canonical A0 eqA ltM
     (mults (A:=A) multA (n:=n)
        (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
           (ppc (A:=A) A1 (n:=n) a b) (b:=a) nZa) (pX a p)))
 in |- *; auto.
change
  (canonical A0 eqA ltM
     (mults (A:=A) multA (n:=n)
        (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
           (ppc (A:=A) A1 (n:=n) a b) (b:=b) nZb) (pX b q)))
 in |- *; auto.
Qed.

Theorem spoly_div_is_minus :
 forall (a b c : Term A n) (nZa : ~ zeroP (A:=A) A0 eqA (n:=n) a)
   (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b)
   (nZppab : ~ zeroP (A:=A) A0 eqA (n:=n) (ppc (A:=A) A1 (n:=n) a b)),
 divP A A0 eqA multA divA n c a ->
 divP A A0 eqA multA divA n c b ->
 forall (p q : list (Term A n)) (Cpxa : canonical A0 eqA ltM (pX a p))
   (Cpxb : canonical A0 eqA ltM (pX b q)),
 eqP A eqA n
   (mults (A:=A) multA (n:=n)
      (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c
         (b:=ppc (A:=A) A1 (n:=n) a b) nZppab)
      (spolyf (pX a p) (pX b q) Cpxa Cpxb))
   (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec
      (mults (A:=A) multA (n:=n)
         (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=a) nZa)
         (pX a p))
      (mults (A:=A) multA (n:=n)
         (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c (b:=b) nZb)
         (pX b q))).
intros a b c nZa nZb nZppab H' H'0 p q Cpxa Cpxb.
cut (canonical A0 eqA ltM p);
 [ intros Op | apply canonical_imp_canonical with (a := a) ];
 auto.
cut (canonical A0 eqA ltM q);
 [ intros Oq | apply canonical_imp_canonical with (a := b) ];
 auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) c); [ intros Z2 | idtac ].
cut (divP A A0 eqA multA divA n c (ppc (A:=A) A1 (n:=n) a b));
 [ intros div1 | idtac ].
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := mults (A:=A) multA (n:=n)
            (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c
               (b:=ppc (A:=A) A1 (n:=n) a b) nZppab)
            (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a b) (b:=a) nZa)
                  (pX a p))
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a b) (b:=b) nZb)
                  (pX b q)))).
apply mults_comp with (1 := cs); auto.
apply spoly_is_minus; auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec
            (mults (A:=A) multA (n:=n)
               (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c
                  (b:=ppc (A:=A) A1 (n:=n) a b) nZppab)
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a b) (b:=a) nZa)
                  (pX a p)))
            (mults (A:=A) multA (n:=n)
               (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c
                  (b:=ppc (A:=A) A1 (n:=n) a b) nZppab)
               (mults (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a b) (b:=b) nZb)
                  (pX b q)))).
apply mults_dist_minuspf with (1 := cs); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec
            (mults (A:=A) multA (n:=n)
               (multTerm (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c
                     (b:=ppc (A:=A) A1 (n:=n) a b) nZppab)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a b) (b:=a) nZa))
               (pX a p))
            (mults (A:=A) multA (n:=n)
               (multTerm (A:=A) multA (n:=n)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) c
                     (b:=ppc (A:=A) A1 (n:=n) a b) nZppab)
                  (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                     (ppc (A:=A) A1 (n:=n) a b) (b:=b) nZb))
               (pX b q))).
apply minuspf_comp with (1 := cs); auto;
 apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply minuspf_comp with (1 := cs); auto.
apply mults_comp with (1 := cs); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); apply divTerm_compo with (1 := cs);
 auto.
apply mults_comp with (1 := cs); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); apply divTerm_compo with (1 := cs);
 auto.
case ppc_is_ppcm with (1 := cs) (a := a) (b := b); auto.
apply (divP_inv1 _ A0 eqA multA divA n) with (b := a); auto.
Qed.

Inductive ReduStarConfluent (Q : list (poly A0 eqA ltM))
(p : list (Term A n)) : Prop :=
    ReduStarConfluent0 :
      (forall r s : list (Term A n),
       reducestar A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
         p r ->
       reducestar A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
         p s -> eqP A eqA n r s) -> ReduStarConfluent Q p.

Theorem confl_under :
 forall (Q : list (poly A0 eqA ltM)) (a : Term A n) (p : list (Term A n)),
 canonical A0 eqA ltM (pX a p) ->
 (forall q : list (Term A n),
  canonical A0 eqA ltM q ->
  ltP (A:=A) (n:=n) ltM q (pX a p) -> ReduStarConfluent Q q) ->
 forall r s : list (Term A n),
 reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
   (pX a p) (pX a r) ->
 reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
   (pX a p) (pX a s) ->
 forall r1 s1 : list (Term A n),
 reducestar A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
   (pX a r) r1 ->
 reducestar A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
   (pX a s) s1 -> eqP A eqA n r1 s1.
intros Q a p Op1 H'0 r s H'1 H'2 r1 s1 H'3 H'4.
cut (canonical A0 eqA ltM p);
 [ intros Op2 | apply canonical_imp_canonical with (a := a); auto ].
cut (canonical A0 eqA ltM (pX a r));
 [ intros Op3 | apply canonical_reduce with (1 := cs) (3 := H'1); auto ].
cut (canonical A0 eqA ltM r);
 [ intros Op4 | apply canonical_imp_canonical with (a := a); auto ].
cut (canonical A0 eqA ltM (pX a s));
 [ intros Op5 | apply canonical_reduce with (1 := cs) (3 := H'2); auto ].
cut (canonical A0 eqA ltM s);
 [ intros Op6 | apply canonical_imp_canonical with (a := a); auto ].
lapply (H'0 p);
 [ intros H'5; lapply H'5;
    [ intros H'6; elim H'6; clear H'5 | apply ltP_refl_pX with (1 := cs) ]
 | idtac ]; auto.
intros H'5.
elim
 reduce0_reducestar
  with (1 := cs) (eqA_dec := eqA_dec) (ltM_dec := ltM_dec) (Q := Q) (p := s);
 auto; intros s0 E.
elim
 reduce0_reducestar
  with (1 := cs) (eqA_dec := eqA_dec) (ltM_dec := ltM_dec) (Q := Q) (p := r);
 auto; intros r0 E0.
cut
 (reduceplus A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
    (pX a r) (pX a r0));
 [ intros red1 | apply reduceplus_skip with (1 := cs); auto; elim E0 ];
 auto.
cut (canonical A0 eqA ltM (pX a r0));
 [ intros Op7 | apply canonical_reduceplus with (1 := cs) (3 := red1) ];
 auto.
cut
 (reduceplus A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
    (pX a s) (pX a s0));
 [ intros red2 | apply reduceplus_skip with (1 := cs); auto; elim E ];
 auto.
cut (canonical A0 eqA ltM (pX a s0));
 [ intros Op8 | apply canonical_reduceplus with (1 := cs) (3 := red2) ];
 auto.
cut (eqP A eqA n (pX a r0) (pX a s0)); [ intros eqPR1 | auto ].
elim
 reduce0_reducestar
  with
    (1 := cs)
    (eqA_dec := eqA_dec)
    (ltM_dec := ltM_dec)
    (Q := Q)
    (p := pX a r0); auto; intros t0 E1.
elim
 reduce0_reducestar
  with
    (1 := cs)
    (eqA_dec := eqA_dec)
    (ltM_dec := ltM_dec)
    (Q := Q)
    (p := pX a s0); auto; intros t1 E2.
cut
 (reducestar A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
    (pX a r) t0);
 [ intros red3
 | apply
    (reducestar_trans A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n
       ltM ltM_dec os Q) with (y := pX a r0) ]; auto.
cut
 (reducestar A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
    (pX a s) t1);
 [ intros red4
 | apply
    (reducestar_trans A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n
       ltM ltM_dec os Q) with (y := pX a s0) ]; auto.
cut (eqP A eqA n t0 t1); [ intros eqPR2 | auto ].
apply (eqp_trans _ _ _ _ _ _ _ _ _ cs n) with (y := t0); auto.
lapply (H'0 (pX a r));
 [ intros H'7; lapply H'7; [ intros H'8; elim H'8; clear H'7 | clear H'7 ]
 | idtac ]; auto.
apply ltP_reduce with (1 := cs) (3 := H'1); auto.
apply (eqp_trans _ _ _ _ _ _ _ _ _ cs n) with (y := t1); auto.
lapply (H'0 (pX a s));
 [ intros H'7; lapply H'7; [ intros H'8; elim H'8; clear H'7 | clear H'7 ]
 | idtac ]; auto.
apply ltP_reduce with (1 := cs) (3 := H'2); auto.
lapply
 (reducestar_eqp_com _ _ _ _ _ _ _ _ _ cs eqA_dec n ltM ltM_dec os Q
    (pX a r0) t0 (pX a s0) t0);
 [ intros H'11; lapply H'11;
    [ intros H'12; lapply H'12;
       [ intros H'13; lapply H'13;
          [ intros H'14; clear H'13 H'12 H'11 | clear H'13 H'12 H'11 ]
       | clear H'12 H'11 ]
    | clear H'11 ]
 | idtac ]; auto.
lapply (H'0 (pX a s0));
 [ intros H'7; lapply H'7; [ intros H'8; elim H'8; clear H'7 | clear H'7 ]
 | idtac ]; auto.
elim
 order_reduceplus
  with
    (1 := cs)
    (Q := Q)
    (p := pX a s)
    (q := pX a s0)
    (ltM_dec := ltM_dec)
    (eqA_dec := eqA_dec); auto.
intros H'13; apply ltP_trans with (y := pX a s); auto.
apply
 ltP_reduce with (1 := cs) (ltM_dec := ltM_dec) (eqA_dec := eqA_dec) (Q := Q);
 auto.
intros H'13;
 apply (ltp_eqp_comp A A0 eqA) with (ltM := ltM) (p := pX a s) (q := pX a p);
 auto.
apply
 ltP_reduce with (Q := Q) (1 := cs) (ltM_dec := ltM_dec) (eqA_dec := eqA_dec);
 auto.
apply eqpP1; auto.
apply H'5; auto.
inversion_clear E0; auto.
apply reducestar0; auto.
apply Rstar_n with (y := r); auto.
apply reduce_inv with (1 := cs) (3 := H'1); auto.
apply reducestar0; auto.
apply Rstar_n with (y := s); auto.
apply reduce_inv with (1 := cs) (3 := H'2); auto.
inversion_clear E; auto.
inversion_clear E; auto.
Qed.

Inductive Spoly_1 (Q : list (poly A0 eqA ltM)) :
list (Term A n) -> list (Term A n) -> Prop :=
  | Spoly_10 :
      forall (p q : list (Term A n)) (Cp : canonical A0 eqA ltM p)
        (Cq : canonical A0 eqA ltM q),
      reducestar A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
        (spolyf p q Cp Cq) (pO A n) -> Spoly_1 Q p q
  | Spoly_11 :
      forall (b c d : Term A n) (q r r0 s0 t : list (Term A n)),
      Spoly_1 Q (pX c r) (pX d t) ->
      Spoly_1 Q (pX d t) (pX b q) ->
      inPolySet A A0 eqA n ltM (pX d t) Q ->
      divP A A0 eqA multA divA n (ppc (A:=A) A1 (n:=n) c b) d ->
      Spoly_1 Q (pX c r) (pX b q).

Inductive SpolyQ (Q : list (poly A0 eqA ltM)) : Prop :=
    SpolyQ0 :
      (forall p q : list (Term A n),
       inPolySet A A0 eqA n ltM p Q ->
       canonical A0 eqA ltM p ->
       inPolySet A A0 eqA n ltM q Q ->
       canonical A0 eqA ltM q -> Spoly_1 Q p q) ->
      SpolyQ Q.

Inductive Reducep (Q : list (poly A0 eqA ltM)) :
list (Term A n) -> list (Term A n) -> list (Term A n) -> Prop :=
    Reducep0 :
      forall (a b c : Term A n) (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b)
        (nZc : ~ zeroP (A:=A) A0 eqA (n:=n) c) (p q r : list (Term A n)),
      reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
        (pX a p)
        (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a
           b nZb p q) ->
      reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
        (pX a p)
        (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a
           c nZc p r) ->
      divP A A0 eqA multA divA n a b ->
      inPolySet A A0 eqA n ltM (pX b q) Q ->
      divP A A0 eqA multA divA n a c ->
      inPolySet A A0 eqA n ltM (pX c r) Q ->
      Reducep Q (pX a p) (pX b q) (pX c r).

Inductive Confluent (Q : list (poly A0 eqA ltM)) :
list (Term A n) -> list (Term A n) -> list (Term A n) -> Prop :=
    Confluent0 :
      forall (a b c : Term A n) (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b)
        (nZc : ~ zeroP (A:=A) A0 eqA (n:=n) c) (p q r : list (Term A n)),
      (forall r1 s1 : list (Term A n),
       reducestar A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
         (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a
            b nZb p q) r1 ->
       reducestar A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
         (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a
            c nZc p r) s1 -> eqP A eqA n r1 s1) ->
      Confluent Q (pX a p) (pX b q) (pX c r).

Theorem Conf_inv1 :
 forall (Q : list (poly A0 eqA ltM)) (a b c : Term A n)
   (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b)
   (nZc : ~ zeroP (A:=A) A0 eqA (n:=n) c) (p q r r1 s1 : list (Term A n)),
 Confluent Q (pX a p) (pX b q) (pX c r) ->
 reducestar A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
   (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a b nZb
      p q) r1 ->
 reducestar A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
   (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a c nZc
      p r) s1 -> eqP A eqA n r1 s1.
intros Q a b c nZb nZc p q r r1 s1 H'0 H'1 H'2; inversion_clear H'0.
apply H.
rewrite sp_rew with (1 := cs) (a := a) (b := b) (nZ2 := nZb); auto.
rewrite sp_rew with (1 := cs) (a := a) (b := c) (nZ2 := nZc); auto.
Qed.

Theorem Conf_trans :
 forall (Q : list (poly A0 eqA ltM)) (a b c d : Term A n)
   (p0 q r t : list (Term A n)),
 Reducep Q (pX a p0) (pX c r) (pX d t) ->
 Reducep Q (pX a p0) (pX d t) (pX b q) ->
 Confluent Q (pX a p0) (pX c r) (pX d t) ->
 Confluent Q (pX a p0) (pX d t) (pX b q) ->
 canonical A0 eqA ltM (pX a p0) ->
 canonical A0 eqA ltM (pX d t) -> Confluent Q (pX a p0) (pX c r) (pX b q).
intros Q a b c d p q r t H' H'0 H'1 H'2 H'3 H'4.
cut (~ zeroP (A:=A) A0 eqA (n:=n) b); [ intros nZb | idtac ].
cut (~ zeroP (A:=A) A0 eqA (n:=n) c); [ intros nZc | idtac ].
cut (~ zeroP (A:=A) A0 eqA (n:=n) d); [ intros nZd | idtac ].
apply Confluent0 with (nZb := nZc) (nZc := nZb); auto.
intros r1 s1 H'5 H'6.
elim
 reduce0_reducestar
  with
    (eqA_dec := eqA_dec)
    (ltM_dec := ltM_dec)
    (1 := cs)
    (Q := Q)
    (p := spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a
            d nZd p t); auto.
intros t0 E; apply (eqp_trans _ _ _ _ _ _ _ _ _ cs n) with (y := t0).
apply
 Conf_inv1
  with
    (Q := Q)
    (a := a)
    (b := c)
    (c := d)
    (nZb := nZc)
    (nZc := nZd)
    (p := p)
    (q := r)
    (r := t); auto.
apply
 Conf_inv1
  with
    (Q := Q)
    (a := a)
    (b := d)
    (c := b)
    (nZb := nZd)
    (nZc := nZb)
    (p := p)
    (q := t)
    (r := q); auto.
apply canonical_spminusf with (1 := cs); auto.
apply canonical_imp_canonical with (a := a); auto.
apply canonical_imp_canonical with (a := d); auto.
inversion_clear H'; auto.
apply canonical_nzeroP with (ltM := ltM) (p := t); auto.
apply canonical_nzeroP with (ltM := ltM) (p := r); auto.
apply inPolySet_imp_canonical with (L := Q); auto.
inversion_clear H'; auto.
apply canonical_nzeroP with (ltM := ltM) (p := q); auto.
apply inPolySet_imp_canonical with (L := Q); auto.
inversion_clear H'0; auto.
Qed.

Theorem confl_top_simpl :
 forall (Q : list (poly A0 eqA ltM)) (a b c : Term A n)
   (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b)
   (nZc : ~ zeroP (A:=A) A0 eqA (n:=n) c) (p q r : list (Term A n))
   (Cpxc : canonical A0 eqA ltM (pX c r))
   (Cpxb : canonical A0 eqA ltM (pX b q)),
 reducestar A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
   (spolyf (pX c r) (pX b q) Cpxc Cpxb) (pO A n) ->
 canonical A0 eqA ltM (pX a p) ->
 divP A A0 eqA multA divA n a b ->
 inPolySet A A0 eqA n ltM (pX b q) Q ->
 divP A A0 eqA multA divA n a c ->
 inPolySet A A0 eqA n ltM (pX c r) Q ->
 (forall q : list (Term A n),
  canonical A0 eqA ltM q ->
  ltP (A:=A) (n:=n) ltM q (pX a p) -> ReduStarConfluent Q q) ->
 reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
   (pX a p)
   (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a b nZb
      p q) ->
 reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
   (pX a p)
   (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a c nZc
      p r) ->
 forall r1 s1 : list (Term A n),
 reducestar A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
   (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a b nZb
      p q) r1 ->
 reducestar A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
   (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a c nZc
      p r) s1 -> eqP A eqA n r1 s1.
intros Q a b c nZb nZc p q r Cpxc Cpxb red_r0 Cpxa divP_ab in_bp_Q divP_ac
 in_cr_Q Rec red1 red2 r1 s1 reds1 reds2.
cut (canonical A0 eqA ltM p);
 [ intros Op1 | apply canonical_imp_canonical with a; auto ].
cut (canonical A0 eqA ltM r);
 [ intros Op2 | apply canonical_imp_canonical with c; auto ].
cut (canonical A0 eqA ltM q);
 [ intros Op3 | apply canonical_imp_canonical with b; auto ].
cut (~ zeroP (A:=A) A0 eqA (n:=n) a); [ intros nZa | idtac ].
cut (~ zeroP (A:=A) A0 eqA (n:=n) (ppc (A:=A) A1 (n:=n) c b));
 [ intros nZppcd | idtac ].
cut
 (eqP A eqA n
    (mults (A:=A) multA (n:=n)
       (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) a
          (b:=ppc (A:=A) A1 (n:=n) c b) nZppcd)
       (spolyf (pX c r) (pX b q) Cpxc Cpxb))
    (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec
       (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a b
          nZb p q)
       (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a c
          nZc p r))); [ intros red3 | apply eqTerm_spolyf_red2; auto ].
2: apply ppc_nZ with (1 := cs); auto.
2: apply canonical_nzeroP with (ltM := ltM) (p := p); auto.
inversion_clear red_r0.
lapply
 (reduceplus_mults _ _ _ _ _ _ _ _ _ cs eqA_dec n ltM ltM_dec os Q
    (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) a
       (b:=ppc (A:=A) A1 (n:=n) c b) nZppcd)
    (spolyf (pX c r) (pX b q) Cpxc Cpxb) (pO A n));
 [ intros H'3; lapply H'3;
    [ intros H'4; lapply H'4; [ intros H'5; clear H'4 H'3 | clear H'4 H'3 ]
    | clear H'3 ]
 | idtac ]; auto.
elim
 (red_minus_zero_reduce _ _ _ _ _ _ _ _ _ cs eqA_dec _ _ ltM_dec os Q
    (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a b
       nZb p q)
    (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a c
       nZc p r));
 [ intros r2 E; elim E; intros H'6 H'7; clear E | idtac | idtac | idtac ];
 auto.
2: apply canonical_spminusf with (1 := cs); auto.
2: apply canonical_spminusf with (1 := cs); auto.
elim
 reduce0_reducestar
  with (1 := cs) (Q := Q) (p := r2) (ltM_dec := ltM_dec) (eqA_dec := eqA_dec);
 auto.
intros t0 E;
 lapply
  (Rec
     (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a b
        nZb p q));
 [ intros H'1; lapply H'1; [ intros H'2; elim H'2; clear H'1 | clear H'1 ]
 | idtac ]; auto.
intros H'.
lapply
 (Rec
    (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a c
       nZc p r));
 [ intros H'1; lapply H'1; [ intros H'3; elim H'3; clear H'1 | clear H'1 ]
 | idtac ]; auto.
intros H'1.
apply (eqp_trans _ _ _ _ _ _ _ _ _ cs n) with (y := t0).
apply H'; auto.
auto;
 apply
  (reducestar_trans A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
     ltM_dec os Q) with (y := r2); auto.
apply canonical_spminusf with (1 := cs); auto.
apply H'1; auto.
apply
 (reducestar_trans A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
    ltM_dec os Q) with (y := r2); auto.
apply canonical_spminusf with (1 := cs); auto.
apply
 ltP_reduce with (Q := Q) (1 := cs) (ltM_dec := ltM_dec) (eqA_dec := eqA_dec);
 auto.
apply canonical_spminusf with (1 := cs); auto.
apply
 ltP_reduce with (Q := Q) (1 := cs) (ltM_dec := ltM_dec) (eqA_dec := eqA_dec);
 auto.
apply canonical_spminusf with (1 := cs); auto.
apply canonical_reduceplus with (1 := cs) (3 := H'7); auto.
apply canonical_spminusf with (1 := cs); auto.
apply
 reduceplus_eqp_com
  with
    (p := mults (A:=A) multA (n:=n)
            (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) a
               (b:=ppc (A:=A) A1 (n:=n) c b) nZppcd)
            (spolyf (pX c r) (pX b q) Cpxc Cpxb))
    (q := mults (A:=A) multA (n:=n)
            (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) a
               (b:=ppc (A:=A) A1 (n:=n) c b) nZppcd)
            (pO A n))
    (1 := cs); auto; simpl in |- *; auto.
Qed.

Theorem fconfl_top :
 forall (Q : list (poly A0 eqA ltM)) (q r : list (Term A n)),
 Spoly_1 Q q r ->
 forall p : list (Term A n),
 Reducep Q p q r ->
 canonical A0 eqA ltM p ->
 canonical A0 eqA ltM q ->
 canonical A0 eqA ltM r ->
 (forall q0 : list (Term A n),
  canonical A0 eqA ltM q0 ->
  ltP (A:=A) (n:=n) ltM q0 p -> ReduStarConfluent Q q0) ->
 Confluent Q p q r.
intros Q q r Spoly1; elim Spoly1; clear Spoly1 q r.
intros q r Cq Cr red0 p H'1;
 (generalize Cq Cr red0; inversion_clear H'1; clear red0 Cq Cr).
intros Cq Cr H' H'0 H'1 H'2 H'3.
apply Confluent0 with (nZb := nZb) (nZc := nZc); auto.
intros r1 s1 H'5 H'6.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n).
apply (confl_top_simpl Q a c b nZc nZb p0 r0 q0 Cq Cr); auto.
intros b c d q r H' H'0 t H'1 H'2 H'3 H'4 H'5 H'6 p H'7 H'8 H'9 H'10 H'11.
generalize H'11 H'8; clear H'11 H'8; inversion_clear H'7.
intros H'8 H'11.
cut (divP A A0 eqA multA divA n a d); [ intros div0 | idtac ].
2: apply
    (divP_trans _ _ _ _ _ _ _ _ _ cs n) with (y := ppc (A:=A) A1 (n:=n) c b);
    auto.
2: case ppc_is_ppcm with (1 := cs) (a := c) (b := b); auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) d); [ intros nZd | inversion div0 ]; auto.
cut (Reducep Q (pX a p0) (pX d t) (pX b q)); [ intros Red0 | idtac ].
2: apply Reducep0 with (nZb := nZd) (nZc := nZc); auto.
cut (Reducep Q (pX a p0) (pX c r) (pX d t)); [ intros Red1 | idtac ].
2: apply Reducep0 with (nZb := nZb) (nZc := nZd); auto.
apply Conf_trans with (d := d) (t := t); auto.
apply H'2; auto.
apply inPolySet_imp_canonical with (L := Q); auto.
apply H'4; auto.
apply inPolySet_imp_canonical with (L := Q); auto.
apply inPolySet_imp_canonical with (L := Q); auto.
apply reducetop_sp with (1 := cs); auto.
apply reducetop_sp with (1 := cs); auto.
Qed.

Theorem confl_top :
 forall Q : list (poly A0 eqA ltM),
 SpolyQ Q ->
 forall (a b c : Term A n) (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b)
   (nZc : ~ zeroP (A:=A) A0 eqA (n:=n) c) (p q r : list (Term A n)),
 canonical A0 eqA ltM (pX a p) ->
 divP A A0 eqA multA divA n a b ->
 inPolySet A A0 eqA n ltM (pX b q) Q ->
 divP A A0 eqA multA divA n a c ->
 inPolySet A A0 eqA n ltM (pX c r) Q ->
 (forall q : list (Term A n),
  canonical A0 eqA ltM q ->
  ltP (A:=A) (n:=n) ltM q (pX a p) -> ReduStarConfluent Q q) ->
 reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
   (pX a p)
   (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a b nZb
      p q) ->
 reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
   (pX a p)
   (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a c nZc
      p r) ->
 forall r1 s1 : list (Term A n),
 reducestar A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
   (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a b nZb
      p q) r1 ->
 reducestar A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
   (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a c nZc
      p r) s1 -> eqP A eqA n r1 s1.
intros Q H' a b c nZb nZc p q r H'0 H'1 H'2 H'3 H'4 H'5 H'6 H'7 r1 s1 H'8 H'9.
cut (canonical A0 eqA ltM (pX b q)); [ intros Op0 | idtac ].
cut (canonical A0 eqA ltM (pX c r)); [ intros Op0bis | idtac ].
cut (Confluent Q (pX a p) (pX b q) (pX c r)); auto.
2: apply fconfl_top; auto.
2: inversion_clear H'; auto.
2: apply Reducep0 with (nZb := nZb) (nZc := nZc); auto.
2: apply inPolySet_imp_canonical with (L := Q); auto.
2: apply inPolySet_imp_canonical with (L := Q); auto.
intros H'10.
apply (Conf_inv1 Q a b c nZb nZc p q r r1 s1); auto.
Qed.

Theorem confl_mix :
 forall (Q : list (poly A0 eqA ltM)) (a b : Term A n)
   (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b) (p q r : list (Term A n)),
 canonical A0 eqA ltM (pX a p) ->
 divP A A0 eqA multA divA n a b ->
 inPolySet A A0 eqA n ltM (pX b r) Q ->
 (forall q : list (Term A n),
  canonical A0 eqA ltM q ->
  ltP (A:=A) (n:=n) ltM q (pX a p) -> ReduStarConfluent Q q) ->
 reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
   (pX a p) (pX a q) ->
 reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
   (pX a p)
   (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a b nZb
      p r) ->
 forall r1 s1 : list (Term A n),
 reducestar A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
   (pX a q) r1 ->
 reducestar A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
   (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a b nZb
      p r) s1 -> eqP A eqA n r1 s1.
intros Q a b nZb p q r Op1 dviP_ab in_br Rec red1 red2 r1 s1 red3 red4.
cut (canonical A0 eqA ltM (pX b r));
 [ intros Op2 | apply inPolySet_imp_canonical with (L := Q); auto ].
cut (reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q p q);
 [ intros H'6 | apply reduce_inv with (1 := cs) (3 := red1); auto ].
cut (canonical A0 eqA ltM p);
 [ intros Op3 | apply canonical_imp_canonical with (a := a); auto ].
cut (canonical A0 eqA ltM r);
 [ intros Op4 | apply canonical_imp_canonical with (a := b); auto ].
cut (canonical A0 eqA ltM q);
 [ intros Op5 | apply canonical_reduce with (1 := cs) (3 := H'6); auto ].
case
 one_minus_reduceplus
  with
    (plusA := plusA)
    (3 := H'6)
    (r := mults (A:=A) multA (n:=n)
            (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) a (b:=b) nZb) r);
 auto.
intros s H; elim H; intros H0 H1; clear H.
cut (canonical A0 eqA ltM s);
 [ intros Op6 | apply canonical_reduceplus with (1 := cs) (3 := H1); auto ].
elim
 reduce0_reducestar
  with (Q := Q) (p := s) (1 := cs) (ltM_dec := ltM_dec) (eqA_dec := eqA_dec);
 auto; intros t E.
apply (eqp_trans _ _ _ _ _ _ _ _ _ cs n) with (y := t); auto.
lapply (Rec (pX a q));
 [ intros H'0; lapply H'0; [ intros H'1; elim H'1; clear H'0 | clear H'0 ]
 | idtac ]; auto.
intros PH'0; apply PH'0; auto.
apply
 (reducestar_trans A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
    ltM_dec os Q) with (y := s); auto.
apply canonical_reduce with (1 := cs) (3 := red1); auto.
apply
 Rstar_n
  with
    (y := minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec q
            (mults (A:=A) multA (n:=n)
               (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) a (b:=b) nZb)
               r)); auto.
apply reducetop with (b := b) (nZb := nZb) (q := r); auto.
apply ltP_reduce with (1 := cs) (3 := red1); auto.
apply canonical_reduce with (1 := cs) (3 := red1); auto.
lapply
 (Rec
    (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a b
       nZb p r));
 [ intros H'0; lapply H'0; [ intros H'1; elim H'1; clear H'0 | clear H'0 ]
 | idtac ]; auto.
intros PH'0; apply PH'0; auto.
apply
 (reducestar_trans A A0 A1 eqA plusA invA minusA multA divA cs eqA_dec n ltM
    ltM_dec os Q) with (y := s); auto.
apply canonical_spminusf with (1 := cs); auto.
apply ltP_reduce with (1 := cs) (3 := red2); auto.
apply canonical_spminusf with (1 := cs); auto.
Qed.
Hint Resolve pO_irreducible.

Theorem confl_restar :
 forall Q : list (poly A0 eqA ltM),
 SpolyQ Q ->
 forall p : poly A0 eqA ltM, ReduStarConfluent Q (s2p A A0 eqA n ltM p).
intros Q H'.
intros p; pattern p in |- *;
 apply
  well_founded_ind
   with (R := sltP (A:=A) (A0:=A0) (eqA:=eqA) (n:=n) (ltM:=ltM));
 auto.
apply sltp_wf; auto.
intros x; elim x; clear x.
intros x Op_x Rec; simpl in |- *.
apply ReduStarConfluent0; auto.
intros r s H'1 H'2.
case reducestar_inv with (1 := cs) (3 := H'2); auto; intros H'8; elim H'8;
 clear H'8.
case reducestar_inv with (1 := cs) (3 := H'1); auto; intros H'9; elim H'9;
 clear H'9.
intros H H0 H1 H2; apply (eqp_trans _ _ _ _ _ _ _ _ _ cs n) with (y := x);
 auto; apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
intros x0 H H0 H1; elim H; intros H2 H3;
 absurd
  (reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q x x0);
 auto.
intros x0 H; elim H; intros H0 H1; clear H.
case reducestar_inv with (1 := cs) (3 := H'1); auto; intros H'9; elim H'9;
 clear H'9.
intros H H2;
 absurd
  (reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q x x0);
 auto.
intros x1 H; elim H; intros H2 H3; clear H.
generalize H3 H0 H'1 Op_x Rec; clear H3 H0 H'1 Rec Op_x; inversion H2.
intros H'3 H'4 H'5 Op_x H'6.
generalize Op_x H'6 H'5 H'3; clear H'5 H'3 H'6 Op_x.
inversion H'4.
intros Op_x H'6 H'5 H'3.
apply
 confl_top
  with
    (Q := Q)
    (a := a)
    (b := b)
    (c := b0)
    (nZb := nZb)
    (nZc := nZb0)
    (p := p0)
    (q := q)
    (r := q0); auto.
intros q1 H'9 H'10.
generalize (H'6 (mks A A0 eqA n ltM q1 H'9)); simpl in |- *; auto.
apply reducetop_sp with (1 := cs); auto.
apply reducetop_sp with (1 := cs); auto.
apply reducestar_eqp_com with (1 := cs) (p := x1) (q := r); auto.
apply canonical_reduce with (1 := cs) (3 := H2); auto.
rewrite <- H4; auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply reducestar_eqp_com with (1 := cs) (p := x0) (q := s); auto.
apply canonical_reduce with (1 := cs) (3 := H'4); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
intros Op_x H'6 H'5 H'3.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n).
apply
 confl_mix
  with (Q := Q) (a := a) (b := b) (nZb := nZb) (p := p0) (q := q0) (r := q);
 auto.
intros q1 H'9 H'10.
generalize (H'6 (mks A A0 eqA n ltM q1 H'9)); simpl in |- *; auto.
apply reducetop_sp with (1 := cs); auto.
apply reducestar_eqp_com with (p := pX b0 q0) (q := s) (1 := cs); auto.
rewrite H9; auto.
rewrite H9.
apply canonical_reduce with (1 := cs) (3 := H'4); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply reducestar_eqp_com with (1 := cs) (p := x1) (q := r); auto.
apply canonical_reduce with (1 := cs) (3 := H2); auto.
rewrite <- H4; auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
intros H'3 H'4 H'5 Op_x H'6.
inversion H'4.
apply (confl_mix Q a b0 nZb p0 q q0); auto.
intros q1 H'9 H'10.
generalize (H'6 (mks A A0 eqA n ltM q1 H'9)); simpl in |- *; auto.
apply reducetop_sp with (1 := cs); auto.
apply reducestar_eqp_com with (1 := cs) (p := pX b q) (q := r); auto.
rewrite H4; auto.
apply canonical_reduce with (1 := cs) (3 := H2); auto.
rewrite <- H3; auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply reducestar_eqp_com with (1 := cs) (p := x0) (q := s); auto.
apply canonical_reduce with (1 := cs) (3 := H'4); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply confl_under with (Q := Q) (a := a) (p := p0) (r := q) (s := q0); auto.
intros q1 H'9 H'10.
generalize (H'6 (mks A A0 eqA n ltM q1 H'9)); simpl in |- *; auto.
apply reducestar_eqp_com with (1 := cs) (p := pX b q) (q := r); auto.
rewrite H4.
apply canonical_reduce with (1 := cs) (3 := H2); auto.
rewrite <- H3; auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply reducestar_eqp_com with (p := pX b0 q0) (q := s) (1 := cs); auto.
rewrite H8; auto.
rewrite H8; apply canonical_reduce with (1 := cs) (3 := H'4); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
Qed.

Theorem confl_reducestar :
 forall Q : list (poly A0 eqA ltM),
 SpolyQ Q ->
 forall p : list (Term A n), canonical A0 eqA ltM p -> ReduStarConfluent Q p.
intros Q H' p H'0.
generalize (confl_restar Q H' (mks A A0 eqA n ltM p H'0)); simpl in |- *;
 auto.
Qed.
End Pspoly.


(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*              Solange Coupet-Grimal & Catherine Nouvet                    *)
(*                                                                          *)
(*                                                                          *)
(*       Laboratoire d'Informatique Fondamentale de Marseille               *)
(*               CMI-Technopole de Chateau-Gombert                          *)
(*                   39, Rue F. Joliot Curie                                *)
(*                   13453 MARSEILLE Cedex 13                               *)
(*           Contact :Solange.Coupet@cmi.univ-mrs.fr                        *)
(*                                                                          *)
(*                                                                          *)
(*                                Coq V7.0                                  *)
(*                             Septembre 2002                               *)
(*                                                                          *)
(****************************************************************************)
(*                               lemma_end.v                                *)
(****************************************************************************)

Section lemma_end.

Require Export gc.
Require Export reachable.

Notation Reachable := (reachable node) (only parsing).

Lemma gcend_ancestor_col :
 forall (s t : state) (n : node),
 (forall m : node,
  reachable node (hp s) m n -> mk s m = white \/ mk s m = free) ->
 gc_end s t ->
 forall m : node,
 reachable node (hp t) m n -> mk t m = white \/ mk t m = free.

intros s t n H_reach gcend m H_reach_m_t; elim gcend; clear gcend.
intros ctls ctlt heap mark; rewrite mark; apply H_reach; rewrite <- heap;
 assumption.
Qed.

Lemma gcend_accest_access :
 forall s t : state,
 gc_end s t ->
 forall n : node, accessible node (hp t) rt n -> accessible node (hp s) rt n.

intros s t gcend n acces_t_n; elim gcend; clear gcend.
intros ctls ctlt heap mark; rewrite <- heap; assumption.
Qed.

Lemma gcend_notaccess_notaccest :
 forall (s t : state) (n : node),
 ~ accessible node (hp s) rt n -> gc_end s t -> ~ accessible node (hp t) rt n.

intros s t n notacces_n_s gcend; elim gcend; clear gcend.
intros ctls ctlt heap mark; rewrite heap; assumption.
Qed.

Lemma gcend_notgreyt_notgreys :
 forall s t : state,
 gc_end s t -> forall n : node, mk t n <> grey -> mk s n <> grey.

intros s t gcend n mktn; elim gcend; clear gcend.
intros ctls ctlt heap mark; rewrite <- mark; assumption.
Qed.

Lemma gcend_blacks_blackt :
 forall s t : state,
 gc_end s t -> forall n : node, mk s n = black -> mk t n = black.

intros s t gcend n mktn; elim gcend; clear gcend.
intros ctls ctlt heap mark; rewrite mark; assumption.
Qed.

Lemma gcend_notfrees_notfreet :
 forall s t : state,
 gc_end s t -> forall n : node, mk s n <> free -> mk t n <> free.

intros s t gcend n mktn; elim gcend; clear gcend.
intros ctls ctlt heap mark; rewrite mark; assumption.
Qed.

Lemma gcend_white :
 forall (s t : state) (n : node),
 mk s n = white -> gc_end s t -> mk t n = white.

intros s t n mksn gcend; elim gcend; clear gcend.
intros ctls ctlt heap mark; rewrite mark; assumption.
Qed.

Lemma gcend_nogrey :
 forall s t : state,
 (forall n : node, mk s n <> grey) ->
 gc_end s t -> forall n : node, mk t n <> grey.

intros s t mksn gcend; elim gcend; clear gcend.
intros ctls ctlt heap mark; rewrite mark; auto.
Qed.

Lemma gcend_nowhite :
 forall s t : state,
 (forall n : node, mk s n <> white) ->
 gc_end s t -> forall n : node, mk t n <> white.

intros s t mksn gcend; elim gcend; clear gcend.
intros ctls ctlt heap mark; rewrite mark; auto.
Qed.

End lemma_end.

Hint Resolve gcend_notaccess_notaccest.
Hint Resolve gcend_white.
Hint Resolve gcend_nowhite.
Hint Resolve gcend_blacks_blackt.
Hint Resolve gcend_nogrey.
Hint Resolve gcend_ancestor_col.


From Categories Require Import Category.Main.
From Categories Require Import Coq_Cats.Coq_Cat.

(*
**********************************************************
***************                          *****************
***************      Set Category        *****************
***************                          *****************
**********************************************************
*)

(** The category of types in Set universe (Coq's "Set")*)

Program Definition Set_Cat : Category := Coq_Cat Set.


Add LoadPath "~/Documents/vfa" as VFA.
Require Import Coq.Strings.String.
Require Export Coq.Bool.Bool.
Require Export Coq.Arith.Arith.
Require Export Coq.Arith.EqNat.
Require Export Coq.omega.Omega.
Require Export Coq.Lists.List.
Export ListNotations.
Require Export Permutation.

Check Nat.lt.
Check lt.
Check Nat.ltb.
Locate "_ < _".
Locate "<?".

Check Nat.ltb_lt.

Notation "a >=? b" := (Nat.leb b a)
                        (at level 70, only parsing) : nat_scope.
Notation "a >? b" := (Nat.ltb b a)
                       (at level 70, only parsing) : nat_scope.
Notation " a =? b" := (beq_nat a b)
                        (at level 70) : nat_scope.

Print reflect.

Lemma beq_reflect : forall x y, reflect (x = y) (x =? y).
Proof.
  intros x y.
  apply iff_reflect. symmetry. apply beq_nat_true_iff.
Qed.

Lemma blt_reflect : forall x y, reflect (x < y) (x <? y).
Proof.
  intros x y.
  apply iff_reflect. symmetry. apply Nat.ltb_lt.
Qed.

Lemma ble_reflect : forall x y, reflect (x <= y) (x <=? y).
Proof.
  intros x y.
  apply iff_reflect. symmetry.
  apply Nat.leb_le.
Qed.

Example reflect_example1: forall a, (if a<? 5 then a else 2) < 6.
Proof.
  intros. destruct (blt_reflect a 5) as [H|H].
  * omega.
  * omega.
Qed.

Hint Resolve blt_reflect ble_reflect beq_reflect : bdestruct.

Ltac bdestruct X :=
  let H := fresh in let e := fresh "e" in
   evar (e: Prop);
   assert (H: reflect e X); subst e;
    [eauto with bdestruct
    | destruct H as [H|H];
      [ | try first [apply not_lt in H | apply not_le in H]]].

Example reflect_example2: forall a, (if a<?5 then a else 2) < 6.
Proof.
  intros. bdestruct (a<?5).
  * omega.
  * omega.
Qed.

Module Exploration1.

  Theorem bogus_subtraction: ~(forall k:nat, k>k-3).
  Proof.
    intro.
    specialize (H O).
    simpl in H. inversion H.
  Qed.

  Theorem omega_example1:
    forall i j k,
      i < j -> ~(k - 3 <= j) ->
      k > i.
  Proof.
    intros.
    apply not_le in H0.
    unfold gt in H0.
    unfold gt.
    Search (_ < _ -> _ <= _ -> _ < _).
    apply lt_le_trans with j.
    apply H.
    apply le_


(* Librarii pentru string-uri *)
Require Import Strings.String.
Local Open Scope string_scope.
Local Open Scope list_scope.
Scheme Equality for string.

(* Librarii pentru int *)
Require Import Coq.ZArith.ZArith.
Open Scope Z_scope.

Definition Var := string -> nat.

Inductive ErrorUnsigned :=
  | error_unsigned : ErrorUnsigned
  | num : nat -> ErrorUnsigned.

Inductive ErrorInt :=
  | error_int : ErrorInt
  | integer : Z -> ErrorInt.

Inductive ErrorBool :=
  | error_bool : ErrorBool
  | boolean : bool -> ErrorBool.

Inductive ErrorString :=
  | error_string : ErrorString
  | str : string -> ErrorString.

Coercion num: nat >-> ErrorUnsigned.
Coercion integer: Z >-> ErrorInt.
Coercion boolean: bool >-> ErrorBool.
Coercion str: string >-> ErrorString.

(* Expresii aritmetice *)
Inductive AExp :=
  | avar: ErrorString -> AExp
  | anum: ErrorUnsigned -> AExp
  | aint: ErrorInt -> AExp
  | aplus: AExp -> AExp -> AExp
  | aminus: AExp -> AExp -> AExp
  | amul: AExp -> AExp -> AExp
  | adiv: AExp -> AExp -> AExp
  | amod: AExp -> AExp -> AExp.

Coercion anum: ErrorUnsigned >-> AExp.
Coercion aint: ErrorInt >-> AExp.
Coercion avar: ErrorString >-> AExp.

Notation "A +' B" := (aplus A B) (at level 50, left associativity).
Notation "A -' B" := (aminus A B) (at level 50, left associativity).
Notation "A *' B" := (amul A B) (at level 40, left associativity).
Notation "A /' B" := (adiv A B) (at level 40, left associativity).
Notation "A %' B" := (amod A B) (at level 40, left associativity).

Check ("x" +' "y").
Check ("x" -' "y").
Check ("x" *' "y").
Check ("x" /' "y").
Check ("x" %' "y").

(* Expresii booleene *)
Inductive BExp :=
  | berror
  | btrue
  | bfalse
  | bvar: string -> BExp
  | blt : AExp -> AExp -> BExp
  | bgt : AExp -> AExp -> BExp
  | bleq : AExp -> AExp -> BExp
  | bgeq : AExp -> AExp -> BExp
  | bnot : BExp -> BExp
  | band : BExp -> BExp -> BExp
  | bor : BExp -> BExp -> BExp.

Coercion bvar: string >-> BExp.

Notation "!' A" := (bnot A) (at level 70, no associativity).
Notation "A <' B" := (blt A B) (at level 70, no associativity).
Notation "A >' B" := (bgt A B) (at level 70, no associativity).
Notation "A <=' B" := (bleq A B) (at level 70, no associativity).
Notation "A >=' B" := (bgeq A B) (at level 70, no associativity).
Notation "A '&&'' B" := (band A B) (at level 40, left associativity).
Notation "A '||'' B" := (bor A B) (at level 40, left associativity).

Check btrue.
Check bfalse.
Check (!' "x").
Check ("x" <' "y").
Check ("x" >' "y").
Check ("x" <=' "y").
Check ("x" >=' "y").
Check ("x" &&' "y").
Check ("x" ||' "y").

(* Expresii cu string-uri *)
Inductive StrExp := (* operatii cu string-uri *)
  | String : ErrorString -> StrExp
  | concat : ErrorString -> ErrorString -> StrExp
  | cmp : ErrorString -> ErrorString -> StrExp
  | length : ErrorString -> StrExp.

Coercion String: ErrorString >-> StrExp.

Notation " A +s B " := (concat A B) (at level 54).
Notation "'strcmp' ( A , B )" := (cmp A B) (at level 56).
Notation "'strlen' ( A )" := (length A) (at level 58).

Check ("abc" +s "abc").
Check (strcmp ( "abc" , "abc" )).
Check (strlen ( "abc" )).

(* Librarii pentru liste *)
Require Import Coq.Lists.List.
Import ListNotations.
Scheme Equality for list.

Print Coq.Lists.List.

(* In Stmt se afla declararile pentru tipuri de date: unsigned, bool, int, string *)
Inductive Stmt :=
  | unsigned_decl : string -> Stmt (* tipul unsigned *)
  | bool_decl : string -> Stmt (* tipul bool *)
  | int_decl : string -> Stmt (* tipul int *)
  | string_decl : string -> Stmt (* tipul string *)
  | unsigned_assign : string -> AExp -> Stmt
  | int_assign : string -> AExp -> Stmt
  | bool_assign : string -> BExp -> Stmt
  | string_assign : string -> AExp -> Stmt
  | sequence : Stmt -> Stmt -> Stmt
  | while : BExp -> Stmt -> Stmt
  | ifthenelse : BExp -> Stmt -> Stmt -> Stmt
  | ifthen : BExp -> Stmt -> Stmt
  | Struct : string -> Stmt -> Stmt (* struct-uri *)
  | funct_decl : string -> Stmt -> Stmt -> Stmt (* declarare functii *)
  | funct_call : string -> list Z -> Stmt (* apelare functii *)
  | switch1 : AExp -> list Case -> Stmt
  with Case :=
  | case1 : AExp -> Stmt -> Case
  | default1 : Stmt -> Case.

Notation "X :u= A" := (unsigned_assign X A)(at level 90).
Notation "X :i= A" := (int_assign X A)(at level 90).
Notation "X :b= A" := (bool_assign X A)(at level 90).
Notation "X :s= A" := (string_assign X A)(at level 90).
Notation "'unsigned' X" := (unsigned_decl X)(at level 90).
Notation "'int' X" := (int_decl X )(at level 90).
Notation "'Bool' X" := (bool_decl X )(at level 90).
Notation "'string'' X" := (int_decl X )(at level 90).
Notation "S1 ;; S2" := (sequence S1 S2) (at level 93, right associativity).
Notation "'if'' B 'then'' S1 'end''" := (ifthen B S1) (at level 97).
Notation "'if'' B 'then'' S1 'else'' S2 'end''" := (ifthenelse B S1 S2) (at level 97).
Notation "'while'' ( B ) { S }" := (while B S) (at level 97).
Notation "'for'' ( A ? B ? C ) { S } 'end''" := (A ;; while B ( S ;; C )) (at level 97).
Notation "'struct' X 'inceput' S 'sfarsit'" := (Struct X S) (at level 88, no associativity).
Notation " 'decl' X 'inceput' S1 'sfarsit' { S2 } " := (funct_decl X S1 S2) (at level 88, no associativity).
Notation " 'call' X 'inceput' L 'sfarsit' " := (funct_call X L) (at level 30, no associativity).
Notation " 'switch' A 'sf' L 'sfarsit' " := (switch1 A L) (at level 97).
Notation " 'case'  A 'sf' S 'sf' " := (case1 A S) (at level 99).
Notation " 'default'' S 'sf' " := (default1 S) (at level 99).

Check ( int "x1").
Check ( unsigned "x1" ;;
        "x1" :u= 3).
Check ( Bool "b" ;;
        "b" :b= btrue ;;
        int "x" ;;
        int "y" ;;
        unsigned "d" ;;
        int "i" ;;
        int "sum" ;;
        "x" :i= 2 ;;
        "y" :i= 3 ;;
        "d" :u= 0 ;;
        "sum" :i= 0 ;;
        if' ( "x" <=' "y" ) then'
          "d" :u= ("y" -' "x")
        else'
          "d" :u= ("x" -' "y")
        end' ;;
        if' ( "x" <=' "y" ) then'
          "d" :u= ("y" -' "x")
        end' ;;
        for' ( ("i" :i= 0) ? ("i" <=' "d") ? ("i" :i= "i" +'1)) {
            "sum" :i= ("sum" +' 1)
        } end' ;;
        "i" :i= 0 ;;
        while' ( "i" <=' "d" ) {
          "sum" :i= ("sum" +' 1)
        }).
Check ( decl "fun" inceput int "x" sfarsit {
        int "s" ;;
        "s" :i= ("x" +' 2)
        } ).
Check ( struct "nume" inceput
          int "x" ;;
          int "y"
        sfarsit ).
Check ( call "fun" inceput [2;3]  sfarsit ).
Check ( switch "x" +' "y" sf [
          case  7 sf "z" :i= 7 sf ;
          case 10 sf "z" :i= 10 sf ;
          default' "z" :i= 0 sf ] sfarsit  ).

Inductive Result :=
  | err_undecl : Result
  | err_assign : Result
  | default : Result
  | res_unsigned : ErrorUnsigned -> Result
  | res_int : ErrorInt -> Result
  | res_string : ErrorString -> Result
  | res_bool : ErrorBool -> Result.

Scheme Equality for Result.

Definition check_eq_over_types (t1 : Result)(t2 : Result) : bool :=
  match t1 with
  | err_undecl => match t2 with
                   | err_undecl => true
                   | _ => false
                   end
  | err_assign => match t2 with
                   | err_assign => true
                   | _ => false
                   end
  | default => match t2 with
                   | default => true
                   | _ => false
                   end
  | res_unsigned x => match t2 with
                   | res_unsigned x  => true
                   | _ => false
                  end
  | res_int x => match t2 with
                   | res_int x  => true
                   | _ => false
                  end
  | res_string x => match t2 with
                   | res_string x => true
                   | _ => false
                   end
  | res_bool x => match t2 with
                   | res_bool x => true
                   | _ => false
                   end
  end.


(** Calculation of a compiler for the call-by-need lambda calculus +
arithmetic. *)

Require Import List.
Require Import ListIndex.
Require Import Tactics.
Require Import Heap.

(** * Syntax *)

Inductive Expr : Set :=
| Val : nat -> Expr
| Add : Expr -> Expr -> Expr
| Var : nat -> Expr
| Abs : Expr -> Expr
| App : Expr -> Expr -> Expr.

(** * Semantics *)

(** The evaluator for this language is taken from Ager et al. "A
functional correspondence between call-by-need evaluators and lazy
abstract machines". We use Haskell syntax to define the
evaluator. Moreover, we use an abstract interface to a heap
implementation:
<<
type Heap a
type Loc

empty :: Heap a
deref :: Heap a -> Loc -> a
update :: Heap a -> Loc -> a -> Heap a
alloc :: Heap a -> a -> (Heap a, Loc)
>>
Moreover, we assume that `Heap` forms a functor with an associated function
<<
hmap :: (a -> b) -> Heap a -> Heap b
>>
which in addition to functoriality also satisfies the following laws:
<<
hmap f empty = empty                                             (hmap-empty)
deref (hmap f h) l = f (deref h l)                               (hmap-deref)
hmap f (update h l e) = update (hmap f h) l (f e)                (hmap-update)
alloc (hmap f h) (f e) = (h', l) <=> alloc h e = (hmap f h', l)  (hmap-alloc)
>>

The evaluator itself is defined as follows:
<<
type Env   = [Loc]
data HElem = Thunk (Heap HElem -> (Value, Heap HElem)) | Value Value
data Value = Num Int | Clo (Loc -> Heap HElem -> (Value, Heap HElem))

eval :: Expr -> Env -> Heap HElem -> (Value, Heap HElem)
eval (Val n)   e h = (Num n, h)
eval (Add x y) e h = case eval x e h of
                       (Num n, h') -> case eval y e h' of
                                        (Num m, h'') -> (Num (n + m), h'')
eval (Var i)   e h = case deref h (e !! i) of
                       Thunk t -> let (v, h') = t h
                                  in (v, update h' (e !! i) (Value v))
                       Value v -> (v, h)
eval (Abs x)   e h = (Clo (\ l h' -> eval x (l : e) h') , h)
eval (App x y) e h = case eval x e h of
                       (Clo , h') -> let (h'',l) = alloc h' (Thunk (\h -> eval y e h))
                                     in f l h''
>>
After defunctionalisation and translation into relational form we
obtain the semantics below.  *)

Definition Env : Set := list Loc.

Inductive Value : Set :=
| Num : nat -> Value
| Clo : Expr -> Env -> Value.

Inductive HElem : Set  :=
  | thunk : Expr -> Env -> HElem
  | value : Value -> HElem.

Definition Heap := Heap.Heap HElem.

Reserved Notation "x ⇓[ e , h , h' ] y" (at level 80, no associativity).

Inductive eval : Expr -> Env -> Heap -> Heap -> Value -> Prop :=
| eval_val e n (h h' : Heap) : Val n ⇓[e,h,h] Num n
| eval_add e x y m n h h' h'' : x ⇓[e,h,h'] Num m -> y ⇓[e,h',h''] Num n -> Add x y ⇓[e,h,h''] Num (m + n)
| eval_var_thunk e e' x i l v h h' : nth e i = Some l -> deref h l = Some (thunk x e') -> x ⇓[e',h,h'] v ->
                          Var i ⇓[e,h,update h' l (value v)] v
| eval_var_val e i l v h : nth e i = Some l -> deref h l = Some (value v) ->
                          Var i ⇓[e,h,h] v
| eval_abs e x h : Abs x ⇓[e,h,h] Clo x e
| eval_app e e' x x' x'' y l h h' h'' h''' : x ⇓[e,h,h'] Clo x' e' -> alloc h' (thunk y e) = (h'',l) ->
                              x' ⇓[l :: e',h'',h'''] x'' -> App x y ⇓[e,h,h'''] x''
where "x ⇓[ e , h , h' ] y" := (eval x e h h' y).

(** * Compiler *)

Inductive Code : Set :=
| PUSH : nat -> Code -> Code
| ADD : Code -> Code
| WRITE : Code
| LOOKUP : nat -> Code -> Code
| RET : Code
| APP : Code -> Code -> Code
| ABS : Code -> Code -> Code
| HALT : Code.

Fixpoint comp' (e : Expr) (c : Code) : Code :=
  match e with
    | Val n => PUSH n c
    | Add x y => comp' x (comp' y (ADD c))
    | Var i => LOOKUP i c
    | App x y => comp' x (APP (comp' y WRITE) c)
    | Abs x => ABS (comp' x RET) c
  end.

Definition comp (e : Expr) : Code := comp' e HALT.

(** * Virtual Machine *)

Inductive Value' : Set :=
| Num' : nat -> Value'
| Clo' : Code -> Env -> Value'.

Inductive HElem' : Set  :=
  | thunk' : Code -> Env -> HElem'
  | value' : Value' -> HElem'.

Definition Heap' := Heap.Heap HElem'.

Inductive Elem : Set :=
| VAL : Value' -> Elem
| THU : Loc -> Code -> Env -> Elem
| FUN : Code -> Env -> Elem
.
Definition Stack : Set := list Elem.

Inductive Conf : Set :=
| conf : Code -> Stack -> Env -> Heap' -> Conf.

Notation "⟨ x , y , e , h ⟩" := (conf x y e h).

Reserved Notation "x ==> y" (at level 80, no associativity).
Inductive VM : Conf -> Conf -> Prop :=
| vm_push n c s e h :  ⟨PUSH n c, s, e, h⟩ ==> ⟨c, VAL (Num' n) :: s, e, h⟩
| vm_add c m n s e h : ⟨ADD c, VAL (Num' n) :: VAL (Num' m) :: s, e, h⟩
                       ==> ⟨c, VAL (Num'(m + n)) :: s, e, h⟩
| vm_write e e' l v c s h : ⟨WRITE, VAL v :: THU l c e :: s, e', h⟩ ==> ⟨c, VAL v :: s,e,update h l (value' v)⟩
| vm_lookup_thunk e e' i c c' h l s : nth e i = Some l -> deref h l = Some (thunk' c' e') ->
                               ⟨LOOKUP i c, s, e, h⟩ ==> ⟨c', THU l c e :: s, e', h⟩
| vm_lookup_value e i c h l v s : nth e i = Some l -> deref h l = Some (value' v) ->
                               ⟨LOOKUP i c, s, e, h⟩ ==> ⟨c, VAL v :: s, e, h⟩
| vm_ret v c e e' h s  : ⟨RET, VAL v :: FUN c e :: s, e', h⟩ ==> ⟨c, VAL v :: s, e, h⟩
| vm_app c c' c'' e e' s h h' l : alloc h (thunk' c' e) = (h',l) ->
                           ⟨APP c' c, VAL (Clo' c'' e') :: s, e, h⟩
                            ==> ⟨c'', FUN c e :: s, l :: e', h'⟩
| vm_abs c c' s e h : ⟨ABS c' c, s, e, h⟩ ==> ⟨c, VAL (Clo' c' e) :: s, e, h⟩
where "x ==> y" := (VM x y).

(** Conversion functions from semantics to VM *)

Definition convV (v : Value) : Value' :=
  match v with
    | Num n => Num' n
    | Clo x e => Clo' (comp' x RET) e
  end.

Definition convHE (t : HElem) : HElem' :=
  match t with
    | value v => value' (convV v)
    | thunk x e => thunk' (comp' x WRITE) e
  end.

Definition convH : Heap -> Heap' := hmap convHE.

(** * Calculation *)

(** Boilerplate to import calculation tactics *)

Module VM <: Preorder.
Definition Conf := Conf.
Definition VM := VM.
End VM.
Module VMCalc := Calculation VM.
Import VMCalc.

(** Specification of the compiler *)

Theorem spec p e r c s h h' : p ⇓[e,h,h'] r -> ⟨comp' p c, s, e, convH h⟩
                                 =>> ⟨c , VAL (convV r) :: s, e, convH h'⟩.

(** Setup the induction proof *)

Proof.
  intros.
  generalize dependent c.
  generalize dependent s.
  induction H;intros.

(** Calculation of the compiler *)

(** - [Val n ⇓[e,h,h] Num n]: *)

  begin
  ⟨c, VAL (Num' n) :: s, e, convH h⟩.
  <== { apply vm_push }
  ⟨PUSH n c, s, e, convH h⟩.
  [].

(** - [Add x y ⇓[e,h,h''] Num (m + n)]: *)

  begin
    ⟨c, VAL (Num' (m + n)) :: s, e, convH h'' ⟩.
  <== { apply vm_add }
    ⟨ADD c, VAL (Num' n) :: VAL (Num' m) :: s, e, convH h''⟩.
  <<= { apply IHeval2 }
  ⟨comp' y (ADD c), VAL (Num' m) :: s, e, convH h'⟩.
  <<= { apply IHeval1 }
  ⟨comp' x (comp' y (ADD c)), s, e, convH h⟩.
  [].

(** - [Var i ⇓[e,h,update h' l (value v)] v] *)

  assert (deref (convH h) l = Some (thunk' (comp' x WRITE) e'))
    by (unfold convH; rewrite hmap_deref; rewrite H0; reflexivity).
  begin
    ⟨c, VAL (convV v) :: s, e, convH (update h' l (value v)) ⟩.
  = {unfold convH; rewrite <- hmap_update}
    ⟨c, VAL (convV v) :: s, e, update (convH h') l (value' (convV v)) ⟩.
  <== {apply vm_write}
    ⟨WRITE, VAL (convV v) :: THU l c e :: s, e', convH h'⟩.
  <<= {apply IHeval}
    ⟨comp' x WRITE, THU l c e :: s, e', convH h⟩.
  <== {eapply vm_lookup_thunk}
    ⟨LOOKUP i c, s, e, convH h ⟩.
  [].

(** - [Var i ⇓[e,h,h] v] *)

  assert (deref (convH h) l = Some (value' (convV v)))
    by (unfold convH; rewrite hmap_deref; rewrite H0; reflexivity).
  begin
    ⟨c, VAL (convV v) :: s, e, convH h ⟩.
  <== {eapply vm_lookup_value }
    ⟨LOOKUP i c, s, e, convH h ⟩.
  [].

(** - [Abs x ⇓[e,h,h] Clo x e] *)

  begin
    ⟨c, VAL (Clo' (comp' x RET) e) :: s, e, convH h ⟩.
  <== { apply vm_abs }
    ⟨ABS (comp' x RET) c, s, e, convH h ⟩.
  [].

(** - [App x y ⇓[e,h,h'''] x''] *)

  assert (alloc (convH h') (convHE (thunk y e)) = (convH h'', l)).
  unfold convH. eapply hmap_alloc in H0. apply H0.

  begin
    ⟨c, VAL (convV x'') :: s, e, convH h''' ⟩.
  <== { apply vm_ret }
    ⟨RET, VAL (convV x'') :: FUN c e :: s, l :: e', convH h''' ⟩.
  <<= { apply IHeval2 }
    ⟨comp' x' RET, FUN c e :: s, l :: e', convH h'' ⟩.
  <== {apply vm_app}
    ⟨APP (comp' y WRITE) c, VAL (Clo' (comp' x' RET) e') :: s, e, convH h'⟩.
   = {reflexivity}
    ⟨APP (comp' y WRITE) c, VAL (convV (Clo x' e')) :: s, e, convH h'⟩.
  <<= { apply IHeval1 }
    ⟨comp' x (APP (comp' y WRITE) c), s, e, convH h⟩.
  [].
Qed.

(** * Soundness *)

(** Custom tactic to apply inversion *)
Ltac inv := match goal with
              | [H1 : nth ?e ?i = Some ?l1,
                 H2 : nth ?e ?i = Some ?l2 |- _] => rewrite H1 in H2; inversion H2; subst; clear H1 H2
              | [H1 : deref ?h ?l = Some ?v1,
                 H2 : deref ?h ?l = Some ?v2 |- _] => rewrite H1 in H2; inversion H2; subst; clear H1 H2
              | [H1 : alloc ?h ?l = _,
                 H2 : alloc ?h ?l = _ |- _] => rewrite H1 in H2; inversion H2; subst; clear H1 H2
              | _ => idtac
            end.

Lemma determ_vm : determ VM.
  intros C C1 C2 V. induction V; intro V'; inversion V'; subst; repeat inv; reflexivity.
Qed.

Definition terminates (p : Expr) : Prop := exists r h, p ⇓[nil,empty,h] r.

Theorem sound p s C : terminates p -> ⟨comp p, s, nil, empty⟩ =>>! C ->
                          exists r h, C = ⟨HALT , VAL (convV r) :: s, nil, convH h⟩
                                    /\ p ⇓[nil, empty, h] r.
Proof.
  unfold terminates. intros. destruct H as [r T]. destruct T as [h T].

  pose (spec p nil r HALT s) as H'. exists r. exists h. split. pose (determ_trc determ_vm) as D.
  unfold determ in D. eapply D. eassumption. split. pose (H' empty h) as H. unfold convH in H.
  rewrite hmap_empty in H. apply H. assumption. intro Con. destruct Con.
  inversion H. assumption.
Qed.


From Minirust.def Require Import ty encoding thm wf.
From Minirust.proof Require Import defs int bool ptr array union tuple ty_ind.
Require Import List.
Import ListNotations.

Section props.

Context {memory: Memory}.

Lemma gen_props (ty: Ty) : wf ty -> Props ty.
Proof.
induction ty using ty_ind; intros Hwf.
- apply (bool_props Hwf).
- apply (int_props Hwf).
- apply (ptr_props Hwf).
- apply (tuple_props H Hwf).
- apply (array_props IHty Hwf).
- apply (union_props Hwf).
Qed.

Theorem gen_rt1 (ty: Ty) : wf ty -> rt1 ty.
Proof. intros Hwf. destruct (gen_props ty); auto. Qed.

Theorem gen_rt2 (ty: Ty) : wf ty -> rt2 ty.
Proof. intros Hwf. destruct (gen_props ty); auto. Qed.

Theorem gen_mono1 (ty: Ty) : wf ty -> mono1 ty.
Proof. intros Hwf. destruct (gen_props ty); auto. Qed.

Theorem gen_mono2 (ty: Ty) : wf ty -> mono2 ty.
Proof. intros Hwf. destruct (gen_props ty); auto. Qed.

End props.


Require Import FP.CoreClasses.
Require Import FP.CoreData.

Import ProperNotation.
Import FunctionNotation.
Import EqvNotation.

Class Monad (m:Type->Type) :=
  { mret : forall {A}, A -> m A
  ; mbind : forall {A B}, m A -> (A -> m B) -> m B
  }.
Arguments mret {m Monad A} _ : simpl never.
Arguments mbind {m Monad A B} _ _ : simpl never.

Section Monad.
  Context {m} `{! Monad m }.

  Definition mextend {A B} : (A -> m B) -> (m A -> m B) := flip mbind.
  Definition mseq {A B} (aM:m A) (bM:m B) : m B := mbind aM (const bM).

  Definition mbind_mpipe {A B C} (f:A -> m B) (g:B -> m C) (a:A) : m C :=
    mbind (f a) g.
  Definition mbind_mjoin {A} (aMM:m (m A)) : m A :=
    mbind aMM id.
  Definition mbind_fmap {A B} (f:A -> B) (aM:m A) : m B :=
    mbind aM (mret '.' f).
  Definition mbind_fapply {A B} (fM:m (A -> B)) (aM:m A) : m B :=
    mbind fM (fun f => mbind aM (fun a => mret (f a))).
  Definition mbind_ftimes {A B} (aM:m A) (bM:m B) : m (A*B) :=
    mbind aM (fun a => mbind bM (fun b => mret (a,b))).
End Monad.
Arguments mextend {m _ A B} _ _ /.
Arguments mbind_mpipe {m _ A B C} f g a /.
Arguments mbind_mjoin {m _ A} aMM /.
Arguments mbind_fmap {m _ A B} f aM /.
Arguments mbind_fapply {m _ A B} fM aM /.
Arguments mbind_ftimes {m _ A B} aM bM /.

Module MonadNotation.
  Notation "x <- c1 ;; c2" := (mbind c1 (fun x => c2))
    (at level 100, c1 at next level, right associativity).

  Notation "e1 ;; e2" := (_ <- e1 ;; e2)
    (at level 100, right associativity).

  Infix ">>=" := mbind (at level 50, left associativity).
  Infix "=<<" := mextend (at level 51, right associativity).
  Infix ">>" := mseq (at level 50, left associativity).
End MonadNotation.
Import MonadNotation.

Section MonadWF.
  Context {m:Type->Type}.
  Context `{! Monad m ,! F_Eqv m ,! F_PER_WF m }.

  Class MonadWF :=
    { Monad_left_unit :
        forall
          {A} `{! Eqv A ,! PER_WF A }
          {B} `{! Eqv B ,! PER_WF B }
          (f:A -> m B) `{! Proper eqv f }
          (a:A) `{! Proper eqv a },
        mbind (mret a) f ~= f a
    ; Monad_right_unit :
        forall
          {A} `{! Eqv A ,! PER_WF A }
          (aM:m A) `{! Proper eqv aM },
        mbind aM mret ~= aM
    ; Monad_associativity :
        forall
          {A} `{! Eqv A ,! PER_WF A }
          {B} `{! Eqv B ,! PER_WF B }
          {C} `{! Eqv C ,! PER_WF C }
          (f:A -> m B) `{! Proper eqv f }
          (g:B -> m C) `{! Proper eqv g }
          (aM:m A) `{! Proper eqv aM },
        mbind (mbind aM f) g ~= mbind aM (fun a => mbind (f a) g)
    ; mret_Proper :>
        forall {A} `{! Eqv A ,! PER_WF A },
        Proper eqv (mret (A:=A))
    ; mbind_Proper :>
        forall
          {A} `{! Eqv A ,! PER_WF A }
          {B} `{! Eqv B ,! PER_WF B },
        Proper eqv (mbind (A:=A) (B:=B))
    }.

End MonadWF.
Arguments MonadWF m {_ _}.
Hint Extern 9 (Proper eqv (mret (m:=?m) (A:=?A))) =>
  let H := fresh "H" in
  pose (H:=(mret_Proper (m:=m) (A:=A))) ; apply H
  : typeclass_instances.
Hint Extern 9 (Proper eqv (mbind (m:=?m) (A:=?A) (B:=?B))) =>
  let H := fresh "H" in
  pose (H:=(mbind_Proper (m:=m) (A:=A) (B:=B))) ; apply H
  : typeclass_instances.