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

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

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

#[local] Create HintDb rsimpl.

Section MakeRingPol.

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

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

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

#[local] Hint Rewrite
  ring_opp_zero ring_opp_add
  ring_add_0_l ring_add_0_r
  ring_mul_1_l ring_mul_1_r
  ring_mul_0_l ring_mul_0_r
  ring_distr_l ring_distr_r
  ring_add_assoc ring_mul_assoc
    : rsimpl.

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

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

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

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

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

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

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

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

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

Definition mkX i := mkXi i 1.

(** Opposite of addition *)

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

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

(** Addition et subtraction *)

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

(* Q quelconque *)

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

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

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

End PaddX.

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

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

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

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

(** Multiplication *)

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

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

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

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

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


(** Evaluation of a polynomial towards R *)

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

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

(** Proofs *)

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

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

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

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

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

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

Lemma PaddCl_ok : forall c P l, (PaddCl c P)@l == [c] + P@l .
Proof.
  induction P as [|????? IH2]; simpl; intros.
  - now rewrite ring_morphism_add.
  - now rewrite IH2, !(ring_add_comm [_]), ring_add_assoc.
Qed.

Lemma PmulC_aux_ok : forall c P l, (PmulC_aux P c)@l ==  P@l * [c].
Proof.
  induction P as [|? IH1 ??? IH2]; simpl; intros.
  - now rewrite ring_morphism_mul.
  - rewrite mkPX_ok, IH1, IH2, !phiCR_comm.
    now rewrite_db rsimpl.
Qed.

Lemma PmulC_ok : forall c P l, (PmulC P c)@l ==  P@l * [c].
Proof.
  intros c P l; unfold PmulC.
  assert (Hh:= ring_morphism_eq c 0);case_eq (c =? 0).
  - intros. rewrite Hh.
    + now rewrite Pphi0, ring_morphism0, ring_mul_0_r.
    + now apply Ceqb_eq.
  - assert (H1h:= ring_morphism_eq c 1);case_eq (c =? 1);intros.
    + rewrite H1h.
      * now rewrite ring_morphism1, ring_mul_1_r.
      * now apply Ceqb_eq.
    + apply PmulC_aux_ok.
Qed.

Lemma Popp_ok : forall P l, (--P)@l == - P@l.
Proof.
  induction P as [|? IH1 ??? IH2];simpl;intros.
  - now rewrite ring_morphism_opp.
  - rewrite IH1, IH2.
    now rewrite ring_opp_add, ring_opp_mul_l.
Qed.

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

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

Lemma PaddX_ok2 : forall P2,
   (forall P l, (P2 ++ P) @ l == P2 @ l + P @ l)
   /\
   (forall P k n l,
           (PaddX Padd P2 k n P) @ l == 
             P2 @ l * pow_pos (nth 0 k l) n  + P @ l).
Proof.
  induction P2 as [|? IH1 ??? IH2];simpl;intros.
  - split.
    + intros. apply PaddCl_ok.
    + intros P. induction P as [|? IH'1 ??? IH'2].
      * unfold PaddX. intros. now rewrite mkPX_ok.
      * intros. simpl.
        destruct (Pos.compare_spec k p) as [Hh|Hh|Hh].
        -- destr_pos_sub H1h; subst.
           ++ rewrite mkPX_ok, PaddCl_ok.
              now rewrite_db rsimpl.
           ++ rewrite mkPX_ok, IH'1, Pos.add_comm, pow_pos_add.
              now rewrite_db rsimpl.
           ++ rewrite mkPX_ok, PaddCl_ok, mkPX_ok, Pphi0, Pos.add_comm, pow_pos_add.
              now rewrite_db rsimpl.
        -- rewrite mkPX_ok, IH'2.
           rewrite_db rsimpl. now rewrite (ring_add_comm (_ * _)).
        -- assert (H1h := ring_morphism_eq c 0);case_eq (Ceqb c  0);
             intros; simpl.
           ++ rewrite H1h;trivial.
              ** rewrite ring_morphism0. now rewrite_db rsimpl.
              ** apply Ceqb_eq; trivial.
           ++ reflexivity.
  - decompose [and] IH1. decompose [and] IH2. clear IH1 IH2.
    split.
    + intros. rewrite H0. rewrite H1.
      now rewrite ring_add_assoc.
    + induction P.
      * unfold PaddX. intros. rewrite mkPX_ok. reflexivity.
      * intros. rewrite PaddXPX.
        destruct (Pos.compare_spec k p1) as [H3h|H3h|H3h].
        -- destr_pos_sub H4h; subst.
           ++ rewrite mkPX_ok. simpl. rewrite H0, H1.
              now rewrite_db rsimpl.
           ++ rewrite mkPX_ok, IHP1. simpl.
              rewrite Pos.add_comm, pow_pos_add.
              now rewrite_db rsimpl.
           ++ rewrite mkPX_ok. simpl. rewrite H0, H1. rewrite mkPX_ok, Pphi0.
              rewrite Pos.add_comm, pow_pos_add.
              now rewrite_db rsimpl.
        -- rewrite mkPX_ok. simpl. rewrite IHP2.
           now rewrite ring_add_comm, <- ring_add_assoc, (ring_add_comm (_ @ _)).
        -- now rewrite mkPX_ok.
Qed.

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

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

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

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

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

 (** Definition of polynomial expressions *)

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

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

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

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

 (** evaluation of polynomial expressions towards R *)

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

Strategy expand [PEeval].

Definition mk_X j := mkX j.

(** Correctness proofs *)

Lemma mkX_ok : forall p l, nth 0 p l == (mk_X p) @ l.
Proof.
  intros. simpl. rewrite ring_morphism0, ring_morphism1. now rewrite_db rsimpl.
Qed.

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

(* Power using the chinise algorithm *)

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

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

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

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

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

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

End POWER2.

 (** Normalization and rewriting *)

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

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

Definition norm_subst pe := subst_l (norm_aux pe).

 
Lemma norm_aux_spec : forall l pe, PEeval l pe == (norm_aux pe)@l.
Proof.
  intros.
  induction pe as [ | | | |pe1 IH1 pe2 IH2|pe1 IH1 pe2 IH2|pe1 IH1 pe2 IH2|pe IH|pe IH n]; simpl.
  - now rewrite <- ring_morphism0.
  - now rewrite <- ring_morphism1.
  - reflexivity.
  - rewrite ring_morphism0, ring_morphism1. now rewrite_db rsimpl.
  - rewrite IH1, IH2. unfold Psub.
    destruct pe2; now rewrite Padd_ok.
  - rewrite IH1, IH2. unfold Psub.
    now rewrite Padd_ok, Popp_ok, ring_sub_def.
  - now rewrite IH1, IH2, Pmul_ok.
  - now rewrite IH, Popp_ok.
  - rewrite Ppow_N_ok; [|intros; reflexivity].
    rewrite rpow_pow_N; [|now apply pow_th].
    destruct n; simpl; [now rewrite ring_morphism1|].
    induction p as [p IHp|p IHp|]; simpl; [| |now apply IH].
    + now rewrite IHp, IH, !Pmul_ok.
    + now rewrite Pmul_ok, IHp.
Qed.

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

End NORM_SUBST_REC.

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


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


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

End MakeRingPol.
