(* 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.
Require Import Arith.
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.
Require Import LetP.

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.

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).
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.

Theorem uniq_plusp :
 forall l l3 l4,
 plusP (fst l) (snd l) l3 -> plusP (fst l) (snd l) l4 -> l3 = l4.
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.

Theorem pluspf_is_plusP : forall l1 l2, plusP l1 l2 (pluspf l1 l2).
intros l1 l2; try assumption.
unfold pluspf in |- *; case (plusp (l1, l2)); simpl in |- *; auto.
Qed.
Hint Resolve pluspf_is_plusP.

Theorem order_plusP :
 forall l1 l2 l3 a,
 plusP l1 l2 l3 ->
 canonical A0 eqA ltM (pX a l1) ->
 canonical A0 eqA ltM (pX a l2) ->
 canonical A0 eqA ltM l3 -> canonical A0 eqA ltM (pX a l3).
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.

Theorem canonical_plusP :
 forall l1 l2 l3,
 plusP l1 l2 l3 ->
 canonical A0 eqA ltM l1 ->
 canonical A0 eqA ltM l2 -> canonical A0 eqA ltM l3.
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).
intros l1 l2 H' H'0; generalize (pluspf_is_plusP l1 l2); intros u1.
apply canonical_plusP with (l1 := l1) (l2 := l2); auto.
Qed.

Theorem pO_plusP_inv1 : forall p q, plusP (pO A n) p q -> p = q.
intros p; elim p.
intros q H'; inversion H'; auto.
intros a l H' q H'0; inversion H'0; auto.
Qed.
Hint Resolve eqp_refl.

Theorem pO_plusP_inv2 : forall p q, plusP p (pO A n) q -> p = q.
intros p; elim p.
intros q H'; inversion H'; auto.
intros a l H' q H'0; inversion H'0; auto.
Qed.
Hint Resolve eqp_refl.

Theorem plusP_decomp :
 forall a p,
 canonical A0 eqA ltM (pX a p) -> plusP (pX a (pO A n)) p (pX a p).
intros a p; case p; auto.
intros m l H'; try assumption.
change (plusP (pX a (pO A n)) (pX m l) (pX a (pX m l))) in |- *.
apply mainu1; auto.
apply (canonical_pX_order _ A0 eqA) with (l := l); auto.
Qed.

Theorem plusP_inv1 :
 forall a b p q s,
 plusP (pX a p) (pX b q) s -> ltT ltM b a -> s = pX a (pluspf p (pX b q)).
unfold pX in |- *; intros a b p q s H'; inversion_clear H'; intros.
change (pX a l3 = pX a (pluspf p (pX b q))) in |- *; apply pX_inj; auto.
apply uniq_plusp with (l := (p, pX b q)); simpl in |- *; auto.
absurd (eqT b a); auto.
apply eqT_sym; auto.
absurd (eqT b a); auto.
apply eqT_sym; auto.
absurd (ltT ltM b a); auto.
Qed.

Theorem plusP_inv2 :
 forall a b p q s,
 plusP (pX a p) (pX b q) s -> ltT ltM a b -> s = pX b (pluspf (pX a p) q).
intros a b p q s H'; inversion_clear H'; intros.
absurd (ltT ltM a b); auto.
absurd (ltT ltM a b); auto.
absurd (ltT ltM a b); auto.
apply pX_inj; auto.
apply uniq_plusp with (l := (pX a p, q)); simpl in |- *; auto.
Qed.

Theorem plusP_inv3a :
 forall a b p q s,
 eqT a b ->
 zeroP (A:=A) A0 eqA (n:=n) (plusTerm (A:=A) plusA (n:=n) a b) ->
 plusP (pX a p) (pX b q) s -> s = pluspf p q.
intros a b p q s Eqd Z0 H'; inversion_clear H'; intros.
absurd (eqT b a); auto.
apply eqT_sym; auto.
apply uniq_plusp with (l := (p, q)); auto.
elim H1; auto.
absurd (eqT a b); auto.
Qed.

Theorem plusP_inv3b :
 forall a b p q s,
 eqT a b ->
 ~ zeroP (A:=A) A0 eqA (n:=n) (plusTerm (A:=A) plusA (n:=n) a b) ->
 plusP (pX a p) (pX b q) s ->
 s = pX (plusTerm (A:=A) plusA (n:=n) a b) (pluspf p q).
unfold pX in |- *; intros a b p q s Eqd Z0 H'; inversion_clear H'; intros.
absurd (eqT b a); auto.
apply eqT_sym; auto.
elim Z0; try assumption.
change
  (pX (plusTerm (A:=A) plusA (n:=n) a b) l3 =
   pX (plusTerm (A:=A) plusA (n:=n) a b) (pluspf p q))
 in |- *.
apply pX_inj; auto.
apply uniq_plusp with (l := (p, q)); auto.
absurd (eqT a b); auto.
Qed.

Theorem pluspf_inv1 :
 forall a b p q,
 ltT ltM b a ->
 eqP A eqA n (pX a (pluspf p (pX b q))) (pluspf (pX a p) (pX b q)).
intros a b p q H'; try assumption.
rewrite (plusP_inv1 a b p q (pluspf (pX a p) (pX b q))); auto.
Qed.

Theorem pluspf_inv2 :
 forall a b p q,
 ltT ltM a b ->
 eqP A eqA n (pX b (pluspf (pX a p) q)) (pluspf (pX a p) (pX b q)).
intros a b p q H'; try assumption.
rewrite (plusP_inv2 a b p q (pluspf (pX a p) (pX b q))); auto.
Qed.

Theorem pluspf_inv3a :
 forall a b p q,
 eqT a b ->
 zeroP (A:=A) A0 eqA (n:=n) (plusTerm (A:=A) plusA (n:=n) a b) ->
 eqP A eqA n (pluspf p q) (pluspf (pX a p) (pX b q)).
intros a b p q H' Z; try assumption.
rewrite (plusP_inv3a a b p q (pluspf (pX a p) (pX b q))); auto.
Qed.

Theorem pluspf_inv3b :
 forall a b p q,
 eqT a b ->
 ~ zeroP (A:=A) A0 eqA (n:=n) (plusTerm (A:=A) plusA (n:=n) a b) ->
 eqP A eqA n (pX (plusTerm (A:=A) plusA (n:=n) a b) (pluspf p q))
   (pluspf (pX a p) (pX b q)).
intros a b p q H' Z; try assumption.
rewrite (plusP_inv3b a b p q (pluspf (pX a p) (pX b q))); auto.
Qed.
Hint Resolve pluspf_inv1 pluspf_inv2 pluspf_inv3a pluspf_inv3b.

Theorem plusP_com :
 forall p q r s, plusP p q r -> plusP q p s -> eqP A eqA n r s.
intros p q r s H'; generalize s; elim H'; clear s H'; auto.
intros l1 s H'; try assumption.
rewrite (pO_plusP_inv2 l1 s); auto.
intros l1 s H'; rewrite (pO_plusP_inv1 l1 s); auto.
intros a1 a2 l1 l2 l3 H' H'0 H'1 s H'2.
rewrite (plusP_inv2 a2 a1 l2 l1 s); auto.
intros a1 a2 l1 l2 l3 H' H'0 H'1 H'2 s R.
rewrite (plusP_inv3a a2 a1 l2 l1 s); auto.
apply (eqT_sym A n a1); auto.
apply
 zeroP_comp_eqTerm with (1 := cs) (a := plusTerm (A:=A) plusA (n:=n) a1 a2);
 auto.
apply plusTerm_com with (1 := cs); auto.
intros a1 a2 l1 l2 l3 H' H'0 H'1 H'2 s H'3.
rewrite (plusP_inv3b a2 a1 l2 l1 s); auto.
apply eqpP1; auto; apply plusTerm_com with (1 := cs); auto.
apply (eqT_sym A n a1); auto.
red in |- *; intros H'4; apply H'2.
apply
 zeroP_comp_eqTerm with (1 := cs) (a := plusTerm (A:=A) plusA (n:=n) a2 a1);
 auto.
apply plusTerm_com with (1 := cs); auto.
apply (eqT_sym A n); auto.
intros a1 a2 l1 l2 l3 H' H'0 H'1 s H'2.
rewrite (plusP_inv1 a2 a1 l2 l1 s); auto.
Qed.

Theorem pluspf_com : forall p q, eqP A eqA n (pluspf p q) (pluspf q p).
intros p q; apply (plusP_com p q (pluspf p q) (pluspf q p)); auto.
Qed.

Theorem plusP_zero_pOl : forall p q, plusP (pO A n) p q -> eqP A eqA n p q.
intros p q H'; inversion H'; auto.
Qed.

Theorem plusP_zero_pOr : forall p q, plusP p (pO A n) q -> eqP A eqA n p q.
intros p q H'; inversion H'; auto.
Qed.
Hint Resolve plusP_zero_pOl plusP_zero_pOr.
Hint Resolve eqp_trans.

Theorem plusP_uniq_eqP :
 forall p q r s, plusP p q r -> plusP p q s -> eqP A eqA n r s.
intros p q r s H' H'0; rewrite (uniq_plusp (p, q) r s); auto.
Qed.
Hint Resolve plusP_uniq_eqP.

Theorem pO_pluspf_inv1 : forall p, p = pluspf (pO A n) p.
intros p.
apply uniq_plusp with (l := (pO A n, p)); auto.
Qed.

Theorem pO_pluspf_inv2 : forall p, p = pluspf p (pO A n).
intros p.
apply uniq_plusp with (l := (p, pO A n)); auto.
Qed.

Theorem pluspf_inv1_eq :
 forall a b p q,
 ltT ltM b a -> pX a (pluspf p (pX b q)) = pluspf (pX a p) (pX b q).
intros a b p q H'; rewrite (plusP_inv1 a b p q (pluspf (pX a p) (pX b q)));
 auto.
Qed.

Theorem pluspf_inv2_eq :
 forall a b p q,
 ltT ltM a b -> pX b (pluspf (pX a p) q) = pluspf (pX a p) (pX b q).
intros a b p q H'; rewrite (plusP_inv2 a b p q (pluspf (pX a p) (pX b q)));
 auto.
Qed.

Theorem pluspf_inv3a_eq :
 forall a b p q,
 eqT a b ->
 zeroP (A:=A) A0 eqA (n:=n) (plusTerm (A:=A) plusA (n:=n) a b) ->
 pluspf p q = pluspf (pX a p) (pX b q).
intros a b p q H' H1';
 rewrite (plusP_inv3a a b p q (pluspf (pX a p) (pX b q)));
 auto.
Qed.

Theorem pluspf_inv3b_eq :
 forall a b p q,
 eqT a b ->
 ~ zeroP (A:=A) A0 eqA (n:=n) (plusTerm (A:=A) plusA (n:=n) a b) ->
 pX (plusTerm (A:=A) plusA (n:=n) a b) (pluspf p q) =
 pluspf (pX a p) (pX b q).
intros a b p q H' H1';
 rewrite (plusP_inv3b a b p q (pluspf (pX a p) (pX b q)));
 auto.
Qed.

Theorem order_pluspf :
 forall l1 l2 a,
 canonical A0 eqA ltM (pX a l1) ->
 canonical A0 eqA ltM (pX a l2) -> canonical A0 eqA ltM (pX a (pluspf l1 l2)).
intros l1 l2 a H' H'0.
apply order_plusP with (l1 := l1) (l2 := l2); auto.
apply canonical_pluspf; auto.
apply canonical_imp_canonical with (a := a); auto.
apply canonical_imp_canonical with (a := a); auto.
Qed.

Theorem pluspf_inv1_eqa :
 forall a p q,
 canonical A0 eqA ltM (pX a p) ->
 canonical A0 eqA ltM (pX a q) -> pX a (pluspf p q) = pluspf (pX a p) q.
intros a p q; case q; auto.
rewrite <- pO_pluspf_inv2; auto.
rewrite <- pO_pluspf_inv2; auto.
intros a0 l H'0 H'1.
change (pX a (pluspf p (pX a0 l)) = pluspf (pX a p) (pX a0 l)) in |- *.
apply pluspf_inv1_eq; auto.
apply (canonical_pX_order _ A0 eqA) with (l := l); auto.
Qed.

Theorem pluspf_inv2_eqa :
 forall a p q,
 canonical A0 eqA ltM (pX a p) ->
 canonical A0 eqA ltM (pX a q) -> pX a (pluspf p q) = pluspf p (pX a q).
intros a p; case p; auto.
intros q H'0 H'1.
rewrite <- pO_pluspf_inv1; auto.
rewrite <- pO_pluspf_inv1; auto.
intros a0 l q H'0 H'1.
change (pX a (pluspf (pX a0 l) q) = pluspf (pX a0 l) (pX a q)) in |- *.
apply pluspf_inv2_eq; auto.
apply (canonical_pX_order A A0 eqA) with (l := l); auto.
Qed.

Theorem p0_pluspf_l : forall p, eqP A eqA n (pluspf (pO A n) p) p.
intros p; rewrite <- pO_pluspf_inv1; auto.
Qed.

Theorem p0_pluspf_r : forall p, eqP A eqA n (pluspf p (pO A n)) p.
intros p; rewrite <- pO_pluspf_inv2; auto.
Qed.
Hint Resolve p0_pluspf_l p0_pluspf_r.

Theorem plusTerm_is_pX :
 forall (a : Term A n) (p : list (Term A n)),
 canonical A0 eqA ltM (pX a p) ->
 eqP A eqA n (pluspf (pX a (pO A n)) p) (pX a p).
intros a p; case p; auto.
intros a0 l H'.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := pX a (pluspf (pO A n) (a0 :: l))); auto.
change
  (eqP A eqA n (pluspf (pX a (pO A n)) (pX a0 l))
     (pX a (pluspf (pO A n) (pX a0 l)))) in |- *.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); apply pluspf_inv1; auto.
apply (canonical_pX_order A A0 eqA) with (l := l); auto.
Qed.
Hint Resolve plusTerm_is_pX.

Theorem pluspf3_assoc :
 forall l,
 canonical A0 eqA ltM (fst l) ->
 canonical A0 eqA ltM (fst (snd l)) ->
 canonical A0 eqA ltM (snd (snd l)) ->
 eqP A eqA n (pluspf (pluspf (fst l) (fst (snd l))) (snd (snd l)))
   (pluspf (fst l) (pluspf (fst (snd l)) (snd (snd l)))).
intros l; pattern l in |- *.
apply (well_founded_ind (wf_lessP3 A n)).
intros x; case x; intros p z; case z; intros q r; simpl in |- *; clear x z;
 auto.
case p.
rewrite <- pO_pluspf_inv1; auto.
case q.
intros a l0; rewrite <- pO_pluspf_inv1; rewrite <- pO_pluspf_inv2; auto.
case r; simpl in |- *; auto.
intros a l0 a0 l1; rewrite <- pO_pluspf_inv2; rewrite <- pO_pluspf_inv2; auto.
intros a l0 a0 l1 a1 l2 H' H'0 H'1 H'2.
cut (canonical A0 eqA ltM (pX a l0)); [ clear H'2; intros H'2 | auto ].
cut (canonical A0 eqA ltM (pX a0 l1)); [ clear H'1; intros H'1 | auto ].
cut (canonical A0 eqA ltM (pX a1 l2)); [ clear H'0; intros H'0 | auto ].
cut (canonical A0 eqA ltM l0);
 [ intros C0 | apply canonical_imp_canonical with (a := a) ];
 auto.
cut (canonical A0 eqA ltM l1);
 [ intros C1 | apply canonical_imp_canonical with (a := a0) ];
 auto.
cut (canonical A0 eqA ltM l2);
 [ intros C2 | apply canonical_imp_canonical with (a := a1) ];
 auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) a);
 [ intros nZ0 | apply (canonical_nzeroP _ A0 eqA _ ltM) with (p := l0) ];
 auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) a0);
 [ intros nZ1 | apply (canonical_nzeroP _ A0 eqA _ ltM) with (p := l1) ];
 auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) a1);
 [ intros nZ2 | apply (canonical_nzeroP _ A0 eqA _ ltM) with (p := l2) ];
 auto.
change
  (eqP A eqA n (pluspf (pluspf (pX a1 l2) (pX a0 l1)) (pX a l0))
     (pluspf (pX a1 l2) (pluspf (pX a0 l1) (pX a l0))))
 in |- *.
case (ltT_dec A n ltM ltM_dec a1 a0);
 [ intros H0; case H0; clear H0 | idtac ]; intros H0.
case (ltT_dec A n ltM ltM_dec a0 a); [ intros H1; case H1; clear H1 | idtac ];
 intros H1.
cut (ltT ltM a1 a);
 [ intros Ord0 | apply (ltT_trans A _ _ os) with (y := a0) ];
 auto.
rewrite <- (pluspf_inv2_eq a1 a0 l2 l1); auto.
rewrite <- (pluspf_inv2_eq a0 a (pluspf (pX a1 l2) l1) l0); auto.
rewrite <- (pluspf_inv2_eq a0 a l1 l0); auto.
rewrite <- (pluspf_inv2_eq a1 a l2 (pluspf (pX a0 l1) l0)); auto.
apply eqpP1; auto.
rewrite (pluspf_inv2_eq a1 a0 l2 l1); auto.
apply H' with (y := (pX a1 l2, (pX a0 l1, l0))); simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; auto with arith.
repeat rewrite (fun a b : nat => plus_comm a (S b)); simpl in |- *.
repeat rewrite (plus_comm (size A n l1)); auto.
rewrite <- (pluspf_inv1_eq a0 a l1 l0); auto.
rewrite <- (pluspf_inv2_eq a1 a0 l2 l1); auto.
rewrite <- (pluspf_inv2_eq a1 a0 l2 (pluspf l1 (pX a l0))); auto.
rewrite <- (pluspf_inv1_eq a0 a (pluspf (pX a1 l2) l1) l0); auto.
apply eqpP1; auto.
apply H' with (y := (pX a1 l2, (l1, pX a l0))); simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; auto with arith.
cut (ltT ltM a1 a); [ intros Ord0 | apply eqT_compat_ltTr with (b := a0) ];
 auto.
case (zeroP_dec A A0 eqA eqA_dec n (plusTerm (A:=A) plusA (n:=n) a0 a));
 intros Z0.
rewrite <- (pluspf_inv3a_eq a0 a l1 l0); auto.
rewrite <- (pluspf_inv2_eq a1 a0 l2 l1); auto.
rewrite <- (pluspf_inv3a_eq a0 a (pluspf (pX a1 l2) l1) l0); auto.
apply H' with (y := (pX a1 l2, (l1, l0))); simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; auto with arith.
repeat rewrite (fun a b : nat => plus_comm a (S b)); simpl in |- *.
repeat rewrite (plus_comm (size A n l2)); auto.
repeat rewrite (plus_comm (size A n l1)); auto.
cut (ltT ltM a1 (plusTerm (A:=A) plusA (n:=n) a0 a));
 [ intros Ord1
 | apply eqT_compat_ltTr with (b := a0); auto; apply (eqT_sym A n);
    apply (plusTerm_eqT1 A plusA n) ]; auto.
rewrite <- (pluspf_inv2_eq a1 a0 l2 l1); auto.
rewrite <- (pluspf_inv3b_eq a0 a l1 l0); auto.
rewrite <- (pluspf_inv3b_eq a0 a (pluspf (pX a1 l2) l1) l0); auto.
rewrite <-
 (pluspf_inv2_eq a1 (plusTerm (A:=A) plusA (n:=n) a0 a) l2 (pluspf l1 l0))
 ; auto.
apply eqpP1; auto.
apply H' with (y := (pX a1 l2, (l1, l0))); simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; auto with arith.
repeat rewrite (fun a b : nat => plus_comm a (S b)); simpl in |- *.
repeat rewrite (plus_comm (size A n l2)); auto.
repeat rewrite (plus_comm (size A n l1)); auto.
rewrite <- (pluspf_inv1_eq a1 a0 l2 l1); auto.
case (ltT_dec A n ltM ltM_dec a0 a); [ intros H1; case H1; clear H1 | idtac ];
 intros H1.
rewrite <- (pluspf_inv2_eq a0 a l1 l0); auto.
case (ltT_dec A n ltM ltM_dec a1 a); [ intros H2; case H2; clear H2 | idtac ];
 intros H2.
rewrite <- (pluspf_inv2_eq a1 a (pluspf l2 (pX a0 l1)) l0); auto.
rewrite <- (pluspf_inv2_eq a1 a l2 (pluspf (pX a0 l1) l0)); auto.
apply eqpP1; auto.
rewrite (pluspf_inv1_eq a1 a0 l2 l1); auto.
apply H' with (y := (pX a1 l2, (pX a0 l1, l0))); simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; auto with arith.
repeat rewrite (fun a b : nat => plus_comm a (S b)); simpl in |- *.
repeat rewrite (plus_comm (size A n l1)); auto.
rewrite <- (pluspf_inv1_eq a1 a l2 (pluspf (pX a0 l1) l0)); auto.
rewrite <- (pluspf_inv1_eq a1 a (pluspf l2 (pX a0 l1)) l0); auto.
apply eqpP1; auto.
rewrite (pluspf_inv2_eq a0 a l1 l0); auto.
apply H' with (y := (l2, (pX a0 l1, pX a l0))); simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; auto.
cut (ltT ltM a0 (plusTerm (A:=A) plusA (n:=n) a1 a));
 [ intros Ord1
 | apply eqT_compat_ltTr with (b := a1); auto; apply (eqT_sym A n);
    apply (plusTerm_eqT1 A plusA n) ]; auto.
case (zeroP_dec A A0 eqA eqA_dec n (plusTerm (A:=A) plusA (n:=n) a1 a));
 intros Z0.
rewrite <- (pluspf_inv3a_eq a1 a (pluspf l2 (pX a0 l1)) l0); auto.
rewrite <- (pluspf_inv3a_eq a1 a l2 (pluspf (pX a0 l1) l0)); auto.
apply H' with (y := (l2, (pX a0 l1, l0))); simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; auto with arith.
rewrite <- (pluspf_inv3b_eq a1 a (pluspf l2 (pX a0 l1)) l0); auto.
rewrite <- (pluspf_inv3b_eq a1 a l2 (pluspf (pX a0 l1) l0)); auto.
apply eqpP1; auto.
apply H' with (y := (l2, (pX a0 l1, l0))); simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; auto with arith.
cut (ltT ltM a a1);
 [ intros Ord0 | apply (ltT_trans A n ltM os) with (y := a0) ];
 auto with arith.
rewrite <- (pluspf_inv1_eq a0 a l1 l0); auto.
rewrite <- (pluspf_inv1_eq a1 a0 l2 (pluspf l1 (pX a l0))); auto.
rewrite <- (pluspf_inv1_eq a1 a (pluspf l2 (pX a0 l1)) l0); auto.
apply eqpP1; auto.
rewrite (pluspf_inv1_eq a0 a l1 l0); auto.
apply H' with (y := (l2, (pX a0 l1, pX a l0))); simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; auto.
cut (ltT ltM a a1);
 [ intros Ord0 | apply eqT_compat_ltTl with (b := a0); auto ];
 auto.
case (zeroP_dec A A0 eqA eqA_dec n (plusTerm (A:=A) plusA (n:=n) a0 a));
 intros Z0.
rewrite <- (pluspf_inv3a_eq a0 a l1 l0); auto.
rewrite <- (pluspf_inv1_eqa a1 l2 (pluspf l1 l0)); auto.
rewrite <- (pluspf_inv1_eq a1 a (pluspf l2 (pX a0 l1)) l0); auto.
apply eqpP1; auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := pluspf l2 (pluspf (pX a0 l1) (pX a l0)));
 auto.
apply H' with (y := (l2, (pX a0 l1, pX a l0))); simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; auto.
rewrite <- (pluspf_inv3a_eq a0 a l1 l0); auto.
apply order_pluspf; auto.
apply canonical_skip_fst with (b := a0); auto.
apply canonical_skip_fst with (b := a); auto.
cut (ltT ltM (plusTerm (A:=A) plusA (n:=n) a0 a) a1);
 [ intros Ord1
 | apply eqT_compat_ltTl with (b := a0); auto; apply (eqT_sym A n); auto;
    apply (plusTerm_eqT1 A plusA n) ]; auto.
rewrite <- (pluspf_inv3b_eq a0 a l1 l0); auto.
rewrite <- (pluspf_inv1_eq a1 a (pluspf l2 (pX a0 l1)) l0); auto.
rewrite <-
 (pluspf_inv1_eq a1 (plusTerm (A:=A) plusA (n:=n) a0 a) l2 (pluspf l1 l0))
 ; auto.
apply eqpP1; auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := pluspf l2 (pluspf (pX a0 l1) (pX a l0)));
 auto.
apply H' with (y := (l2, (pX a0 l1, pX a l0))); simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; auto.
rewrite <- (pluspf_inv3b_eq a0 a l1 l0); auto.
case (zeroP_dec A A0 eqA eqA_dec n (plusTerm (A:=A) plusA (n:=n) a1 a0));
 intros Z0.
rewrite <- (pluspf_inv3a_eq a1 a0 l2 l1); auto.
case (ltT_dec A n ltM ltM_dec a1 a); [ intros H2; case H2; clear H2 | idtac ];
 intros H2.
cut (ltT ltM a0 a); [ intros Ord0 | apply eqT_compat_ltTl with (b := a1) ];
 auto.
rewrite <- (pluspf_inv2_eq a0 a l1 l0); auto.
rewrite <- (pluspf_inv2_eq a1 a l2 (pluspf (pX a0 l1) l0)); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := pX a (pluspf (pluspf (pX a1 l2) (pX a0 l1)) l0));
 auto.
rewrite <- (pluspf_inv3a_eq a1 a0 l2 l1); auto.
rewrite <- (pluspf_inv2_eqa a (pluspf l2 l1) l0); auto.
apply order_pluspf; auto.
apply canonical_skip_fst with (b := a1); auto.
apply canonical_skip_fst with (b := a0); auto.
apply eqpP1; auto.
apply H' with (y := (pX a1 l2, (pX a0 l1, l0))); simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; auto with arith.
repeat rewrite (fun a b : nat => plus_comm a (S b)); simpl in |- *.
repeat rewrite (plus_comm (size A n l1)); auto.
cut (ltT ltM a a0); [ intros Ord0 | apply eqT_compat_ltTr with (b := a1) ];
 auto.
rewrite <- (pluspf_inv1_eq a0 a l1 l0); auto.
rewrite <- (pluspf_inv3a_eq a1 a0 l2 (pluspf l1 (pX a l0))); auto.
apply H' with (y := (l2, (l1, pX a l0))); simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; auto with arith.
case (zeroP_dec A A0 eqA eqA_dec n (plusTerm (A:=A) plusA (n:=n) a0 a));
 intros Z1.
cut (eqT a0 a);
 [ intros eqTerm0
 | apply (eqT_trans A n) with (y := a1); auto; apply (eqT_sym A n) ];
 auto.
cut (eqT a (plusTerm (A:=A) plusA (n:=n) a1 a0));
 [ intros eqTerm1
 | apply (eqT_trans A n) with (y := a0); auto; apply (eqT_sym A n); auto;
    apply (plusTerm_eqT2 A plusA n) ]; auto.
cut (eqT (plusTerm (A:=A) plusA (n:=n) a a1) a0);
 [ intros eqTerm2
 | apply (eqT_trans A n) with (y := a);
    [ apply (plusTerm_eqT1 A plusA n)
    | apply (eqT_trans A n) with (y := a1) ]; auto;
    apply (eqT_sym A n) ]; auto.
cut (eqT (plusTerm (A:=A) plusA (n:=n) a1 a) a0);
 [ intros eqTerm3
 | apply (eqT_trans A n) with (y := a); auto;
    [ apply (plusTerm_eqT2 A plusA n) | apply (eqT_sym A n) ] ];
 auto.
cut (eqT a1 (plusTerm (A:=A) plusA (n:=n) a a0));
 [ intros eqTerm4
 | apply (eqT_trans A n) with (y := a0); auto; apply (eqT_sym A n);
    apply (plusTerm_eqT2 A plusA n); auto; apply (eqT_sym A n) ];
 auto.
cut (eqT a1 (plusTerm (A:=A) plusA (n:=n) a0 a));
 [ intros eqTerm5
 | apply (eqT_trans A n) with (y := a0); auto; apply (eqT_sym A n);
    apply (plusTerm_eqT1 A plusA n) ]; auto.
rewrite <- (pluspf_inv3a_eq a0 a l1 l0); auto.
rewrite <- (pluspf_inv2_eqa a (pluspf l2 l1) l0); auto.
rewrite <- (pluspf_inv1_eqa a1 l2 (pluspf l1 l0)); auto.
apply eqpP1; auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := plusTerm (A:=A) plusA (n:=n) a (plusTerm (A:=A) plusA (n:=n) a1 a0));
 auto.
apply zeroP_plusTermr with (1 := cs); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := plusTerm (A:=A) plusA (n:=n) a1 (plusTerm (A:=A) plusA (n:=n) a0 a));
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := plusTerm (A:=A) plusA (n:=n) a1 (plusTerm (A:=A) plusA (n:=n) a a0));
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := plusTerm (A:=A) plusA (n:=n) (plusTerm (A:=A) plusA (n:=n) a a1) a0);
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply plusTerm_assoc with (1 := cs); auto.
apply (eqT_sym A n); auto.
apply (eqT_sym A n); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := plusTerm (A:=A) plusA (n:=n) (plusTerm (A:=A) plusA (n:=n) a1 a) a0);
 auto.
apply plusTerm_comp_l with (1 := cs); auto.
apply plusTerm_com with (1 := cs); auto.
apply (eqT_sym A n); auto.
apply plusTerm_assoc with (1 := cs); auto.
apply plusTerm_comp_r with (1 := cs); auto.
apply plusTerm_com with (1 := cs); auto.
apply (eqT_sym A n); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply zeroP_plusTermr with (1 := cs); auto.
apply H' with (y := (l2, (l1, l0))); simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; auto with arith.
apply order_pluspf; auto.
apply canonical_pX_eqT with (a := a0); auto.
apply (eqT_sym A n); auto.
apply canonical_pX_eqT with (a := a); auto.
apply (eqT_sym A n); auto.
apply order_pluspf; auto.
apply canonical_pX_eqT with (a := a1); auto.
apply canonical_pX_eqT with (a := a0); auto.
cut (eqT a0 a);
 [ intros Ord0
 | apply (eqT_trans A n) with (y := a1); auto; apply (eqT_sym A n) ];
 auto.
cut (eqT a (plusTerm (A:=A) plusA (n:=n) a1 a0));
 [ intros eqTerm1
 | apply (eqT_trans A n) with (y := a0); auto; apply (eqT_sym A n); auto;
    apply (plusTerm_eqT2 A plusA n) ]; auto.
rewrite <- (pluspf_inv3b_eq a0 a l1 l0); auto.
rewrite <-
 (pluspf_inv3b_eq a1 (plusTerm (A:=A) plusA (n:=n) a0 a) l2 (pluspf l1 l0))
 ; auto.
rewrite <- (pluspf_inv2_eqa a (pluspf l2 l1) l0); auto.
apply eqpP1; auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := plusTerm (A:=A) plusA (n:=n) a (plusTerm (A:=A) plusA (n:=n) a1 a0));
 auto.
apply zeroP_plusTermr with (1 := cs); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := plusTerm (A:=A) plusA (n:=n) (plusTerm (A:=A) plusA (n:=n) a1 a0) a);
 auto.
apply plusTerm_com with (1 := cs); auto.
apply plusTerm_assoc with (1 := cs); auto.
apply (eqT_sym A n); auto.
apply H' with (y := (l2, (l1, l0))); simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; auto with arith.
apply order_pluspf; auto.
apply canonical_pX_eqT with (a := a1); auto.
apply canonical_pX_eqT with (a := a0); auto.
apply (eqT_trans A n) with (y := a); auto; apply (eqT_sym A n); auto.
apply (plusTerm_eqT2 A plusA n); auto.
red in |- *; intros H'3; absurd (zeroP (A:=A) A0 eqA (n:=n) a); auto.
apply
 zeroP_comp_eqTerm
  with
    (1 := cs)
    (a := plusTerm (A:=A) plusA (n:=n) a1 (plusTerm (A:=A) plusA (n:=n) a0 a));
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := plusTerm (A:=A) plusA (n:=n) (plusTerm (A:=A) plusA (n:=n) a1 a0) a);
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply plusTerm_assoc with (1 := cs); auto.
apply (eqT_sym A n); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply zeroP_plusTerml with (1 := cs); auto.
apply (eqT_sym A n); auto.
rewrite <- (pluspf_inv3b_eq a1 a0 l2 l1); auto.
case (ltT_dec A n ltM ltM_dec a0 a); [ intros H1; case H1; clear H1 | idtac ];
 intros H1.
cut (ltT ltM a1 a);
 [ intros Ord0
 | apply eqT_compat_ltTl with (b := a0); auto; apply (eqT_sym A n) ];
 auto.
cut (ltT ltM (plusTerm (A:=A) plusA (n:=n) a1 a0) a);
 [ intros Ord1
 | apply eqT_compat_ltTl with (b := a1); auto; apply (eqT_sym A n);
    apply (plusTerm_eqT1 A plusA n) ]; auto.
rewrite <- (pluspf_inv2_eq a0 a l1 l0); auto.
rewrite <- (pluspf_inv2_eq a1 a l2 (pluspf (pX a0 l1) l0)); auto.
rewrite <-
 (pluspf_inv2_eq (plusTerm (A:=A) plusA (n:=n) a1 a0) a (pluspf l2 l1) l0)
 ; auto.
apply eqpP1; auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := pluspf (pluspf (pX a1 l2) (pX a0 l1)) l0);
 auto.
rewrite <- (pluspf_inv3b_eq a1 a0 l2 l1); auto.
apply H' with (y := (pX a1 l2, (pX a0 l1, l0))); simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; auto with arith.
repeat rewrite (fun a b : nat => plus_comm a (S b)); simpl in |- *.
repeat rewrite (plus_comm (size A n l1)); auto.
cut (ltT ltM a a1);
 [ intros Ord0
 | apply eqT_compat_ltTr with (b := a0); auto; apply (eqT_sym A n) ];
 auto.
cut (ltT ltM a (plusTerm (A:=A) plusA (n:=n) a1 a0));
 [ intros Ord1
 | apply eqT_compat_ltTr with (b := a0); auto; apply (eqT_sym A n);
    apply (plusTerm_eqT2 A plusA n) ]; auto.
rewrite <- (pluspf_inv1_eq a0 a l1 l0); auto.
rewrite <- (pluspf_inv3b_eq a1 a0 l2 (pluspf l1 (pX a l0))); auto.
rewrite <-
 (pluspf_inv1_eq (plusTerm (A:=A) plusA (n:=n) a1 a0) a (pluspf l2 l1) l0)
 ; auto.
apply eqpP1; auto.
apply H' with (y := (l2, (l1, pX a l0))); simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; auto with arith.
cut (eqT a1 (plusTerm (A:=A) plusA (n:=n) a0 a));
 [ intros eqTerm1
 | apply (eqT_trans A n) with (y := a0); auto; apply (eqT_sym A n);
    apply (plusTerm_eqT1 A plusA n) ]; auto.
cut (eqT a1 a);
 [ intros eqT0
 | apply (eqT_trans A n) with (y := a0); auto; apply (eqT_sym A n) ];
 auto.
case (zeroP_dec A A0 eqA eqA_dec n (plusTerm (A:=A) plusA (n:=n) a0 a));
 intros Z1.
rewrite <- (pluspf_inv3a_eq a0 a l1 l0); auto.
rewrite <- (pluspf_inv1_eqa a1 l2 (pluspf l1 l0)); auto.
cut
 (~
  zeroP (A:=A) A0 eqA (n:=n)
    (plusTerm (A:=A) plusA (n:=n) (plusTerm (A:=A) plusA (n:=n) a1 a0) a));
 [ intros Z2 | idtac ].
rewrite <-
 (pluspf_inv3b_eq (plusTerm (A:=A) plusA (n:=n) a1 a0) a (pluspf l2 l1) l0)
 ; auto.
apply eqpP1; auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := plusTerm (A:=A) plusA (n:=n) a1 (plusTerm (A:=A) plusA (n:=n) a0 a));
 auto.
apply plusTerm_assoc with (1 := cs); auto.
apply (eqT_sym A n); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply zeroP_plusTermr with (1 := cs); auto.
apply H' with (y := (l2, (l1, l0))); simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; auto with arith.
apply (eqT_trans A n) with (y := a1); auto.
apply (plusTerm_eqT1 A plusA n); auto.
red in |- *; intros H'3; absurd (zeroP (A:=A) A0 eqA (n:=n) a1); auto.
apply
 zeroP_comp_eqTerm
  with
    (1 := cs)
    (a := plusTerm (A:=A) plusA (n:=n) (plusTerm (A:=A) plusA (n:=n) a1 a0) a);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := plusTerm (A:=A) plusA (n:=n) a1 (plusTerm (A:=A) plusA (n:=n) a0 a));
 auto.
apply plusTerm_assoc with (1 := cs); auto.
apply (eqT_sym A n); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply zeroP_plusTermr with (1 := cs); auto.
apply order_pluspf; auto.
apply canonical_pX_eqT with (a := a0); auto.
apply (eqT_trans A n) with a; auto.
apply (eqT_sym A n); auto.
apply canonical_pX_eqT with (a := a); auto.
apply (eqT_sym A n); auto.
rewrite <- (pluspf_inv3b_eq a0 a l1 l0); auto.
cut
 (eqTerm eqA
    (plusTerm (A:=A) plusA (n:=n) (plusTerm (A:=A) plusA (n:=n) a1 a0) a)
    (plusTerm (A:=A) plusA (n:=n) a1 (plusTerm (A:=A) plusA (n:=n) a0 a)));
 [ intros eqTerm0 | idtac ].
case
 (zeroP_dec A A0 eqA eqA_dec n
    (plusTerm (A:=A) plusA (n:=n) (plusTerm (A:=A) plusA (n:=n) a1 a0) a));
 intros Z2.
rewrite <-
 (pluspf_inv3a_eq (plusTerm (A:=A) plusA (n:=n) a1 a0) a (pluspf l2 l1) l0)
 ; auto.
rewrite <-
 (pluspf_inv3a_eq a1 (plusTerm (A:=A) plusA (n:=n) a0 a) l2 (pluspf l1 l0))
 ; auto.
apply H' with (y := (l2, (l1, l0))); simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; auto with arith.
apply
 zeroP_comp_eqTerm
  with
    (1 := cs)
    (a := plusTerm (A:=A) plusA (n:=n) (plusTerm (A:=A) plusA (n:=n) a1 a0) a);
 auto.
apply (eqT_trans A n) with (y := a0); auto.
apply (plusTerm_eqT2 A plusA n); auto.
rewrite <-
 (pluspf_inv3b_eq (plusTerm (A:=A) plusA (n:=n) a1 a0) a (pluspf l2 l1) l0)
 ; auto.
rewrite <-
 (pluspf_inv3b_eq a1 (plusTerm (A:=A) plusA (n:=n) a0 a) l2 (pluspf l1 l0))
 ; auto.
apply eqpP1; auto.
apply H' with (y := (l2, (l1, l0))); simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; auto with arith.
apply
 nzeroP_comp_eqTerm
  with
    (1 := cs)
    (a := plusTerm (A:=A) plusA (n:=n) (plusTerm (A:=A) plusA (n:=n) a1 a0) a);
 auto.
apply (eqT_trans A n) with (y := a0); auto.
apply (plusTerm_eqT2 A plusA n); auto.
apply plusTerm_assoc with (1 := cs); auto.
apply (eqT_sym A n); auto.
Qed.

Theorem pluspf_assoc :
 forall p q r,
 canonical A0 eqA ltM p ->
 canonical A0 eqA ltM q ->
 canonical A0 eqA ltM r ->
 eqP A eqA n (pluspf (pluspf p q) r) (pluspf p (pluspf q r)).
intros p q r H' H'0 H'1.
apply pluspf3_assoc with (l := (p, (q, r))); auto.
Qed.
Hint Resolve pluspf_assoc.

Theorem eqp_pluspf_com_l :
 forall p q r,
 eqP A eqA n p q ->
 canonical A0 eqA ltM p ->
 canonical A0 eqA ltM q ->
 canonical A0 eqA ltM r -> eqP A eqA n (pluspf p r) (pluspf q r).
intros p q r H'; generalize r; elim H'; clear r H'.
intros r H' H'0 H'1; rewrite <- pO_pluspf_inv1; auto.
intros ma mb p0 q0 H' H'0 H'1 r H'2 H'3 H'4.
cut (canonical A0 eqA ltM p0);
 [ intros C0 | apply canonical_imp_canonical with (a := ma) ];
 auto.
cut (canonical A0 eqA ltM q0);
 [ intros C1 | apply canonical_imp_canonical with (a := mb) ];
 auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) ma);
 [ intros nZ0 | apply (canonical_nzeroP _ A0 eqA n ltM) with (p := p0) ];
 auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) mb);
 [ intros nZ1 | apply (canonical_nzeroP _ A0 eqA n ltM) with (p := q0) ];
 auto.
generalize H'4; elim r; clear H'4 r.
intros H'4; rewrite <- pO_pluspf_inv2; rewrite <- pO_pluspf_inv2; auto.
intros a l H'4 H'5.
cut (canonical A0 eqA ltM l);
 [ intros C2 | apply canonical_imp_canonical with (a := a) ];
 auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) a);
 [ intros nZ2 | apply (canonical_nzeroP _ A0 eqA n ltM) with (p := l) ];
 auto.
change
  (eqP A eqA n (pluspf (pX ma p0) (pX a l)) (pluspf (pX mb q0) (pX a l)))
 in |- *.
case (ltT_dec A n ltM ltM_dec ma a); [ intros H0; case H0; clear H0 | idtac ];
 intros H0.
cut (ltT ltM mb a); [ intros Or0 | idtac ].
rewrite <- (pluspf_inv2_eq ma a p0 l); auto.
rewrite <- (pluspf_inv2_eq mb a q0 l); auto.
apply eqT_compat_ltTl with (b := ma); auto.
apply (eqTerm_imp_eqT A eqA n); auto.
cut (ltT ltM a mb); [ intros Or0 | idtac ]; auto.
rewrite <- (pluspf_inv1_eq ma a p0 l); auto.
rewrite <- (pluspf_inv1_eq mb a q0 l); auto.
apply eqT_compat_ltTr with (b := ma); auto.
apply (eqTerm_imp_eqT A eqA n); auto.
cut
 (eqTerm eqA (plusTerm (A:=A) plusA (n:=n) ma a)
    (plusTerm (A:=A) plusA (n:=n) mb a)); [ intros eqTerm0 | idtac ];
 auto.
case (zeroP_dec A A0 eqA eqA_dec n (plusTerm (A:=A) plusA (n:=n) ma a));
 intros Z0.
rewrite <- (pluspf_inv3a_eq ma a p0 l); auto.
rewrite <- (pluspf_inv3a_eq mb a q0 l); auto.
apply (eqT_trans A n) with (y := ma); auto.
apply (eqTerm_imp_eqT A eqA n); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply
 zeroP_comp_eqTerm with (1 := cs) (a := plusTerm (A:=A) plusA (n:=n) ma a);
 auto.
rewrite <- (pluspf_inv3b_eq ma a p0 l); auto.
rewrite <- (pluspf_inv3b_eq mb a q0 l); auto.
apply (eqT_trans A n) with (y := ma); auto.
apply (eqTerm_imp_eqT A eqA n); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
red in |- *; intros H'6; apply Z0.
apply
 zeroP_comp_eqTerm with (1 := cs) (a := plusTerm (A:=A) plusA (n:=n) mb a);
 auto.
apply plusTerm_comp_l with (1 := cs); auto.
change (eqT mb a) in |- *.
apply (eqT_trans A n) with (y := ma); auto.
apply (eqTerm_imp_eqT A eqA n); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply plusTerm_comp_l with (1 := cs); auto.
change (eqT mb a) in |- *.
apply (eqT_trans A n) with (y := ma); auto.
apply (eqTerm_imp_eqT A eqA n); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
Qed.

Theorem eqp_pluspf_com_r :
 forall p q r,
 eqP A eqA n p q ->
 canonical A0 eqA ltM p ->
 canonical A0 eqA ltM q ->
 canonical A0 eqA ltM r -> eqP A eqA n (pluspf r p) (pluspf r q).
intros p q r H'; generalize r; elim H'; clear r H'.
intros r H' H'0 H'1; rewrite <- pO_pluspf_inv2; auto.
intros ma mb p0 q0 H' H'0 H'1 r H'2 H'3 H'4.
cut (canonical A0 eqA ltM p0);
 [ intros C0 | apply canonical_imp_canonical with (a := ma) ];
 auto.
cut (canonical A0 eqA ltM q0);
 [ intros C1 | apply canonical_imp_canonical with (a := mb) ];
 auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) ma);
 [ intros nZ0 | apply (canonical_nzeroP _ A0 eqA n ltM) with (p := p0) ];
 auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) mb);
 [ intros nZ1 | apply (canonical_nzeroP _ A0 eqA n ltM) with (p := q0) ];
 auto.
generalize H'4; elim r; clear H'4 r.
intros H'4; rewrite <- pO_pluspf_inv1; rewrite <- pO_pluspf_inv1; auto.
intros a l H'4 H'5.
cut (canonical A0 eqA ltM l);
 [ intros C2 | apply canonical_imp_canonical with (a := a) ];
 auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) a);
 [ intros nZ2 | apply (canonical_nzeroP _ A0 eqA n ltM) with (p := l) ];
 auto.
change
  (eqP A eqA n (pluspf (pX a l) (pX ma p0)) (pluspf (pX a l) (pX mb q0)))
 in |- *.
case (ltT_dec A n ltM ltM_dec ma a); [ intros H0; case H0; clear H0 | idtac ];
 intros H0.
cut (ltT ltM mb a); [ intros Or0 | idtac ].
rewrite <- (pluspf_inv1_eq a ma l p0); auto.
rewrite <- (pluspf_inv1_eq a mb l q0); auto.
apply eqT_compat_ltTl with (b := ma); auto.
apply (eqTerm_imp_eqT _ eqA n); auto.
cut (ltT ltM a mb); [ intros Or0 | idtac ]; auto.
rewrite <- (pluspf_inv2_eq a ma l p0); auto.
rewrite <- (pluspf_inv2_eq a mb l q0); auto.
apply eqT_compat_ltTr with (b := ma); auto.
apply (eqTerm_imp_eqT _ eqA n); auto.
cut
 (eqTerm eqA (plusTerm (A:=A) plusA (n:=n) a ma)
    (plusTerm (A:=A) plusA (n:=n) a mb)); [ intros eqTerm0 | idtac ];
 auto.
case (zeroP_dec A A0 eqA eqA_dec n (plusTerm (A:=A) plusA (n:=n) a ma));
 intros Z0.
rewrite <- (pluspf_inv3a_eq a ma l p0); auto.
rewrite <- (pluspf_inv3a_eq a mb l q0); auto.
apply (eqT_trans A n) with (y := ma); auto; apply (eqT_sym A n); auto.
apply (eqTerm_imp_eqT _ eqA n); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply
 zeroP_comp_eqTerm with (1 := cs) (a := plusTerm (A:=A) plusA (n:=n) a ma);
 auto.
apply (eqT_sym A n); auto.
rewrite <- (pluspf_inv3b_eq a ma l p0); auto.
rewrite <- (pluspf_inv3b_eq a mb l q0); auto.
apply (eqT_trans A n) with (y := ma); auto.
apply (eqT_sym A n); auto.
apply (eqTerm_imp_eqT _ eqA n); auto.
red in |- *; intros H'6; apply Z0.
apply
 zeroP_comp_eqTerm with (1 := cs) (a := plusTerm (A:=A) plusA (n:=n) a mb);
 auto.
apply plusTerm_comp_r with (1 := cs); auto.
change (eqT a mb) in |- *.
apply (eqT_trans A n) with (y := ma); auto.
apply (eqT_sym A n); auto.
apply (eqTerm_imp_eqT _ eqA n); auto.
apply (eqT_sym A n); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply (eqT_sym A n); auto.
apply plusTerm_comp_r with (1 := cs); auto.
apply (eqT_sym A n); auto.
change (eqT a mb) in |- *.
apply (eqT_trans A n) with (y := ma); auto.
apply (eqT_sym A n); auto.
apply (eqTerm_imp_eqT _ eqA n); auto.
Qed.

Theorem eqp_pluspf_com :
 forall p q r t,
 canonical A0 eqA ltM p ->
 canonical A0 eqA ltM q ->
 canonical A0 eqA ltM r ->
 canonical A0 eqA ltM t ->
 eqP A eqA n p r -> eqP A eqA n q t -> eqP A eqA n (pluspf p q) (pluspf r t).
intros p q r t H' H'0 H'1 H'2 H'3 H'4.
apply (eqp_trans _ _ _ _ _ _ _ _ _ cs n) with (y := pluspf r q); auto.
apply eqp_pluspf_com_l; auto.
apply eqp_pluspf_com_r; auto.
Qed.
Hint Resolve eqp_pluspf_com.
Set Implicit Arguments.
Unset Strict Implicit.

Definition splus : poly A0 eqA ltM -> poly A0 eqA ltM -> poly A0 eqA ltM.
intros sp1 sp2.
case sp1; case sp2.
intros p1 H'1 p2 H'2; exists (pluspf p1 p2); auto.
apply canonical_pluspf; auto.
Defined.
Set Strict Implicit.
Unset Implicit Arguments.
End Pplus.


(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University

  This file is part of Velisarios.

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

  Velisarios is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with Velisarios.  If not, see <http://www.gnu.org/licenses/>.

  Authors: Vincent Rahli
           Ivana Vukotic

 *)

Require Export PBFT_A_1_2_2.
Require Export PBFT_A_1_2_2_direct_pred.
Require Export PBFTgarbage_collect.

Section PBFT_A_1_2_2_somewhere.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { pbft_context : PBFTcontext      }.
  Context { pbft_auth    : PBFTauth         }.
  Context { pbft_keys    : PBFTinitial_keys }.
  Context { pbft_hash    : PBFThash         }.

  Lemma PBFT_A_1_2_2_direct_pred_on :
    forall (eo      : EventOrdering)
           (e1 e2   : Event)
           (i       : Rep)
           (n       : SeqNum)
           (v       : View)
           (rs1 rs2 : list Request)
           (a1 a2   : Tokens)
           (d1 d2   : PBFTdigest)
           (s1 s2   : PBFTstate),
      e1 ⊂ e2
      -> is_primary v i = true
      -> state_sm_on_event (PBFTreplicaSM i) e1 = Some s1
      -> state_sm_on_event (PBFTreplicaSM i) e2 = Some s2
      -> pre_prepare_in_log (mk_pre_prepare v n rs1 a1) d1 (log s1) = true
      -> pre_prepare_in_log (mk_pre_prepare v n rs2 a2) d2 (log s2) = true
      -> d1 = d2.
  Proof.
    introv ltev isprim eqst1 eqst2 prep1 prep2.
    eapply state_sm_before_event_if_on_event_direct_pred in ltev;[|eauto].
    eauto 3 with pbft.
  Qed.
  Hint Resolve PBFT_A_1_2_2_direct_pred_on : pbft.

  Lemma PBFT_A_1_2_2_local_pred :
    forall (eo      : EventOrdering)
           (e1 e2   : Event)
           (i       : Rep)
           (n       : SeqNum)
           (v       : View)
           (rs1 rs2 : list Request)
           (a1 a2   : Tokens)
           (d1 d2   : PBFTdigest)
           (s1 s2   : PBFTstate),
      e1 ⊏ e2
      -> is_primary v i = true
      -> state_sm_on_event (PBFTreplicaSM i) e1 = Some s1
      -> state_sm_on_event (PBFTreplicaSM i) e2 = Some s2
      -> pre_prepare_in_log (mk_pre_prepare v n rs1 a1) d1 (log s1) = true
      -> pre_prepare_in_log (mk_pre_prepare v n rs2 a2) d2 (log s2) = true
      -> d1 = d2.
  Proof.
    intros eo e1 e2.
    induction e2 as [? ind] using predHappenedBeforeInd_local_pred;[].
    introv ltev isprim eqst1 eqst2 pl1 pl2.

    pose proof (local_implies_pred_or_local e1 e2) as q; autodimp q hyp.
    repndors; eauto 3 with pbft;[].

    exrepnd.

    pose proof (state_sm_on_event_some_between e e2 (PBFTreplicaSM i) s2) as w.
    repeat (autodimp w hyp); eauto 3 with eo;[].
    exrepnd.

    remember (pre_prepare_in_log (mk_pre_prepare v n rs2 a2) d2 (log s')) as b.
    symmetry in Heqb; destruct b.

    + apply pred_implies_local_pred in q1; subst.
      eapply ind; eauto; autorewrite with eo; eauto 3 with eo pbft.

    + remember (pre_prepare_in_log (mk_pre_prepare v n rs1 a1) d1 (log s')) as w.
      symmetry in Heqw; destruct w; eauto 3 with pbft;[].

      pose proof (pre_prepares_get_garbage_collected_v2
                    i eo e1 e s1 s' (mk_pre_prepare v n rs1 a1) d1) as q.
      repeat (autodimp q hyp); simpl in q;[].

      pose proof (pre_prepares_are_between_water_marks_if_in_log
                    (mk_pre_prepare v n rs2 a2) d2 i eo e2 s2) as z.
      repeat (autodimp z hyp); eauto 4 with pbft; simpl in z;[].

      pose proof (PBFTlow_water_mark_increases_on_event
                    eo e e2 i s' s2) as u.
      repeat (autodimp u hyp); eauto 3 with eo;[].

      unfold check_between_water_marks in *; smash_pbft; try omega.
  Qed.
  Hint Resolve PBFT_A_1_2_2_local_pred : pbft.

  Lemma PBFT_A_1_2_2_local :
    forall (eo      : EventOrdering)
           (e1 e2   : Event)
           (i       : Rep)
           (n       : SeqNum)
           (v       : View)
           (rs1 rs2 : list Request)
           (a1 a2   : Tokens)
           (d1 d2   : PBFTdigest)
           (s1 s2   : PBFTstate),
      loc e1 = loc e2
      -> is_primary v i = true
      -> state_sm_on_event (PBFTreplicaSM i) e1 = Some s1
      -> state_sm_on_event (PBFTreplicaSM i) e2 = Some s2
      -> pre_prepare_in_log (mk_pre_prepare v n rs1 a1) d1 (log s1) = true
      -> pre_prepare_in_log (mk_pre_prepare v n rs2 a2) d2 (log s2) = true
      -> d1 = d2.
  Proof.
    introv eqloc isprim eqst1 eqst2 pl1 pl2.

    pose proof (tri_if_same_loc e1 e2) as h; autodimp h hyp; try congruence.
    repndors; subst;
      [|rewrite eqst1 in eqst2; ginv;
        eapply PBFT_A_1_2_2; eauto
       |].

    - eapply PBFT_A_1_2_2_local_pred;
        try (exact pl1); try (exact pl2); try (exact h); try (exact isprim); auto.

    - symmetry.
      eapply PBFT_A_1_2_2_local_pred;
        try (exact pl1); try (exact pl2); try (exact h); try (exact isprim); auto.
  Qed.
  Hint Resolve PBFT_A_1_2_2_local : pbft.

End PBFT_A_1_2_2_somewhere.

Hint Resolve PBFT_A_1_2_2_direct_pred_on : pbft.
Hint Resolve PBFT_A_1_2_2_local_pred : pbft.
Hint Resolve PBFT_A_1_2_2_local : pbft.


(* Encoding of PURE *)

From Coq Require Import Utf8 RelationClasses.
From PDM Require Import util.

Set Default Goal Selector "!".
Set Printing Projections.
Set Universe Polymorphism.
Unset Universe Minimization ToSet.

(* Monad structure (no laws) *)
Class Monad (M : Type → Type) := {
  ret : ∀ A (x : A), M A ;
  bind : ∀ A B (c : M A) (f : A → M B), M B
}.

(* Monad with a require operator *)
Class ReqMonad M `{Monad M} := {
  req : ∀ (p : Prop), M p
}.

Arguments ret {_ _} [_].
Arguments bind {_ _} [_ _].

Class Order W `{Monad W} := {
  wle : ∀ A, W A → W A → Prop ;
  trans :> ∀ A, Transitive (@wle A)
}.

Arguments wle {_ _ _} {_}.

Notation "x ≤ᵂ y" := (wle x y) (at level 80).

Class MonoSpec W `{Order W} := {
  bind_mono :
    ∀ A B (w w' : W A) (wf wf' : A → W B),
      w ≤ᵂ w' →
      (∀ x, wf x ≤ᵂ wf' x) →
      bind w wf ≤ᵂ bind w' wf'
}.

Definition observation (M W : Type → Type) :=
  ∀ A (c : M A), W A.

Class LaxMorphism {M W} `{Monad M} `{Order W} (θ : observation M W) := {
  θ_ret :
    ∀ A (x : A),
      θ _ (ret x) ≤ᵂ ret x ;
  θ_bind :
    ∀ A B c f,
      θ _ (bind (A:=A) (B:=B) c f) ≤ᵂ bind (θ _ c) (λ x, θ _ (f x))
}.

Class ReqLaxMorphism
  {M W} `{ReqMonad M} `{ReqMonad W} (Word : Order W)
  (θ : observation M W) {θ_lax : LaxMorphism θ} := {
  θ_req : ∀ p, θ _ (req p) ≤ᵂ req p
}.

Class DijkstraMonad {W} `{Word : Order W} (D : ∀ A (w : W A), Type) := {
  retᴰ : ∀ A (x : A), D A (ret x) ;
  bindᴰ : ∀ A B w wf (c : D A w) (f : ∀ x, D B (wf x)), D B (bind w wf) ;
  subcompᴰ : ∀ A w w' (c : D A w) (h : w ≤ᵂ w'), D A w'
}.

Arguments retᴰ {_ _ _ _ _} [_].
Arguments bindᴰ {_ _ _ _ _} [_ _ _ _].
Arguments subcompᴰ {_ _ _ _ _} [_ _ _] _ {_}.

(* Laws *)

Class MonadLaws M `{Monad M} := {
  left_id : ∀ A B (x : A) (f : A → M B), bind (ret x) f = f x ;
  right_id : ∀ A (c : M A), bind c (λ x, ret x) = c ;
  assoc :
    ∀ A B C (c : M A) (f : A → M B) (g : B → M C),
      bind (bind c f) g = bind c (λ x, bind (f x) g)
}.

(* Monad morphism *)

Class Morphism M N {hM : Monad M} {hN : Monad N} (f : ∀ A, M A → N A) := {
  morph_ret : ∀ A (x : A), f A (ret x) = ret x ;
  morph_bind :
    ∀ A B (c : M A) (k : A → M B),
      f _ (bind c k) = bind (f _ c) (λ x, f _ (k x))
}.

(* Monad transformers *)

Class MonadTransformer T := {
  liftᵀ : ∀ M {hM : Monad M} (A : Type), M A → T M A ;
  mapᵀ : ∀ M N f `{Morphism M N f} (A : Type), T M A → T N A
}.

Arguments liftᵀ {_ _} [_ _ _].
Arguments mapᵀ {_ _} [_ _] _ {_ _ _} [_].

Class MonadTransformerLaws T `{MonadTransformer T} := {
  transf_monad :> ∀ M `{Monad M}, Monad (T M) ;
  liftᵀ_ret : ∀ M `{MonadLaws M} A (x : A), liftᵀ (ret x) = ret x ;
  liftᵀ_bind :
    ∀ M `{MonadLaws M} A B (c : M A) (f : A → M B),
      liftᵀ (bind c f) = bind (liftᵀ c) (λ x, liftᵀ (f x)) ;
  mapᵀ_morph : ∀ M N f `{Morphism M N f}, Morphism _ _ (mapᵀ f) ;
  mapᵀ_liftᵀ :
    ∀ M N f `{Morphism M N f} A (c : M A),
      mapᵀ f (liftᵀ c) = liftᵀ (f _ c)
}.


From Coq Require Import
     ssreflect
.

From ExtensibleCompiler Require Import

     Semantics.Static.All.Bool
     Semantics.Static.All.BoolType
     Semantics.Static.All.If2
     Semantics.Static.All.Unit
     Semantics.Static.All.UnitType
     Semantics.Static.TypeOf

     Syntax.Terms.Bool
     Syntax.Terms.If1
     Syntax.Terms.If2
     Syntax.Terms.Unit
     Syntax.Types.BoolType
     Syntax.Types.UnitType

     Theory.Algebra
     Theory.Eval
     Theory.Functor
     Theory.ProgramAlgebra
     Theory.SubFunctor
     Theory.Sum1
     Theory.Types
     Theory.UniversalProperty

.

Local Open Scope SubFunctor.

(* Create an expression language that supports [Bool], [If2], and [Unit] *)
Definition E := (Bool + If2 + Unit)%Sum1.

(* Create a type language that supports [Bool] and [Unit] *)
Definition T := (BoolType + UnitType)%Sum1.

(* Create a concrete representation for the result of type-checking, so
   that it is easy to inspect manually *)
Inductive Result :=
| WellTypedBool
| WellTypedUnit
| IllTyped
.

Variant ForComputeResult := .

(* Algebra to turn the extensible results into concrete results *)
Global Instance computeResult
  : forall R, ProgramAlgebra ForComputeResult T R Result
  := fun _ =>
       {|
         programAlgebra :=
           fun rec =>
             (fun   'MkBoolType => WellTypedBool)
             || (fun 'MkUnitType => WellTypedUnit)
         ;
       |}%Sum1.

Definition typeCheck
           (e : WellFormedValue E)
  : Result
  :=
    match typeOf (E := E) (T := T) (proj1_sig e) with
    | Some t => foldProgramAlgebra (Alg := @computeResult) (proj1_sig t)
    | None   => IllTyped
    end.

Theorem regression__unit : typeCheck unit = WellTypedUnit.
Proof. reflexivity. Qed.

Theorem regression__true : typeCheck (boolean true) = WellTypedBool.
Proof. reflexivity. Qed.

Theorem regression__false : typeCheck (boolean false) = WellTypedBool.
Proof. reflexivity. Qed.

Theorem regression__if2Unit
  : typeCheck (if2 (boolean true) unit unit) = WellTypedUnit.
Proof. reflexivity. Qed.

Theorem regression__if2Bool
  : typeCheck (if2 (boolean true) (boolean true) (boolean false)) = WellTypedBool.
Proof. reflexivity. Qed.

Theorem regression__if2IllTypedCondition
  : typeCheck (if2 unit (boolean true) (boolean false)) = IllTyped.
Proof. reflexivity. Qed.

Theorem regression__if2IllTypedBranchMismatch
  : typeCheck (if2 (boolean true) (boolean true) unit) = IllTyped.
Proof. reflexivity. Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O E Eprime U A B C : Universe, ((wd_ U O /\ (wd_ U E /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ O U /\ (wd_ U Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ A O /\ (wd_ U Eprime /\ (col_ O E U /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O U A /\ (col_ O U B /\ (col_ O U C /\ (col_ A U Eprime /\ (col_ O U Eprime /\ col_ O Eprime O)))))))))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


(** We show that presentable signatures generate a syntax
 *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
(* Require Import UniMath.SubstitutionSystems.FromBindingSigsToMonads_Summary. *)
Require Import UniMath.SubstitutionSystems.BindingSigToMonad.
Require Import UniMath.SubstitutionSystems.Signatures.
Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.categories.HSET.All.

Require Import UniMath.CategoryTheory.Epis.
Require Import UniMath.CategoryTheory.EpiFacts.
Require Import Modules.Prelims.EpiComplements.
Require Import UniMath.Combinatorics.Lists.
Require Import UniMath.CategoryTheory.whiskering.
Require Import Modules.Prelims.lib.
Require Import Modules.Signatures.Signature.
Require Import Modules.Signatures.SigWithStrengthToSignature.
Require Import Modules.Signatures.BindingSig.
Require Import Modules.Signatures.EpiSigRepresentability.
Require Import Modules.Signatures.PreservesEpi.
Require Import Modules.Signatures.EpiArePointwise.

Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monads.LModules.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.coproducts.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.DisplayedCats.Fiber.
Open Scope cat.

Section PresentableDefinition.

Context {C : category} (bp : BinProducts C) (bcp : BinCoproducts C) (T : Terminal C)
          (cp : ∏ (I : hSet), Coproducts I C).

Let toSig sig  :=
  (BindingSigToSignature bp bcp T  sig (cp (BindingSigIndexhSet sig))).

Definition isPresentable (a : signature C) :=
  ∑ (S : BindingSig) (F : signature_Mor (sigWithStrength_to_sig (C := C) (toSig S)) a),
                            ∏ (R : Monad C), (isEpi (C := [_, _]) (pr1 (F R))).

End PresentableDefinition.

Section PresentableProjections.
  Context {C : category} {bp : BinProducts C} {bcp : BinCoproducts C} {T : Terminal C}
          {cp : ∏ (I : hSet), Coproducts I C}.

  Context {a : signature C} (p : isPresentable bp bcp T cp a).
Definition p_sig   : BindingSig := pr1 p.
Let toSig sig  :=
  (BindingSigToSignature bp bcp T  sig (cp (BindingSigIndexhSet sig))).
Definition p_alg_ar   : signature C :=
  sigWithStrength_to_sig (C := C) (toSig p_sig).

Definition p_mor : signature_Mor (p_alg_ar ) a := pr1 (pr2 p).
Definition epi_p_mor   :
  ∏ (R : Monad C), (isEpi (C := [_, _]) (pr1 (p_mor  R)))
  := pr2 (pr2 p).

End PresentableProjections.

Local Notation hom_SET := has_homsets_HSET.
Local Notation Sig := (Signature SET has_homsets_HSET hset_precategory has_homsets_HSET).
Local Notation EndSet := [hset_category, hset_category].

Local Notation toSig sig :=
  (BindingSigToSignature has_homsets_HSET BinProductsHSET
                         BinCoproductsHSET TerminalHSET sig
                         (CoproductsHSET (BindingSigIndex sig) (BindingSigIsaset sig))).

Lemma PresentableisEffective
      {a : signature SET} (p : isPresentable (C := SET) BinProductsHSET BinCoproductsHSET TerminalHSET
                                             (fun i => CoproductsHSET _ (setproperty i)) a)
  :
   Initial (rep_disp SET) [{a}].
Proof.
  use (push_initiality (p_mor  p) _ _  ).
  - apply alg_initialR.
  - apply algebraic_model_Epi.
  - apply BindingSig_on_model_isEpi.
  - apply algSig_NatEpi.
  - apply pwEpiSig_isEpi.
    apply epi_p_mor.
  - apply algebraic_sig_effective.
Qed.


Require Import ZArith List String Omega.
Require Import  Vellvm.LLVMAst Vellvm.Util.
Require Import Vellvm.StepSemantics.
Import ListNotations.

Set Implicit Arguments.
Set Contextual Implicit.

Inductive Addr :=
| Null
| Ptr (n:nat)
.

Module A : Vellvm.LLVMIO.ADDR with Definition addr := Addr.
  Definition addr := Addr.
  Definition null := Null.
End A.

Module SS := StepSemantics.StepSemantics(A).
Export SS.
Export SS.DV.

Definition memory := list dvalue.

Definition mem_step {X} (e:IO X) (m:memory) : (IO X) + (list dvalue * X) :=
  match e in IO Y return (IO Y) + (list dvalue * Y) with
  | Alloca t =>
    inr  ((m ++ [undef t])%list,
          DVALUE_Addr (Ptr (List.length m)))

  | Load t a =>
    inr (m,
         match a with
         | DVALUE_Addr (Ptr n) => nth_default (undef t) m n
         | _ => undef t
         end)

  | Store a v =>
    inr (
        match a with
        | DVALUE_Addr (Ptr n) => replace m n v
        | _ => m   (* TODO: should fail! *)
        end,
        ())

  | GEP t a vs => inl (GEP t a vs) (* TODO: GEP semantics *)

  | ItoP t i => inl (ItoP t i) (* TODO: ItoP semantics *)

  | PtoI t a => inl (PtoI t a) (* TODO: ItoP semantics *)

  | Call t f args  => inl (Call t f args)

  | DeclareFun f =>
    (* TODO: should check for re-declarations and maintain that state in the memory *)
    inr (m,
         DVALUE_FunPtr f)
  end.

(*
 memory -> TraceLLVMIO () -> TraceX86IO () -> Prop
*)

CoFixpoint memD {X} (m:memory) (d:Trace X) : Trace X :=
  match d with
  | Trace.Tau d'            => Trace.Tau (memD m d')
  | Trace.Vis _ io k =>
    match mem_step io m with
    | inr (m', v) => Trace.Tau (memD m' (k v))
    | inl e => Trace.Vis io k
    end
  | Trace.Ret x => d
  | Trace.Err x => d
  end.

Definition run_with_memory prog : option (Trace dvalue) :=
  let scfg := AstLib.modul_of_toplevel_entities prog in
  match CFG.mcfg_of_modul scfg with
  | None => None
  | Some mcfg =>
    mret
      (memD []
      ('s <- SS.init_state mcfg "main";
         SS.step_sem mcfg (SS.Step s)))
  end.

(*
Fixpoint MemDFin (m:memory) (d:Trace ()) (steps:nat) : option memory :=
  match steps with
  | O => None
  | S x =>
    match d with
    | Vis (Fin d) => Some m
    | Vis (Err s) => None
    | Tau _ d' => MemDFin m d' x
    | Vis (Eff e)  =>
      match mem_step e m with
      | inr (m', v, k) => MemDFin m' (k v) x
      | inl _ => None
      end
    end
  end%N.
*)

(*
Previous bug:
Fixpoint MemDFin {A} (memory:mtype) (d:Obs A) (steps:nat) : option mtype :=
  match steps with
  | O => None
  | S x =>
    match d with
    | Ret a => None
    | Fin d => Some memory
    | Err s => None
    | Tau d' => MemDFin memory d' x
    | Eff (Alloca t k)  => MemDFin (memory ++ [undef])%list (k (DVALUE_Addr (pred (List.length memory)))) x
    | Eff (Load a k)    => MemDFin memory (k (nth_default undef memory a)) x
    | Eff (Store a v k) => MemDFin (replace memory a v) k x
    | Eff (Call d ds k)    => None
    end
  end%N.
*)


Require Import SO_semantics Pred_in_SO.
Require Import Pred_is_pos_neg_SO nlist_sem_eg.
Require Import Correctness_ST.

Inductive Ip_extends (W : Set) (Ip Ip' : predicate -> W -> Prop)
          (P : predicate) : Type :=
  | Ip_ext : (forall (w : W), (Ip P w) -> (Ip' P w)) ->
             (forall (Q : predicate), P <> Q -> (Ip Q = Ip' Q)) ->
             Ip_extends W Ip Ip' P.

Definition alpha_upward_monotone_P (alpha : SecOrder) (P : predicate) :=
    forall (W : Set) (Iv : FOvariable -> W) (R : W -> W -> Prop)
           (Ip Ip' : predicate -> W -> Prop),
   Ip_extends W Ip Ip' P
      -> (SOturnst W Iv Ip R alpha) ->
                          (SOturnst W Iv Ip' R alpha).

Definition alpha_downward_monotone_P (alpha : SecOrder) (P : predicate) :=
    forall (W : Set) (Iv : FOvariable -> W) (R : W -> W -> Prop)
           (Ip Ip' : predicate -> W -> Prop),
   Ip_extends W Ip' Ip P
      -> (SOturnst W Iv Ip R alpha) ->
                          (SOturnst W Iv Ip' R alpha).

(* ---------------------------------------------------------------------------- *)

Lemma Ip_ext_alt_Ip : forall (W : Set) (Ip Ip' : predicate -> W -> Prop)
                             (pa : W -> Prop) (P Q : predicate),
  Ip_extends W Ip Ip' P ->
  Ip_extends W (alt_Ip Ip pa Q) (alt_Ip Ip' pa Q) P.
Proof.
  intros W Ip Ip' pa P Q Ipext.
  destruct Ipext as [Ipext1 Ipext2].
  constructor. intros w H1.
    destruct (predicate_dec Q P) as [H2 | H2].
    subst. rewrite alt_Ip_eq. rewrite alt_Ip_eq in H1.
    auto. rewrite alt_Ip_neq. rewrite alt_Ip_neq in H1.
    apply Ipext1. all : auto.

    intros R H1. destruct (predicate_dec Q R) as [H2 | H2].
    subst. do 2  rewrite alt_Ip_eq. auto.
    rewrite alt_Ip_neq. rewrite alt_Ip_neq. apply Ipext2.
    all : auto.
Qed.

Lemma Ip_ext_pa_f : forall (W : Set)
                    (Ip : predicate -> W -> Prop)
                    (P : predicate)
                    (pa : W -> Prop),
  Ip_extends W (alt_Ip Ip pa_f P) (alt_Ip Ip pa P) P.
Proof.
  intros W Ip P pa. constructor.
    intros w H.
    unfold pa_f in *.
    rewrite alt_Ip_eq in *. contradiction.

    intros Q H. rewrite alt_Ip_neq. rewrite alt_Ip_neq.
    all : auto.
Qed.

Lemma Ip_extends_same_Ip_list : forall l W Ip Ip' P,
  Ip_extends W Ip Ip' P ->
  ~ In P l -> same_Ip_list Ip Ip' l.
Proof.
  induction l; intros W Ip Ip' P Hext Hpocc. constructor.
  simpl in *. apply not_or_and in Hpocc.
  inversion Hext. destruct Hext as [H1 H2].
  specialize (H2 a). constructor.
  + apply H2; auto. firstorder.
  + eapply IHl. constructor. apply H. apply H0. apply Hpocc.
Qed.

Lemma same_Ip_list_comm: forall l (W : Set) (Ip Ip' : predicate -> W -> Prop),
  same_Ip_list Ip Ip' l <->
  same_Ip_list Ip' Ip l.
Proof.
  induction l; intros W Iv Ip'.
  split; intros; constructor.
  simpl. split; (intros H; inversion H; subst; constructor;
      [auto | apply IHl; auto]).
Qed.

(* ---------------------------------------------------------------------------- *)

Lemma lem_bb2 : forall alpha P W Iv Ip Ip' Ir,
~ Pred_in_SO alpha P ->
Ip_extends W Ip Ip' P ->
SOturnst W Iv Ip Ir alpha ->
SOturnst W Iv Ip' Ir alpha.
Proof.
  intros.
  apply same_preds_in with (Ip := Ip).
  apply Ip_extends_same_Ip_list with (P := P).
  all : assumption.
Qed.

Lemma lem_bb2_2 : forall alpha P W Iv Ip Ip' Ir,
~ Pred_in_SO alpha P ->
Ip_extends W Ip' Ip P ->
SOturnst W Iv Ip Ir alpha ->
SOturnst W Iv Ip' Ir alpha.
Proof.
  intros.
  apply same_preds_in with (Ip := Ip).

  rewrite same_Ip_list_comm.
  apply Ip_extends_same_Ip_list with (P := P).
  all : try assumption.
Qed.

Lemma up_not_occ_SO : forall (alpha : SecOrder) (P : predicate),
  ~ Pred_in_SO alpha P ->
    (alpha_upward_monotone_P alpha P /\ alpha_downward_monotone_P alpha P).
Proof.
  intros alpha P H.
  unfold alpha_upward_monotone_P.
  unfold alpha_downward_monotone_P.
  apply conj; intros until 0.
    apply lem_bb2; auto.
    apply lem_bb2_2; auto.
Qed.

(* -------------------------------------------------------------------- *)

Lemma up_negSO : forall (alpha: SecOrder) (P : predicate),
  alpha_upward_monotone_P alpha P ->
    alpha_downward_monotone_P (negSO alpha) P.
Proof.
  intros alpha P H.
  destruct (Pred_in_SO_dec (negSO alpha) P) as [Hocc|Hocc];
     [ | apply up_not_occ_SO; exact Hocc].
  unfold alpha_upward_monotone_P in *.
  intros W Iv Ir Ip Ip' Ipext.
  simpl in *.
  unfold not; intros SOt' H2; apply SOt'.
  apply H with (Ip := Ip'); assumption.
Qed.

Lemma up_conjSO12 : forall (alpha1 alpha2 : SecOrder) (P : predicate),
  alpha_upward_monotone_P alpha1 P ->
    alpha_upward_monotone_P alpha2 P ->
      alpha_upward_monotone_P (conjSO alpha1 alpha2) P.
Proof.
  intros alpha1 alpha2 P H1 H2.
  destruct (Pred_in_SO_dec (conjSO alpha1 alpha2) P) as [Hocc|Hocc];
    [ | apply up_not_occ_SO; exact Hocc].
  unfold alpha_upward_monotone_P in *.
  intros W Iv Ir Ip Ip' Ipext SOt.
  simpl in *.
  apply conj; [apply H1 with (Ip := Ip) | apply H2 with (Ip := Ip)];
   try apply SOt; try assumption.
Qed.

Lemma up_disjSO12 : forall (alpha1 alpha2 : SecOrder) (P : predicate),
  alpha_upward_monotone_P alpha1 P ->
    alpha_upward_monotone_P alpha2 P ->
      alpha_upward_monotone_P (disjSO alpha1 alpha2) P.
Proof.
  intros alpha1 alpha2 P H1 H2.
  destruct (Pred_in_SO_dec (disjSO alpha1 alpha2) P) as [Hocc|Hocc];
    [ | apply up_not_occ_SO; exact Hocc].
  unfold alpha_upward_monotone_P in *.
  intros W Iv Ir Ip Ip' Ipext SOt.
  simpl in *.
  destruct SOt as [SOt | SOt];
    [left ;apply H1 with (Ip := Ip) |
    right ; apply H2 with (Ip := Ip)]; assumption.
Qed.

Lemma up_implSO12 : forall (alpha1 alpha2 : SecOrder) (P : predicate),
  alpha_downward_monotone_P alpha1 P ->
    alpha_upward_monotone_P alpha2 P ->
      alpha_upward_monotone_P (implSO alpha1 alpha2) P.
Proof.
  intros alpha1 alpha2 P H1 H2.
  destruct (Pred_in_SO_dec (implSO alpha1 alpha2) P) as [Hocc|Hocc];
    [ | apply up_not_occ_SO; exact Hocc].
  unfold alpha_upward_monotone_P in *.
  intros W Iv Ir Ip Ip' Ipext SOt.
  simpl in *; intros H.
  apply H2 with (Ip := Ip); try assumption.
  apply SOt.
  apply H1 with (Ip := Ip'); assumption.
Qed.

Lemma up_allFO : forall (alpha : SecOrder) (x : FOvariable)
                         (P : predicate),
    ((alpha_upward_monotone_P alpha P) ->
     (alpha_upward_monotone_P (allFO x alpha) P)).
Proof.
  intros alpha x P Hmono.
  unfold alpha_upward_monotone_P in *.
  intros W Iv R Ip Ip' Ipext SOt.
  simpl in *.
  destruct x as [xn]; intros d.
  specialize (SOt d).
  specialize (Hmono W (alt_Iv Iv d (Var xn)) R Ip Ip' Ipext).
  apply Hmono.
  assumption.
Qed.

Lemma up_exFO : forall (alpha : SecOrder) (x : FOvariable)
                         (P : predicate),
    ((alpha_upward_monotone_P alpha P) ->
     (alpha_upward_monotone_P (exFO x alpha) P)).
Proof.
  intros alpha x P Hmono.
  unfold alpha_upward_monotone_P in *.
  intros W Iv R Ip Ip' Ipext SOt.
  simpl in *.
  destruct x as [xn]; destruct SOt as [d SOt].
  exists d.
  specialize (Hmono W (alt_Iv Iv d (Var xn)) R Ip Ip' Ipext).
  apply Hmono.
  assumption.
Qed.

Lemma up_allSO : forall (alpha : SecOrder) (P Q: predicate),
    ((alpha_upward_monotone_P alpha P) ->
     (alpha_upward_monotone_P (allSO Q alpha) P)).
Proof.
  intros alpha P Q Hmono.
  unfold alpha_upward_monotone_P in *.
  intros W Iv R Ip Ip' Ipext SOt.
  simpl in *.
  destruct Q as [Qm]; destruct P as [Pn].
  intros pa.
  specialize (SOt pa).
  specialize (Hmono W Iv R (alt_Ip Ip pa (Pred Qm))
        (alt_Ip Ip' pa (Pred Qm))).
  apply Hmono.
  apply Ip_ext_alt_Ip; assumption.

  assumption.
Qed.

Lemma up_exSO : forall (alpha : SecOrder) (P Q: predicate),
    ((alpha_upward_monotone_P alpha P) ->
     (alpha_upward_monotone_P (exSO Q alpha) P)).
Proof.
  intros alpha P Q Hmono.
  unfold alpha_upward_monotone_P in *.
  intros W Iv R Ip Ip' Ipext SOt.
  simpl in *.
  destruct Q as [Qm]; destruct P as [Pn].
  destruct SOt as [pa SOt].
  exists pa.
  specialize (Hmono W Iv R (alt_Ip Ip pa (Pred Qm))
        (alt_Ip Ip' pa (Pred Qm))).
  apply Hmono.
  apply Ip_ext_alt_Ip; assumption.

  assumption.
Qed.

(* -------------------------------------------------------------------- *)

Lemma down_negSO : forall (alpha: SecOrder) (P : predicate),
  alpha_downward_monotone_P alpha P ->
    alpha_upward_monotone_P (negSO alpha) P.
Proof.
  intros alpha P H.
  destruct (Pred_in_SO_dec (negSO alpha) P) as [Hocc|Hocc];
    [ | apply up_not_occ_SO; exact Hocc].
  unfold alpha_upward_monotone_P in *.
  intros W Iv Ir Ip Ip' Ipext.
  simpl in *.
  unfold not; intros SOt' H2; apply SOt'.
  apply H with (Ip := Ip'); assumption.
Qed.

Lemma down_conjSO12 : forall (alpha1 alpha2 : SecOrder) (P : predicate),
  alpha_downward_monotone_P alpha1 P ->
    alpha_downward_monotone_P alpha2 P ->
      alpha_downward_monotone_P (conjSO alpha1 alpha2) P.
Proof.
  intros alpha1 alpha2 P H1 H2.
  destruct (Pred_in_SO_dec (conjSO alpha1 alpha2) P) as [Hocc|Hocc];
    [ | apply up_not_occ_SO; exact Hocc].
  unfold alpha_upward_monotone_P in *.
  intros W Iv Ir Ip Ip' Ipext SOt.
  simpl in *.
  apply conj; [apply H1 with (Ip := Ip) | apply H2 with (Ip := Ip)];
   try apply SOt; try assumption.
Qed.

Lemma down_disjSO12 : forall (alpha1 alpha2 : SecOrder) (P : predicate),
  alpha_downward_monotone_P alpha1 P ->
    alpha_downward_monotone_P alpha2 P ->
      alpha_downward_monotone_P (disjSO alpha1 alpha2) P.
Proof.
  intros alpha1 alpha2 P H1 H2.
  destruct (Pred_in_SO_dec (disjSO alpha1 alpha2) P) as [Hocc|Hocc];
    [ | apply up_not_occ_SO; exact Hocc].
  unfold alpha_downward_monotone_P in *.
  intros W Iv Ir Ip Ip' Ipext SOt.
  simpl in *.
  destruct SOt as [SOt | SOt];
    [left ;apply H1 with (Ip := Ip) |
    right ; apply H2 with (Ip := Ip)]; try assumption.
Qed.

Lemma down_implSO12 : forall (alpha1 alpha2 : SecOrder) (P : predicate),
  alpha_upward_monotone_P alpha1 P ->
    alpha_downward_monotone_P alpha2 P ->
      alpha_downward_monotone_P (implSO alpha1 alpha2) P.
Proof.
  intros alpha1 alpha2 P H1 H2.
  destruct (Pred_in_SO_dec (implSO alpha1 alpha2) P) as [Hocc|Hocc];
    [ | apply up_not_occ_SO; exact Hocc].
  unfold alpha_upward_monotone_P in *.
  intros W Iv Ir Ip Ip' Ipext SOt.
  simpl in *; intros H.
  apply H2 with (Ip := Ip); try assumption.
  apply SOt.
  apply H1 with (Ip := Ip'); assumption.
Qed.

Lemma down_allFO : forall (alpha : SecOrder) (x : FOvariable)
                         (P : predicate),
    ((alpha_downward_monotone_P alpha P) ->
     (alpha_downward_monotone_P (allFO x alpha) P)).
Proof.
  intros alpha x P Hmono.
  unfold alpha_downward_monotone_P in *.
  intros W Iv R Ip Ip' Ipext SOt.
  simpl in *.
  destruct x as [xn]; intros d.
  specialize (SOt d).
  specialize (Hmono W (alt_Iv Iv d (Var xn)) R Ip Ip' Ipext).
  apply Hmono.
  assumption.
Qed.

Lemma down_exFO : forall (alpha : SecOrder) (x : FOvariable)
                         (P : predicate),
    ((alpha_downward_monotone_P alpha P) ->
     (alpha_downward_monotone_P (exFO x alpha) P)).
Proof.
  intros alpha x P Hmono.
  unfold alpha_downward_monotone_P in *.
  intros W Iv R Ip Ip' Ipext SOt.
  simpl in *.
  destruct x as [xn]; destruct SOt as [d SOt];
  exists d.
  specialize (Hmono W (alt_Iv Iv d (Var xn)) R Ip Ip' Ipext).
  apply Hmono.
  assumption.
Qed.

Lemma down_allSO : forall (alpha : SecOrder) (P Q: predicate),
    ((alpha_downward_monotone_P alpha P) ->
     (alpha_downward_monotone_P (allSO Q alpha) P)).
Proof.
  intros alpha P Q Hmono.
  unfold alpha_downward_monotone_P in *.
  intros W Iv R Ip Ip' Ipext SOt.
  simpl in *.
  destruct Q as [Qm]; destruct P as [Pn].
  intros pa.
  specialize (SOt pa).
  specialize (Hmono W Iv R (alt_Ip Ip pa (Pred Qm))
        (alt_Ip  Ip' pa (Pred Qm))).
  apply Hmono.
  apply Ip_ext_alt_Ip; assumption.

  assumption.
Qed.

Lemma down_exSO : forall (alpha : SecOrder) (P Q: predicate),
    ((alpha_downward_monotone_P alpha P) ->
     (alpha_downward_monotone_P (exSO Q alpha) P)).
Proof.
  intros alpha P Q Hmono.
  unfold alpha_downward_monotone_P in *.
  intros W Iv R Ip Ip' Ipext SOt.
  simpl in *.
  destruct Q as [Qm]; destruct P as [Pn].
  destruct SOt as [pa SOt].
  exists pa.
  specialize (Hmono W Iv R (alt_Ip Ip pa (Pred Qm))
        (alt_Ip Ip' pa (Pred Qm))).
  apply Hmono.
  apply Ip_ext_alt_Ip; assumption.

  assumption.
Qed.

(* ------------------------------------------------------------- *)

Lemma monotonicity_SO_predSO : forall (P Q : predicate) (x : FOvariable),
  Pred_in_SO (predSO Q x) P ->
  (Pred_is_pos_SO (predSO Q x) P -> alpha_upward_monotone_P (predSO Q x) P) /\
  (Pred_is_neg_SO (predSO Q x) P -> alpha_downward_monotone_P (predSO Q x) P).
Proof.
  intros P Q x HPocc.
  apply conj; intros H.
    unfold alpha_upward_monotone_P.
    intros W Iv R Ip Ip' Ipext SOt.
    simpl in *.
    destruct Ipext as [Ha Hb].
    destruct (predicate_dec P Q) as [H2 | H2].
      subst. apply Ha. auto.

      rewrite <- Hb; auto.

    unfold alpha_downward_monotone_P.
    intros W Iv R Ip Ip' Ipext SOt.
    simpl in *.
    destruct Ipext as [Ha Hb].
    destruct (predicate_dec P Q) as [H2 | H2].
      subst. contradiction (Pred_is_neg_SO_not_predSO _ _ H).

      rewrite Hb; auto.
Qed.

Lemma monotonicity_SO_relatSO : forall (P: predicate) (x y : FOvariable),
  Pred_in_SO (relatSO x y) P  ->
  (Pred_is_pos_SO (relatSO x y) P -> alpha_upward_monotone_P (relatSO x y) P) /\
  (Pred_is_neg_SO (relatSO x y) P -> alpha_downward_monotone_P (relatSO x y) P).
Proof. firstorder. Qed.

Lemma monotonicity_SO_eqFO : forall (P: predicate) (x y : FOvariable),
  Pred_in_SO (eqFO x y) P ->
  (Pred_is_pos_SO (eqFO x y) P -> alpha_upward_monotone_P (eqFO x y) P) /\
  (Pred_is_neg_SO (eqFO x y) P -> alpha_downward_monotone_P (eqFO x y) P).
Proof. firstorder. Qed.

Lemma monotonicity_SO_allFO : forall (alpha : SecOrder) (P: predicate)
                                     (x : FOvariable),
  (Pred_in_SO alpha P ->
          (Pred_is_pos_SO alpha P -> alpha_upward_monotone_P alpha P) /\
          (Pred_is_neg_SO alpha P -> alpha_downward_monotone_P alpha P)) ->
  Pred_in_SO (allFO x alpha) P ->
    (Pred_is_pos_SO (allFO x alpha) P -> alpha_upward_monotone_P (allFO x alpha) P) /\
    (Pred_is_neg_SO (allFO x alpha) P -> alpha_downward_monotone_P (allFO x alpha) P).
Proof.
  intros alpha P x IHalpha HPocc.
  rewrite <- Pred_in_SO_allFO with (x := x) in HPocc.
  specialize (IHalpha HPocc).
  apply conj; intros H.
    rewrite Pred_is_pos_SO_allFO in H.
    apply up_allFO; apply IHalpha;
      assumption.

    rewrite Pred_is_neg_SO_allFO in H.
    apply down_allFO; apply IHalpha;
      assumption.
Qed.

Lemma monotonicity_SO_exFO : forall (alpha : SecOrder) (P: predicate)
                                     (x : FOvariable),
  (Pred_in_SO alpha P ->
          (Pred_is_pos_SO alpha P -> alpha_upward_monotone_P alpha P) /\
          (Pred_is_neg_SO alpha P -> alpha_downward_monotone_P alpha P)) ->
  Pred_in_SO (exFO x alpha) P ->
    (Pred_is_pos_SO (exFO x alpha) P -> alpha_upward_monotone_P (exFO x alpha) P) /\
    (Pred_is_neg_SO (exFO x alpha) P -> alpha_downward_monotone_P (exFO x alpha) P).
Proof.
  intros alpha P x IHalpha HPocc.
  rewrite <- Pred_in_SO_exFO with (x := x) in HPocc.
  specialize (IHalpha HPocc).
  apply conj; intros H.
    rewrite Pred_is_pos_SO_exFO in H.
    apply up_exFO; apply IHalpha;
      assumption.

    rewrite Pred_is_neg_SO_exFO in H.
    apply down_exFO; apply IHalpha;
      assumption.
Qed.

Lemma monotonicity_SO_negSO : forall (alpha : SecOrder) (P: predicate),
    (Pred_in_SO alpha P ->
          (Pred_is_pos_SO alpha P -> alpha_upward_monotone_P alpha P) /\
          (Pred_is_neg_SO alpha P -> alpha_downward_monotone_P alpha P)) ->
     Pred_in_SO (negSO alpha) P ->
    ((Pred_is_pos_SO (negSO alpha) P -> alpha_upward_monotone_P (negSO alpha) P) /\
     (Pred_is_neg_SO (negSO alpha) P -> alpha_downward_monotone_P (negSO alpha) P)).
Proof.
  intros alpha P IHalpha Hpocc.
  rewrite <- Pred_in_SO_negSO in Hpocc.
  specialize (IHalpha Hpocc).
  split; intros H.
    apply down_negSO.
    apply IHalpha.
    apply P_pos_negSO.
    assumption.

    apply up_negSO.
    apply IHalpha.
    apply P_neg_negSO.
    assumption.
Qed.

Lemma monotonicity_SO_conjSO : forall (alpha1 alpha2 : SecOrder) (P: predicate),
  (Pred_in_SO alpha1 P ->
           (Pred_is_pos_SO alpha1 P -> alpha_upward_monotone_P alpha1 P) /\
           (Pred_is_neg_SO alpha1 P -> alpha_downward_monotone_P alpha1 P)) ->
  (Pred_in_SO alpha2 P ->
           (Pred_is_pos_SO alpha2 P -> alpha_upward_monotone_P alpha2 P) /\
           (Pred_is_neg_SO alpha2 P -> alpha_downward_monotone_P alpha2 P)) ->
  Pred_in_SO (conjSO alpha1 alpha2) P ->
  (Pred_is_pos_SO (conjSO alpha1 alpha2) P ->
   alpha_upward_monotone_P (conjSO alpha1 alpha2) P) /\
  (Pred_is_neg_SO (conjSO alpha1 alpha2) P ->
   alpha_downward_monotone_P (conjSO alpha1 alpha2) P).
Proof.
  intros alpha1 alpha2 P IHalpha1 IHalpha2 Hpocc.
  apply conj; intros H; [apply up_conjSO12| apply down_conjSO12].
    destruct (Pred_in_SO_dec alpha1 P) as [Hpocc1 | Hpocc1].
      apply IHalpha1; auto.
      eapply Pred_is_pos_SO_conjSO_l. auto. apply H.
      apply up_not_occ_SO. auto.

    destruct (Pred_in_SO_dec alpha2 P) as [Hpocc2 | Hpocc2].
      apply IHalpha2; auto.
      eapply Pred_is_pos_SO_conjSO_r. auto. apply H.
      apply up_not_occ_SO. auto.

    destruct (Pred_in_SO_dec alpha1 P) as [Hpocc1 | Hpocc1].
      apply IHalpha1; auto.
      eapply Pred_is_neg_SO_conjSO_l. auto. apply H.
      apply up_not_occ_SO. auto.

    destruct (Pred_in_SO_dec alpha2 P) as [Hpocc2 | Hpocc2].
      apply IHalpha2; auto.
      eapply Pred_is_neg_SO_conjSO_r. auto. apply H.
      apply up_not_occ_SO. auto.
Qed.

Lemma monotonicity_SO_disjSO : forall (alpha1 alpha2 : SecOrder) (P: predicate),
  (Pred_in_SO alpha1 P  ->
           (Pred_is_pos_SO alpha1 P -> alpha_upward_monotone_P alpha1 P) /\
           (Pred_is_neg_SO alpha1 P -> alpha_downward_monotone_P alpha1 P)) ->
  (Pred_in_SO alpha2 P ->
           (Pred_is_pos_SO alpha2 P -> alpha_upward_monotone_P alpha2 P) /\
           (Pred_is_neg_SO alpha2 P -> alpha_downward_monotone_P alpha2 P)) ->
  Pred_in_SO (disjSO alpha1 alpha2) P ->
  (Pred_is_pos_SO (disjSO alpha1 alpha2) P ->
   alpha_upward_monotone_P (disjSO alpha1 alpha2) P) /\
  (Pred_is_neg_SO (disjSO alpha1 alpha2) P ->
   alpha_downward_monotone_P (disjSO alpha1 alpha2) P).
Proof.
  intros alpha1 alpha2 P IHalpha1 IHalpha2 Hpocc.
  apply conj; intros H; [apply up_disjSO12| apply down_disjSO12].
    destruct (Pred_in_SO_dec alpha1 P) as [Hpocc1 | Hpocc1].
      apply IHalpha1; auto.
      eapply Pred_is_pos_SO_disjSO_l. auto. apply H.
      apply up_not_occ_SO. auto.

    destruct (Pred_in_SO_dec alpha2 P) as [Hpocc2 | Hpocc2].
      apply IHalpha2; auto.
      eapply Pred_is_pos_SO_disjSO_r. auto. apply H.
      apply up_not_occ_SO. auto.

    destruct (Pred_in_SO_dec alpha1 P) as [Hpocc1 | Hpocc1].
      apply IHalpha1; auto.
      eapply Pred_is_neg_SO_disjSO_l. auto. apply H.
      apply up_not_occ_SO. auto.

    destruct (Pred_in_SO_dec alpha2 P) as [Hpocc2 | Hpocc2].
      apply IHalpha2; auto.
      eapply Pred_is_neg_SO_disjSO_r. auto. apply H.
      apply up_not_occ_SO. auto.
Qed.

Lemma monotonicity_SO_implSO : forall (alpha1 alpha2 : SecOrder) (P: predicate),
  (Pred_in_SO alpha1 P ->
           (Pred_is_pos_SO alpha1 P -> alpha_upward_monotone_P alpha1 P) /\
           (Pred_is_neg_SO alpha1 P -> alpha_downward_monotone_P alpha1 P)) ->
  (Pred_in_SO alpha2 P ->
           (Pred_is_pos_SO alpha2 P -> alpha_upward_monotone_P alpha2 P) /\
           (Pred_is_neg_SO alpha2 P -> alpha_downward_monotone_P alpha2 P)) ->
  Pred_in_SO (implSO alpha1 alpha2) P ->
  (Pred_is_pos_SO (implSO alpha1 alpha2) P ->
   alpha_upward_monotone_P (implSO alpha1 alpha2) P) /\
  (Pred_is_neg_SO (implSO alpha1 alpha2) P ->
   alpha_downward_monotone_P (implSO alpha1 alpha2) P).
Proof.
  intros alpha1 alpha2 P IHalpha1 IHalpha2 Hpocc.
  apply conj; intros H; [apply up_implSO12| apply down_implSO12].
    destruct (Pred_in_SO_dec alpha1 P) as [Hpocc1 | Hpocc1].
      apply IHalpha1; auto.
      eapply Pred_is_pos_SO_implSO_l. auto. apply H.
      apply up_not_occ_SO. auto.

    destruct (Pred_in_SO_dec alpha2 P) as [Hpocc2 | Hpocc2].
      apply IHalpha2; auto.
      eapply Pred_is_pos_SO_implSO_r. auto. apply H.
      apply up_not_occ_SO. auto.

    destruct (Pred_in_SO_dec alpha1 P) as [Hpocc1 | Hpocc1].
      apply IHalpha1; auto.
      eapply Pred_is_neg_SO_implSO_l. auto. apply H.
      apply up_not_occ_SO. auto.

    destruct (Pred_in_SO_dec alpha2 P) as [Hpocc2 | Hpocc2].
      apply IHalpha2; auto.
      eapply Pred_is_neg_SO_implSO_r. auto. apply H.
      apply up_not_occ_SO. auto.
Qed.

Lemma monotonicity_SO_allSO : forall (alpha : SecOrder) (P Q: predicate),
  (Pred_in_SO alpha P ->
          (Pred_is_pos_SO alpha P -> alpha_upward_monotone_P alpha P) /\
          (Pred_is_neg_SO alpha P -> alpha_downward_monotone_P alpha P)) ->
  Pred_in_SO (allSO Q alpha) P ->
  (Pred_is_pos_SO (allSO Q alpha) P -> alpha_upward_monotone_P (allSO Q alpha) P) /\
  (Pred_is_neg_SO (allSO Q alpha) P -> alpha_downward_monotone_P (allSO Q alpha) P).
Proof.
  intros alpha P Q IHalpha Hpocc.
  destruct P as [Pn]; destruct Q as [Qm].
  apply conj; intros H.
    apply up_allSO. destruct (Pred_in_SO_dec alpha (Pred Pn)) as [Hpocc2 | Hpocc2].
      apply IHalpha; try assumption.
      apply Pred_is_pos_SO_allSO in H; assumption.

      apply up_not_occ_SO.  assumption.

    apply down_allSO. destruct (Pred_in_SO_dec alpha (Pred Pn)) as [Hpocc2 | Hpocc2].
      apply IHalpha; try assumption.
      apply Pred_is_neg_SO_allSO in H; assumption.

      apply up_not_occ_SO.  assumption.
Qed.

Lemma monotonicity_SO_exSO : forall (alpha : SecOrder) (P Q: predicate),
  (Pred_in_SO alpha P ->
          (Pred_is_pos_SO alpha P -> alpha_upward_monotone_P alpha P) /\
          (Pred_is_neg_SO alpha P -> alpha_downward_monotone_P alpha P)) ->
  Pred_in_SO (allSO Q alpha) P ->
  (Pred_is_pos_SO (exSO Q alpha) P -> alpha_upward_monotone_P (exSO Q alpha) P) /\
  (Pred_is_neg_SO (exSO Q alpha) P -> alpha_downward_monotone_P (exSO Q alpha) P).
Proof.
  intros alpha P Q IHalpha Hpocc.
  destruct P as [Pn]; destruct Q as [Qm].
  apply conj; intros H.
    apply up_exSO. destruct (Pred_in_SO_dec alpha (Pred Pn)) as [Hpocc2 | Hpocc2].
      apply IHalpha; try assumption.
      apply Pred_is_pos_SO_exSO in H; assumption.

      apply up_not_occ_SO.  assumption.

    apply down_exSO. destruct (Pred_in_SO_dec alpha (Pred Pn)) as [Hpocc2 | Hpocc2].
      apply IHalpha; try assumption.
      apply Pred_is_neg_SO_exSO in H; assumption.

      apply up_not_occ_SO.  assumption.
Qed.

Lemma monotonicity_SO : forall (alpha : SecOrder) (P : predicate),
  Pred_in_SO alpha P ->
    (Pred_is_pos_SO alpha P ->
      alpha_upward_monotone_P alpha P) /\
    (Pred_is_neg_SO alpha P ->
      alpha_downward_monotone_P alpha P).
Proof.
  intros alpha P.
  induction alpha.
    apply monotonicity_SO_predSO.
    apply monotonicity_SO_relatSO.
    apply monotonicity_SO_eqFO.
    apply monotonicity_SO_allFO; assumption.
    apply monotonicity_SO_exFO; assumption.
    apply monotonicity_SO_negSO; assumption.
    apply monotonicity_SO_conjSO; assumption.
    apply monotonicity_SO_disjSO; assumption.
    apply monotonicity_SO_implSO; assumption.
    apply monotonicity_SO_allSO; assumption.
    apply monotonicity_SO_exSO; assumption.
Qed.

Lemma mono_pos : forall (W : Set) (Iv : FOvariable -> W)
                    (Ip : predicate -> W -> Prop)
                    (Ir : W -> W -> Prop)
                    (alpha : SecOrder) (P : predicate)
                    (pa : W -> Prop),
  Pred_is_pos_SO alpha P ->
  SOturnst W Iv (alt_Ip Ip pa_f P) Ir alpha ->
  SOturnst W Iv (alt_Ip Ip pa P) Ir alpha.
Proof.
  intros W Iv Ip Ir alpha P pa Hpos Hf.
  pose proof monotonicity_SO as H.
  unfold alpha_upward_monotone_P in H.
  pose proof (Pred_is_pos__in_SO _ _ Hpos) as H2.
  specialize (H alpha P H2). destruct H as [Ha Hb].
  apply Ha with (Ip := (alt_Ip Ip pa_f P)); auto.
  apply Ip_ext_pa_f.
Qed.