Require Import Coq.ZArith.ZArith.
Require Import Coq.Init.Byte.
Require Import coqutil.Word.Bitwidth coqutil.Word.Properties.
Require Import coqutil.Map.Interface coqutil.Map.Properties.
Require Import coqutil.Datatypes.ZList.
Require Import coqutil.Datatypes.Inhabited.
Require Import coqutil.Tactics.Tactics.
Require Import coqutil.Tactics.syntactic_unify.
Require Import coqutil.Tactics.fwd.
Require Import coqutil.Tactics.fold_hyps.
Require Import coqutil.Datatypes.RecordSetters.
Require Import bedrock2.Lift1Prop bedrock2.Map.Separation bedrock2.Map.DisjointUnion.
Require Import bedrock2.PurifySep.
Require Import bedrock2.SepLib.
Require Import bedrock2.sepapp.
Require Import bedrock2.ZnWords.
Require Import bedrock2.TacticError.
Require Import bedrock2.HeapletwiseHyps.
Require Import bedrock2.bottom_up_simpl_ltac1.
Require Import bedrock2.Map.SeparationLogic.

Import ZList.List.ZIndexNotations.
Local Open Scope zlist_scope.
Local Open Scope Z_scope.

Section SepLog.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word byte}.
  Context {word_ok: word.ok word} {mem_ok: map.ok mem}.

  (* Different kinds of splitting/merging back:
     a) single array element
     b) subarray
     c) record field in a sepapp
     d) unfolding/folding the name of a record predicate

     Note that c) and d) are separate because if we access two fields of the
     same record, step d) happens once, but step c) happens twice *)

  Lemma split_off_elem_from_array{E: Type}{inh: inhabited E}:
    forall a a' elem {elemSize: PredicateSize elem} n i,
      (* to be solved by reflexivity (instantiates i): *)
      word.unsigned (word.sub a' a) / elemSize = i ->
      (* to be solved by ZnWords: *)
      ((word.unsigned (word.sub a' a)) mod elemSize = 0 /\ 0 <= i < n) ->
      (* split direction: *)
      (forall (vs: list E) m,
          array elem n vs a m ->
          sep (elem vs[i] a')
              (sep (array elem i vs[:i] a)
                  (array elem (n-i-1) vs[i+1:]
                      (word.add a' (word.of_Z elemSize)))) m) /\
      (* merge direction: *)
      (forall vs1 vs2 v m,
          sep (array elem i vs1 a)
              (sep (elem v a')
                  (array elem (n-i-1) vs2
                      (word.add a' (word.of_Z elemSize)))) m ->
          array elem n (vs1 ++ [|v|] ++ vs2) a m).
  Proof.
    split; intros.
    {
      unfold array in *.
      do 3 heapletwise_step.
      rewrite List.len_upto by ZnWords.
      rewrite List.len_from by ZnWords.

      assert (vs = vs[:i] ++ [|vs[i]|] ++ vs[i+1:]) as Hexposed by
        (apply (List.expose_nth vs i); ZnWords).
      rewrite Hexposed in H3.

      apply Array.array_append in H3.
      heapletwise_step.
      simpl in H4.
      unfold with_mem in H4.
      heapletwise_step.

      assert (a' = (word.add a
        (word.of_Z (word.unsigned (width := width)
          (word.of_Z elemSize) * len vs[:i])))) as Ha' by
        (rewrite List.len_upto;
          destruct width_cases as [Ew | Ew]; rewrite Ew in *; ZnWords).
      rewrite <- Ha' in *; clear Ha'.
      repeat heapletwise_step; ZnWords.
    }
    {
      unfold array in *.
      do 6 heapletwise_step.

      epose proof (Array.array_append) as Happ.
      eapply iff1ToEq in Happ.
      rewrite Happ; clear Happ; simpl.

      assert (a' = (word.add a
        (word.of_Z (word.unsigned (width := width)
          (word.of_Z elemSize) * len vs1)))) as Ha' by
        (destruct width_cases as [Ew | Ew]; rewrite Ew in *; ZnWords).
      rewrite <- Ha' in *; clear Ha'.

      repeat heapletwise_step.
      rewrite List.app_length; simpl.
      destruct width_cases as [Ew | Ew]; rewrite Ew in *; ZnWords.
    }
  Qed.

  Lemma split_off_subarray_from_array{E: Type}{inh: inhabited E}:
    (* a = start of the entire array. a' = start of the subarray (i). *)
    (* size = number of elements to split off *)
    forall a a' elem {elemSize: PredicateSize elem} n (nbytes: Z) i (size: Z),
      word.unsigned (word.sub a' a) / elemSize = i ->
      nbytes / elemSize = size ->

      (word.unsigned (word.sub a' a)) mod elemSize = 0 /\
      nbytes mod elemSize = 0 /\
      0 <= size /\
      0 <= i /\ i+size <= n ->

      (forall (vs: list E) m,
        array elem n vs a m ->

        (* first part *)
        sep (array elem i vs[:i] a)
        (* middle subarray part *)
          (sep (array elem size vs[i:][:size] a')
        (* final part *)
            (array elem (n-i-size) vs[i+size:]
              (word.add a' (word.of_Z (elemSize * size))))) m)

      /\

      (forall vsl vsr vsm m,
        (* first part *)
        sep (array elem i vsl a)
        (* middle subarray part *)
          (sep (array elem size vsm a')
        (* final part *)
            (array elem (n-i-size) vsr
              (word.add a' (word.of_Z (elemSize * size))))) m  ->

        array elem n (vsl ++ vsm ++ vsr) a m
      ).
  Proof.
    split; intros.
    {
      unfold array in *.
      repeat heapletwise_step; unfold with_mem in *.

      rewrite List.len_upto by ZnWords.
      rewrite List.len_sized_slice by ZnWords.
      rewrite List.from_upto_comm by ZnWords.
      rewrite List.from_canon with (i := i+size).
      rewrite List.len_indexed_slice with (i := i+size) (j := len vs) by ZnWords.

      assert (vs = vs[:i] ++ vs[i:i+size] ++ vs[i+size:len vs]) as Hsplit.
      {
        rewrite List.merge_adjacent_slices.
        - rewrite <- List.from_canon.
          apply List.split_at_index.
          ZnWords.
        - ZnWords.
      }
      rewrite Hsplit in H4; clear Hsplit.
      apply Array.array_append in H4.
      heapletwise_step.
      apply Array.array_append in H5.
      heapletwise_step.
      rewrite List.len_add_sized_slice in * by ZnWords.

      replace (word.add a
               (word.of_Z (word.unsigned (width := width)
                 (word.of_Z elemSize) * len vs[:i]))) with a' in * by
        (rewrite List.len_upto by ZnWords;
          destruct width_cases as [Ew | Ew]; rewrite Ew in *; ZnWords).
      replace (word.of_Z (word.unsigned (word.of_Z elemSize) * size))
        with (word.of_Z (word := word) (elemSize * size)) in * by
          (destruct width_cases as [Ew | Ew]; rewrite Ew in *; ZnWords).
      repeat heapletwise_step; ZnWords.
    }
    {
      unfold array in *.
      do 8 heapletwise_step.

      epose proof (Array.array_append) as Happ.
      eapply iff1ToEq in Happ.
      rewrite Happ; clear Happ.

      rewrite <- H5 in H6.
      epose proof (Array.array_append) as Happ.
      eapply iff1ToEq in Happ.
      rewrite Happ; clear Happ.

      replace (word.add a
               (word.of_Z (word.unsigned (width := width)
                 (word.of_Z elemSize) * len vsl))) with a' in * by
        (destruct width_cases as [Ew | Ew]; rewrite Ew in *; ZnWords).
      replace (word.of_Z (word.unsigned (word.of_Z elemSize) * len vsm))
        with (word.of_Z (word := word) (elemSize * len vsm)) in * by
          (destruct width_cases as [Ew | Ew]; rewrite Ew in *; ZnWords).

      collect_heaplets_into_one_sepclause m'.
      repeat heapletwise_step.
      rewrite 2 List.app_length; ZnWords.
    }
  Qed.

  (* does not depend on any library functions so that we can safely cbn it *)
  Fixpoint sepapps_offset(n: nat)(l: list sized_predicate): Z :=
    match n with
    | O => 0
    | S n' =>
        match l with
        | nil => 0
        | cons (mk_sized_predicate _ sz) t => Z.add sz (sepapps_offset n' t)
        end
    end.

  Lemma sepapps_offset_spec: forall n l,
      sepapps_offset n l = sepapps_size (List.firstn n l).
  Proof.
    induction n; intros.
    - reflexivity.
    - destruct l. 1: reflexivity. simpl. destruct s. rewrite IHn. reflexivity.
  Qed.

  (* does not depend on any library functions so that we can safely cbn it *)
  Fixpoint sepapps_replace(l: list sized_predicate)(n: nat)(p: sized_predicate) :=
    match l with
    | cons h t =>
        match n with
        | O => cons p t
        | S n' => cons h (sepapps_replace t n' p)
        end
    | nil => cons p nil
    end.

  Lemma sepapps_replace_spec: forall l n p,
      sepapps_replace l n p = List.firstn n l ++ cons p (List.skipn (S n) l).
  Proof.
    induction l; intros; destruct n; try reflexivity.
    simpl. rewrite IHl. reflexivity.
  Qed.

  Lemma split_off_field_from_sepapps: forall a a' sz ofs n,
      word.unsigned (word.sub a' a) = ofs -> (* <- simplify lhs, then reflexivity
                                                determines ofs *)
      (forall l P m,
          sepapps_offset n l = ofs -> (* <- determines n *)
          List.nth_error l n = Some (mk_sized_predicate P sz) ->
          sepapps l a m ->
          sep (sepapps (sepapps_replace l n (mk_sized_predicate (hole sz) sz)) a)
              (P a') m) /\
      (forall l P m,
          sepapps_offset n l = ofs -> (* <- should be eq_refl *)
          List.nth_error l n = Some (mk_sized_predicate (hole sz) sz) ->
          sep (sepapps l a) (P a') m ->
          sepapps (sepapps_replace l n (mk_sized_predicate P sz)) a m).
  Proof.
    intros. split; intros; subst;
      rewrite sepapps_offset_spec in H0;
      rewrite sepapps_replace_spec.
    - rewrite (expose_nth_sepapp l n a P sz H1) in H2.
      eapply SeparationLogic.sep_comm. eqapply H2. f_equal.
      rewrite H0. rewrite word.of_Z_unsigned, word.add_sub_r_same_r; trivial.
    - rewrite <- (merge_back_nth_sepapp l n a P sz H1).
      eapply SeparationLogic.sep_comm. eqapply H2. f_equal.
      rewrite H0. rewrite word.of_Z_unsigned, word.add_sub_r_same_r; trivial.
  Qed.

(* alternative way of expressing "1 past a'":
  Lemma split_off_elem_from_array{E: Type}{inh: inhabited E}:
    forall a a' elem {elemSize: PredicateSize elem} n i,
      (word.unsigned (word.sub a' a)) mod elemSize = 0 ->
      word.unsigned (word.sub a' a) / elemSize = i ->
      (forall (vs: list E) m,
          array elem n vs a m ->
          sep (elem vs[i] a')
              (sep (array elem i vs[:i] a)
                   (array elem (n-i-1) vs[i+1:]
                      (word.add a (word.of_Z (elemSize * (i + 1)))))) m) /\
      (forall vs1 vs2 v m,
          sep (array elem i vs1 a)
              (sep (elem v a')
                   (array elem (n-i-1) vs2
                      (word.add a (word.of_Z (elemSize * (i + 1)))))) m ->
          array elem n (vs1 ++ [|v|] ++ vs2) a m).
  Proof.
  Admitted.
*)
End SepLog.

Definition find_superrange_hyp{word: Type}(start: word)(size: Z)(tGoal: Prop) := tGoal.
Definition split_range_from_hyp{word: Type}(start: word)(size: Z)(tHyp: Prop)
  (H: tHyp)(tGoal: Prop) := tGoal.

Definition merge_step(P: Prop) := P.

Inductive fold_step{SomeRecordType word mem: Type}
  (pred: SomeRecordType -> word -> mem -> Prop) := mk_fold_step.

Ltac fold_in_hyps p :=
  let h := head p in
  let p' := eval cbv beta iota delta [h] in p in
  idtac p';
  match goal with
  | H: context C[?x] |- _ =>
    syntactic_unify p' x;
    let g := context C[p] in
    change g in H
  end.

Ltac prepend_reversed l acc :=
  lazymatch l with
  | nil => acc
  | cons ?h ?t => prepend_reversed t (cons h acc)
  end.

Ltac list_reverse l := prepend_reversed l open_constr:(@nil _).

(* Given
   c: record_constructor ?arg1 ... ?argN
   l: [| mk_sized_predicate (predN vN) sizeN; ...; mk_sized_predicate (pred1 v1) size1 |]
   instantiates the evars ?arg1 ... ?argN with v1 ... vN *)
Ltac instantiate_constructor_with_reversed_sepapps c l :=
  lazymatch l with
  | cons (mk_sized_predicate (?pred ?v) ?size) ?l' =>
      lazymatch c with
      | ?c' ?e => unify e v; instantiate_constructor_with_reversed_sepapps c' l'
      end
  | nil => idtac
  end.

(* Given
   c: record_constructor ?arg1 ... ?argN
   l: [| mk_sized_predicate (pred1 v1) size1; ...; mk_sized_predicate (predN vN) sizeN |]
   instantiates the evars ?arg1 ... ?argN with v1 ... vN *)
Ltac instantiate_constructor_with_sepapps c l :=
  let lrev := list_reverse l in
  instantiate_constructor_with_reversed_sepapps c lrev.

Ltac pick_nat n :=
  multimatch n with
  | S ?m => constr:(m)
  | S ?m => pick_nat m
  end.

Ltac find_field_index_from_offset :=
  lazymatch goal with
  | |- sepapps_offset ?i_ev ?l = ?ofs =>
      tryif is_evar i_ev then
        lazymatch concrete_list_length_err l with
        | Some ?n => once (let i := pick_nat n in unify i_ev i; reflexivity)
        | None => fail 1000 l "is not a concrete list"
        end
      else
        fail 1000 i_ev "is not an evar"
  end.

Ltac split_range_from_hyp_default :=
  lazymatch goal with
  | |- split_range_from_hyp ?start ?size (with_mem ?m ?P) ?H ?g =>
      lazymatch P with
      | sepapps _ _ => idtac
      | array _ _ _ _ => idtac
      | _ => let h := head P in unfold h in H;
             record.simp_hyp H;
             lazymatch P with
             | ?pred ?v ?addr => pose proof (mk_fold_step pred)
             end
      end;
      let pf := fresh in
      lazymatch type of H with
      | with_mem _ (@array _ _ _ _ _ ?elem (*must match:*)size ?n ?vs ?start') =>
          unshelve epose proof
            (split_off_elem_from_array start' start elem n _ _ _) as pf;
          [ (* i *)
          | bottom_up_simpl_in_goal; reflexivity
          | ZnWords
          | change g;
            eapply (proj1 pf) in H;
            eapply proj2 in pf;
            let t := type of pf in change (merge_step t) in pf ]
      | with_mem _ (@array _ _ _ _ _ ?elem ?elemSize ?n ?vs ?start') =>
          unshelve epose proof
            (split_off_subarray_from_array start' start elem n size _ _ _ _ _) as pf;
          [ (* index of first element *)
          | (* number of elements to split off *)
          | bottom_up_simpl_in_goal; reflexivity
          | bottom_up_simpl_in_goal; reflexivity
          | ZnWords
          | change g;
            eapply (proj1 pf) in H;
            eapply proj2 in pf;
            let t := type of pf in change (merge_step t) in pf ]
      | with_mem _ (sepapps _ ?start') =>
          unshelve epose proof
            (split_off_field_from_sepapps start' start size _ _ _) as pf;
          [ (* offset: dependent evar will be determined by second subgoal *)
          | (* n (index of field): determined later below *)
          | (* address difference equals offset *)
            bottom_up_simpl_in_goal; reflexivity
          | change g;
            eapply (proj1 pf) in H;
            [ eapply proj2 in pf
            | find_field_index_from_offset
            | reflexivity ];
            cbn [sepapps_replace] in H;
            let t := type of pf in change (merge_step t) in pf ]
      end
  end.

Ltac split_range_from_hyp_hook := split_range_from_hyp_default.

Section CancelingInHyp.
  Context {key value: Type} {mem: map.map key value} {mem_ok: map.ok mem}
          {key_eqb: key -> key -> bool} {key_eqb_spec: Decidable.EqDecider key_eqb}.

  Definition canceling_in_hyp(mAll: mem)(omAvailable: mmap mem)
    (Ps: list (mem -> Prop))(Q: mem -> Prop) :=
    exists mUsed, mmap.du omAvailable (mmap.Def mUsed) = mmap.Def mAll /\
                  forall mp mq, mmap.du (mmap.Def mp) (mmap.Def mUsed) = mmap.Def mq ->
                                seps Ps mp -> Q mq.

  Lemma start_canceling_in_hyp: forall Ps (Q: mem -> Prop) omAll mAll,
      omAll = mmap.Def mAll ->
      (forall m, SeparationLogic.Tree.to_sep Ps m -> Q m) ->
      canceling_in_hyp mAll omAll (SeparationLogic.Tree.flatten Ps) Q.
  Proof.
    unfold canceling_in_hyp. intros. exists map.empty. split.
    - rewrite mmap.du_empty_r. exact H.
    - intros. rewrite mmap.du_empty_r in H1. inversion H1. subst mp. clear H1.
      eapply H0. eapply SeparationLogic.Tree.flatten_iff1_to_sep. assumption.
  Qed.

  Lemma canceling_step_in_hyp: forall (P: mem -> Prop) Ps Q mAll m path hs1 hs2,
      with_mem m P ->
      mem_tree_lookup hs1 path = Some m ->
      mem_tree_remove hs1 path = Some (Some hs2) ->
      canceling_in_hyp mAll (interp_mem_tree hs1) (cons P Ps) Q ->
      canceling_in_hyp mAll (interp_mem_tree hs2) Ps Q.
  Proof.
    unfold canceling_in_hyp. intros. fwd.
    unfold mmap.du, mmap.of_option in H2p0. fwd.
    epose proof (split_mem_tree H0 H1 E) as A.
    exists (map.putmany m mUsed).
    unfold map.du in E0. fwd.
    unfold mmap.du, mmap.of_option in A. fwd.
    eapply map.disjointb_spec in E1.
    assert (map.disjoint m mUsed) as D. {
      unfold map.du in E2. fwd. eapply map.disjointb_spec in E3.
      unfold map.disjoint in *. intros. eapply E1. 2: eassumption.
      rewrite map.get_putmany_dec. rewrite H2. reflexivity.
    }
    split.
    - unfold map.du in E2. fwd.
      unfold mmap.du, mmap.of_option, map.du.
      eapply map.disjoint_putmany_l in E1. fwd.
      replace (map.disjointb m1 (map.putmany m mUsed)) with true.
      1: rewrite map.putmany_assoc; reflexivity.
      symmetry. eapply map.disjointb_spec. eapply map.disjoint_putmany_r.
      eapply map.disjointb_spec in E3. auto.
    - intros.
      unfold mmap.du, mmap.of_option, map.du in H2. fwd.
      eapply map.disjointb_spec in E4. eapply map.disjoint_putmany_r in E4. fwd.
      eapply H2p1.
      2: {
        eapply SeparationLogic.seps_cons. eapply sep_from_disjointb. 2,3: eassumption.
        eapply map.disjointb_spec. apply map.disjoint_comm. assumption.
      }
      unfold mmap.du, mmap.of_option, map.du.
      replace (map.disjointb (map.putmany m mp) mUsed) with true.
      + rewrite map.putmany_assoc. f_equal. f_equal. eapply map.putmany_comm.
        eapply map.disjoint_comm. assumption.
      + symmetry. eapply map.disjointb_spec. eapply map.disjoint_putmany_l. auto.
  Qed.

  Lemma canceling_done_in_hyp: forall Q mAll omAvailable,
      canceling_in_hyp mAll omAvailable nil Q ->
      exists m, mmap.du omAvailable (mmap.Def m) = mAll /\ with_mem m Q.
  Proof.
    unfold canceling_in_hyp. intros. fwd. exists mUsed. split. 1: assumption.
    eapply Hp1. 1: eapply mmap.du_empty_l. unfold seps, emp. auto.
  Qed.
End CancelingInHyp.

Ltac start_canceling_in_hyp H :=
  unfold merge_step in H;
  repeat lazymatch type of H with
    | forall m, ?A m -> ?B m => fail (* done *)
    | forall (_: ?A), _ => let x := lazymatch open_constr:(_: A) with ?x => x end in
                           specialize (H x)
    end;
  lazymatch type of H with
  | forall m, ?A m -> ?B m =>
      let clausetree := SeparationLogic.reify A in
      change (forall m, SeparationLogic.Tree.to_sep clausetree m -> B m) in H;
      lazymatch goal with
      | D: _ = mmap.Def _ |- _ =>
          eapply (start_canceling_in_hyp clausetree _ _ _ D) in H;
          clear D;
          cbn [SeparationLogic.Tree.flatten
               SeparationLogic.Tree.interp
               bedrock2.Map.SeparationLogic.app] in H
      end
  end.

Ltac canceling_step_in_hyp C :=
  lazymatch type of C with
  | canceling_in_hyp ?mAll ?om (cons ?P ?Ps) ?Q =>
      let H := match goal with
               | H: with_mem _ ?P' |- _ =>
                   let __ := match constr:(Set) with _ => syntactic_unify P P' end in H
               end in
      let m := lazymatch type of H with with_mem ?m _ => m end in
      let hs := reify_mem_tree om in
      let p := path_in_mem_tree hs m in
      eapply (canceling_step_in_hyp P Ps Q mAll m p hs _ H) in C;
      [ | reflexivity | reflexivity];
      cbn [interp_mem_tree] in C;
      clear H m
  end.

Ltac merge_step_in_hyp H :=
  lazymatch type of H with
  (* Special case for records: Need to solve sideconditions SC1 and SC2 (using eq_refl).
     Match for proj2 of split_off_field_from_sepapps: *)
  | merge_step (forall l P m,
          sepapps_offset ?n l = ?ofs -> (* <-SC1 *)
          List.nth_error l ?n = Some (mk_sized_predicate (hole ?sz) ?sz) -> (* <-SC2 *)
          sep (sepapps l ?p) (P ?p_plus_ofs) m ->
          sepapps (sepapps_replace l ?n (mk_sized_predicate P ?sz)) ?p m) =>
      lazymatch goal with
      | _: with_mem _ (sepapps ?l p) |- _ =>
          specialize (H l); specialize H with (1 := eq_refl) (2 := eq_refl);
          cbn [sepapps_replace] in H
      end
  | _ => idtac
  end;
  start_canceling_in_hyp H;
  repeat canceling_step_in_hyp H;
  eapply canceling_done_in_hyp in H;
  destruct H as (?m & ?D & ?H).

Lemma f_equal_fun[A B: Type]: forall (f g: A -> B) (x: A), f = g -> f x = g x.
Proof. intros. subst. reflexivity. Qed.

Ltac syntactic_f_equal_step_with_ZnWords :=
  lazymatch goal with
  | |- ?x = ?x => reflexivity
  | |- @eq (@word.rep _ _) _ _ => ZnWords
  | |- @eq Z _ _ => ZnWords
  | |- ?f ?a = ?f ?b => eapply (@f_equal _ _ f a b)
  | |- ?f ?x = ?g ?x => eapply (f_equal_fun f g x)
  end.

Ltac syntactic_f_equal_with_ZnWords := solve [repeat syntactic_f_equal_step_with_ZnWords].

Lemma rew_with_mem{mem: Type}: forall (P1 P2: mem -> Prop) (m: mem),
    P1 = P2 ->
    with_mem m P1 -> with_mem m P2.
Proof. intros. subst. assumption. Qed.

Ltac sepclause_equality_hook := syntactic_f_equal_with_ZnWords.

(* Returns a Prop claiming that start..start+size is a subrange of start'..start'+size'.
   Assumes 0<=size<2^width and 0<=size'<2^width.
   Both ranges may wrap around. *)
Definition subrange{width: Z}{word: word.word width}(start: word)(size: Z)
  (start': word)(size': Z) := word.unsigned (word.sub start start') + size <= size'.

Ltac is_subrange start size start' size' :=
  assert_succeeds (idtac; assert (subrange start size start' size') by
                     (unfold subrange; ZnWords)).

Inductive PredicateSizeNotFound := .

Ltac get_predicate_size_or_pose_err P :=
  let t := constr:(PredicateSize P) in
  match constr:(Set) with
  | _ => lazymatch constr:(_: t) with ?s => s end
  | _ => let __ := match constr:(Set) with
                   | _ => pose_err Error:("typeclasses eauto" "should find" t)
                   end in constr:(PredicateSizeNotFound)
  end.

Ltac gather_is_subrange_claims_into_error start size :=
  fold_hyps_upwards_cont
    (fun res h tp =>
       lazymatch tp with
       | with_mem ?m (?P' ?start') =>
          lazymatch get_predicate_size_or_pose_err P' with
          | PredicateSizeNotFound => fail "can't find PredicateSize for" P'
          | ?size' =>
              constr:(cons (subrange start size start' size') res)
          end
       | _ => res
       end)
    (@nil Prop)
    (fun r => pose_err
                Error:("Exactly one of the following subrange claims should hold:" r)).

Ltac split_step :=
  lazymatch goal with
  | |- canceling (cons (?P ?start) _) ?m _ =>
      let size := lazymatch constr:(_: PredicateSize P) with ?s => s end in
      let g := lazymatch goal with |- ?x => x end in
      change (find_superrange_hyp start size g)
  | |- find_superrange_hyp ?start ?size ?g =>
      match goal with
      | H: with_mem ?mH (?P' ?start') |- _ =>
          lazymatch get_predicate_size_or_pose_err P' with
          | PredicateSizeNotFound => idtac
          | ?size' =>
              is_subrange start size start' size';
              tryif assert_succeeds (idtac;
                assert (size = size') by ZnWords)
              then (
                change g;
                let P := lazymatch goal with | |- canceling (cons ?P _) _ _ => P end in
                eapply (rew_with_mem (P' start') P mH) in H (* <-- leaves 2 open goals *)
              ) else change (split_range_from_hyp start size _ H g)
          end
      | _ => gather_is_subrange_claims_into_error start size
      end
  | |- split_range_from_hyp ?start ?size ?tH ?H ?g => split_range_from_hyp_hook
  | |- @eq (@map.rep (@word.rep _ _) Init.Byte.byte _ -> Prop) _ _ =>
      syntactic_f_equal_with_ZnWords
  end.

Ltac merge_step :=
  lazymatch goal with
  | H: merge_step _ |- _ => merge_step_in_hyp H
  | F: @fold_step ?R _ _ ?pred |- _ =>
      let c := lazymatch open_constr:(ltac:(constructor) : R) with ?c => c end in
      lazymatch goal with
      | H: with_mem ?m (sepapps ?l ?a) |- _ =>
          instantiate_constructor_with_sepapps c l;
          change (with_mem m (pred c a)) in H
      end;
      clear F
  end.


(** **********************************************************

Anders Mörtberg, 2016

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

(** **********************************************************

Contents :

- Definition of the sum of a family of signatures ([Sum_of_Signatures)]

Adapted from the binary case

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

Require Import UniMath.Foundations.PartD.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Local Open Scope cat.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.PointedFunctors.
Require Import UniMath.CategoryTheory.PointedFunctorsComposition.
Require Import UniMath.SubstitutionSystems.Signatures.
Require Import UniMath.CategoryTheory.limits.coproducts.
Require Import UniMath.SubstitutionSystems.Notation.
Local Open Scope subsys.
Require Import UniMath.CategoryTheory.Chains.Chains.
Require Import UniMath.CategoryTheory.Chains.OmegaCocontFunctors.
Require Import UniMath.CategoryTheory.limits.products.

Section sum_of_signatures.

Context (I : UU) (C D D' : category) (CD : Coproducts I D).

Section construction.

Local Notation "'CCD'" := (Coproducts_functor_precat I C D CD : Coproducts I [C, D]).

Variables H1 : I -> functor [C, D'] [C, D].

Variable θ1 : ∏ i, θ_source (H1 i) ⟹ θ_target (H1 i).

(** * Definition of the data of the sum of signatures *)

Local Definition H : functor [C, D'] [C, D] := coproduct_of_functors _ _ _ CCD H1.

Local Definition θ_ob_fun (X : [C, D']) (Z : category_Ptd C) (x : C) :
   D ⟦ coproduct_of_functors_ob _ _ _ CD (λ i, H1 i X) (pr1 Z x),
       coproduct_of_functors_ob _ _ _ CD (λ i, H1 i (functor_composite (pr1 Z) X)) x ⟧.
Proof.
  apply CoproductOfArrows; intro i.
  exact (pr1 (θ1 i (X ⊗ Z)) x).
Defined.

Local Lemma is_nat_trans_θ_ob_fun (X : [C, D']) (Z : category_Ptd C) :
  is_nat_trans (functor_composite_data (pr1 Z)
                 (coproduct_of_functors_data _ _ _  CD (λ i, H1 i X)))
                 (coproduct_of_functors_data _ _ _ CD (λ i, H1 i (functor_composite (pr1 Z) X)))
               (θ_ob_fun X Z).
Proof.
  intros x x' f.
  eapply pathscomp0; [ apply CoproductOfArrows_comp | ].
  eapply pathscomp0; [ | eapply pathsinv0; apply CoproductOfArrows_comp].
  apply maponpaths, funextsec; intro i.
  apply (nat_trans_ax (θ1 i (X ⊗ Z))).
Qed.

Definition θ_ob : ∏ XF, θ_source H XF --> θ_target H XF.
Proof.
  intros [X Z]; exists (θ_ob_fun X Z); apply is_nat_trans_θ_ob_fun.
Defined.

Local Lemma is_nat_trans_θ_ob :
  is_nat_trans (θ_source H) (θ_target H) θ_ob.
Proof.
  intros [X Z] [X' Z'] αβ.
  apply nat_trans_eq_alt; intro c.
  eapply pathscomp0; [ | eapply pathsinv0, CoproductOfArrows_comp].
  eapply pathscomp0; [ apply cancel_postcomposition, CoproductOfArrows_comp |].
  eapply pathscomp0; [ apply CoproductOfArrows_comp |].
  apply maponpaths, funextsec; intro i.
  apply (nat_trans_eq_pointwise (nat_trans_ax (θ1 i) (X,,Z) (X',,Z') αβ) c).
Qed.

Local Definition θ : PrestrengthForSignature H := tpair _ _ is_nat_trans_θ_ob.

(** * Proof of the strength laws of the sum of two signatures *)

Variable S11' : ∏ i, θ_Strength1_int (θ1 i).
Variable S12' : ∏ i, θ_Strength2_int (θ1 i).

Lemma SumStrength1' : θ_Strength1_int θ.
Proof.
  intro X.
  apply nat_trans_eq_alt; intro x; simpl.
  etrans; [apply CoproductOfArrows_comp|].
  apply pathsinv0, Coproduct_endo_is_identity; intro i.
  etrans; [ apply (CoproductOfArrowsIn _ _ (CD (λ i, pr1 (pr1 (H1 i) X) x))) |].
  etrans; [| apply id_left].
  apply cancel_postcomposition, (nat_trans_eq_pointwise (S11' i X) x).
Qed.

Lemma SumStrength2' : θ_Strength2_int θ.
Proof.
  intros X Z Z'.
  apply nat_trans_eq_alt; intro x; simpl; rewrite id_left.
  etrans; [apply CoproductOfArrows_comp|].
  apply pathsinv0.
  etrans; [apply CoproductOfArrows_comp|].
  apply pathsinv0, maponpaths, funextsec; intro i.
  assert (Ha_x := nat_trans_eq_pointwise (S12' i X Z Z') x); simpl in Ha_x.
  rewrite id_left in Ha_x; apply Ha_x.
Qed.

End construction.

Definition Sum_of_Signatures (S : I -> Signature C D D') : Signature C D D'.
Proof.
  use tpair.
  - apply H; intro i.
    apply (S i).
  - exists (θ (λ i, S i) (λ i, theta (S i))).
    split.
    + apply SumStrength1'; intro i; apply (Sig_strength_law1 (S i)).
    + apply SumStrength2'; intro i; apply (Sig_strength_law2 (S i)).
Defined.

Lemma is_omega_cocont_Sum_of_Signatures (S : I -> Signature C D D')
  (h : ∏ i, is_omega_cocont (S i)) : is_omega_cocont (Sum_of_Signatures S).
Proof.
  apply is_omega_cocont_coproduct_of_functors; try assumption.
Defined.

End sum_of_signatures.


Require Export XR_R1.
Require Export XR_Rplus.

Local Open Scope R_scope.

Definition R2 := R1 + R1.


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

From Buchberger Require Export Preducestar LetP.

Set Default Proof Using "Type".

Section Pspoly.
Load hCoefStructure.
Load hOrderStructure.
Load hReducestar.

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

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

Local Hint Resolve spolyf_canonical : core.

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

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

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

Local Hint Resolve spolyf_def : core.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Local Hint Resolve pO_irreducible : core.

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

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

End Pspoly.