(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(*  A <X1,...,Xn>: non commutative polynomials on a commutative ring A *)

Set Implicit Arguments.
Require Import Setoid.
Require Import BinList.
Require Import BinPos.
Require Import BinNat.
Require Import BinInt.
Require Export Ring_polynom. (* n'utilise que PExpr *)
Require Export Ncring.

Section MakeRingPol.

Context (C R:Type) `{Rh:Ring_morphism C R}.

Variable phiCR_comm: forall (c:C)(x:R), x * [c] == [c] * x.

 Ltac rsimpl := repeat (gen_rewrite || rewrite phiCR_comm).
 Ltac add_push := gen_add_push .

(* Definition of non commutative multivariable polynomials
   with coefficients in C :
 *)

 Inductive Pol : Type :=
  | Pc : C -> Pol
  | PX : Pol -> positive -> positive -> Pol -> Pol.
    (* PX P i n Q represents P * X_i^n + Q *)
Definition cO:C . exact ring0. Defined.
Definition cI:C . exact ring1. Defined.

 Definition P0 := Pc 0.
 Definition P1 := Pc 1.

Variable Ceqb:C->C->bool.
Class Equalityb (A : Type):= {equalityb : A -> A -> bool}.
Notation "x =? y" := (equalityb x y) (at level 70, no associativity).
Variable Ceqb_eq: forall x y:C, Ceqb x y = true -> (x == y).

Instance equalityb_coef : Equalityb C :=
  {equalityb x y := Ceqb x y}.

 Fixpoint Peq (P P' : Pol) {struct P'} : bool :=
  match P, P' with
  | Pc c, Pc c' => c =? c'
  | PX P i n Q, PX P' i' n' Q' =>
    match Pos.compare i i', Pos.compare n n' with
    | Eq, Eq => if Peq P P' then Peq Q Q' else false
    | _,_ => false
    end
  | _, _ => false
  end.

Instance equalityb_pol : Equalityb Pol :=
  {equalityb x y := Peq x y}.

(* Q a ses variables de queue < i *)
 Definition mkPX P i n Q :=
  match P with
  | Pc c => if c =? 0 then Q else PX P i n Q
  | PX P' i' n' Q' =>
       match Pos.compare i i' with
        | Eq => if Q' =? P0 then PX P' i (n + n') Q else PX P i n Q
        | _ => PX P i n Q
       end
  end.

 Definition mkXi i n := PX P1 i n P0.

 Definition mkX i := mkXi i 1.

 (** Opposite of addition *)

 Fixpoint Popp (P:Pol) : Pol :=
  match P with
  | Pc c => Pc (- c)
  | PX P i n Q => PX (Popp P) i n (Popp Q)
  end.

 Notation "-- P" := (Popp P)(at level 30).

 (** Addition et subtraction *)

 Fixpoint PaddCl (c:C)(P:Pol) {struct P} : Pol :=
  match P with
  | Pc c1 => Pc (c + c1)
  | PX P i n Q => PX P i n (PaddCl c Q)
  end.

(* Q quelconque *)

Section PaddX.
Variable Padd:Pol->Pol->Pol.
Variable P:Pol.

(* Xi^n * P + Q
les variables de tete de Q ne sont pas forcement < i
mais Q est normalisé : variables de tete decroissantes *)

Fixpoint PaddX (i n:positive)(Q:Pol){struct Q}:=
  match Q with
  | Pc c => mkPX P i n Q
  | PX P' i' n' Q' =>
      match Pos.compare i i' with
      | (* i > i' *)
        Gt => mkPX P i n Q
      | (* i < i' *)
        Lt => mkPX P' i' n' (PaddX i n Q')
      | (* i = i' *)
        Eq => match Z.pos_sub n n' with
              | (* n > n' *)
                Zpos k => mkPX (PaddX i k P') i' n' Q'
              | (* n = n' *)
                Z0 => mkPX (Padd P P') i n Q'
              | (* n < n' *)
                Zneg k => mkPX (Padd P (mkPX P' i k P0)) i n Q'
              end
      end
  end.

End PaddX.

Fixpoint Padd (P1 P2: Pol) {struct P1} : Pol :=
  match P1 with
  | Pc c => PaddCl c P2
  | PX P' i' n' Q' =>
      PaddX Padd P' i' n' (Padd Q' P2)
  end.

 Notation "P ++ P'" := (Padd P P').

Definition Psub(P P':Pol):= P ++ (--P').

 Notation "P -- P'" := (Psub P P')(at level 50).

 (** Multiplication *)

 Fixpoint PmulC_aux (P:Pol) (c:C)  {struct P} : Pol :=
  match P with
  | Pc c' => Pc (c' * c)
  | PX P i n Q => mkPX (PmulC_aux P c) i n (PmulC_aux Q c)
  end.

 Definition PmulC P c :=
  if c =? 0 then P0 else
  if c =? 1 then P else PmulC_aux P c.

 Fixpoint Pmul (P1 P2 : Pol) {struct P2} : Pol :=
   match P2 with
   | Pc c => PmulC P1 c
   | PX P i n Q =>
     PaddX Padd (Pmul P1 P) i n (Pmul P1 Q)
   end.

 Notation "P ** P'" := (Pmul P P')(at level 40).

 Definition Psquare (P:Pol) : Pol := P ** P.

 (** Evaluation of a polynomial towards R *)

 Fixpoint Pphi(l:list R) (P:Pol) {struct P} : R :=
  match P with
  | Pc c => [c]
  | PX P i n Q =>
     let x := nth 0 i l in
     let xn := pow_pos x n in
   (Pphi l P) * xn + (Pphi l Q)
  end.

 Reserved Notation "P @ l " (at level 10, no associativity).
 Notation "P @ l " := (Pphi l P).

 (** Proofs *)

 Ltac destr_pos_sub H :=
  match goal with |- context [Z.pos_sub ?x ?y] =>
   assert (H := Z.pos_sub_discr x y); destruct (Z.pos_sub x y)
  end.

 Lemma Peq_ok : forall P P',
    (P =? P') = true -> forall l, P@l == P'@ l.
 Proof.
 induction P;destruct P';simpl;intros ;try easy.
 - now apply ring_morphism_eq, Ceqb_eq.
 - specialize (IHP1 P'1). specialize (IHP2 P'2).
   simpl in IHP1, IHP2.
   destruct (Pos.compare_spec p p1); try discriminate;
   destruct (Pos.compare_spec p0 p2); try discriminate.
   destruct (Peq P2 P'1); try discriminate.
   subst; now rewrite IHP1, IHP2.
 Qed.

 Lemma Pphi0 : forall l, P0@l == 0.
 Proof.
  intros;simpl.
 rewrite ring_morphism0. reflexivity.
 Qed.

 Lemma Pphi1 : forall l,  P1@l == 1.
 Proof.
  intros;simpl; rewrite ring_morphism1. reflexivity.
 Qed.

 Lemma mkPX_ok : forall l P i n Q,
  (mkPX P i n Q)@l == P@l * (pow_pos (nth 0 i l) n) + Q@l.
 Proof.
  intros l P i n Q;unfold mkPX.
  destruct P;try (simpl;reflexivity).
  assert (Hh := ring_morphism_eq  c 0).
  simpl; case_eq (Ceqb c 0);simpl;try reflexivity.
  intros.
  rewrite Hh. rewrite ring_morphism0.
  rsimpl. apply Ceqb_eq. trivial.
  destruct (Pos.compare_spec i p).
  assert (Hh := @Peq_ok P3 P0). case_eq (P3=? P0). intro. simpl.
  rewrite Hh.
  rewrite Pphi0. rsimpl. rewrite Pos.add_comm. rewrite pow_pos_add;rsimpl.
  subst;trivial. reflexivity. trivial. intros. simpl. reflexivity. simpl. reflexivity.
 simpl. reflexivity.
 Qed.

Ltac Esimpl :=
  repeat (progress (
   match goal with
   | |- context [?P@?l] =>
       match P with
       | P0 => rewrite (Pphi0 l)
       | P1 => rewrite (Pphi1 l)
       | (mkPX ?P ?i ?n ?Q) => rewrite (mkPX_ok l P i n Q)
       end
   | |- context [[?c]] =>
       match c with
       | 0 => rewrite ring_morphism0
       | 1 => rewrite ring_morphism1
       | ?x + ?y => rewrite ring_morphism_add
       | ?x * ?y => rewrite ring_morphism_mul
       | ?x - ?y => rewrite ring_morphism_sub
       | - ?x => rewrite ring_morphism_opp
       end
   end));
  simpl; rsimpl.

 Lemma PaddCl_ok : forall c P l, (PaddCl c P)@l == [c] + P@l .
 Proof.
  induction P; simpl; intros; Esimpl; try reflexivity.
 rewrite IHP2. rsimpl.
rewrite (ring_add_comm  (P2 @ l * pow_pos (nth 0 p l) p0) [c]).
reflexivity.
 Qed.

 Lemma PmulC_aux_ok : forall c P l, (PmulC_aux P c)@l ==  P@l * [c].
 Proof.
  induction P;simpl;intros.  rewrite ring_morphism_mul.
try reflexivity.
  simpl. Esimpl.  rewrite IHP1;rewrite IHP2;rsimpl.
  Qed.

 Lemma PmulC_ok : forall c P l, (PmulC P c)@l ==  P@l * [c].
 Proof.
  intros c P l; unfold PmulC.
  assert (Hh:= ring_morphism_eq c 0);case_eq (c =? 0). intros.
  rewrite Hh;Esimpl. apply Ceqb_eq;trivial.
  assert (H1h:= ring_morphism_eq c 1);case_eq (c =? 1);intros.
  rewrite H1h;Esimpl. apply Ceqb_eq;trivial.
  apply PmulC_aux_ok.
 Qed.

 Lemma Popp_ok : forall P l, (--P)@l == - P@l.
 Proof.
  induction P;simpl;intros.
  Esimpl.
  rewrite IHP1;rewrite IHP2;rsimpl.
 Qed.

 Ltac Esimpl2 :=
  Esimpl;
  repeat (progress (
   match goal with
   | |- context [(PaddCl ?c ?P)@?l] => rewrite (PaddCl_ok c P l)
   | |- context [(PmulC ?P ?c)@?l] => rewrite (PmulC_ok c P l)
   | |- context [(--?P)@?l] => rewrite (Popp_ok P l)
   end)); Esimpl.

Lemma PaddXPX: forall P i n Q,
  PaddX Padd P i n Q =
  match Q with
  | Pc c => mkPX P i n Q
  | PX P' i' n' Q' =>
      match Pos.compare i i' with
      | (* i > i' *)
        Gt => mkPX P i n Q
      | (* i < i' *)
        Lt => mkPX P' i' n' (PaddX Padd P i n Q')
      | (* i = i' *)
        Eq => match Z.pos_sub n n' with
              | (* n > n' *)
                Zpos k => mkPX (PaddX Padd P i k P') i' n' Q'
              | (* n = n' *)
                Z0 => mkPX (Padd P P') i n Q'
              | (* n < n' *)
                Zneg k => mkPX (Padd P (mkPX P' i k P0)) i n Q'
              end
      end
  end.
induction Q; reflexivity.
Qed.

Lemma PaddX_ok2 : forall P2,
   (forall P l, (P2 ++ P) @ l == P2 @ l + P @ l)
   /\
   (forall P k n l,
           (PaddX Padd P2 k n P) @ l ==
             P2 @ l * pow_pos (nth 0 k l) n  + P @ l).
induction P2;simpl;intros. split. intros. apply PaddCl_ok.
 induction P.  unfold PaddX. intros. rewrite mkPX_ok.
 simpl. rsimpl.
intros. simpl.
 destruct (Pos.compare_spec k p) as [Hh|Hh|Hh].
 destr_pos_sub H1h. Esimpl2.
rewrite Hh; trivial. rewrite H1h. reflexivity.
simpl. rewrite mkPX_ok. rewrite IHP1. Esimpl2.
 rewrite Pos.add_comm in H1h.
rewrite H1h.
rewrite pow_pos_add.  Esimpl2.
rewrite Hh; trivial. reflexivity.
rewrite mkPX_ok. rewrite PaddCl_ok. Esimpl2. rewrite Pos.add_comm in H1h.
rewrite H1h.  Esimpl2. rewrite pow_pos_add. Esimpl2.
rewrite Hh; trivial. reflexivity.
rewrite mkPX_ok. rewrite IHP2. Esimpl2.
rewrite (ring_add_comm  (P2 @ l * pow_pos (nth 0 p l) p0)
                             ([c] * pow_pos (nth 0 k l) n)).
reflexivity.  assert (H1h := ring_morphism_eq c 0);case_eq (Ceqb c  0);
 intros; simpl.
rewrite H1h;trivial. Esimpl2. apply Ceqb_eq; trivial. reflexivity.
decompose [and] IHP2_1. decompose [and] IHP2_2. clear IHP2_1 IHP2_2.
split. intros. rewrite H0. rewrite H1.
Esimpl2.
induction P. unfold PaddX. intros. rewrite mkPX_ok. simpl. reflexivity.
intros. rewrite PaddXPX.
destruct (Pos.compare_spec k p1) as [H3h|H3h|H3h].
destr_pos_sub H4h.
rewrite mkPX_ok. simpl. rewrite H0. rewrite H1. Esimpl2.
rewrite H4h. rewrite H3h;trivial. reflexivity.
rewrite mkPX_ok. rewrite IHP1. Esimpl2. rewrite H3h;trivial.
rewrite Pos.add_comm in H4h.
rewrite H4h. rewrite pow_pos_add. Esimpl2.
rewrite mkPX_ok. simpl. rewrite H0. rewrite H1.
rewrite mkPX_ok.
 Esimpl2. rewrite H3h;trivial.
 rewrite Pos.add_comm in H4h.
rewrite H4h. rewrite pow_pos_add. Esimpl2.
rewrite mkPX_ok. simpl. rewrite IHP2. Esimpl2.
gen_add_push (P2 @ l * pow_pos (nth 0 p1 l) p2). try reflexivity.
rewrite mkPX_ok. simpl. reflexivity.
Qed.

Lemma Padd_ok : forall P Q l, (P ++ Q) @ l == P @ l + Q @ l.
intro P. elim (PaddX_ok2 P); auto.
Qed.

Lemma PaddX_ok : forall P2 P k n l,
   (PaddX Padd P2 k n P) @ l ==  P2 @ l * pow_pos (nth 0 k l) n  + P @ l.
intro P2. elim (PaddX_ok2 P2); auto.
Qed.

 Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l.
unfold Psub. intros. rewrite Padd_ok. rewrite Popp_ok. rsimpl.
 Qed.

 Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
induction P'; simpl; intros. rewrite PmulC_ok. reflexivity.
rewrite PaddX_ok. rewrite IHP'1. rewrite IHP'2. Esimpl2.
Qed.

 Lemma Psquare_ok : forall P l, (Psquare P)@l == P@l * P@l.
 Proof.
  intros. unfold Psquare. apply Pmul_ok.
 Qed.

 (** Definition of polynomial expressions *)

(*
 Inductive PExpr : Type :=
  | PEc : C -> PExpr
  | PEX : positive -> PExpr
  | PEadd : PExpr -> PExpr -> PExpr
  | PEsub : PExpr -> PExpr -> PExpr
  | PEmul : PExpr -> PExpr -> PExpr
  | PEopp : PExpr -> PExpr
  | PEpow : PExpr -> N -> PExpr.
*)

 (** Specification of the power function *)
 Section POWER.
  Variable Cpow : Set.
  Variable Cp_phi : N -> Cpow.
  Variable rpow : R -> Cpow -> R.

  Record power_theory : Prop := mkpow_th {
    rpow_pow_N : forall r n,  (rpow r (Cp_phi n))== (pow_N r n)
  }.

 End POWER.
 Variable Cpow : Set.
 Variable Cp_phi : N -> Cpow.
 Variable rpow : R -> Cpow -> R.
 Variable pow_th : power_theory Cp_phi rpow.

 (** evaluation of polynomial expressions towards R *)

 Fixpoint PEeval (l:list R) (pe:PExpr C) {struct pe} : R :=
   match pe with
   | PEO => 0
   | PEI => 1
   | PEc c => [c]
   | PEX _ j => nth 0 j l
   | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2)
   | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2)
   | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2)
   | PEopp pe1 => - (PEeval l pe1)
   | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n)
   end.

Strategy expand [PEeval].

 Definition mk_X j := mkX j.

 (** Correctness proofs *)

 Lemma mkX_ok : forall p l, nth 0 p l == (mk_X p) @ l.
 Proof.
  destruct p;simpl;intros;Esimpl;trivial.
 Qed.

 Ltac Esimpl3 :=
  repeat match goal with
  | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P1 P2 l)
  | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P1 P2 l)
  end;try Esimpl2;try reflexivity;try apply ring_add_comm.

(* Power using the chinise algorithm *)

Section POWER2.
  Variable subst_l : Pol -> Pol.
  Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol :=
   match p with
   | xH => subst_l (Pmul P res)
   | xO p => Ppow_pos (Ppow_pos res P p) P p
   | xI p => subst_l (Pmul P (Ppow_pos (Ppow_pos res P p) P p))
   end.

  Definition Ppow_N P n :=
   match n with
   | N0 => P1
   | Npos p => Ppow_pos P1 P p
   end.

  Fixpoint pow_pos_gen (R:Type)(m:R->R->R)(x:R) (i:positive) {struct i}: R :=
  match i with
  | xH => x
  | xO i => let p := pow_pos_gen m x i in m p p
  | xI i => let p := pow_pos_gen m x i in m x (m p p)
  end.

Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) ->
         forall res P p, (Ppow_pos res P p)@l == (pow_pos_gen Pmul P p)@l * res@l.
  Proof.
   intros l subst_l_ok res P p. generalize res;clear res.
   induction p;simpl;intros. try rewrite subst_l_ok.
 repeat rewrite Pmul_ok. repeat rewrite IHp.
   rsimpl. repeat rewrite Pmul_ok. repeat rewrite IHp. rsimpl.
 try rewrite subst_l_ok.
 repeat rewrite Pmul_ok. reflexivity.
  Qed.

Definition pow_N_gen (R:Type)(x1:R)(m:R->R->R)(x:R) (p:N) :=
  match p with
  | N0 => x1
  | Npos p => pow_pos_gen m x p
  end.

  Lemma Ppow_N_ok : forall l,  (forall P, subst_l P@l == P@l) ->
         forall P n, (Ppow_N P n)@l == (pow_N_gen P1 Pmul P n)@l.
  Proof.  destruct n;simpl. reflexivity. rewrite Ppow_pos_ok; trivial. Esimpl.  Qed.

 End POWER2.

 (** Normalization and rewriting *)

 Section NORM_SUBST_REC.
  Let subst_l (P:Pol) := P.
  Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2).
  Let Ppow_subst := Ppow_N subst_l.

  Fixpoint norm_aux (pe:PExpr C) : Pol :=
   match pe with
   | PEO => Pc cO
   | PEI => Pc cI
   | PEc c => Pc c
   | PEX _ j => mk_X j
   | PEadd pe1 (PEopp pe2) =>
     Psub (norm_aux pe1) (norm_aux pe2)
   | PEadd pe1 pe2 => Padd (norm_aux  pe1) (norm_aux pe2)
   | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2)
   | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2)
   | PEopp pe1 => Popp (norm_aux pe1)
   | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n
   end.

  Definition norm_subst pe := subst_l (norm_aux pe).

 Lemma norm_aux_spec :
     forall l pe,
       PEeval l pe == (norm_aux pe)@l.
  Proof.
   intros.
   induction pe.
   - now simpl; rewrite <- ring_morphism0.
   - now simpl; rewrite <- ring_morphism1.
   - Esimpl3.
   - Esimpl3.
   - simpl.
     rewrite IHpe1;rewrite IHpe2.
     destruct pe2; Esimpl3.
     unfold Psub.
     destruct pe1; destruct pe2; rewrite Padd_ok; rewrite Popp_ok; reflexivity.
   - simpl. unfold Psub. rewrite IHpe1;rewrite IHpe2.
     now destruct pe1;
       [destruct pe2; rewrite Padd_ok; rewrite Popp_ok; Esimpl3 | Esimpl3..].
   - simpl. rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. reflexivity.
   - now simpl; rewrite IHpe; Esimpl3.
   - simpl.
     rewrite Ppow_N_ok; (intros;try reflexivity).
     rewrite rpow_pow_N; [| now apply pow_th].
     induction n;simpl; [now Esimpl3|].
     induction p; simpl; trivial.
     + try rewrite IHp;try rewrite IHpe;
         repeat rewrite Pms_ok; repeat rewrite Pmul_ok;reflexivity.
     + rewrite Pmul_ok.
       try rewrite IHp;try rewrite IHpe; repeat rewrite Pms_ok;
         repeat rewrite Pmul_ok;reflexivity.
  Qed.

 Lemma norm_subst_spec :
     forall l pe,
       PEeval l pe == (norm_subst pe)@l.
 Proof.
  intros;unfold norm_subst.
  unfold subst_l.  apply norm_aux_spec.
 Qed.

 End NORM_SUBST_REC.

 Fixpoint interp_PElist (l:list R) (lpe:list (PExpr C * PExpr C)) {struct lpe} : Prop :=
   match lpe with
   | nil => True
   | (me,pe)::lpe =>
     match lpe with
     | nil => PEeval l me == PEeval l pe
     | _ => PEeval l me == PEeval l pe /\ interp_PElist l lpe
     end
  end.

 Lemma norm_subst_ok : forall l pe,
   PEeval l pe == (norm_subst pe)@l.
 Proof.
   intros;apply norm_subst_spec.
  Qed.

 Lemma ring_correct : forall l pe1 pe2,
   (norm_subst pe1 =? norm_subst pe2) = true ->
   PEeval l pe1 == PEeval l pe2.
 Proof.
  simpl;intros.
  do 2 (rewrite (norm_subst_ok l);trivial).
  apply Peq_ok;trivial.
 Qed.

End MakeRingPol.


Set Implicit Arguments.

Require Import Arith_Max_extra.
Require Import LNameless_Meta.
Require Import LNameless_Meta_Env.
Require Import LNameless_Isomorphism.
Require Import LNameless_Fsub_Iso.
Require Import LN_Template_Two_Sort.

(* ************************************************************ *)
(** ** Fsub Part 1A and 2A *)

(** Reference: Chargueraud's POPL solution using Locally Nameless style
   and cofinite quantification *)

(****************************************************************************)
(****************************************************************************)
(** Here begins a concrete formalization of System Fsub for part 1A and 2A. *)
(****************************************************************************)
(****************************************************************************)

(** [typ] and [trm] are already defined in LNameless_Fsub_Iso.v
<<
Notation var := atom.

Inductive typ : Set :=
| typ_bvar  : nat -> typ
| typ_fvar  : var -> typ
| typ_top   : typ
| typ_arrow : typ -> typ -> typ
| typ_all   : typ -> typ -> typ.

Inductive trm : Set :=
| trm_bvar : nat -> trm
| trm_fvar : var -> trm
| trm_app  : trm -> trm -> trm
| trm_abs  : typ -> trm -> trm
| trm_tapp : trm -> typ -> trm
| trm_tabs : typ -> trm -> trm.
>> *)

(** Many of the generic properties about substitution, environments are
   already proved in a generic
   *)

(** M_tt, M_yt, M_yy, and M_ty are already defined in LN_Template_Two_Sort.v *)

(** Notation for opening up binders with type or term variables *)

Notation "T 'open_tt_var' X" := (M_yy.M.Tbsubst T 0 (typ_fvar X)) (at level 67).
Notation "t 'open_te_var' X" := (M_yt.M.Tbsubst t 0 (typ_fvar X)) (at level 67).
Notation "t 'open_ee_var' x" := (M_tt.M.Tbsubst t 0 (trm_fvar x)) (at level 67).

(** Types as locally closed pre-types *)

Inductive type : typ -> Prop :=
| type_top :
  type typ_top
| type_var : forall (X:atom),
  type (typ_fvar X)
| type_arrow : forall T1 T2,
  type T1 ->
  type T2 ->
  type (typ_arrow T1 T2)
| type_all : forall L T1 T2,
  type T1 ->
  (forall (X:atom), X `notin` L -> type (T2 open_tt_var X)) ->
  type (typ_all T1 T2).

(** Terms as locally closed pre-terms *)

Inductive term : trm -> Prop :=
| term_var : forall (x:atom),
  term (trm_fvar x)
| term_abs : forall L V e1,
  type V ->
  (forall (x:atom), x `notin` L -> term (e1 open_ee_var x)) ->
  term (trm_abs V e1)
| term_app : forall e1 e2,
  term e1 ->
  term e2 ->
  term (trm_app e1 e2)
| term_tabs : forall L V e1,
  type V ->
  (forall (X:atom), X `notin` L -> term (e1 open_te_var X)) ->
  term (trm_tabs V e1)
| term_tapp : forall e1 V,
  term e1 ->
  type V ->
  term (trm_tapp e1 V).

(** Binding are either mapping type or term variables.
 [X ~<: T] is a subtyping asumption and [x ~: T] is
 a typing assumption *)

Inductive bind : Set :=
| bind_sub : typ -> bind
| bind_typ : typ -> bind.

Notation "X ~<: T" := (X ~ bind_sub T) (at level 31, left associativity).

Notation "x ~: T" := (x ~ bind_typ T) (at level 31, left associativity).

(** Environment is an associative list of bindings. *)

(** Well-formedness of a pre-type T in an environment E:
  all the type variables of T must be bound via a
  subtyping relation in E. This predicates implies
  that T is a type *)

Inductive wft : env bind -> typ -> Prop :=
| wft_top : forall E,
  wft E typ_top
| wft_var : forall U E X,
  binds X (bind_sub U) E ->
  wft E (typ_fvar X)
| wft_arrow : forall E T1 T2,
  wft E T1 ->
  wft E T2 ->
  wft E (typ_arrow T1 T2)
| wft_all : forall L E T1 T2,
  wft E T1 ->
  (forall (X:atom), X `notin` L -> wft (X ~<: T1 ++ E) (T2 open_tt_var X)) ->
  wft E (typ_all T1 T2).

(** A environment E is well-formed if it contains no duplicate bindings
  and if each type in it is well-formed with respect to the environment
  it is pushed on to. *)

Inductive okt : env bind -> Prop :=
| okt_empty :
  okt empty_env
| okt_sub : forall E X T,
  okt E -> wft E T -> X # E -> okt (X ~<: T ++ E)
| okt_typ : forall E x T,
  okt E -> wft E T -> x # E -> okt (x ~: T ++ E).

(** Subtyping relation *)

Inductive sub : env bind -> typ -> typ -> Prop :=
| sub_top : forall E S,
  okt E ->
  wft E S ->
  sub E S typ_top
| sub_refl_tvar : forall E X,
  okt E ->
  wft E (typ_fvar X) ->
  sub E (typ_fvar X) (typ_fvar X)
| sub_trans_tvar : forall U E T X,
  binds X (bind_sub U) E ->
  sub E U T ->
  sub E (typ_fvar X) T
| sub_arrow : forall E S1 S2 T1 T2,
  sub E T1 S1 ->
  sub E S2 T2 ->
  sub E (typ_arrow S1 S2) (typ_arrow T1 T2)
| sub_all : forall L E S1 S2 T1 T2,
  sub E T1 S1 ->
  (forall (X:atom), X `notin` L ->
    sub (X ~<: T1 ++ E) (S2 open_tt_var X) (T2 open_tt_var X)) ->
  sub E (typ_all S1 S2) (typ_all T1 T2).

(** Typing relation *)

Inductive typing : env bind -> trm -> typ -> Prop :=
| typing_var : forall E x T,
  okt E ->
  binds x (bind_typ T) E ->
  typing E (trm_fvar x) T
| typing_abs : forall L E V e1 T1,
  (forall (x:atom), x `notin` L ->
    typing (x ~: V ++ E) (e1 open_ee_var x) T1) ->
  typing E (trm_abs V e1) (typ_arrow V T1)
| typing_app : forall T1 E e1 e2 T2,
  typing E e1 (typ_arrow T1 T2) ->
  typing E e2 T1 ->
  typing E (trm_app e1 e2) T2
| typing_tabs : forall L E V e1 T1,
  (forall (X:atom), X `notin` L ->
    typing (X ~<: V ++ E) (e1 open_te_var X) (T1 open_tt_var X)) ->
  typing E (trm_tabs V e1) (typ_all V T1)
| typing_tapp : forall T1 E e1 T T2,
  typing E e1 (typ_all T1 T2) ->
  sub E T T1 ->
  typing E (trm_tapp e1 T) (M_yy.M.Tbsubst T2 0 T)
| typing_sub : forall S E e T,
  typing E e S ->
  sub E S T ->
  typing E e T.

(** Values *)

Inductive value : trm -> Prop :=
| value_abs  : forall V e1, term (trm_abs V e1) -> value (trm_abs V e1)
| value_tabs : forall V e1, term (trm_tabs V e1) -> value (trm_tabs V e1).

(** One-step reduction *)

Inductive red : trm -> trm -> Prop :=
| red_app_1 : forall e1 e1' e2,
  term e2 ->
  red e1 e1' ->
  red (trm_app e1 e2) (trm_app e1' e2)
| red_app_2 : forall e1 e2 e2',
  value e1 ->
  red e2 e2' ->
  red (trm_app e1 e2) (trm_app e1 e2')
| red_tapp : forall e1 e1' V,
  type V ->
  red e1 e1' ->
  red (trm_tapp e1 V) (trm_tapp e1' V)
| red_abs : forall V e1 v2,
  term (trm_abs V e1) ->
  value v2 ->
  red (trm_app (trm_abs V e1) v2) (M_tt.M.Tbsubst e1 0 v2)
| red_tabs : forall V1 e1 V2,
  term (trm_tabs V1 e1) ->
  type V2 ->
  red (trm_tapp (trm_tabs V1 e1) V2) (M_yt.M.Tbsubst e1 0 V2).

(** Our goal is to prove preservation and progress *)

Definition preservation := forall E e e' T,
  typing E e T ->
  red e e' ->
  typing E e' T.

Definition progress := forall e T,
  typing empty_env e T ->
  value e \/ exists e', red e e'.


Set Implicit Arguments.
Require Import LibUtils.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import Metalib.Metatheory.
Require Import Lia.
Require Import MetaExt.

Notation included l1 l2 := (Forall (fun x => In x l2) l1).
Local Hint Constructors Forall.
Local Hint Resolve in_or_app.

Section Included.

  Context {A : Type}.

  Local Ltac init :=
    intros; repeat rewrite Forall_forall in *; intros.

  Local Ltac spec :=
    lazymatch goal with
    | H : forall x, In x _ -> _, H' : In _ _ |- _ =>
      specialize (H _ H')
    end.

  Local Ltac dang := init; spec; auto.

  Lemma included_cons : forall (l1 l2 : list A) x,
      included l1 l2 ->
      included l1 (x :: l2).
  Proof. dang. right; auto. Qed.

  Lemma included_app1 : forall (l1 l2 l3 : list A),
      included l1 l2 ->
      included l1 (l2 ++ l3).
  Proof. dang. Qed.

  Lemma included_app2 : forall (l1 l2 l3 : list A),
      included l1 l3 ->
      included l1 (l2 ++ l3).
  Proof. dang. Qed.

  Lemma included_app3 : forall (l1 l2 l3 : list A),
      included (l1 ++ l2) l3 ->
      included l1 l3 /\ included l2 l3.
  Proof.
    init. split; intros; apply H.
    all:rewrite in_app_iff; auto.
  Qed.

End Included.

Section OrderPreservingEmbeddings.

  Context {A : Type}.

  (** l1 <= l2 *)
  Inductive ope_list : list A -> list A -> Prop :=
  | ol_nil : ope_list nil nil
  | ol_keep : forall x l1 l2, ope_list l1 l2 -> ope_list (x :: l1) (x :: l2)
  | ol_drop : forall x l1 l2, ope_list l1 l2 -> ope_list l1 (x :: l2).
  Hint Constructors ope_list.

  Local Ltac ind_list l :=
    induction l; intros; simpl in *; auto.

  Lemma ope_list_refl : forall l,
      ope_list l l.
  Proof. ind_list l. Qed.
  Local Hint Resolve ope_list_refl.

  Lemma ope_list_to_nil : forall l,
      ope_list [ ] l.
  Proof. ind_list l. Qed.
  Local Hint Resolve ope_list_to_nil.

  Lemma ope_list_trans : forall l1 l2 l3,
      ope_list l1 l2 ->
      ope_list l2 l3 ->
      ope_list l1 l3.
  Proof.
    intros. generalize dependent l1.
    induction H0; intros; auto.
    inversion H; subst; auto.
  Qed.

  Lemma ope_list_append1 : forall l1 l2,
      ope_list l1 (l1 ++ l2).
  Proof. ind_list l1. Qed.

  Lemma ope_list_append2 : forall l1 l2,
      ope_list l2 (l1 ++ l2).
  Proof. ind_list l1. Qed.

  Lemma ope_list_implies_included : forall l1 l2,
      ope_list l1 l2 ->
      included l1 l2.
  Proof.
    induction 1; auto.
    all: rewrite Forall_forall in *; intros.
    - destruct H0; subst;
        [left | right]; auto.
    - right; auto.
  Qed.

  Lemma ope_list_length : forall l1 l2,
      ope_list l1 l2 ->
      length l1 <= length l2.
  Proof. induction 1; simpl; lia. Qed.

  Lemma ope_list_decons : forall x l1 l2,
      ope_list (x :: l1) l2 ->
      ope_list l1 l2.
  Proof.
    intros. remember (x :: l1).
    revert Heql. revert l1.
    induction H; intros; try congruence.
    - inversion Heql; subst. auto.
    - subst. constructor.
      apply IHope_list. trivial.
  Qed.
  Local Hint Resolve ope_list_decons.

  Lemma ope_list_inv : forall x l1 l2,
      ope_list (x :: l1) (x :: l2) ->
      ope_list l1 l2.
  Proof.
    intros. remember (x :: l1). remember (x :: l2).
    revert Heql Heql0. revert l1 l2.
    induction H; intros; try congruence.
    inversion Heql0; subst.
    eauto.
  Qed.
  Local Hint Resolve ope_list_inv.

  Lemma ope_list_antisym : forall l1 l2,
      ope_list l1 l2 ->
      ope_list l2 l1 ->
      l1 = l2.
  Proof.
    induction 1; intros; trivial.
    - f_equal; auto. apply IHope_list.
      eauto.
    - apply ope_list_length in H.
      apply ope_list_length in H0.
      simpl in H0. lia.
  Qed.

  Global Instance PreorderOpe : PreOrder ope_list :=
    {
      PreOrder_Reflexive := ope_list_refl;
      PreOrder_Transitive := ope_list_trans
    }.

  Global Instance PartialOrderOpe : @PartialOrder _ _ eq_equivalence _ PreorderOpe :=
    { }.
  Proof.
    repeat split; subst; cbv; auto.
    intros. destruct H.
    apply ope_list_antisym; assumption.
  Qed.

End OrderPreservingEmbeddings.

Section DecMembership.

  Context {A : Type} {eqA : EqDec_eq A}.

  Definition In_dec (a : A) (l : list A)
    : { In a l } + { ~ In a l }.
  Proof. apply in_dec. apply eqA. Defined.

  Definition In_remove (a : A) (l : list A) : list A.
  Proof. exact (List.remove eqA a l). Defined.

  Theorem In_removed : forall a l, ~In a (In_remove a l).
  Proof.
    unfold In_remove. intros.
    apply remove_In.
  Qed.

  Theorem remove_length_invar : forall (a : A) l,
      length (In_remove a l) <= length l.
  Proof.
    induction l; simpl; intros; auto.
    destruct (eqA a a0); subst; simpl; lia.
  Qed.

  Theorem remove_length : forall (a : A) l,
      In a l ->
      length (In_remove a l) < length l.
  Proof.
    induction l; simpl; intros.
    - intuition.
    - destruct (eqA a a0); subst.
      + pose proof (remove_length_invar a0 l).
        lia.
      + destruct H; try congruence.
        specialize (IHl H).
        simpl. lia.
  Qed.

  Lemma in_before_removal : forall a l b,
      In b (In_remove a l) ->
      In b l.
  Proof.
    induction l; simpl; intros; auto.
    destruct (eqA a a0).
    - subst. auto.
    - destruct H; auto.
  Qed.

  Lemma eq_after_removal : forall a l b,
      In b l ->
      ~In b (In_remove a l) ->
      a = b.
  Proof.
    induction l; simpl; intros; auto.
    - contradiction.
    - destruct (eqA a a0).
      + subst. destruct H; auto.
      + destruct H.
        * subst. exfalso. apply H0. left. trivial.
        * apply IHl; trivial.
          intro Contra; apply H0. right. auto.
  Qed.

  Hint Resolve ope_list_refl.
  Hint Constructors ope_list.

  Lemma In_remove_ope_list : forall (x : A) l,
      ope_list (In_remove x l) l.
  Proof.
    induction l; intros; simpl; auto.
    destruct (eqA x a); simpl; auto.
  Qed.

  Lemma not_ope_after_removal : forall (x : A) l,
      In x l ->
      ~ope_list l (In_remove x l).
  Proof.
    intros. intro Contra.
    apply ope_list_length in Contra.
    apply remove_length in H.
    lia.
  Qed.

End DecMembership.

Section AtomLists.

  Theorem remove_from_list : forall a l S S',
    Forall (fun v => v `notin` S) (In_remove a l) ->
    S' [<=] S ->
    a `notin` S' ->
    Forall (fun v => v `notin` S') l.
  Proof.
    induction l; intros; auto.
    simpl in H.
    change (EqDec_eq_of_X a a0) with (a == a0) in H.
    constructor.
    - simpl in H.
      destruct (a == a0); subst; trivial.
      inversion H; subst.
      set solve.
    - eapply IHl; auto.
      destruct (a == a0); subst; auto.
  Qed.

End AtomLists.

(* l1 is a prefix of l2 *)
Inductive prefix {A} : list A -> list A -> Prop :=
| pf_refl : forall l, prefix l l
| pf_cons : forall a l1 l2, prefix l1 l2 -> prefix l1 (a :: l2).
Local Hint Constructors prefix.

Section PrefixProperties.

  Context {A : Type}.
  Implicit Type a : A.
  Implicit Type l : list A.

  Lemma prefix_to_app : forall l1 l2,
      prefix l1 l2 ->
      exists l, l2 = l ++ l1.
  Proof.
    induction on @prefix.
    - exists nil. easy.
    - tidy_up. eexists.
      instantiate (1 := ltac:(apply cons)).
      simpl. reflexivity.
  Qed.

  Lemma app_to_prefix : forall l1 l2 l3,
      l1 ++ l2 = l3 ->
      prefix l2 l3.
  Proof. induction l1; routine. Qed.

  Lemma prefix_iff_app : forall l1 l2,
      prefix l1 l2 <-> exists l, l2 = l ++ l1.
  Proof.
    split.
    - apply prefix_to_app.
    - intros. tidy_up.
      eapply app_to_prefix.
      eauto.
  Qed.

  Lemma prefix_nil : forall l,
      prefix nil l.
  Proof. induction on list; routine. Qed.

  Lemma prefix_app : forall l' l,
      prefix l (l' ++ l).
  Proof. induction l'; routine. Qed.
  Hint Resolve prefix_app.

  Lemma prefix_deapp : forall l1 l2 l3,
      prefix (l1 ++ l2) l3 ->
      prefix l2 l3.
  Proof. dep induction on @prefix; eauto. Qed.

  Lemma prefix_decons : forall a l1 l2,
      prefix (a :: l1) l2 ->
      prefix l1 l2.
  Proof.
    intros. eapply prefix_deapp.
    instantiate (1 := cons a nil).
    trivial.
  Qed.
  Hint Resolve prefix_decons.

  Lemma prefix_dom : forall A (l1 l2 : list (var * A)),
      prefix l1 l2 ->
      dom l1 [<=] dom l2.
  Proof.
    induction on @prefix; routine.
  Qed.

  Lemma prefix_trans : forall l1 l2 l3,
      prefix l1 l2 ->
      prefix l2 l3 ->
      prefix l1 l3.
  Proof.
    intros. gen l3.
    induction H; eroutine.
  Qed.

  Global Instance PrefixPreOrder : PreOrder (@prefix A) := { }.
  Proof.
    - exact pf_refl.
    - exact prefix_trans.
  Qed.

End PrefixProperties.

Section OpeListProperties.
  Hint Constructors ope_list.
  Hint Resolve ope_list_refl ope_list_trans ope_list_to_nil.

  Context {A : Type}.
  Implicit Type x : var.
  Implicit Type a : A.
  Implicit Type l : list (var * A).

  Lemma prefix_is_ope_list : forall l1 l2,
      prefix l1 l2 ->
      ope_list l1 l2.
  Proof. induction on @prefix; routine. Qed.

  Lemma ope_list_dom : forall l1 l2,
      ope_list l1 l2 ->
      dom l1 [<=] dom l2.
  Proof.
    induction on @ope_list; set solve.
    destruct_conjs. simpl.
    set solve.
  Qed.

  Lemma ope_list_uniq : forall l1 l2,
      ope_list l1 l2 ->
      uniq l2 ->
      uniq l1.
  Proof.
    induction on @ope_list; routine.
    constructor; auto.
    pose proof (ope_list_dom H1).
    set solve.
  Qed.

  Lemma ope_list_witness_uniq_gen :
    forall l l',
      ope_list l l' ->
    forall x a1 a2 l1 l2 l3 l4,
      l = l1 ++ x ~ a1 ++ l2 ->
      l' = l3 ++ x ~ a2 ++ l4 ->
      uniq l' ->
      ope_list l1 l3 /\ a1 = a2 /\ ope_list l2 l4.
   Proof.
     induction on @ope_list; intros; destruct_conjs.
     - apply List.app_cons_not_nil in H.
       contradiction.
     - destruct l0, l4; simpl in *; progressive_inversions.
       + repeat split; trivial.
       + exfalso. solve_uniq.
       + exfalso. pose proof (ope_list_dom H1).
         set simpl in *. destruct_conjs. set solve.
       + edestruct IHope_list; try reflexivity; trivial.
         destruct_conjs.
         repeat split; auto.
     - subst l1.
       destruct l4; simpl in *; progressive_inversions.
       + exfalso. pose proof (ope_list_dom H1).
         set simpl in *. destruct_conjs; set solve.
       + edestruct IHope_list; try reflexivity; trivial.
         destruct_conjs.
         auto.
   Qed.

  Lemma ope_list_witness_uniq : forall {x a1 a2 l1 l2 l3 l4},
      ope_list (l1 ++ x ~ a1 ++ l2) (l3 ++ x ~ a2 ++ l4) ->
      uniq (l3 ++ x ~ a2 ++ l4) ->
      ope_list l1 l3 /\ a1 = a2 /\ ope_list l2 l4.
  Proof.
    intros. eapply ope_list_witness_uniq_gen; eauto.
  Qed.

End OpeListProperties.


(* 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, definition of Pplus

          Laurent Thery March 97 (revised April 01)

  ************************************************************************** *)

From Coq Require Import Arith.
From Buchberger Require Export Peq.
From Buchberger Require Import LetP.

Set Default Proof Using "Type".

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

Local Hint Resolve nillu1 nillu2 mainu1 mainu2a mainu2b mainu3 : core.

Definition projsig1 (A : Type) (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_type 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)).

Local Hint Unfold projsig1 pluspf : core.

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).
Proof.
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.
Proof using os.
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).
Proof.
intros l1 l2; try assumption.
unfold pluspf in |- *; case (plusp (l1, l2)); simpl in |- *; auto.
Qed.

Local Hint Resolve pluspf_is_plusP : core.

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).
Proof using os.
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.
Proof using os.
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).
Proof using os.
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.
Proof.
intros p; elim p.
intros q H'; inversion H'; auto.
intros a l H' q H'0; inversion H'0; auto.
Qed.

Local Hint Resolve eqp_refl : core.

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

Local Hint Resolve eqp_refl : core.

Theorem plusP_decomp :
 forall a p,
 canonical A0 eqA ltM (pX a p) -> plusP (pX a (pO A n)) p (pX a p).
Proof.
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)).
Proof using os.
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).
Proof using os.
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.
Proof using os.
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).
Proof using os.
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)).
Proof using os multA minusA invA divA cs A1.
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)).
Proof using os multA minusA invA divA cs A1.
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)).
Proof using os multA minusA invA divA cs A1.
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)).
Proof using os multA minusA invA divA cs A1.
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.

Local Hint Resolve pluspf_inv1 pluspf_inv2 pluspf_inv3a pluspf_inv3b : core.

Theorem plusP_com :
 forall p q r s, plusP p q r -> plusP q p s -> eqP A eqA n r s.
Proof using os multA minusA ltM_dec invA eqA_dec divA cs A1.
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).
Proof using os multA minusA invA divA cs A1.
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.
Proof using multA minusA invA divA cs A1.
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.
Proof using multA minusA invA divA cs A1.
intros p q H'; inversion H'; auto.
Qed.

Local Hint Resolve plusP_zero_pOl plusP_zero_pOr : core.
Local Hint Resolve eqp_trans : core.

Theorem plusP_uniq_eqP :
 forall p q r s, plusP p q r -> plusP p q s -> eqP A eqA n r s.
Proof using os multA minusA invA divA cs A1.
intros p q r s H' H'0; rewrite (uniq_plusp (p, q) r s); auto.
Qed.

Local Hint Resolve plusP_uniq_eqP : core.

Theorem pO_pluspf_inv1 : forall p, p = pluspf (pO A n) p.
Proof using os.
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).
Proof using os.
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).
Proof using os.
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).
Proof using os.
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).
Proof using os.
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).
Proof using os.
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)).
Proof using os.
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.
Proof using os.
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).
Proof using os.
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.
Proof using os multA minusA invA divA cs A1.
intros p; rewrite <- pO_pluspf_inv1; auto.
Qed.

Theorem p0_pluspf_r : forall p, eqP A eqA n (pluspf p (pO A n)) p.
Proof using os multA minusA invA divA cs A1.
intros p; rewrite <- pO_pluspf_inv2; auto.
Qed.

Local Hint Resolve p0_pluspf_l p0_pluspf_r : core.

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).
Proof using os multA minusA invA divA cs A1.
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.

Local Hint Resolve plusTerm_is_pX : core.

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)))).
Proof using os multA minusA invA divA cs A1.
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 => Nat.add_comm a (S b)); simpl in |- *.
repeat rewrite (Nat.add_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 => Nat.add_comm a (S b)); simpl in |- *.
repeat rewrite (Nat.add_comm (size A n l2)); auto.
repeat rewrite (Nat.add_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 => Nat.add_comm a (S b)); simpl in |- *.
repeat rewrite (Nat.add_comm (size A n l2)); auto.
repeat rewrite (Nat.add_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 => Nat.add_comm a (S b)); simpl in |- *.
repeat rewrite (Nat.add_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 => Nat.add_comm a (S b)); simpl in |- *.
repeat rewrite (Nat.add_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 => Nat.add_comm a (S b)); simpl in |- *.
repeat rewrite (Nat.add_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)).
Proof using os multA minusA invA divA cs A1.
intros p q r H' H'0 H'1.
apply pluspf3_assoc with (l := (p, (q, r))); auto.
Qed.

Local Hint Resolve pluspf_assoc : core.

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).
Proof using os multA minusA invA divA cs A1.
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).
Proof using os multA minusA invA divA cs A1.
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).
Proof using os multA minusA invA divA cs A1.
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.

Local Hint Resolve eqp_pluspf_com : core.

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.