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.
intros p q l a b H'; simple inversion H'.
discriminate H.
discriminate H0.
rewrite <- H3; rewrite (pX_invl _ _ a2 b l2 q H2);
rewrite (pX_invr _ _ l2 q a2 b H2); rewrite (pX_invl _ _ a1 a l1 p H1);
rewrite (pX_invr _ _ l1 p a1 a H1).
intros H'0 H'1; exists l3; left; split;
[ idtac | split; [ try assumption | idtac ] ]; auto.
rewrite <- H3.
intros H'0 H'1 H'2; exists l3; right; right.
rewrite <- (pX_invl _ _ a2 b l2 q H3); rewrite <- (pX_invl _ _ a1 a l1 p H2);
auto.
rewrite <- (pX_invr _ _ l2 q a2 b H3); rewrite <- (pX_invr _ _ l1 p a1 a H2);
auto.
rewrite <- H4; auto.
intros H'0 H'1 H'2; exists l3; right; right.
rewrite <- (pX_invl _ _ a2 b l2 q H3); rewrite <- (pX_invl _ _ a1 a l1 p H2);
auto.
rewrite <- (pX_invr _ _ l2 q a2 b H3); rewrite <- (pX_invr _ _ l1 p a1 a H2);
auto.
intros H'0 H'1; exists l3; right; left; split;
[ idtac | split; [ try assumption | idtac ] ]; auto.
rewrite <- (pX_invl _ _ a2 b l2 q H2); rewrite <- (pX_invl _ _ a1 a l1 p H1);
auto.
rewrite <- (pX_invl _ _ a1 a l1 p H1); rewrite <- (pX_invr _ _ l2 q a2 b H2);
rewrite <- (pX_invr _ _ l1 p a1 a H1); auto.
rewrite <- H3; rewrite <- (pX_invl _ _ a2 b l2 q H2); auto.
Qed.
intros l; pattern l in |- *.
apply well_founded_ind with (1 := wf_lessP A n).
intros (l1, l2); simpl in |- *.
case l1; clear l1.
intros H' l3 l4 H'0; inversion_clear H'0; intros H'2; inversion_clear H'2;
auto.
case l2; clear l2.
simpl in |- *; intros n0 l0 H' l3 l4 H'0 H'2; inversion H'2; inversion H'0;
auto.
simpl in |- *; intros n2 l2 n1 l1 Induc l3 l4 Hl3 Hl4.
case (plusP_inv l1 l2 l4 n1 n2); auto.
intros x H'; elim H';
[ intros H'0; elim H'0; intros H'1 H'2; elim H'2; intros H'3 H'4;
rewrite H'4; clear H'2 H'0 H'
| intros H'0; clear H' ].
case (plusP_inv l1 l2 l3 n1 n2); auto.
intros x0 H'; elim H';
[ intros H'0; elim H'0; intros H'2 H'5; elim H'5; intros H'6 H'7;
rewrite H'7; clear H'5 H'0 H'
| intros H'0; clear H' ]; auto.
apply pX_inj; auto.
apply Induc with (y := (l1, n2 :: l2)); simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; auto.
elim H'0;
[ intros H'; elim H'; intros H'2 H'5; clear H' H'0 | intros H'; clear H'0 ].
absurd (ltT ltM n1 n2); auto.
elim H'; intros H'0 H'2; try exact H'0; clear H'.
absurd (eqT n2 n1); auto.
apply (eqT_sym A n n1); auto.
elim H'0;
[ intros H'; elim H'; intros H'1 H'2; elim H'2; intros H'3 H'4; rewrite H'4;
clear H'2 H' H'0
| intros H'; clear H'0 ].
case (plusP_inv l1 l2 l3 n1 n2); auto.
intros x0 H'; elim H';
[ intros H'0; elim H'0; intros H'2 H'5; clear H'0 H'
| intros H'0; clear H' ].
absurd (ltT ltM n1 n2); auto.
elim H'0;
[ intros H'; elim H'; intros H'2 H'5; elim H'5; intros H'6 H'7; rewrite H'7;
clear H'5 H' H'0
| intros H'; clear H'0 ].
apply pX_inj; auto.
apply Induc with (y := (pX n1 l1, l2)); simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; auto with arith.
elim H'; intros H'0 H'2; try exact H'0; clear H'.
absurd (eqT n1 n2); auto.
elim H'; intros H'0 H'1; try exact H'0; clear H'.
case (plusP_inv l1 l2 l3 n1 n2); auto.
intros x0 H'; elim H';
[ intros H'2; elim H'2; intros H'3 H'4; try exact H'3; clear H'2 H'
| intros H'2; clear H' ].
absurd (eqT n2 n1); auto.
apply (eqT_sym A n n1); auto.
elim H'2;
[ intros H'; elim H'; intros H'3 H'4; try exact H'3; clear H' H'2
| intros H'; clear H'2 ].
absurd (eqT n1 n2); auto.
elim H'; intros H'2 H'3; elim H'3;
[ intros H'4; elim H'4; intros H'5 H'6; try exact H'5; clear H'4 H'3 H'
| intros H'4; clear H'3 H' ].
elim H'1;
[ intros H'; clear H'1
| intros H'; elim H'; intros H'3 H'4; apply H'3 || elim H'3; clear H' H'1 ];
auto.
elim H'; intros H'1 H'3; clear H'.
apply Induc with (y := (l1, l2)); auto; red in |- *; simpl in |- *; auto.
simpl in |- *; auto with arith.
elim H'4; intros H' H'3; elim H'3; intros H'5 H'6; rewrite H'6; clear H'3 H'4.
elim H'1;
[ intros H'3; clear H'1
| intros H'3; elim H'3; intros H'4 H'7; elim H'7; intros H'8 H'9;
rewrite H'9; clear H'7 H'3 H'1 ].
elim H'3; intros H'1 H'4; try exact H'1; clear H'3.
apply H' || elim H'; try assumption.
apply pX_inj; auto.
apply Induc with (y := (l1, l2)); auto.
red in |- *; red in |- *; simpl in |- *; auto with arith.
Qed.
intros l1 l2; try assumption.
unfold pluspf in |- *; case (plusp (l1, l2)); simpl in |- *; auto.
Qed.
Hint Resolve pluspf_is_plusP.
intros l1 l2 l3 a H'; generalize a; elim H'; auto.
intros a1 a2 l4 l5 l6 H'0 H'1 H'2 a0 H'3 H'4 H'5.
apply canonical_cons; auto.
apply (canonical_pX_order _ A0 eqA) with (l := l4); auto.
apply (canonical_nzeroP _ A0 eqA _ ltM) with (p := pX a1 l4); auto.
intros a1 a2 l4 l5 l6 H'0 H'1 H'2 H'3 a0 H'4 H'5 H'6.
apply H'1; auto.
apply canonical_skip_fst with (b := a1); auto.
apply canonical_skip_fst with (b := a2); auto.
intros a1 a2 l4 l5 l6 H'0 H'1 H'2 H'3 a0 H'4 H'5 H'6.
apply canonical_cons; auto.
apply ltT_eqTr with (a := a1); auto.
apply (eqT_sym A n (plusTerm (A:=A) plusA (n:=n) a1 a2)).
apply plusTerm_eqT1; auto.
apply (canonical_pX_order _ A0 eqA) with (l := l4); auto.
apply (canonical_nzeroP _ A0 eqA _ ltM) with (p := pX a1 l4); auto.
intros a1 a2 l4 l5 l6 H'0 H'1 H'2 a0 H'3 H'4 H'5.
apply canonical_cons; auto.
apply (canonical_pX_order _ A0 eqA) with (l := l5); auto.
apply (canonical_nzeroP _ A0 eqA _ ltM) with (p := pX a1 l4); auto.
Qed.
intros l1 l2 l3 H'; elim H'; auto.
intros a1 a2 l4 l5 l6 H'0 H'1 H'2 H'3 H'4; try assumption.
apply order_plusP with (l1 := l4) (l2 := pX a2 l5); auto.
apply canonical_cons; auto.
apply (canonical_nzeroP _ A0 eqA _ ltM) with (p := l4); auto.
apply H'2; auto.
apply (canonical_imp_canonical _ A0 eqA _ ltM) with (a := a1); auto.
intros a1 a2 l4 l5 l6 H'0 H'1 H'2 H'3 H'4 H'5.
apply H'1; auto.
apply (canonical_imp_canonical _ A0 eqA _ ltM) with (a := a1); auto.
apply (canonical_imp_canonical _ A0 eqA _ ltM) with (a := a2); auto.
intros a1 a2 l4 l5 l6 H'0 H'1 H'2 H'3 H'4 H'5.
apply order_plusP with (l1 := l4) (l2 := l5); auto.
apply canonical_pX_eqT with (a := a1); auto.
apply (eqT_sym A n (plusTerm (A:=A) plusA (n:=n) a1 a2)).
apply plusTerm_eqT1; auto.
apply canonical_pX_eqT with (a := a2); auto; auto.
apply (eqT_sym A n (plusTerm (A:=A) plusA (n:=n) a1 a2)).
apply plusTerm_eqT2; auto.
apply H'1.
apply (canonical_imp_canonical _ A0 eqA _ ltM) with (a := a1); auto.
apply (canonical_imp_canonical _ A0 eqA _ ltM) with (a := a2); auto.
intros a1 a2 l4 l5 l6 H'0 H'1 H'2 H'3 H'4.
apply order_plusP with (l1 := pX a1 l4) (l2 := l5); auto.
apply canonical_cons; auto.
apply (canonical_nzeroP _ A0 eqA _ ltM) with (p := l5); auto.
apply H'2; auto.
apply canonical_imp_canonical with (a := a2); auto.
Qed.

Theorem canonical_pluspf :
forall l1 l2,
canonical A0 eqA ltM l1 ->
canonical A0 eqA ltM l2 -> canonical A0 eqA ltM (pluspf l1 l2).