(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)
(****************************************************************************  Buchberger : addition over polynomials  Laurent Thery March 97 (revised April 01)  *************************************************************************** definition of Pplus *)
Require Export Peq.
Section Pplus.
Load "hCoefStructure".
Load "hOrderStructure".
Load "hEq".
Inductive plusP :
list (Term A n) -> list (Term A n) -> list (Term A n) -> Prop :=
| nillu1 : forall l1, plusP (pO A n) l1 l1
| nillu2 : forall l1, plusP l1 (pO A n) l1
| mainu1 :
forall a1 a2 l1 l2 l3,
ltT ltM a2 a1 ->
plusP l1 (pX a2 l2) l3 -> plusP (pX a1 l1) (pX a2 l2) (pX a1 l3)
| mainu2a :
forall a1 a2 l1 l2 l3,
plusP l1 l2 l3 ->
eqT a1 a2 ->
zeroP (A:=A) A0 eqA (n:=n) (plusTerm (A:=A) plusA (n:=n) a1 a2) ->
plusP (pX a1 l1) (pX a2 l2) l3
| mainu2b :
forall a1 a2 l1 l2 l3,
plusP l1 l2 l3 ->
eqT a1 a2 ->
~ zeroP (A:=A) A0 eqA (n:=n) (plusTerm (A:=A) plusA (n:=n) a1 a2) ->
plusP (pX a1 l1) (pX a2 l2)
(pX (plusTerm (A:=A) plusA (n:=n) a1 a2) l3)
| mainu3 :
forall a1 a2 l1 l2 l3,
ltT ltM a1 a2 ->
plusP (pX a1 l1) l2 l3 -> plusP (pX a1 l1) (pX a2 l2) (pX a2 l3).
Hint Resolve nillu1 nillu2 mainu1 mainu2a mainu2b mainu3.
Definition projsig1 (A : Set) (P : A -> Prop) (H : sig P) :=
let (a, _) return A := H in a.
Definition plusp : forall l, {a : _ | plusP (fst l) (snd l) a}.
intros l; pattern l in |- *.
apply well_founded_induction with (R := lessP A n); auto.
apply wf_lessP; auto.
intros x; case x; intros p q; simpl in |- *.
case p; clear p.
intros H'; exists q; auto.
intros a1 m1; case q; clear q.
intros H'; exists (pX a1 m1); auto.
intros a2 m2 H'; case (ltT_dec A n ltM ltM_dec a1 a2);
[ intros P; case P; clear P | idtac ]; intros H1.
lapply (H' (pX a1 m1, m2)); simpl in |- *;
[ intros Rec; case Rec; clear Rec; intros Orec Prec | idtac ].
exists (pX a2 Orec); auto.
change (plusP (pX a1 m1) (pX a2 m2) (pX a2 Orec)) in |- *; auto.
red in |- *; red in |- *; simpl in |- *; auto with arith.
lapply (H' (m1, pX a2 m2)); simpl in |- *;
[ intros Rec; case Rec; clear Rec; intros Orec Prec | idtac ].
exists (pX a1 Orec); auto.
change (plusP (pX a1 m1) (pX a2 m2) (pX a1 Orec)) in |- *; auto.
red in |- *; red in |- *; simpl in |- *; auto.
apply LetP with (h := plusTerm (A:=A) plusA (n:=n) a1 a2).
intros letA eqL0; case (zeroP_dec A A0 eqA eqA_dec n letA); intros H'0.
lapply (H' (m1, m2)); simpl in |- *;
[ intros Rec; case Rec; clear Rec; intros Orec Prec | idtac ].
exists Orec; auto.
change (plusP (pX a1 m1) (pX a2 m2) Orec) in |- *; auto.
rewrite eqL0 in H'0; auto.
red in |- *; red in |- *; simpl in |- *; auto with arith.
lapply (H' (m1, m2)); simpl in |- *;
[ intros Rec; case Rec; clear Rec; intros Orec Prec | idtac ].
exists (pX letA Orec); auto.
change (plusP (pX a1 m1) (pX a2 m2) (pX letA Orec)) in |- *; auto.
rewrite eqL0; auto.
rewrite eqL0 in H'0; auto.
red in |- *; red in |- *; simpl in |- *; auto with arith.
Defined.
Set Implicit Arguments.
Unset Strict Implicit.
Definition pluspf l1 l2 := projsig1 _ _ (plusp (l1, l2)).
Hint Unfold projsig1 pluspf.
Set Strict Implicit.
Unset Implicit Arguments.

(* Specifications: *)
Lemma plusP_inv :
forall p q l (a b : Term A n),
plusP (pX a p) (pX b q) l ->
exists l1 : _,
ltT ltM b a /\ plusP p (pX b q) l1 /\ l = pX a l1 \/
ltT ltM a b /\ plusP (pX a p) q l1 /\ l = pX b l1 \/
eqT a b /\
(zeroP (A:=A) A0 eqA (n:=n) (plusTerm (A:=A) plusA (n:=n) a b) /\
plusP p q l \/
~ zeroP (A:=A) A0 eqA (n:=n) (plusTerm (A:=A) plusA (n:=n) a b) /\
plusP p q l1 /\ l = pX (plusTerm (A:=A) plusA (n:=n) a b) l1).