Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Basic_Cons.Terminal.
Require Import Ext_Cons.Arrow.
Require Import Coq_Cats.Type_Cat.Card_Restriction.
Require Export NatTrans.NatTrans NatTrans.Operations.
Require Export KanExt.Local KanExt.Global KanExt.GlobalDuality
        KanExt.GlobaltoLocal KanExt.LocaltoGlobal KanExt.LocalFacts.Main.
Require Export Cat.Cat_Terminal.

Local Open Scope functor_scope.

(** Definition of limits and colimits using right and left kan extensions along the functor to
the terminal category. *)
Section Limit.
  Context {J C : Category} (D : J –≻ C).

  Definition Cone := LoKan_Cone (Functor_To_1_Cat J) D.

  Definition Cone_Morph Cn Cn' := @LoKan_Cone_Morph _ _ (Functor_To_1_Cat J) _ D Cn Cn'.

  Definition Limit : Type := Local_Right_KanExt (Functor_To_1_Cat J) D.

  Definition limit_to_cone (l : Limit) : Cone := (LRKE l).

  Coercion limit_to_cone : Limit >-> Cone.

  Definition cone_to_obj (cn : Cone) : C := (cone_apex cn) _o tt.

  Coercion cone_to_obj : Cone >-> Obj.

  Definition is_Limit (Cn : Cone) := is_Cone_Local_Right_KanExt (Functor_To_1_Cat J) D Cn.

  Definition is_Limit_Limit {Cn : Cone} (il : is_Limit Cn) : Limit :=
    is_Cone_Local_Right_KanExt_Local_Right_KanExt (Functor_To_1_Cat J) D il.

  Definition Limit_is_Limit {L : Limit} : is_Limit L :=
    Local_Right_KanExt_is_Cone_Local_Right_KanExt (Functor_To_1_Cat J) D L.

End Limit.

(** Limits are unique up to isomorphism. *)
Program Definition Limit_Iso {J C : Category} {D : J –≻ C} (l l' : Limit D) :
  (l ≃≃ l' ::> C)%isomorphism :=
  {|
    iso_morphism :=
      Trans
        (cone_morph (iso_morphism (Local_Right_KanExt_unique _ _ l l')))
        tt;
    inverse_morphism :=
      Trans
        (cone_morph (inverse_morphism (Local_Right_KanExt_unique _ _ l l')))
        tt
  |}.

Next Obligation.
Proof (
    f_equal
      (fun x : LoKan_Cone_Morph l l => Trans (cone_morph x) tt)
      (left_inverse (Local_Right_KanExt_unique _ _ l l'))
  ).

Next Obligation.
Proof (
    f_equal
      (fun x : LoKan_Cone_Morph l' l' => Trans (cone_morph x) tt)
      (right_inverse (Local_Right_KanExt_unique _ _ l l'))
  ).

(** Proposition stating that category C has all limits of cardinality specified by P *)
Definition Has_Restr_Limits (C : Category) (P : Card_Restriction) :=
  ∀ {J : Category} (D : J –≻ C), P J → P (Arrow J) → Limit D.

(** A complete category has all limits – here it has global right kan extension *)
Definition Complete (C : Category) := ∀ J : Category, Right_KanExt (Functor_To_1_Cat J) C.

Existing Class Complete.

(** If a category is complete, we can produce all limits. *)
Definition Limit_of {C D : Category} {H : Complete D} (F : C –≻ D) : Limit F :=
  Global_to_Local_Right _ _ (H _) F.

(** A category having restricted limitis where the restriction always holds
is just complete. *)
Section Restricted_Limits_to_Complete.
  Context {C : Category} {P : Card_Restriction} (HRL : Has_Restr_Limits C P).

  Definition No_Restriction_Complete : (∀ t, P t) → Complete C :=
    fun All_Ps J => Local_to_Global_Right _ _ (fun D => HRL _ D (All_Ps J) (All_Ps (Arrow J))).

End Restricted_Limits_to_Complete.

(** A complete category has restricted limits for any restriction. *)
Section Complete_to_Restricted_Limits.
  Context (C : Category) {CC : Complete C} (P : Card_Restriction).

  Definition Complete_Has_Restricted_Limits : Has_Restr_Limits C P :=
    fun J D _ _ => Global_to_Local_Right _ _ (CC _) D.

End Complete_to_Restricted_Limits.

(** A functor is continuous if it preserces all limits. *)
Section Continuous.
  Context
    {C D : Category}
    (CC : Complete C)
    (G : (C –≻ D)%functor)
  .

  Section Cone_Conv.
    Context
      {J : Category}
      {F : (J –≻ C)%functor}
      (Cn : Cone F)
    .

    Program Definition Cone_Conv : Cone (G ∘ F)%functor
      :=
        {|
          cone_apex :=
            (G ∘ (cone_apex Cn))%functor;
          cone_edge :=
            (((NatTrans_id G) ∘_h (cone_edge Cn)) ∘ (NatTrans_Functor_assoc _ _ _))%nattrans
        |}
    .

  End Cone_Conv.

  Definition Continuous :=
    ∀ (J : Category) (F : (J –≻ C)%functor),
      is_Cone_Local_Right_KanExt _ _ (Cone_Conv (LRKE (Limit_of F)))
  .

End Continuous.

(** CoLimits *)

Section CoLimit.
  Context {J C : Category} (D : J –≻ C).

  Definition CoCone :=
    LoKan_Cone (Functor_To_1_Cat J^op) (D^op).

  Definition CoCone_Morph Cn Cn' :=
    @LoKan_Cone_Morph _ _ (Functor_To_1_Cat J^op) _ (D^op) Cn Cn'.

  Definition CoLimit := Local_Left_KanExt (Functor_To_1_Cat J) D.

  Definition is_CoLimit (Cn : CoCone) := is_Cone_Local_Right_KanExt (Functor_To_1_Cat (J^op)) (D^op) Cn.

  Definition is_CoLimit_CoLimit {Cn : CoCone} (il : is_CoLimit Cn) : CoLimit :=
    is_Cone_Local_Right_KanExt_Local_Right_KanExt (Functor_To_1_Cat (J^op)) (D^op) il.

  Definition CoLimit_is_CoLimit {L : CoLimit} : is_CoLimit L :=
    Local_Right_KanExt_is_Cone_Local_Right_KanExt (Functor_To_1_Cat (J^op)) (D^op) L.

End CoLimit.

(** Proposition stating that category C has all colimits of cardinality specified by P *)
Definition Has_Restr_CoLimits (C : Category) (P : Card_Restriction) :=
  ∀ {J : Category} (D : J –≻ C), P J → P (Arrow J) → CoLimit D.

(** A cocomplete category has all colimits – here it has global left kan extension *)
Definition CoComplete (C : Category) := ∀ J : Category, Left_KanExt (Functor_To_1_Cat J) C.

Existing Class CoComplete.

(** If a category is cocomplete, we can produce all colimits. *)
Definition CoLimit_of {C D : Category} {H : CoComplete D} (F : C –≻ D) : CoLimit F :=
  Global_to_Local_Left _ _ (H _) F.

(** If a category is complete, its dual is cocomplete *)
Definition Complete_to_CoComplete_Op {C : Category} {CC : Complete C} : CoComplete (C ^op) :=
  fun D => KanExt_Right_to_Left (Functor_To_1_Cat D ^op) C (CC (D ^op)%category).

(** If a category is cocomplete, its dual is complete *)
Definition CoComplete_to_Complete_Op {C : Category} {CC : CoComplete C} : Complete (C ^op) :=
    fun D => KanExt_Left_to_Right (Functor_To_1_Cat D ^op) C (CC (D ^op)%category).

(** A category having restricted colimitis where the restriction always holds
is just cocomplete. *)
Section Restricted_CoLimits_to_CoComplete.
  Context {C : Category} {P : Card_Restriction} (HRL : Has_Restr_CoLimits C P).

  Definition No_Restriction_CoComplete : (∀ t, P t) → CoComplete C :=
    fun All_Ps J =>
      Local_to_Global_Left _ _ (fun D => HRL _ D (All_Ps J) (All_Ps (Arrow J))).

End Restricted_CoLimits_to_CoComplete.

(** A cocomplete category has restricted colimits for any restriction. *)
Section CoComplete_to_Restricted_CoLimits.
  Context (C : Category) {CC : CoComplete C} (P : Card_Restriction).

  Definition CoComplete_Has_Restricted_CoLimits : Has_Restr_CoLimits C P :=
    fun J D _ _ => Global_to_Local_Left _ _ (CC _) D.

End CoComplete_to_Restricted_CoLimits.

(** If a category has restricted limits, its dual has restricted colomits *)
Definition Has_Restr_Limits_to_Has_Restr_CoLimits_Op
        {C : Category} {P : Card_Restriction}
        (HRL : Has_Restr_Limits C P) :
  Has_Restr_CoLimits (C ^op) P :=
  (fun (D : Category)
       (F : D –≻ C ^op)
       (H1 : P D)
       (H2 : P (Arrow D)) =>
     HRL
       (D ^op)%category
       (F ^op)%functor H1
       (Card_Rest_Respect P (Arrow D) (Arrow (D^op)) (Arrow_OP_Iso D) H2)
  ).

(** If a category has restricted colimits, its dual has restricted lomits *)
Definition Has_Restr_CoLimits_to_Has_Restr_Limits_Op
        {C : Category}
        {P : Card_Restriction}
        (HRL : Has_Restr_CoLimits C P) :
  Has_Restr_Limits (C ^op) P :=
  (fun (D : Category)
       (F : D –≻ C ^op)
       (H1 : P D)
       (H2 : P (Arrow D)) =>
     HRL
       (D ^op)%category
       (F ^op)%functor
       H1
       (Card_Rest_Respect P (Arrow D) (Arrow (D^op)) (Arrow_OP_Iso D) H2)
  ).

(** A functor is co-continuous if it preserces all co-limits. *)
Section CoContinuous.
  Context
    {C D : Category}
    (CC : CoComplete C)
    (G : (C –≻ D)%functor)
  .

  Section CoCone_Conv.
    Context
      {J : Category}
      {F : (J –≻ C)%functor}
      (Cn : CoCone F)
    .

    Program Definition CoCone_Conv : CoCone (G ∘ F)%functor
      :=
        {|
          cone_apex :=
            ((G ^op) ∘ (cone_apex Cn))%functor;
          cone_edge := _
            (((NatTrans_id (G ^op)) ∘_h (cone_edge Cn)) ∘ (NatTrans_Functor_assoc _ _ _))%nattrans
        |}
    .

  End CoCone_Conv.

  Definition CoContinuous :=
    ∀ (J : Category) (F : (J –≻ C)%functor),
      is_Cone_Local_Right_KanExt _ _ (CoCone_Conv (LRKE (CoLimit_of F)))
  .

End CoContinuous.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Arith Omega List Permutation.

Require Import utils ill_form ill_rules phase_sem rules_algebra.

Set Implicit Arguments.

Section Okada.

(*  Hint Resolve ill_cf_perm_bang_t. *)

  Variables (sc : bool) (* commutativity switch *).

  Notation comp := (comp_ctx sc).

  Notation sg := (@eq _).
  Infix "∘" := (Composes comp) (at level 50, no associativity).
  Infix "⊸" := (Magicwand_l comp) (at level 51, right associativity).
  Infix "⟜" := (Magicwand_r comp) (at level 52, left associativity).

  Let cl := cl_ctx sc false.

  Let cl_increase X : X ⊆ cl X.
  Proof. apply cl_ctx_increase. Qed.

  Let cl_mono X Y : X ⊆ Y -> cl X ⊆ cl Y.
  Proof. apply cl_ctx_mono. Qed.

  Let cl_idem X : cl (cl X) ⊆  cl X.
  Proof. apply cl_ctx_idem. Qed.

  Let cl_stable_l : forall X Y, cl X ∘ Y ⊆ cl (X ∘ Y).
  Proof. apply cl_ctx_stable_l; eauto. Qed.

  Let cl_stable_r : forall X Y, X ∘ cl Y ⊆ cl (X ∘ Y).
  Proof. apply cl_ctx_stable_r; eauto. Qed.

  Notation "↓" := (fun A Γ => ill_proof sc false Γ A).
  Notation K := (fun Δ => { Γ | Δ = ‼Γ }).

  Let dc_closed A : cl (↓A) ⊆ ↓A.
  Proof. apply dc_closed. Qed.

  Let v x := ↓ (£x).

  Let Hv x : cl (v x) ⊆ v x.
  Proof. apply dc_closed. Qed.

  Notation "'⟦' A '⟧'" := (Form_sem cl comp ∅ K v A) (at level 49).

  Let cl_sem_closed A : cl (⟦A⟧) ⊆ ⟦A⟧.
  Proof. apply closed_Form_sem; eauto. Qed.

  Section Okada.

    (** This is Okada's lemma which states that the interpretation ⟦A⟧
        of A is nearly identical to ↓A,

               A::nil ∈ ⟦A⟧ ⊆ ↓A.

        a result which is similar to what happens in the Lidenbaum construction.
        Indeed, in Lidenbaum construction, one proves

                 ⟦A⟧ ≃ ↓A

        but that result needs the cut-rule.

        The MAJOR difference is that Okada's proof does not require
        the use of cut. It is done by induction on A.

         But first, let us give the algebraic interpretation
         of the rules of the cut-free ILL sequent calculus *)

    Let rule_ax A : ↓A (A::∅).
    Proof. apply in_llp_ax. Qed.

    Let rule_limp_l A B : (↓A ⊸ cl (sg (B::∅))) (A -o B::∅).
    Proof.
      apply rule_limp_l_eq; eauto.
      intros ? ? ? ?; apply in_llp_limp_l.
    Qed.

    Let rule_limp_r A B : sg (A::∅) ⊸ ↓B ⊆ ↓(A -o B).
    Proof.
      apply rule_limp_r_eq; eauto.
      intros ?; apply in_llp_limp_r.
    Qed.

    Let rule_rimp_l A B : (cl (sg (B::∅)) ⟜ ↓A) (B o- A::∅).
    Proof.
      apply rule_rimp_l_eq; eauto.
      intros ? ? ? ?; apply in_llp_rimp_l.
    Qed.

    Let rule_rimp_r A B : ↓B ⟜ sg (A::∅) ⊆ ↓(B o- A).
    Proof.
      apply rule_rimp_r_eq; eauto.
      intros ?; apply in_llp_rimp_r.
    Qed.

    Let rule_times_l A B : cl (sg (A::B::nil)) (A⊗B::nil).
    Proof.
      apply rule_times_l_eq.
      intros ? ? ?; apply in_llp_times_l.
    Qed.

    Let rule_times_r A B : ↓A ∘ ↓B ⊆ ↓(A⊗B).
    Proof.
      apply rule_times_r_eq; eauto.
      intros ? ?; apply in_llp_times_r.
    Qed.

    Let rule_with_l1 A B : cl (sg (A::∅)) (A&B::∅).
    Proof.
      apply rule_with_l1_eq.
      intros ? ? ?; apply in_llp_with_l1.
    Qed.

    Let rule_with_l2 A B : cl (sg (B::∅)) (A&B::∅).
    Proof.
      apply rule_with_l2_eq.
      intros ? ? ?; apply in_llp_with_l2.
    Qed.

    Let rule_with_r A B : ↓A ∩ ↓B ⊆ ↓(A & B).
    Proof.
      apply rule_with_r_eq.
      intros ?; apply in_llp_with_r.
    Qed.

    Let rule_plus_l A B : cl (sg (A::∅) ∪ sg (B::∅)) (A⊕B::∅).
    Proof.
      apply rule_plus_l_eq.
      intros ? ?; apply in_llp_plus_l.
    Qed.

    Let rule_plus_r1 A B : ↓A ⊆ ↓(A⊕B).
    Proof.
      apply rule_plus_r1_eq.
      intro; apply in_llp_plus_r1.
    Qed.

    Let rule_plus_r2 A B : ↓B ⊆ ↓(A⊕B).
    Proof.
      apply rule_plus_r2_eq.
      intro; apply in_llp_plus_r2.
    Qed.

    Let rule_bang_l A : cl (sg (A::∅)) (!A::∅).
    Proof.
      apply rule_bang_l_eq.
      intros ? ?; apply in_llp_bang_l.
    Qed.

    Let rule_bang_r A : K ∩ ↓A ⊆ ↓(!A).
    Proof.
      apply rule_bang_r_eq.
      intros ?; apply in_llp_bang_r.
    Qed.

    Let rule_unit_l : cl (sg ∅) (𝝐::nil).
    Proof.
      apply rule_unit_l_eq.
      intros ?; apply in_llp_unit_l.
    Qed.

    Let rule_unit_r : sg ∅ ⊆ ↓𝝐.
    Proof.
      apply rule_unit_r_eq.
      apply in_llp_unit_r.
    Qed.

    Let rule_bot_l : cl (fun _ => False) (⟘::∅).
    Proof.
      apply rule_bot_l_eq, in_llp_bot_l.
    Qed.

    Let rule_top_r : (fun _ => True) ⊆ ↓⟙ .
    Proof.
      apply rule_top_r_eq, in_llp_top_r.
    Qed.

    Let mwl_mono (X Y X' Y' : _ -> Type) : X ⊆ X' -> Y ⊆ Y' -> X' ⊸ Y ⊆ X ⊸ Y'.
    Proof. apply magicwand_l_monotone; auto. Qed.

    Let mwr_mono (X Y X' Y' : _ -> Type) : X ⊆ X' -> Y ⊆ Y' -> Y ⟜ X' ⊆ Y' ⟜ X.
    Proof. apply magicwand_r_monotone; auto. Qed.

    Let inc1_prop (K : Type) (X Y : K -> Type)  x : Y ⊆ X -> Y x -> X x.
    Proof. simpl; auto. Qed.

    Let cl_under_closed X Y : cl Y ⊆ Y -> X ⊆ Y -> cl X ⊆ Y.
    Proof. apply cl_closed; eauto. Qed.

    Lemma Okada_formula A : ((sg (A::nil) ⊆ ⟦A⟧) * (⟦A⟧ ⊆ ↓A))%type.
    Proof.
      induction A as [ | [] | A [H1 H2] | [] A [H1 H2] B [H3 H4] ]; auto.
      + split; simpl; auto.
        intros _ []; apply rule_ax.
      + split.
        * intros _ []; apply rule_unit_l.
        * simpl; apply cl_under_closed; auto; apply rule_unit_r.
      + split.
        * intros _ []; apply rule_bot_l.
        * simpl; apply cl_under_closed; auto; intros _ [].
      + split; simpl; red; auto.
      + split.
        * intros _ [].
          simpl.
          intros Th De B H.
          apply H with (ϴ := !A::nil); split.
          - exists (A::nil); auto.
          - apply inc1_prop with (2 := @rule_bang_l _).
            apply cl_under_closed; auto.
        * simpl; apply cl_under_closed; auto.
          intros x []; apply rule_bang_r; split; auto.
      + split.
        * intros _ [].
          simpl; split.
          - apply cl_under_closed with (2 := H1); auto.
          - apply cl_under_closed with (2 := H3); auto.
        * intros Ga (? & ?); apply rule_with_r; auto.
      + split.
        * intros _ []; simpl.
          apply inc1_prop with (2 := @rule_limp_l _ _).
          apply mwl_mono; auto; apply cl_under_closed; auto.
        * simpl; intros x Hx; apply rule_limp_r.
          revert Hx; apply mwl_mono; auto.
      + split.
        * intros _ []; simpl.
          apply inc1_prop with (2 := @rule_rimp_l _ _).
          apply mwr_mono; auto; apply cl_under_closed; auto.
        * simpl; intros x Hx; apply rule_rimp_r.
          revert Hx; apply mwr_mono; auto.
      + split.
        * intros _ [].
          apply inc1_prop with (2 := @rule_times_l _ _).
          simpl; apply cl_mono.
          intros _ []; constructor 1 with (A::∅) (B::∅); auto.
          red; simpl; auto.
        * simpl; apply cl_under_closed; auto.
          intros x Hx; apply rule_times_r.
          revert Hx; apply composes_monotone; eauto.
      + split.
        * intros _ [].
          apply inc1_prop with (2 := @rule_plus_l _ _).
          simpl; apply cl_mono; eauto.
          intros _ [ [] | [] ]; auto.
        * simpl; apply cl_under_closed; auto.
          intros x [ Hx | Hx ]; auto.
          - apply rule_plus_r1; auto.
          - apply rule_plus_r2; auto.
    Qed.

  End Okada.

  Notation "'⟬߭' Γ '⟭'" := (list_Form_sem cl comp ∅ K v Γ) (at level 49).

  (* We lift the result to contexts, ie list of formulas *)

  Lemma Okada_ctx Γ: ⟬߭Γ⟭  Γ.
  Proof.
    induction Γ as [ | A ga Hga ]; simpl;
      apply cl_increase; auto.
    constructor 1 with (A :: nil) ga; auto.
    + apply Okada_formula; auto.
    + red; auto.
  Qed.

End Okada.

(** The notation Γ ⊢ A [comm,cut] is for the type of proofs of the sequent Γ ⊢ A
    * in commutative ILL if comm=true; ILLNC if comm=false
    * with cut if cut=true; cut-free if cut=false
*)

Section NC_cut_admissibility.

  Theorem ill_nc_cut_elimination Γ A : Γ ⊢ A [false,true] -> Γ ⊢ A [false,false].
  Proof.
     intros H.
     apply rules_nc_sound with (s1 := false) (s2 := false) (v := fun x ga => ill_proof false false ga (£x)) in H.
     + apply Okada_formula, H, Okada_ctx.
     + intros x Ga H1; red in H1.
       replace Ga with (nil++Ga++nil); [ apply H1 | ]; intros; rewrite <- app_nil_end; auto.
  Qed.

End NC_cut_admissibility.

Section COMM_cut_admissibility.

  Theorem ill_comm_cut_elimination Γ A : Γ ⊢ A [true,true] -> Γ ⊢ A [true,false].
  Proof.
     intros H.
     apply rules_comm_sound with (s1 := true) (s2 := false) (v := fun x ga => ill_proof true false ga (£x)) in H; auto.
     + apply Okada_formula, H, Okada_ctx.
     + intros x Ga H1; red in H1.
       replace Ga with (nil++Ga++nil); [ apply H1 | ]; intros; rewrite <- app_nil_end; auto.
  Qed.

End COMM_cut_admissibility.

Check ill_nc_cut_elimination.
Print Assumptions ill_nc_cut_elimination.

Check ill_comm_cut_elimination.
Print Assumptions ill_comm_cut_elimination.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2018   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.Abs.
Require int.EuclideanDivision.
Require int.ComputerDivision.
Require number.Parity.
Require number.Divisibility.
Require number.Gcd.
Require number.Prime.

(* Why3 assumption *)
Definition coprime (a:Z) (b:Z): Prop := ((number.Gcd.gcd a b) = 1%Z).

Lemma coprime_is_Zrel_prime :
  forall a b, coprime a b <-> Znumtheory.rel_prime a b.
intros.
unfold coprime.
unfold Znumtheory.rel_prime.
split; intro h.
rewrite <- h; apply Znumtheory.Zgcd_is_gcd.
apply Znumtheory.Zis_gcd_gcd; auto with zarith.
Qed.

(* Why3 goal *)
Lemma prime_coprime :
forall (p:Z),
 (number.Prime.prime p) <->
 ((2%Z <= p)%Z /\ forall (n:Z), ((1%Z <= n)%Z /\ (n < p)%Z) -> (coprime n p)).
intros p.
(*
Znumtheory.prime_intro:
  forall p : int,
  (1 < p)%Z ->
  (forall n : int, (1 <= n < p)%Z -> Znumtheory.rel_prime n p) ->
  Znumtheory.prime p
*)
rewrite Prime.prime_is_Zprime.
split.
intro h; inversion h; clear h.
split; auto with zarith.
intros n h.
rewrite coprime_is_Zrel_prime.
apply H0; auto.
intros (h1,h2).
constructor; auto with zarith.
intros n h.
rewrite <- coprime_is_Zrel_prime.
apply h2; auto.
Qed.

(* Why3 goal *)
Lemma Gauss :
forall (a:Z) (b:Z) (c:Z),
 ((number.Divisibility.divides a (b * c)%Z) /\ (coprime a b)) ->
 (number.Divisibility.divides a c).
intros a b c (h1,h2).
apply Znumtheory.Gauss with b; auto.
rewrite <- coprime_is_Zrel_prime; auto.
Qed.

(* Why3 goal *)
Lemma Euclid :
forall (p:Z) (a:Z) (b:Z),
 ((number.Prime.prime p) /\ (number.Divisibility.divides p (a * b)%Z)) ->
 ((number.Divisibility.divides p a) \/ (number.Divisibility.divides p b)).
intros p a b (h1,h2).
apply Znumtheory.prime_mult; auto.
now rewrite <- Prime.prime_is_Zprime.
Qed.

(* Why3 goal *)
Lemma gcd_coprime :
forall (a:Z) (b:Z) (c:Z),
 (coprime a b) -> ((number.Gcd.gcd a (b * c)%Z) = (number.Gcd.gcd a c)).
intros a b c h1.
apply Z.gcd_unique.
- apply Z.gcd_nonneg.
- apply Gcd.gcd_def1.
- apply Divisibility.divides_multl.
  apply Gcd.gcd_def2.
- intros q h2 h3.
  apply Gcd.gcd_def3.
  trivial.
  apply Gauss with b; split; auto.
  rewrite coprime_is_Zrel_prime.
  rewrite coprime_is_Zrel_prime in h1.
  now apply Znumtheory.rel_prime_div with (2:=h2).
Qed.


Module tmp.
Inductive day : Type :=
| monday : day
| tuesday : day
| wednesday : day
| thursday : day
| friday : day
| saturday : day
| sunday : day.

Definition next_weekday (d:day) : day :=
  match d with
    | monday => tuesday
    | tuesday => wednesday
    | wednesday => thursday
    | thursday => friday
    | friday => monday
    | saturday => monday
    | sunday => monday
  end.

Eval simpl in (next_weekday friday).
Eval simpl in (next_weekday (next_weekday saturday)).

Example text_next_weekday:
  (next_weekday (next_weekday saturday)) = tuesday.

Proof. simpl. reflexivity. Qed.

Inductive bool: Type :=
| true : bool
| false : bool.

Definition negb (b:bool) : bool :=
  match b with
    | true => false
    | false => true
  end.

Definition andb (b1: bool) (b2: bool) : bool :=
  match b1 with
    | true => b2
    | false => false
  end.

Definition orb (b1: bool) (b2: bool) : bool :=
  match b1 with
    | true => true
    | false => b2
  end.

Example test_orb1: (orb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb2: (orb false false) = false.
Proof. simpl. reflexivity. Qed.
Example test_orb3: (orb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb4: (orb true true) = true.
Proof. simpl. reflexivity. Qed.

Definition admit {T: Type} : T. Admitted.

Definition nandb (b1: bool) (b2: bool) : bool :=
  match b1 with
    | true => negb b2
    | false => true
  end.

Example test_nandb1: (nandb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb2: (nandb false false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb3: (nandb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb4: (nandb true true) = false.
Proof. simpl. reflexivity. Qed.

Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool :=
  match b1 with
    | true => andb b2 b3
    | false => false
  end.

Example test_andb31: (andb3 true true true) = true.
Proof. simpl. reflexivity. Qed.
Example test_andb32: (andb3 false true true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb33: (andb3 true false true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb34: (andb3 true true false) = false.
Proof. simpl. reflexivity. Qed.

Check (negb true).
Check negb.

Module Playground1.

  Inductive nat : Type :=
| O : nat
| S : nat -> nat.

  Definition pred (n: nat) : nat :=
    match n with
      | O => O
      | S n' => n'
    end.

End Playground1.

Definition minustwo (n: nat) : nat :=
  match n with
    | O => O
    | S O => O
    | S (S n') => n'
  end.

Check (S (S (S (S 0)))).

Eval simpl in (minustwo 4).

Check S.
Check pred.
Check minustwo.

Fixpoint evenb (n:nat) : bool :=
  match n with
    | O => true
    | S O => false
    | S (S n') => evenb n'
  end.

Definition oddb (n:nat) : bool := negb (evenb n).

Example test_oddb1: (oddb (S O)) = true.
Proof. simpl. reflexivity. Qed.
Example test_oddb2: (oddb (S (S (S (S O))))) = false.
Proof. simpl. reflexivity. Qed.

Module Playground2.

  Fixpoint plus (n : nat) (m : nat) : nat :=
    match n with
      | O => m
      | S n' => S (plus n' m)
    end.

  Eval simpl in (plus (S (S (S 0)))) (S (S 0)).

  Fixpoint mult (n m : nat) : nat :=
    match n with
      | O => O
      | S n' => plus m (mult n' m)
    end.

  Fixpoint minus (n m: nat) : nat :=
    match n, m with
      | O, _ => O
      | S _, O => n
      | S n', S m' => minus n' m'
    end.
End Playground2.

Fixpoint exp (base power : nat) : nat :=
  match power with
    | O => S O
    | S p => mult base (exp base p)
  end.

Example test_mult1: (mult 3 3) = 9.
Proof. simpl. reflexivity. Qed.

Fixpoint factorial (n:nat) : nat :=
  match n with
    | O => 1
    | S n' => mult n (factorial n')
  end.

Example test_factorial1: (factorial 3) = 6.
Proof. simpl. reflexivity. Qed.

Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. simpl. reflexivity. Qed.

Notation "x + y" := (plus x y) (at level 50, left associativity) : nat_scope.
Notation "x - y" := (minus x y) (at level 50, left associativity) : nat_scope.
Notation "x * y" := (mult x y) (at level 40, left associativity) : nat_scope.

Check ((0 + 1) + 1).

Fixpoint beq_nat (n m : nat) : bool :=
  match n with
    | O => match m with
             | O => true
             | S m' => false
           end
    | S n' => match m with
                | O => false
                | S m' => beq_nat n' m'
              end
  end.

Fixpoint ble_nat (n m : nat) : bool :=
  match n with
    | O => true
    | S n' => match m with
                | O => false
                | S m' => ble_nat n' m'
              end
  end.

Example test_ble_nat1: (ble_nat 2 2) = true.
Proof. simpl. reflexivity. Qed.
Example test_ble_nat2: (ble_nat 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_ble_nat3: (ble_nat 4 2) = false.
Proof. simpl. reflexivity. Qed.

Fixpoint blt_nat (n m : nat) : bool :=
  match n, m with
    | O, O => false
    | O, S _ => true
    | S _, O => false
    | S n', S m' => blt_nat n' m'
  end.

Example test_blt_nat1: (blt_nat 2 2) = false.
Proof. simpl. reflexivity. Qed.
Example test_blt_nat2: (blt_nat 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_blt_nat3: (blt_nat 4 2) = false.
Proof. simpl. reflexivity. Qed.

Theorem plus_0_n : forall n: nat, 0 + n = n.
Proof. simpl. reflexivity. Qed.

Theorem plus_0_n' : forall n: nat, 0 + n = n.
Proof. reflexivity. Qed.

Eval simpl in (forall n: nat, n + 0 = n).
Eval simpl in (forall n: nat, 0 + n = n).

Theorem plus_0_n'' : forall n: nat, 0 + n = n.
Proof. intros n. reflexivity. Qed.

Theorem plus_1_l : forall n: nat, 1 + n = S n.
Proof. intros. reflexivity. Qed.

Theorem mult_0_l : forall n:nat, 0 * n = 0.
Proof. intros. reflexivity. Qed.

Theorem plus_id_example : forall n m : nat,
                            n = m -> n + n = m + m.
Proof. intros n m. intros H. rewrite -> H. reflexivity. Qed.

Theorem plus_id_exercise : forall n m o : nat,
  n = m -> m = o -> n + m = m + o.
Proof.
  intros n m o.
  intros H.
  intros I.
  rewrite -> H.
  rewrite -> I.
  reflexivity.
Qed.

Theorem mult_0_plus : forall n m : nat,
                        (0 + n) * m  = n * m.
Proof.
  intros n m.
  rewrite -> plus_0_n.
  reflexivity.
Qed.

Theorem mult_1_plus : forall n m : nat,
                        (1 + n) * m = m + (n * m).
Proof.
  intros n m.
  rewrite -> plus_1_l.
  reflexivity.
Qed.

Theorem plus_1_neq_0 : forall n : nat,
                         beq_nat(n + 1) 0 = false.
Proof.
  intros n. destruct n as [| n'].
  reflexivity.
  reflexivity.
Qed.

Theorem negb_involtive : forall b : bool,
                           negb (negb b) = b.
Proof.
  intros b. destruct b.
  reflexivity.
  reflexivity.
Qed.

Theorem zero_nbeq_plus_1 : forall n : nat,
                             beq_nat 0 (n + 1) = false.
Proof.
  intros n.
  destruct n.
  reflexivity.
  reflexivity.
Qed.

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
    | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
    clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
      set (x := name); move_to_top x
    | assert_eq x name; move_to_top x
    | fail 1 "because we are working on a different case"
    ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

Theorem andb_true_elim1 : forall b c : bool,
                            andb b c = true -> b = true.
Proof.
  intros b c H.
  destruct b.
  Case "b = true".
  reflexivity.
  Case "b = false".
  rewrite <- H.
  reflexivity.
Qed.

Theorem andb_true_elim2 : forall b c : bool,
                            andb b c = true -> c = true.
Proof.
  intros b c H.
  destruct c.
  rewrite <- H.
  reflexivity.
  rewrite <- H.
  destruct b.
  reflexivity.
  reflexivity.
Qed.

Theorem plus_0_r : forall n:nat, n + 0 = n.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0". reflexivity.
  Case "n = S n'". simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem minus_diag : forall n,
                       minus n n = 0.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0". simpl. reflexivity.
  Case "n = S n'". simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem mult_0_r : forall n:nat,
                     n * 0 = 0.
Proof.
  intros n.
  induction n as [| n'].
  + simpl.
    reflexivity.
  + simpl.
    rewrite -> IHn'.
    reflexivity.
Qed.

Theorem plus_n_Sm : forall n m : nat,
                      S (n + m) = n + (S m).
Proof.
  intros n m.
  induction n as [| n'].
  + simpl.
    reflexivity.
  + simpl.
    rewrite -> IHn'.
    reflexivity.
Qed.

Lemma succ : forall n m : nat,
               S(n + m) = n + S(m).
Proof.
  intros n m.
  induction n.
  + reflexivity.
  + simpl.
    rewrite IHn.
    reflexivity.
Qed.

Theorem plus_comm : forall n m : nat,
                      n + m = m + n.
Proof.
  intros n m.
  induction n as [| n'].
  + simpl.
    rewrite plus_0_r.
    reflexivity.
  + simpl.
    rewrite IHn'.
    destruct m.
    reflexivity.
    induction m as [| m'].
    * reflexivity.
    * simpl.
      rewrite succ.
      reflexivity.
Qed.

Fixpoint double (n: nat) :=
  match n with
    | O => O
    | S n' => S (S (double n'))
  end.

Lemma double_plus : forall n, double n = n + n.
Proof.
  intros n.
  induction n as [| n'].
  + reflexivity.
  + simpl.
    rewrite <- succ.
    rewrite <- IHn'.
    reflexivity.
Qed.

Theorem beq_nat_refl : forall n : nat,
                         true = beq_nat n n.
Proof.
  intros n.
  induction n as [| n'].
  + reflexivity.
  + simpl.
    rewrite IHn'.
    reflexivity.
Qed.

Theorem mult_0_plus' : forall n m : nat,
                         (0 + n) * m = n * m.
Proof.
  intros n m.
  assert (H: 0 + n = n).
  + reflexivity.
  + rewrite -> H.
    reflexivity.
Qed.

Theorem plus_assoc : forall n m p : nat,
                       n + (m + p) = (n + m) + p.
Proof.
  intros n m p.
  induction n as [|n'].
  + simpl.
    reflexivity.
  + simpl.
    rewrite IHn'.
    reflexivity.
Qed.

Theorem plus_swap : forall n m p : nat,
                      n + (m + p) = m + (n + p).
Proof.
  intros n m p.
  assert(H: (n + m) + p = n + (m + p)).
  + rewrite <-plus_assoc.
    reflexivity.
  + assert(I: (m + n) + p = m + (n + p)).
      rewrite <- plus_assoc.
      reflexivity.
  rewrite <- H.
  rewrite <- I.
  assert(J: n + m = m + n).
  rewrite <- plus_comm.
  reflexivity.
  rewrite J.
  reflexivity.
Qed.

Theorem ble_nat_refl : forall n: nat,
                         true = ble_nat n n.
Proof.
  intros n.
  induction n as [|n'].
  + simpl. reflexivity.
  + simpl. rewrite IHn'.
    reflexivity.
Qed.

Theorem zero_nbeq_S : forall n:nat,
                        beq_nat 0 (S n) = false.
Proof.
  intros n.
  simpl.
  reflexivity.
Qed.

Theorem andb_false_r : forall b : bool,
                         andb b false = false.
Proof.
  intros b.
  destruct b.
  + reflexivity.
  + reflexivity.
Qed.

Theorem plus_ble_compat_l : forall n m p : nat,
                              ble_nat n m = true -> ble_nat (p + n) (p + m) = true.
Proof.
  intros n m p.
  intros H.
  induction p as [| p'].
  + simpl. rewrite H. reflexivity.
  + simpl. rewrite IHp'. reflexivity.
Qed.

Theorem S_nbeq_0 : forall n: nat,
                     beq_nat (S n) 0 = false.
Proof.
  intros n.
  simpl.
  reflexivity.
Qed.

Theorem mult_1_l : forall n:nat, 1*n = n.
Proof.
  intros n.
  simpl.
  rewrite plus_0_r.
  reflexivity.
Qed.

Theorem all3_spec : forall b c : bool,
                      orb (andb b c)
                          (orb (negb b)
                               (negb c)) = true.
Proof.
  intros b c.
  destruct b.
  + simpl.
    destruct c.
    simpl.
    reflexivity.
    simpl.
    reflexivity.
  + simpl.
    reflexivity.
Qed.

Inductive bin: Type :=
| O  : bin
| B  : bin -> bin
| Bp : bin -> bin.

Fixpoint binc (b : bin) :bin :=
  match b with
    | O     => Bp O
    | B b'  => Bp b'
    | Bp b' => B (binc b')
  end.

Fixpoint bin_to_nat (b: bin) :nat :=
  match b with
    | O     => 0
    | B O   => 0
    | B b'  => 2 * (bin_to_nat b')
    | Bp b' => 2 * (bin_to_nat b') + 1
  end.

Fixpoint nat_to_bin (n : nat) : bin :=
  match n with
    | 0 => O
    | S (n') => binc (nat_to_bin n')
  end.

Fixpoint normalize (b: bin) : bin :=
  match bin_to_nat b with
    | 0    => O
    | S n  => binc (nat_to_bin n)
  end.

End tmp.


Require Export Logic.

Print beautiful.
Check b_sum.

Theorem eight_is_beautiful: beautiful 8.
Proof.
    apply b_sum with (n := 3) (m := 5).
    apply b_3.
    apply b_5. Qed.

Print eight_is_beautiful.
Check (b_sum 3 5 b_3 b_5).

Theorem eight_is_beautiful': beautiful 8.
Proof.
    apply (b_sum 3 5 b_3 b_5).
Qed.

Theorem eight_is_beautiful'': beautiful 8.
Proof.
    Show Proof.
    apply b_sum with (n:=3) (m:=5).
    Show Proof.
    apply b_3.
    Show Proof.
    apply b_5.
    Show Proof.
Qed.

Definition eight_is_beautiful''' : beautiful 8 :=
    b_sum 3 5 b_3 b_5.

Print eight_is_beautiful.
Print eight_is_beautiful'.
Print eight_is_beautiful''.
Print eight_is_beautiful'''.

Theorem six_is_beautiful : beautiful 6.
Proof.
    apply b_sum with (n:=3) (m:=3).
    apply b_3.
    apply b_3.
Qed.

Definition six_is_beautiful' : beautiful 6 :=
    b_sum 3 3 b_3 b_3.

Theorem nine_is_beautiful :
    beautiful 9.
Proof.
    apply b_sum with (n:=3) (m:=6).
    apply b_3.
    apply six_is_beautiful.
Qed.

Definition nine_is_beautiful' : beautiful 9 :=
    b_sum 3 6 b_3 six_is_beautiful'.

Theorem b_plus3: forall n, beautiful n -> beautiful (3+n).
Proof.
    intros n H.
    apply b_sum.
    apply b_3.
    apply H.
Qed.

Definition b_plus3' : forall n, beautiful n -> beautiful (3+n) :=
    fun (n : nat) => fun (H : beautiful n) =>
        b_sum 3 n b_3 H.

Check b_plus3'.

Definition b_plus3'' (n : nat) (H : beautiful n) : beautiful (3+n) :=
    b_sum 3 n b_3 H.

Check b_plus3''.

Definition beautiful_plus3 : Prop :=
    forall n, forall(E : beautiful n), beautiful (n+3).

Definition beautiful_plus3' : Prop :=
    forall n, forall(_ : beautiful n), beautiful (n+3).

Definition beatufiul_plus3'' : Prop :=
    forall n, beautiful n -> beautiful (n+3).

(* "P -> Q" is a syntatic sugar for "forall (_:P), Q" *)

Theorem b_times2: forall n, beautiful n -> beautiful (2*n).
Proof.
    intros.
    simpl.
    apply b_sum.
        Case "n".
            apply H.
        Case "n + 0".
            apply b_sum.
            SCase "n". apply H.

            SCase "0". apply b_0.
Qed.

Definition b_times2': forall n, beautiful n -> beautiful (2*n) :=
    fun (n : nat) => fun (H : beautiful n) =>
        b_sum n (n+0) H (b_sum n 0 H b_0).

Definition gorgeous_plus13_po : forall n, gorgeous n -> gorgeous (13+n) :=
    fun (n : nat) => fun (H : gorgeous n) =>
        g_plus5 (8+n) (g_plus5 (3+n) (g_plus3 n H)).

Theorem and_example :
    (beautiful 0) /\ (beautiful 3).
Proof.
    apply conj.
        apply b_0.
        apply b_3.
Qed.

Print and_example.

Theorem and_commut : forall P Q : Prop,
    P /\ Q -> Q /\ P.
Proof.
    intros P Q H.
    inversion H as [HP HQ].
    split.
        Case "left". apply HQ.
        Case "right". apply HP.
Qed.

Print and_commut.

Check plus_comm.

Lemma plus_comm_r : forall a b c, c + (b + a) = c + (a + b).
Proof.
    intros a b c.
    (* rewrite plus_comm *)
        (* rewrites in the first possible spot; not what we want *)
    rewrite (plus_comm b a). (* directs rewriting to the right spot *)
    reflexivity.
Qed.

(* In this case giving just one argument would be sufficient *)
Lemma plus_comm_r' : forall a b c, c + (b + a) = c + (a + b).
Proof.
    intros a b c.
    rewrite (plus_comm b).
    reflexivity.
Qed.

(* Arguments must be given in order, but wildcards (_) may be used to
    * skip arguments that Coq can infer *)
Lemma plus_comm_r'' : forall a b c, c + (b + a) = c + (a + b).
Proof.
    intros a b c.
    rewrite (plus_comm _ a).
    reflexivity.
Qed.

Lemma plus_comm_r''' : forall a b c, c + (b + a) = c + (a + b).
Proof.
    intros a b c.
    rewrite plus_comm with (n := b).
    reflexivity.
Qed.


(* sem1.v *)

(**** Expressions ****)

(* Integer expressions with variables *)

Require Export ZArith.
Open Scope Z.

Inductive value : Set :=
| Val : Z -> value
| Err : value.

Definition context := nat -> (option Z).

Inductive expr : Set :=
| Cte : Z -> expr
| Var : nat -> expr
| Plus : expr -> expr -> expr
| Moins : expr -> expr -> expr
| Mult : expr -> expr -> expr
| Div : expr -> expr -> expr.

Inductive eval (env : context) : expr -> value -> Prop :=
| ECte : forall c : Z , eval env (Cte c) (Val c)
| EVar : forall (i : nat) (v : Z), (env i) = Some v -> eval env (Var i) (Val v)
| EVar_Err : forall (i : nat), (env i) = None -> eval env (Var i) Err
| EPlus : forall (e1 e2 : expr) (v1 v2 v : Z),
  eval env e1 (Val v1) -> eval env e2 (Val v2) -> v = v1 + v2 ->
  eval env (Plus e1 e2) (Val v)
| EPlus_Err1 : forall (e1 e2 : expr),
  eval env e1 Err -> eval env (Plus e1 e2) Err
| EPlus_Err2 : forall (e1 e2 : expr) (v1 : Z),
  eval env e1 (Val v1) -> eval env e2 Err -> eval env (Plus e1 e2) Err
| EMoins : forall (e1 e2 : expr) (v1 v2 v : Z),
  eval env e1 (Val v1) -> eval env e2 (Val v2) -> v = v1 - v2 ->
  eval env (Moins e1 e2) (Val v)
| EMoins_Err1 : forall (e1 e2 : expr),
  eval env e1 Err -> eval env (Moins e1 e2) Err
| EMoins_Err2 : forall (e1 e2 : expr) (v1 : Z),
  eval env e1 (Val v1) -> eval env e2 Err -> eval env (Moins e1 e2) Err
| EMult : forall (e1 e2 : expr) (v1 v2 v : Z),
  eval env e1 (Val v1) -> eval env e2 (Val v2) -> v = v1 * v2 ->
  eval env (Mult e1 e2) (Val v)
| EMult_Err1 : forall (e1 e2 : expr),
  eval env e1 Err -> eval env (Mult e1 e2) Err
| EMult_Err2 : forall (e1 e2 : expr) (v1 : Z),
  eval env e1 (Val v1) -> eval env e2 Err -> eval env (Mult e1 e2) Err
| EDiv : forall (e1 e2 : expr) (v1 v2 v : Z),
  eval env e1 (Val v1) -> eval env e2 (Val v2) -> v = v1 / v2 ->
  eval env (Div e1 e2) (Val v)
| EDiv_Err1 : forall (e1 e2 : expr),
  eval env e1 Err -> eval env (Div e1 e2) Err
| EDiv_Err2 : forall (e1 e2 : expr) (v1 : Z),
  eval env e1 (Val v1) -> eval env e2 Err -> eval env (Div e1 e2) Err.

Definition env0 (n : nat) : (option Z) :=
  match n with
  | 0%nat => Some 2
  | _ => None
  end.

Lemma eval0 : eval env0 (Plus (Var 0) (Cte 1)) (Val 3).
Proof.
  eapply EPlus.
  apply EVar; simpl; auto.
  apply ECte.
  auto.
Save.

Lemma eval1 :
  eval env0 (Mult (Plus (Cte 4) (Var 0)) (Moins (Cte 9) (Var 0))) (Val 42).
Proof.
  eapply EMult.
  eapply EPlus.
  apply ECte.
  apply EVar; simpl; auto.
  auto.
  eapply EMoins.
  apply ECte.
  apply EVar; simpl; auto.
  auto.
  auto.
Save.

Lemma eval2 :
  eval env0 (Mult (Plus (Cte 4) (Var 1)) (Moins (Cte 9) (Var 0))) Err.
Proof.
  apply EMult_Err1.
  eapply EPlus_Err2.
  apply ECte.
  apply EVar_Err; simpl; auto.
Save.

Ltac apply_eval_val :=
  repeat
    eapply EPlus || eapply EMoins || eapply EMult || eapply EDiv ||
    apply ECte || (apply EVar; simpl; auto) || auto.

Ltac apply_eval_err :=
  match goal with
  | |- eval _ (Var _) Err => apply EVar_Err; simpl; auto
  | |- eval _ (Plus _ _) Err =>
    (apply EPlus_Err1; apply_eval_err) ||
    (eapply EPlus_Err2; [ apply_eval_val | apply_eval_err])
  | |- eval _ (Moins _ _) Err =>
    (apply EMoins_Err1; apply_eval_err) ||
    (eapply EMoins_Err2; [ apply_eval_val | apply_eval_err])
  | |- eval _ (Mult _ _) Err =>
    (apply EMult_Err1; apply_eval_err) ||
    (eapply EMult_Err2; [ apply_eval_val | apply_eval_err])
  | |- eval _ (Div _ _) Err =>
    (apply EDiv_Err1; apply_eval_err) ||
    (eapply EDiv_Err2; [ apply_eval_val | apply_eval_err])
  end.

Lemma eval0b : eval env0 (Plus (Var 0) (Cte 1)) (Val 3).
Proof.
  apply_eval_val.
Save.

Lemma eval1b :
  eval env0 (Mult (Plus (Cte 4) (Var 0)) (Moins (Cte 9) (Var 0))) (Val 42).
Proof.
  apply_eval_val.
Save.

Lemma eval2b :
  eval env0 (Mult (Plus (Cte 4) (Var 1)) (Moins (Cte 9) (Var 0))) Err.
Proof.
  apply_eval_err.
Save.

Fixpoint f_eval (env : context) (e : expr) : value :=
  match e with
  | Cte c => Val c
  | Var i =>
    match (env i) with
    | Some v => Val v
    | None => Err
    end
  | Plus e1 e2 =>
    let v1 := f_eval env e1 in
    match v1 with
    | Err => Err
    | Val z1 =>
      let v2 := f_eval env e2 in
      match v2 with
      | Err => Err
      | Val z2 => Val (z1 + z2)
      end
    end
  | Moins e1 e2 =>
    let v1 := f_eval env e1 in
    match v1 with
    | Err => Err
    | Val z1 =>
      let v2 := f_eval env e2 in
      match v2 with
      | Err => Err
      | Val z2 => Val (z1 - z2)
      end
    end
  | Mult e1 e2 =>
    let v1 := f_eval env e1 in
    match v1 with
    | Err => Err
    | Val z1 =>
      let v2 := f_eval env e2 in
      match v2 with
      | Err => Err
      | Val z2 => Val (z1 * z2)
      end
    end
  | Div e1 e2 =>
    let v1 := f_eval env e1 in
    match v1 with
    | Err => Err
    | Val z1 =>
      let v2 := f_eval env e2 in
      match v2 with
      | Err => Err
      | Val z2 => Val (z1 / z2)
      end
    end
  end.

Lemma eval0t :  f_eval env0 (Plus (Var 0) (Cte 1)) = (Val 3).
Proof.
  simpl; reflexivity.
Save.

Lemma eval1t :
  f_eval env0 (Mult (Plus (Cte 4) (Var 0)) (Moins (Cte 9) (Var 0))) = (Val 42).
Proof.
  simpl; reflexivity.
Save.

Lemma eval2t :
  f_eval env0 (Mult (Plus (Cte 4) (Var 1)) (Moins (Cte 9) (Var 0))) = Err.
Proof.
  simpl; reflexivity.
Save.

Functional Scheme f_eval_ind := Induction for f_eval Sort Prop.

Theorem f_eval_sound : forall (env : context) (e : expr) (v : value),
  (f_eval env e) = v -> eval env e v.
Proof.
  do 2 intro; functional induction (f_eval env e) using f_eval_ind; intros.
  rewrite <- H; apply ECte.
  rewrite <- H; apply EVar; auto.
  rewrite <- H; apply EVar_Err; auto.
  rewrite <- H;
    apply EPlus with (v1 := z1) (v2 := z2);
      [ apply (IHv (Val z1)); auto | apply (IHv0 (Val z2)); auto | auto ].
  rewrite <- H;
    apply EPlus_Err2 with (v1 := z1);
      [ apply (IHv (Val z1)); auto | apply (IHv0 Err); auto ].
  rewrite <- H; apply EPlus_Err1; apply (IHv Err); auto.
  rewrite <- H;
    apply EMoins with (v1 := z1) (v2 := z2);
      [ apply (IHv (Val z1)); auto | apply (IHv0 (Val z2)); auto | auto ].
  rewrite <- H;
    apply EMoins_Err2 with (v1 := z1);
      [ apply (IHv (Val z1)); auto | apply (IHv0 Err); auto ].
  rewrite <- H; apply EMoins_Err1; apply (IHv Err); auto.
  rewrite <- H;
    apply EMult with (v1 := z1) (v2 := z2);
      [ apply (IHv (Val z1)); auto | apply (IHv0 (Val z2)); auto | auto ].
  rewrite <- H;
    apply EMult_Err2 with (v1 := z1);
      [ apply (IHv (Val z1)); auto | apply (IHv0 Err); auto ].
  rewrite <- H; apply EMult_Err1; apply (IHv Err); auto.
  rewrite <- H;
    apply EDiv with (v1 := z1) (v2 := z2);
      [ apply (IHv (Val z1)); auto | apply (IHv0 (Val z2)); auto | auto ].
  rewrite <- H;
    apply EDiv_Err2 with (v1 := z1);
      [ apply (IHv (Val z1)); auto | apply (IHv0 Err); auto ].
  rewrite <- H; apply EDiv_Err1; apply (IHv Err); auto.
Save.


From mathcomp Require Import all_ssreflect all_algebra.
Import GRing.
Import FracField.
Require Import q_tools.

Local Open Scope ring_scope.

Section q_analogue.
Variable (R : rcfType) (q : R).
Hypothesis Hq : q - 1 != 0.

Notation "f ** g" := (fun x => f x * g x) (at level 40).
Notation "f // g" := (fun x => f x / g x) (at level 40).
Notation "a */ f" := (fun x => a * (f x)) (at level 40).
(* q-differential *)
Definition dq (f : R -> R) x := f (q * x) - f x.

(* q-differential product rule *)
Lemma dq_prod f g x :
  dq (f ** g) x = (f (q * x)) * dq g x + (g x) * dq f x.
Proof.
  rewrite /dq !mulrBr.
  rewrite [g x * f (q * x)]mulrC.
  by rewrite [g x * f x]mulrC subrKA.
Qed.

(* q-derivative *)
Definition Dq f := dq f // dq id.

Fixpoint hoDq n f := match n with
  | 0 => f
  | n.+1 => Dq (hoDq n f)
  end.

(* q-derivative for const is 0 *)
Lemma Dq_const x c : Dq (fun x => c) x = 0.
Proof. by rewrite /Dq /dq addrK' mul0r. Qed.

(* q-derivative is linear *)
Lemma Dq_is_linear a b f g x :
  Dq ((a */ f) \+ (b */ g)) x = a * (Dq f x) + b * (Dq g x).
Proof.
  rewrite /Dq /dq !mulrA.
  case Hx : (x == 0).
  - move: Hx => /eqP ->.
    by rewrite mulr0 !addrK' !mulr0 -mulrDl addr0.
  - rewrite add_div.
      rewrite !mulrBr opprD !addrA.
      rewrite [a * f (q * x) + b * g (q * x) - a * f x]addrC.
      rewrite [(a * f (q * x) + b * g (q * x))]addrC addrA.
      rewrite [- (a * f x) + b * g (q * x) + a * f (q * x)] addrC.
      by rewrite addrA.
  apply denom_is_nonzero => //.
  by rewrite Hx.
Qed.

(* q-analogue of natural number *)
Definition qnat n : R := (q ^ n - 1) / (q - 1).

(* qnat 0 is 0 *)
Lemma qnat0 : qnat 0 = 0.
Proof. by rewrite /qnat expr0z addrK' mul0r. Qed.

Lemma qnat1 : qnat 1 = 1.
Proof. by rewrite /qnat expr1z divff. Qed.

Lemma qnatE (n : nat) : qnat n.+1 = \sum_(0 <= i < n.+1) (q ^ i).
Proof.
  elim: n => [|n IH].
  - by rewrite qnat1 big_nat1 expr0z.
  - have -> : qnat n.+2 = qnat n.+1 + q ^ n.+1.
      apply (same_prod _ (q - 1)) => //.
      by rewrite mulrDl !denomK // mulrBr mulr1 -exprSzr [RHS]addrC subrKA.
    by rewrite IH [RHS](@big_cat_nat _ _ _ n.+1) //= big_nat1.
Qed.

Lemma qnat_cat {n} j : (j < n)%N ->
  qnat n.+1 = qnat j.+1 + q ^ j.+1 * qnat (n.+1 - j.+1)%N.
Proof.
  move=> Hjn.
  have Hjn' : (j < n.+1)%N by apply ltnW.
  have Hjn'' : (0 < n.+1 - j.+1)%N.
    by rewrite subn_gt0.
  rewrite !qnatE (@big_cat_nat _ _ _ j.+1) //=.
  have {2}-> : j.+1 = (0 + j.+1)%N by [].
  rewrite big_addn.
  have -> : (n.+1 - j.+1)%N = (n.+1 - j.+1 - 1).+1.
    by rewrite subn1 prednK // // subn_gt0.
  f_equal.
  under eq_bigr do rewrite exprzD_nat.
  by rewrite sum_distr qnatE.
Qed.

Lemma qnat_cat1 n : qnat n.+1 = 1 + q * qnat n.
Proof.
  destruct n.
  - by rewrite qnat1 qnat0 mulr0 addr0.
  - by rewrite (qnat_cat 0) ?qnat1 ?expr1z ?subn1.
Qed.

Lemma qnat_catn n : qnat n.+1 = qnat n + q ^ n.
Proof.
  destruct n.
  - by rewrite qnat1 qnat0 add0r expr0z.
  - by rewrite (qnat_cat n) ?subSnn ?qnat1 ?mulr1.
Qed.

(* q-derivative of x ^ n *)
Lemma Dq_pow n x :
  x != 0 -> Dq (fun x => x ^ n) x = qnat n * x ^ (n - 1).
Proof.
  move=> Hx.
  rewrite /Dq /dq /qnat.
  rewrite -{4}(mul1r x) -mulrBl expfzMl -add_div; last by apply mulf_neq0.
  rewrite [in x ^ n](_ : n = (n -1) +1) //; last by rewrite subrK.
  rewrite expfzDr ?expr1z ?mulrA -?mulNr ?red_frac_r ?add_div //.
  rewrite -{2}[x ^ (n - 1)]mul1r -mulrBl mulrC mulrA.
  by rewrite [in (q - 1)^-1 * (q ^ n - 1)] mulrC.
Qed.

(* q-derivative product rule *)
Lemma Dq_prod f g x : x != 0 ->
  Dq (f ** g) x = f (q * x) * Dq g x + (g x) * Dq f x.
Proof.
  move=> Hx.
  rewrite /Dq dq_prod -add_div.
    by rewrite !mulrA.
  by apply denom_is_nonzero.
Qed.

(* q-derivative product rule' *)
Lemma Dq_prod' f g x : x != 0 ->
   Dq (f ** g) x = (f x) * Dq g x + g (q * x) * Dq f x.
Proof.
  move=> Hx.
  have -> : Dq (f ** g) x = Dq (g ** f) x.
    by rewrite /Dq /dq (mulrC (f (q * x))) (mulrC (f x)).
  by rewrite Dq_prod // addrC.
Qed.

(* reduce fraction in q-derivative *)
Lemma Dq_divff f g x : g x != 0 -> g (q * x) != 0 ->
  Dq (g ** (f // g)) x = Dq f x.
Proof.
  move=> Hgx Hgqx.
  rewrite /Dq /dq.
  rewrite [f (q * x) / g (q * x)] mulrC.
  rewrite [f x / g x] mulrC.
  by rewrite !mulrA !divff // !mul1r.
Qed.

(* q-derivative quotient rule *)
Lemma Dq_quot f g x : x != 0 -> g x != 0 -> g (q * x) != 0 ->
  Dq (f // g) x =
  (g x * Dq f x - f x * Dq g x) / (g x * g (q * x)).
Proof.
  move=> Hx Hgx Hgqx.
  rewrite -add_div.
    rewrite red_frac_l // mulNr.
    apply /rtransposition /(same_prod _ (g (q * x))) => //.
    rewrite mulrDl.
    rewrite -[f x * Dq g x / (g x * g (q * x)) * g (q * x)]
              mulrA.
    rewrite [(g x * g (q * x))^-1 * g (q * x)] mulrC.
    rewrite mulrA red_frac_r //.
    rewrite -[Dq f x / g (q * x) * g (q * x)] mulrA.
    rewrite [(g (q * x))^-1 * g (q * x)] mulrC.
    rewrite divff // mulr1 mulrC.
    rewrite -[f x * Dq g x / g x] mulrA.
    rewrite [Dq g x / g x] mulrC.
    rewrite [f x * ((g x)^-1 * Dq g x)] mulrA.
    rewrite -Dq_prod //.
    by apply Dq_divff.
  by apply mulf_neq0.
Qed.

(* q-derivative quotient rule' *)
Lemma Dq_quot' f g x : x != 0 ->
  g x != 0 -> g (q * x) != 0 ->
  Dq (f // g) x =
  (g (q * x) * Dq f x
   - f (q * x) * Dq g x) / (g x * g (q * x)).
Proof.
  move=> Hx Hgx Hgqx.
  rewrite -add_div; last by apply mulf_neq0.
  rewrite [g x * g (q * x)] mulrC.
  rewrite red_frac_l // mulNr.
  apply /rtransposition /(same_prod _ (g x)) => //.
  rewrite mulrDl.
  rewrite [f (q * x) * Dq g x / (g (q * x) * g x) * g x]mulrC.
  rewrite [g (q * x) * g x]mulrC mulrA red_frac_l //.
  rewrite -[Dq f x / g x * g x]mulrA [(g x)^-1 * g x]mulrC.
  rewrite divff // mulr1 mulrC.
  rewrite -[f (q * x) * Dq g x / g (q * x)]mulrA.
  rewrite [Dq g x / g (q * x)]mulrC.
  rewrite [f (q * x) * ((g (q * x))^-1 * Dq g x)]mulrA.
  rewrite -Dq_prod' //.
  by apply Dq_divff.
Qed.

(* q-analogue of polynomial for nat *)
Fixpoint qbinom_pos a n x := match n with
  | 0 => 1
  | n.+1 => (qbinom_pos a n x) * (x - q ^ n * a)
  end.

Lemma qbinom_pos_head a n x:
   qbinom_pos a n.+1 x =
  (x - a) * qbinom_pos (q * a) n x.
Proof.
  elim: n => [|n IH] /=.
  - by rewrite expr0z !mul1r mulr1.
  - by rewrite !mulrA -IH exprSzr.
Qed.

Lemma qbinomxa a n : qbinom_pos a n.+1 a = 0.
Proof. by rewrite qbinom_pos_head addrK' mul0r. Qed.

Lemma qbinomx0 a n :
  qbinom_pos (- a) n 0 = q ^+((n * (n - 1))./2) * a ^+ n.
Proof.
  elim: n => [| n IH] //.
  - by rewrite mul0n /= expr0 mulr1.
  - destruct n.
      by rewrite /= !mul1r sub0r opp_oppE expr1.
    case Hq0 : (q == 0).
    + rewrite qbinom_pos_head.
      destruct n.
        rewrite /= expr0z.
        move: Hq0 => /eqP ->.
        by rewrite opp_oppE add0r mul1r expr1 sub0r !mul0r mul1r oppr0 mulr0.
      rewrite qbinom_pos_head.
      move: Hq0 => /eqP ->.
      rewrite mul0r subr0 mulrA !mulr0 !mul0r.
      have -> : (n.+3 * (n.+3 - 1))./2 =
                ((n.+3 * (n.+3 - 1))./2 - 1)%N.+1.
        by rewrite -[RHS]addn1 subnK.
      by rewrite expr0n mul0r.
    + rewrite /= in IH.
      rewrite [LHS] /= IH // sub0r -mulrN opp_oppE.
      rewrite [q ^ n.+1 * a] mulrC.
      rewrite mulrA mulrC 2!mulrA -exprD.
      have -> : (n.+1 + (n.+1 * (n.+1 - 1))./2 =
                (n.+2 * (n.+2 - 1))./2)%N.
        by rewrite !subn1 /= half_add.
      by rewrite -mulrA -(exprSzr a n.+1).
Qed.

(* q-derivative of q-polynomial for nat *)
Theorem Dq_qbinom_pos a n x : x != 0 ->
  Dq (qbinom_pos a n.+1) x =
  qnat n.+1 * qbinom_pos a n x.
Proof.
  move=> Hx.
  elim: n => [|n IH].
  - rewrite /Dq /dq /qbinom_pos /qnat.
    rewrite !mul1r mulr1 expr1z.
    rewrite opprB subrKA !divff //.
    by rewrite denom_is_nonzero.
  - rewrite (_ : Dq (qbinom_pos a n.+2) x =
                 Dq ((qbinom_pos a n.+1) **
                 (fun x => (x - q ^ (n.+1) * a))) x) //.
    rewrite Dq_prod' //.
    rewrite [Dq (+%R^~ (- (q ^ n.+1 * a))) x]/Dq /dq.
    rewrite opprB subrKA divff //; last by apply denom_is_nonzero.
    rewrite mulr1 exprSz.
    rewrite -[q * q ^ n * a]mulrA -(mulrBr q) IH.
    rewrite -[q * (x - q ^ n * a) * (qnat n.+1 * qbinom_pos a n x)]mulrA.
    rewrite [(x - q ^ n * a) * (qnat n.+1 * qbinom_pos a n x)]mulrC.
    rewrite -[qnat n.+1 * qbinom_pos a n x * (x - q ^ n * a)]mulrA.
    rewrite (_ : qbinom_pos a n x * (x - q ^ n * a) = qbinom_pos a n.+1 x) //.
    rewrite mulrA -{1}(mul1r (qbinom_pos a n.+1 x)).
    by rewrite -mulrDl -qnat_cat1.
Qed.

(* q-polynomial exponential law for nat *)
Lemma qbinom_pos_explaw x a m n :
  qbinom_pos a (m + n) x =
    qbinom_pos a m x * qbinom_pos (q ^ m * a) n x.
Proof.
  elim: n.
  - by rewrite addn0 /= mulr1.
  - elim => [_|n _ IH].
    + by rewrite addnS /= addn0 expr0z !mul1r.
    + rewrite addnS [LHS]/= IH /= !mulrA.
      by rewrite -[q ^ n.+1 * q ^ m] expfz_n0addr // addnC.
Qed.

Lemma qbinom_exp_non0l x a m n :
  qbinom_pos a (m + n) x != 0 -> qbinom_pos a m x != 0.
Proof.
  rewrite qbinom_pos_explaw.
  by apply mulnon0.
Qed.

Lemma qbinom_exp_non0r x a m n :
  qbinom_pos a (m + n) x != 0 -> qbinom_pos (q ^ m * a) n x != 0.
Proof.
  rewrite qbinom_pos_explaw mulrC.
  by apply mulnon0.
Qed.

(* q-polynomial for neg *)
Definition qbinom_neg a n x := 1 / qbinom_pos (q ^ ((Negz n) + 1) * a) n x.

(* q-poly_nat 0 = q-poly_neg 0 *)
Lemma qbinom_0 a x : qbinom_neg a 0 x = qbinom_pos a 0 x.
Proof. by rewrite /qbinom_neg /= -[RHS] (@divff _ 1) ?oner_neq0. Qed.

Theorem qbinom_neg_inv a n x :
  qbinom_pos (q ^ (Negz n + 1) * a) n x != 0 ->
  qbinom_neg a n x * qbinom_pos (q ^ (Negz n + 1) * a) n x = 1.
Proof.
  move=> H.
  by rewrite /qbinom_neg mulrC mulrA mulr1 divff.
Qed.

(* q-analogue polynomial for int *)
Definition qbinom a n x :=
  match n with
  | Posz n0 => qbinom_pos a n0 x
  | Negz n0 => qbinom_neg a n0.+1 x
  end.

Definition qbinom_denom a n x :=
 match n with
  | Posz n0 => 1
  | Negz n0 => qbinom_pos (q ^ Negz n0 * a) n0.+1 x
  end.

Lemma Dq_qbinom_int_to_neg a n x :
  Dq (qbinom a (Negz n)) x = Dq (qbinom_neg a (n + 1)) x.
Proof. by rewrite /Dq /dq /= addn1. Qed.

Lemma qbinom_exp_0 a m n x : m = 0 \/ n = 0 ->
  qbinom a (m + n) x = qbinom a m x * qbinom (q ^ m * a) n x.
Proof.
  move=> [->|->].
  - by rewrite add0r expr0z /= !mul1r.
  - by rewrite addr0 /= mulr1.
Qed.

Lemma qbinom_exp_pos_neg a (m n : nat) x : q != 0 ->
  qbinom_pos (q ^ (Posz m + Negz n) * a) n.+1 x != 0 ->
  qbinom a (Posz m + Negz n) x = qbinom a m x * qbinom (q ^ m * a) (Negz n) x.
Proof.
  move=> Hq0 Hqbinommn.
  case Hmn : (Posz m + Negz n) => [l|l]  /=.
  - rewrite /qbinom_neg mul1r.
    rewrite (_ : qbinom_pos a m x = qbinom_pos a (l + n.+1) x).
      rewrite qbinom_pos_explaw.
      have -> : q ^ (Negz n.+1 + 1) * (q ^ m * a) = q ^ l * a.
        by rewrite mulrA -expfzDr // -addn1 Negz_addK addrC Hmn.
      rewrite -{2}(mul1r (qbinom_pos (q ^ l * a) n.+1 x)) red_frac_r.
        by rewrite divr1.
      by rewrite -Hmn.
    apply Negz_transp in Hmn.
    apply (eq_int_to_nat R) in Hmn.
    by rewrite Hmn.
  - rewrite /qbinom_neg.
    have Hmn' : n.+1 = (l.+1 + m)%N.
      move /Negz_transp /esym in Hmn.
      rewrite addrC in Hmn.
      move /Negz_transp /(eq_int_to_nat R) in Hmn.
      by rewrite addnC in Hmn.
    rewrite (_ : qbinom_pos (q ^ (Negz n.+1 + 1) * (q ^ m * a)) n.+1 x
               = qbinom_pos (q ^ (Negz n.+1 + 1) * (q ^ m * a))
                              (l.+1 + m) x).
      rewrite qbinom_pos_explaw.
      have -> : q ^ (Negz n.+1 + 1) * (q ^ m * a) =
                q ^ (Negz l.+1 + 1) * a.
        by rewrite mulrA -expfzDr // !NegzS addrC Hmn.
      have -> : q ^ l.+1 * (q ^ (Negz l.+1 + 1) * a) = a.
        by rewrite mulrA -expfzDr // NegzS NegzK expr0z mul1r.
      rewrite mulrA.
      rewrite [qbinom_pos (q ^ (Negz l.+1 + 1) * a) l.+1 x *
               qbinom_pos a m x]mulrC.
      rewrite red_frac_l //.
      have -> : a = q ^ l.+1 * (q ^ (Posz m + Negz n) * a) => //.
        by rewrite mulrA -expfzDr // Hmn NegzK expr0z mul1r.
      apply qbinom_exp_non0r.
      rewrite -Hmn' //.
    by rewrite Hmn'.
Qed.

Lemma qbinom_exp_neg_pos a m n x : q != 0 ->
  qbinom_pos (q ^ Negz m * a) m.+1 x != 0 ->
  qbinom a (Negz m + Posz n) x =
  qbinom a (Negz m) x * qbinom (q ^ Negz m * a) n x.
Proof.
  move=> Hq0 Hqbinomm.
  case Hmn : (Negz m + n) => [l|l] /=.
  - rewrite /qbinom_neg.
    rewrite (_ : qbinom_pos (q ^ Negz m * a) n x =
                 qbinom_pos (q ^ Negz m * a)
                   (m.+1 + l) x).
      rewrite qbinom_pos_explaw.
      have -> : q ^ (Negz m.+1 + 1) * a = q ^ Negz m * a.
        by rewrite -addn1 Negz_addK.
      have -> : q ^ m.+1 * (q ^ Negz m * a) = a.
        by rewrite mulrA -expfzDr // NegzK expr0z mul1r.
      rewrite mulrC mulrA mulr1.
      rewrite -{2}[qbinom_pos (q ^ Negz m * a) m.+1 x]mulr1.
      rewrite red_frac_l //.
      by rewrite divr1.
    move: Hmn.
    rewrite addrC.
    move /Negz_transp /eq_int_to_nat.
    by rewrite addnC => ->.
  - rewrite /qbinom_neg.
    have Hmn' : m.+1 = (n + l.+1)%N.
      rewrite addrC in Hmn.
      move /Negz_transp /esym in Hmn.
      rewrite addrC in Hmn.
      by move /Negz_transp /(eq_int_to_nat R) in Hmn.
    rewrite {2}Hmn'.
    rewrite qbinom_pos_explaw.
    have -> : q ^ n * (q ^ (Negz m.+1 + 1) * a) =
                q ^ (Negz l.+1 + 1) * a.
      by rewrite mulrA -expfzDr // !NegzS addrC Hmn.
    have -> : q ^ (Negz m.+1 + 1) * a = q ^ Negz m * a.
      by rewrite NegzS.
    rewrite [RHS] mulrC mulrA red_frac_l //.
    apply (@qbinom_exp_non0l x _ n l.+1).
    by rewrite -Hmn'.
Qed.

Lemma qbinom_exp_neg_neg a m n x : q != 0 ->
  qbinom a (Negz m + Negz n) x =
  qbinom a (Negz m) x * qbinom (q ^ Negz m * a) (Negz n) x .
Proof.
  move=> Hq0 /=.
  rewrite /qbinom_neg.
  have -> : (m + n).+2 = ((n.+1) + (m.+1))%N.
    by rewrite addnC addnS -addn2.
  rewrite qbinom_pos_explaw.
  have -> : q ^ n.+1 * (q ^ (Negz (n.+1 + m.+1) + 1) * a) =
              q ^ (Negz m.+1 + 1) * a.
    rewrite mulrA -expfzDr //.
    have -> : Posz n.+1 + (Negz (n.+1 + m.+1) + 1) = Negz m.+1 + 1 => //.
    by rewrite Negz_add 2!addrA NegzK add0r.
  have -> : (q ^ (Negz n.+1 + 1) * (q ^ Negz m * a)) =
              (q ^ (Negz (n.+1 + m.+1) + 1) * a).
    by rewrite mulrA -expfzDr // NegzS -Negz_add addnS NegzS.
  rewrite mulf_div mulr1.
  by rewrite [qbinom_pos (q ^ (Negz (n.+1 + m.+1) + 1) * a) n.+1 x *
            qbinom_pos (q ^ (Negz m.+1 + 1) * a) m.+1 x] mulrC.
Qed.

Theorem qbinom_explaw a m n x : q != 0 ->
  qbinom_denom a m x != 0 ->
  qbinom_denom (q ^ m * a) n x != 0 ->
  qbinom a (m + n) x = qbinom a m x * qbinom (q ^ m * a) n x.
Proof.
  move=> Hq0.
  case: m => m Hm.
  - case: n => n Hn.
    + by apply qbinom_pos_explaw.
    + rewrite qbinom_exp_pos_neg //.
      by rewrite addrC expfzDr // -mulrA.
  - case: n => n Hn.
    + by rewrite qbinom_exp_neg_pos.
    + by apply qbinom_exp_neg_neg.
Qed.

(* q-derivative of q-polynomial for 0 *)
Lemma Dq_qbinomn0 a x :
  Dq (qbinom a 0) x = qnat 0 * qbinom a (- 1) x.
Proof. by rewrite Dq_const qnat0 mul0r. Qed.

Lemma qbinom_qx a m n x : q != 0 ->
  qbinom_pos (q ^ m * a) n (q * x) =
    q ^ n * qbinom_pos (q ^ (m - 1) * a) n x.
Proof.
  move=> Hq0.
  elim: n => [|n IH] /=.
  - by rewrite expr0z mul1r.
  - rewrite IH.
    rewrite exprSzr -[RHS]mulrA.
    rewrite [q * (qbinom_pos (q ^ (m - 1) * a) n x *
              (x - q ^ n * (q ^ (m - 1) * a)))]mulrA.
    rewrite [q * qbinom_pos (q ^ (m - 1) * a) n x]mulrC.
    rewrite -[qbinom_pos (q ^ (m - 1) * a) n x * q *
               (x - q ^ n * (q ^ (m - 1) * a))]mulrA.
    rewrite [q * (x - q ^ n * (q ^ (m - 1) * a))]mulrBr.
    rewrite [q * (q ^ n * (q ^ (m - 1) * a))]mulrA.
    rewrite [q * q ^ n]mulrC.
    rewrite -[q ^ n * q * (q ^ (m - 1) * a)]mulrA.
    rewrite (_ : q * (q ^ (m - 1) * a) = q ^ m * a).
      by rewrite [RHS] mulrA.
    by rewrite mulrA -{1}(expr1z q) -expfzDr // addrC subrK.
Qed.

(* q-derivative of q-polynomial for neg *)
Theorem Dq_qbinom_neg a n x : q != 0 -> x != 0 ->
  (x - q ^ (Negz n) * a) != 0 ->
  qbinom_pos (q ^ (Negz n + 1) * a) n x != 0 ->
  Dq (qbinom_neg a n) x = qnat (Negz n + 1) * qbinom_neg a (n.+1) x.
Proof.
  move=> Hq0 Hx Hqn Hqbinom.
  destruct n.
  - by rewrite /Dq /dq /qbinom_neg /= addrK' qnat0 !mul0r.
  - rewrite Dq_quot //.
      rewrite Dq_const mulr0 mul1r sub0r.
      rewrite Dq_qbinom_pos // qbinom_qx // -mulNr.
      rewrite [qbinom_pos (q ^ (Negz n.+1 + 1) * a) n.+1 x *
                (q ^ n.+1 * qbinom_pos (q ^ (Negz n.+1 + 1 - 1) *
                  a) n.+1 x)] mulrC.
      rewrite -mulf_div.
      have -> : qbinom_pos (q ^ (Negz n.+1 + 1) * a) n x /
                    qbinom_pos (q ^ (Negz n.+1 + 1) * a) n.+1 x =
                      1 / (x - q ^ (- 1) * a).
        rewrite -(mulr1 (qbinom_pos (q ^ (Negz n.+1 + 1) * a) n x)) /=.
        rewrite red_frac_l.
          rewrite NegzE mulrA -expfzDr // addrA -addn2.
          rewrite (_ : Posz (n + 2)%N = Posz n + 2) //.
          by rewrite -{1}(add0r (Posz n)) addrKA.
        by rewrite /=; apply mulnon0 in Hqbinom.
      rewrite mulf_div.
      rewrite -[q ^ n.+1 *
                 qbinom_pos (q ^ (Negz n.+1 + 1 - 1) * a) n.+1 x *
                   (x - q ^ (-1) * a)]mulrA.
      have -> : qbinom_pos (q ^ (Negz n.+1 + 1 - 1) * a) n.+1 x *
                (x - q ^ (-1) * a) =
                qbinom_pos (q ^ (Negz (n.+1)) * a) n.+2 x => /=.
        have -> : Negz n.+1 + 1 - 1 = Negz n.+1.
          by rewrite addrK.
        have -> : q ^ n.+1 * (q ^ Negz n.+1 * a) = q ^ (-1) * a => //.
        rewrite mulrA -expfzDr // NegzE.
        have -> : Posz n.+1 - Posz n.+2 = - 1 => //.
        rewrite -addn1 -[(n + 1).+1]addn1.
        rewrite (_ : Posz (n + 1)%N = Posz n + 1) //.
        rewrite (_ : Posz (n + 1 + 1)%N = Posz n + 1 + 1) //.
        rewrite -(add0r (Posz n + 1)).
        by rewrite addrKA.
      rewrite /qbinom_neg /=.
      rewrite (_ : Negz n.+2 + 1 = Negz n.+1) // -mulf_div.
      congr (_ * _).
      rewrite NegzE mulrC /qnat -mulNr mulrA.
      congr (_ / _).
      rewrite opprB mulrBr mulr1 mulrC divff; last by rewrite expnon0.
      rewrite invr_expz (_ : - Posz n.+2 + 1 = - Posz n.+1) //.
      rewrite -addn1 (_ : Posz (n.+1 + 1)%N = Posz n.+1 + 1) //.
      by rewrite addrC [Posz n.+1 + 1]addrC -{1}(add0r 1) addrKA sub0r.
    rewrite qbinom_qx // mulf_neq0 ?expnon0 //.
    rewrite qbinom_pos_head mulf_neq0 //.
    rewrite (_ : Negz n.+1 + 1 - 1 = Negz n.+1) ?addrK //.
    move: Hqbinom => /=.
    move/mulnon0.
    by rewrite addrK mulrA -{2}(expr1z q) -expfzDr.
Qed.

Theorem Dq_qbinom a n x : q != 0 -> x != 0 ->
  x - q ^ (n - 1) * a != 0 ->
  qbinom (q ^ n * a) (- n) x != 0 ->
  Dq (qbinom a n) x = qnat n * qbinom a (n - 1) x.
Proof.
  move=> Hq0 Hx Hxqa Hqbinom.
  case: n Hxqa Hqbinom => [|/=] n Hxqa Hqbinom.
  - destruct n.
    + by rewrite Dq_qbinomn0.
    + rewrite Dq_qbinom_pos //.
      rewrite (_ : Posz n.+1 - 1 = n) // -addn1.
      by rewrite (_ : Posz (n + 1)%N = Posz n + 1) ?addrK.
  - rewrite Dq_qbinom_int_to_neg Dq_qbinom_neg //.
        rewrite Negz_addK.
        rewrite (_ : (n + 1).+1 = (n + 0).+2) //.
        by rewrite addn0 addn1.
      rewrite (_ : Negz (n + 1) = Negz n - 1) //.
      by apply itransposition; rewrite Negz_addK.
    by rewrite Negz_addK addn1.
Qed.

Fixpoint qfact n := match n with
  | 0 => 1
  | n.+1 => qfact n * qnat n.+1
  end.

Lemma qfact_nat_non0 n : qfact n.+1 != 0 -> qnat n.+1 != 0.
Proof.
  rewrite /= mulrC.
  by apply mulnon0.
Qed.

Lemma qfact_lenon0 m n : qfact (m + n) != 0 -> qfact m != 0.
Proof.
  elim: n => [|n IH].
  - by rewrite addn0.
  - rewrite addnS /=.
    move/ mulnon0.
    apply IH.
Qed.

(* Lemma qfact_non0 n : qfact n != 0.
Proof.
  elim: n => [|n IH] //=.
  - by apply oner_neq0.
  - Search (_ * _ != 0).
    apply mulf_neq0 => //.
Admitted. *)

Definition qbicoef n j :=
  qfact n / (qfact j * qfact (n - j)).

Lemma qbicoefn0 n : qfact n != 0 -> qbicoef n 0 = 1.
Proof.
move=> H.
by rewrite /qbicoef /= mul1r subn0 divff.
Qed.

Lemma qbicoefnn n : qfact n != 0 -> qbicoef n n = 1.
Proof.
  move=> H.
  rewrite /qbicoef.
  by rewrite -{3}(addn0 n) addKn /= mulr1 divff.
Qed.

(* Lemma qfact1 n : (n <= 0)%N -> qfact n = 1.
Proof.
  move=> Hn.
  have -> : (n = 0)%N => //.
  apply /eqP.
  by rewrite -(subn0 n) subn_eq0 //.
Qed. *)

(*Lemma qbicoef_jn n j : (n - j <= 0)%N ->
  q_coef n j = qfact n / qfact j.
Proof.
  move=> Hjn.
  rewrite /q_coef.
  by rewrite (qfact1 (n - j)%N) // mulr1.
Qed. *)

(* Lemma qfact_jn n j : (n - j <= 0)%N ->
  qfact j = qfact (n - (n - j)).
Proof.
Qed. *)

Lemma qbicoef_compute n j : qfact n != 0 -> (j < n)%N ->
  qbicoef n j * qfact j * qnat (n - j.+1).+1 =
  qbicoef n j.+1 * (qfact j * qnat j.+1).
Proof.
move=> Hfact Hj.
  rewrite (mulrC (qbicoef n j)) -mulrA mulrC (mulrC (qfact j)) [RHS]mulrA.
  f_equal.
  rewrite /qbicoef -mulrA -[RHS]mulrA.
  f_equal => /=.
  rewrite mulrC subnSK //.
  have -> : qfact (n - j) = qfact (n - j.+1) * qnat (n - j)%N.
    by rewrite -(subnSK Hj) /=.
  rewrite mulrA -{1}(mul1r (qnat (n - j)%N)) red_frac_r; last first.
    rewrite -(subnSK Hj).
    apply /qfact_nat_non0 /(qfact_lenon0 _ j).
    rewrite subnSK ?subnK //.
    by apply ltnW.
  rewrite [RHS]mulrC [qfact j * qnat j.+1]mulrC -{1}(mulr1 (qnat j.+1)).
  rewrite -[qnat j.+1 * qfact j * qfact (n - j.+1)]mulrA red_frac_l //.
  apply /qfact_nat_non0 /(qfact_lenon0 _ (n - j.+1)%N).
  by rewrite subnKC.
Qed.

Lemma qbicoefE n j : (j <= n)%N ->
  qbicoef n (n - j) = qbicoef n j.
Proof.
  move=> Hjn.
  rewrite /qbicoef.
  rewrite subKn //.
  by rewrite [qfact (n - j) * qfact j] mulrC.
Qed.

Lemma q_pascal n j : (j < n)%N ->
  qfact j.+1 != 0 ->
  qfact (n - j) != 0 ->
  qbicoef n.+1 j.+1 = qbicoef n j +
                 q ^ j.+1 * qbicoef n j.+1.
Proof.
  move=> Hjn Hj0 Hnj0.
  rewrite [LHS] /qbicoef [qfact n.+1] /= (qnat_cat j) // mulrDr -add_div.
    have -> : qfact n * qnat j.+1 / (qfact j.+1 * qfact (n.+1 - j.+1)) =
              qbicoef n j.
      rewrite -mulrA -(mul1r (qnat j.+1)).
      rewrite [qfact j.+1 * qfact (n.+1 - j.+1)] mulrC /=.
      rewrite [qfact (n.+1 - j.+1) * (qfact j * qnat j.+1)] mulrA.
      rewrite red_frac_r //.
        rewrite mul1r subSS.
        by rewrite [qfact (n - j) * qfact j] mulrC.
      by apply qfact_nat_non0.
    rewrite mulrA [qfact n * q ^ j.+1]mulrC subSS -subnSK //.
    rewrite [qfact (n - j.+1).+1] /= mulrA red_frac_r.
      by rewrite mulrA.
    apply qfact_nat_non0.
    rewrite subnSK //.
  by apply mulf_neq0.
Qed.

Fixpoint hoD {A} D n (f : A) := match n with
  | 0 => f
  | n.+1 => D (hoD D n f)
  end.

Notation "D \^ n" := (hoD D n) (at level 49).

Definition islinear (D : {poly R} -> {poly R}) :=
  forall a b f g, D ((a *: f) + (b *: g)) = a *: D f + b *: D g.

Lemma linear_add D f g : islinear D -> D (f + g) = D f + D g.
Proof.
  move=> HlD.
  by rewrite -(scale1r f) -(scale1r g) HlD !scale1r.
Qed.

Lemma linear0 D : islinear D -> D 0 = 0.
Proof.
  move=> HlD.
  by rewrite -(addr0 0) -(scale0r 0%:P) HlD !scale0r.
Qed.

Lemma nth_islinear D n : islinear D -> islinear (D \^ n).
Proof.
  elim: n => [|n IH] //=.
  move=> HlD a b f g.
  by rewrite IH.
Qed.

Lemma linear_distr D n c F : islinear D ->
  D (\sum_(0 <= i < n.+1) c i *: F i) = \sum_(0 <= i < n.+1) c i *: D (F i).
Proof.
  move=> HlD.
  elim: n => [|n IH].
  - rewrite !big_nat1.
    have -> : c 0%N *: F 0%N = c 0%N *: F 0%N + 0 *: 0%:P.
      by rewrite scale0r addr0.
    by rewrite HlD scale0r addr0.
  - rewrite (@big_cat_nat _ _ _ n.+1) //= big_nat1.
    rewrite -(scale1r (\sum_(0 <= i < n.+1) c i *: F i)).
    rewrite HlD scale1r IH.
    by rewrite [RHS](@big_cat_nat _ _ _ n.+1) //= big_nat1.
Qed.

Lemma linear_distr' D j n c F : islinear D -> (j < n)%N ->
  D (\sum_(j.+1 <= i < n.+1) c i *: F i) =
  \sum_(j.+1 <= i < n.+1) c i *: D (F i).
Proof.
  move=> HlD Hjn.
  have Hjn' : (j < n.+1)%N.
    by apply ltnW.
  move: (linear_distr D n c F HlD).
  rewrite (@big_cat_nat _ _ _ j.+1) //=.
  rewrite linear_add // linear_distr //.
  rewrite (@big_cat_nat _ _ _ j.+1 0 n.+1) //=.
  by move /same_addl.
Qed.

Definition isfderiv D (P : nat -> {poly R}) := forall n,
  match n with
  | 0 => (D (P n)) = 0
  | n.+1 => (D (P n.+1)) = P n
  end.

Lemma poly_basis n (P : nat -> {poly R}) (f : {poly R}) :
  (forall m, size (P m) = m.+1) ->
  (size f <= n.+1)%N ->
  exists (c : nat -> R), f = \sum_(0 <= i < n.+1)
          c i *: P i.
Proof.
  elim: n.+1 f => {n} [|n IH] f HP Hf //=.
  - exists (fun i => 0).
    rewrite big_nil.
    move: Hf.
    by rewrite leqn0 -/(nilp f) nil_poly => /eqP.
  - set cn := f`_n / (P n)`_n.
    set f' := f - cn *: P n.
    destruct (IH f') as [c Hc] => //.
      have Hf' : (size f' <= n.+1)%N.
        rewrite /f' -scaleNr.
        move: (size_add f (- cn *: P n)).
        rewrite leq_max.
        move /orP => [H1 | H2].
        + by apply (leq_trans H1 Hf).
        + move: (size_scale_leq (- cn) (P n)).
          move: (HP n) -> => HP'.
          by apply (leq_trans H2 HP').
      have Hf'n : f'`_n = 0.
        rewrite /f' /cn coefB coefZ denomK ?addrK' //.
        have {2}-> : n = n.+1.-1 by [].
        move: (HP n) <-.
        rewrite -lead_coefE.
        case H : (lead_coef (P n) == 0) => //.
        move: H.
        rewrite lead_coef_eq0 -size_poly_eq0.
        by move: (HP n) ->.
      move /leq_sizeP in Hf'.
      have Hf'' : forall j : nat, (n <= j)%N -> f'`_j = 0.
        move=> j.
        rewrite leq_eqVlt.
        move/orP => [/eqP <-|] //.
        by apply Hf'.
      by apply /leq_sizeP.
    exists (fun i => if i == n then cn else c i).
    rewrite big_nat_recr //=.
    under eq_big_nat => i /andP [_].
      rewrite ltn_neqAle => /andP [/negbTE ] -> _.
    over.
    by rewrite -Hc eqxx /f' subrK.
Qed.

Lemma nthisfderiv_pos j D P : isfderiv D P ->
  forall i, (i >= j)%N -> (D \^ j) (P i) = P (i - j)%N.
Proof.
  move=> Hd i.
  elim: j => [|j IH] Hij //=.
  - by rewrite subn0.
  - rewrite IH.
      have -> : (i - j)%N = (i - j.+1)%N.+1.
        rewrite -subSn // subSS.
      by apply (Hd _.+1).
    by apply ltnW.
Qed.

Lemma nthisfderiv_0 j D P : islinear D -> isfderiv D P ->
  forall i, (i < j)%N -> (D \^ j) (P i) = 0.
Proof.
  move=> HlD Hd i.
  elim: j => [|j IH] Hij //=.
  case Hij' : (i == j).
  - move: (Hij') => /eqP ->.
    rewrite nthisfderiv_pos // subnn.
    by apply (Hd 0%N).
  - have Hij'' : (i < j)%N.
      rewrite ltn_neqAle.
      apply /andP; split.
      + by rewrite Hij'.
      + by rewrite -ltnS.
    by rewrite IH // linear0.
Qed.

Theorem general_Taylor D n P (f : {poly R}) a :
  islinear D -> isfderiv D P ->
  (P 0%N).[a] = 1 ->
  (forall n, (P n.+1).[a] = 0) ->
  (forall m, size (P m) = m.+1) ->
  size f = n.+1 ->
  f = \sum_(0 <= i < n.+1)
          ((D \^ i) f).[a] *: P i.
Proof.
  move=> Hl Hd HP0 HP HdP Hdf.
  have Hdf' : (size f <= n.+1)%N.
    by rewrite Hdf leqnn.
  move: (poly_basis n P f HdP Hdf') => [c] Hf.
  have Hc0 : c 0%N = ((D \^ 0) f).[a] => /=.
    rewrite Hf.
    destruct n.
      by rewrite big_nat1 hornerZ HP0 mulr1.
    rewrite hornersumD.
    rewrite (@big_cat_nat _ _ _ 1) //= big_nat1.
    rewrite hornerZ HP0 mulr1.
    have -> : (1 = 0 + 1)%N by [].
    rewrite big_addn subn1 /=.
    under eq_big_nat => i /andP [_ _].
      rewrite hornerZ addn1 HP mulr0.
    over.
    by rewrite big1 // addr0.
  have ithD : forall j, (j.+1 <= n)%N ->
    (D \^ j.+1) f = \sum_(j.+1 <= i < n.+1) c i *: P (i - j.+1)%N.
    move=> j Hj.
    rewrite Hf linear_distr; last by apply nth_islinear.
    rewrite {1}(lock j.+1).
    rewrite (@big_cat_nat _ _ _ j.+1) //=; last by apply leqW.
    rewrite -lock.
    under eq_big_nat => i /andP [_ Hi].
      rewrite nthisfderiv_0 // scaler0.
    over.
    rewrite big1 // add0r.
    by under eq_big_nat => i /andP [Hi _] do rewrite nthisfderiv_pos //.
  have coef : forall j, (j <= n)%N -> c j = ((D \^ j) f).[a].
    move=> j Hj.
    destruct j => //.
    rewrite ithD //.
    rewrite (@big_cat_nat _ _ _ j.+2) //= big_nat1 hornerD.
    rewrite subnn hornerZ HP0 mulr1 hornersumD.
    under eq_big_nat => i /andP [Hi Hi'].
      rewrite hornerZ.
      move: (Hi).
      rewrite -addn1 -leq_subRL //; last by apply ltnW.
      case: (i - j.+1)%N => // k Hk.
      rewrite HP mulr0.
    over.
    by rewrite big1 // addr0.
  rewrite {1}Hf big_nat_cond [RHS]big_nat_cond.
  apply eq_bigr => i /andP [/andP [Hi Hi'] _].
  by rewrite coef.
Qed.

Definition ap_op_poly (D : (R -> R) -> (R -> R)) (p : {poly R}) :=
  D (fun (x : R) => p.[x]).

Notation "D # p" := (ap_op_poly D p) (at level 49).

Definition scale_var (p : {poly R}):= \poly_(i < size p) (q ^ i * p`_i).

Lemma scale_var_scale a p : scale_var (a *: p) = a *: scale_var p.
Proof.
  rewrite /scale_var; apply polyP => j.
  case Ha : (a == 0).
  - move/eqP : Ha ->; rewrite !scale0r.
    by rewrite coef_poly size_poly0 //= coef0.
  - have Ha' : a != 0 by rewrite Ha.
    rewrite size_scale // coefZ !coef_poly.
    case : (j < size p)%N; last by rewrite mulr0.
    by rewrite scalerAr'.
Qed.

Lemma scale_varC c : scale_var c%:P = c%:P.
Proof.
  rewrite /scale_var poly_def.
  rewrite (sumW _ (fun i => (q ^ i * c%:P`_i) *: 'X^i)) size_polyC.
  case Hc : (c == 0) => /=.
  - rewrite big_nil.
    by move /eqP : Hc ->.
  - by rewrite big_nat1 expr0z mul1r coefC /= -mul_polyC mulr1.
Qed.

Lemma scale_var_add p p' : scale_var (p + p') = scale_var p + scale_var p'.
Proof.
  rewrite /scale_var.
  rewrite (polyW' R (p + p') (maxn (size p) (size p'))); last by apply size_add.
  rewrite (polyW' R p (maxn (size p) (size p'))); last by apply leq_maxl.
  rewrite (polyW' R p' (maxn (size p) (size p'))); last by apply leq_maxr.
  rewrite sum_add.
  by under eq_bigr do rewrite coefD mulrDr scalerDl.
Qed.

Lemma scale_var_prodX p : scale_var ('X * p) = scale_var 'X * scale_var p.
Proof.
  case Hp : (p == 0).
    move /eqP : Hp ->.
    by rewrite mulr0 scale_varC mulr0.
  rewrite /scale_var !poly_def.
  rewrite (sumW _ (fun i => (q ^ i * ('X * p)`_i) *: 'X^i)).
  rewrite (sumW _ (fun i => (q ^ i * 'X`_i) *: 'X^i)).
  rewrite (sumW _ (fun i => (q ^ i * p`_i) *: 'X^i)).
  rewrite size_polyX.
  rewrite (@big_cat_nat  _ _ _ 1 _ 2) //= !big_nat1.
  rewrite !coefX /= mulr0 scale0r add0r expr1z mulr1.
  rewrite -sum_distr.
  have -> : size ('X * p) = (size p).+1.
    by rewrite mulrC size_mulX ?Hp.
  rewrite (@big_cat_nat _ _ _ 1) //= !big_nat1.
  rewrite coefXM /= mulr0 scale0r add0r.
  have -> : (1 = 0 + 1)%N by [].
  rewrite big_addn subn1 /=.
  under eq_big_nat => i /andP [] _ Hi.
    rewrite coefXM addn1 /= exprSzr -mulrA [q * p`_i]mulrC mulrA.
    rewrite -scalerA exprSr scalerAr -{2}(expr1 'X) -(add0n 1%N) scalerAl.
  over.
  done.
Qed.

Lemma scale_var_prod (p p' : {poly R}) :
  scale_var (p * p') = scale_var p * scale_var p'.
Proof.
  pose n := size p.
  have : (size p <= n)%N by [].
  clearbody n.
  have Hp0 : forall (p : {poly R}), size p = 0%N ->
    scale_var (p * p') = scale_var p * scale_var p'.
    move=> p0 /eqP.
    rewrite size_poly_eq0.
    move/eqP ->.
    by rewrite mul0r scale_varC mul0r.
  elim: n p => [|n IH] p Hsize.
    move: Hsize.
    rewrite leqn0 => /eqP.
    by apply Hp0.
  case Hp : (size p == 0%N).
    rewrite Hp0 //.
    by apply/eqP.
  have -> : p = p - (p`_0)%:P + (p`_0)%:P by rewrite subrK.
  set p1 := (\poly_(i < (size p).-1) p`_i.+1).
  have -> : p - (p`_0)%:P = 'X * p1.
    rewrite -{1}(coefK p) poly_def.
    rewrite (sumW _ (fun i => p`_i *: 'X^i)).
    rewrite (@big_cat_nat _ _ _ 1) //=; last by apply neq0_lt0n.
    rewrite big_nat1 -mul_polyC mulr1 (addrC (p`_0)%:P) addrK.
    have -> : (1 = 0 + 1)%N by [].
    rewrite big_addn subn1.
    under eq_bigr do rewrite addn1 exprSr scalerAl.
    by rewrite sum_distr /p1 poly_def -sumW.
  rewrite mulrDl [LHS]scale_var_add mul_polyC scale_var_scale -mulrA scale_var_prodX.
  have -> : scale_var (p1 * p') = scale_var p1 * scale_var p'.
    rewrite IH //.
    apply (@leq_trans (size p).-1).
      apply size_poly.
    rewrite -(leq_add2r 1).
    have -> : ((size p).-1 + 1 = size p)%N.
      rewrite addn1 prednK //.
      by apply neq0_lt0n.
    by rewrite addn1.
  by rewrite mulrA -scale_var_prodX -mul_polyC -mulrDl -{1}scale_varC -scale_var_add.
Qed.

Lemma scale_varX a : scale_var ('X - a%:P) = q *: 'X - a%:P.
Proof.
  rewrite /scale_var poly_def size_XsubC.
  rewrite (sumW _ (fun i => (q ^ i * ('X - a%:P)`_i) *: 'X^i)).
  rewrite (@big_cat_nat _ _ _ 1) //= !big_nat1.
  rewrite addrC expr1z expr0z !coefB !coefX !coefC /=.
  by rewrite subr0 sub0r mulrN mulr1 mul1r scale_constpoly mulr1 polyCN.
Qed.

Lemma scale_varXn n : scale_var ('X ^+ n) = (q ^ n) *: 'X ^+ n.
Proof.
  rewrite /scale_var poly_def size_polyXn.
  rewrite (sumW _ (fun i => (q ^ i * 'X^n`_i) *: 'X^i)).
  rewrite (@big_cat_nat _ _ _ n) //= big_nat1 coefXn.
  have -> : (eq_op n n) => //=.
  rewrite mulr1.
  under eq_big_nat => i /andP [] _ Hi.
    rewrite coefXn.
    have -> : (eq_op i n) = false => /=.
    by apply ltn_eqF.
    rewrite -mul_polyC mulr0 polyC0 mul0r.
  over.
  by rewrite big1 ?add0r.
Qed.

Definition dqp p := scale_var p - p.

Lemma dqppXE p : dqp p = 'X * \poly_(i < size p) ((q ^ i.+1 - 1) * p`_i.+1).
Proof.
  rewrite /dqp /scale_var.
  rewrite -{3}(coefK p).
  rewrite !poly_def.
  rewrite (sumW _ (fun i => (q ^ i * p`_i) *: 'X^i)).
  rewrite (sumW _ (fun i => (p`_i *: 'X^i))).
  rewrite (sumW _ (fun i => (((q ^ i.+1 - 1) * p`_i.+1) *: 'X^i))).
  rewrite sum_sub.
  case Hsize : (size p == 0%N).
  - move /eqP : Hsize ->.
    by rewrite !big_nil mulr0.
  - rewrite (@big_cat_nat _ _ _ 1) //=; last by apply size_N0_lt.
    rewrite big_nat1 expr0z mul1r addrK' add0r.
    have -> : (1 = 0 + 1)%N by [].
    rewrite big_addn -sum_distr.
    rewrite [RHS](@big_cat_nat _ _ _ (size p - 1)) //=; last by rewrite subn1 leq_pred.
    have {4}-> : size p = ((size p) - 1).+1.
      rewrite subn1 prednK //.
      by apply size_N0_lt.
    rewrite big_nat1.
    have -> : p`_(size p - 1).+1 = 0.
      rewrite subn1 prednK //.
        by apply /(leq_sizeP _ (size p)) => //=.
      by apply size_N0_lt.
    rewrite mulr0 scale0r mul0r addr0.
    under eq_bigr => i _.
      rewrite -scalerBl addn1 -{2}(mul1r p`_i.+1) -mulrBl exprSr scalerAl.
    over.
    by move=> /=.
Qed.

Lemma dqp_prod' p p' : dqp (p * p') = p * dqp p' + scale_var p' * dqp p.
Proof.
  rewrite /dqp.
  rewrite scale_var_prod // !mulrBr [RHS]addrC addrA.
  f_equal.
  rewrite -addrA [- (scale_var p' * p) + p * scale_var p']addrC.
  by rewrite [p * scale_var p']mulrC addrK' addr0 mulrC.
Qed.

Lemma dqpXE : dqp 'X = (q - 1) *: 'X.
Proof.
  rewrite /dqp /scale_var.
  rewrite poly_def size_polyX.
  rewrite (sumW _ (fun i => (q ^ i * 'X`_i) *: 'X^i)).
  rewrite (@big_cat_nat _ _ _ 1) //= !big_nat1.
  rewrite !coefX /=.
  by rewrite mulr0 scale0r add0r expr1z mulr1 scalerBl scale1r.
Qed.

Lemma dqp_dqE p x : (dqp p).[x] = (dq # p) x.
Proof.
  rewrite /dqp /scale_var /(_ # _) /dq.
  rewrite hornerD hornerN.
  f_equal.
  rewrite -{3}(coefK p).
  rewrite !horner_poly.
  have -> : \sum_(i < size p) q ^ i * p`_i * x ^+ i =
            \sum_(0 <= i < size p) q ^ i * p`_i * x ^+ i.
    by rewrite big_mkord.
  rewrite (sumW _ (fun i => p`_i * (q * x) ^+ i)).
  apply esym.
  under eq_big_nat => i /andP [] Hi _.
    rewrite exprMn_comm ?mulrA ?[p`_i * q ^+ i]mulrC.
  over.
    by rewrite /GRing.comm mulrC.
  done.
Qed.

Definition Dqp p := dqp p %/ dqp 'X.

Lemma Dqp_ok p : dqp 'X %| dqp p.
Proof. by rewrite dqpXE dvdpZl ?dqppXE ?dvdp_mulIl. Qed.

Local Notation tofrac := (@tofrac [idomainType of {poly R}]).
Local Notation "x %:F" := (tofrac x).

Theorem Dqp_ok_frac p : (dqp p)%:F / (dqp 'X)%:F = (Dqp p)%:F.
Proof.
Locate tofrac_eq.
  have Hn0 : (dqp 'X)%:F != 0.
    rewrite tofrac_eq dqpXE lreg_polyZ_eq0 ?polyX_eq0 //.
    rewrite /(GRing.lreg) /(injective) => x y.
    rewrite mulrC (mulrC (q - 1)).
    by apply same_prod.
  apply (frac_same_prod _ _ _ (dqp 'X)%:F) => //.
  rewrite [LHS]mulC mulA (mulC ((dqp 'X))%:F) -mulA.
  rewrite (mulC ((dqp 'X))%:F) mulV_l // mulC mul1_l.
  rewrite /(Dqp) -tofracM.
  apply /eqP.
  rewrite tofrac_eq.
  apply /eqP.
  by rewrite divpK ?Dqp_ok.
Qed.

Lemma DqpE' p : Dqp p = dqp p %/ ((q - 1) *: 'X).
Proof. by rewrite /Dqp dqpXE. Qed.

Lemma Dqp_prod' p p' : Dqp (p * p') = p * Dqp p' + scale_var p' * Dqp p.
Proof.
  rewrite /Dqp !divp_mulA ?Dqp_ok //.
  by rewrite -divpD dqp_prod'.
Qed.

Lemma Dqp_const c : Dqp c%:P = 0%:P.
Proof.
  rewrite /Dqp.
  have -> : dqp c%:P = 0.
    rewrite /dqp /scale_var poly_def size_polyC.
    rewrite (sumW _ (fun i => (q ^ i * c%:P`_i) *: 'X^i)).
    case Hc : (c != 0) => /=.
    - rewrite big_nat1.
      rewrite expr0z mul1r.
      have -> : 'X^0 = 1%:P by [].
      by rewrite coefC /= polyC1 alg_polyC addrK'.
    - rewrite big_nil.
      move: Hc.
      rewrite /(_ != 0) /=.
      case Hc : (c == 0) => //= _.
      move/ eqP : Hc ->.
      by rewrite polyC0 subr0.
    by rewrite div0p.
Qed.

Definition Dqp' (p : {poly R}) := \poly_(i < size p) (qnat (i.+1) * p`_i.+1).

Lemma Dqp_Dqp'E p : Dqp p = Dqp' p.
Proof.
  case Hsize : (size p == 0%N).
  - move: Hsize.
    rewrite size_poly_eq0 => /eqP ->.
    rewrite Dqp_const.
    rewrite /Dqp' poly_def.
    rewrite (sumW _ (fun i => (qnat i.+1 * 0%:P`_i.+1) *: 'X^i)).
    by rewrite size_poly0 big_nil.
  - rewrite DqpE' /dqp /scale_var /Dqp' -{3}(coefK p) !poly_def.
    rewrite (sumW _ (fun i => (q ^ i * p`_i) *: 'X^i)).
    rewrite (sumW _ (fun i => p`_i *: 'X^i)).
    rewrite (sumW _ (fun i => (qnat i.+1 * p`_i.+1) *: 'X^i)).
    rewrite sum_sub.
    rewrite divpsum.
    under eq_bigr => i _.
      rewrite -scalerBl -{2}(mul1r p`_i) -mulrBl scale_div //.
      have -> : (q ^ i - 1) * p`_i / (q - 1) = (q ^ i - 1) / (q - 1) * p`_i.
        by rewrite -mulrA [p`_i / (q - 1)]mulrC mulrA.
      rewrite -/(qnat i).
    over.
    move=> /=.
    rewrite (@big_cat_nat _ _ _ 1) //=; last by apply size_N0_lt.
    rewrite big_nat1 qnat0 mul0r scale0r add0r.
    have -> : (1 = 0 + 1)%N by [].
    rewrite big_addn.
    under eq_bigr do rewrite addn1 polyX_div.
    rewrite (@big_cat_nat _ _ _ (size p - 1) 0 (size p)) //=; last by rewrite subn1 leq_pred.
    have {4}-> : size p = ((size p) - 1).+1.
      rewrite subn1 prednK //.
      by apply size_N0_lt.
    rewrite big_nat1.
    have -> : p`_(size p - 1).+1 = 0.
      rewrite subn1 prednK //.
        by apply /(leq_sizeP _ (size p)) => //=.
      by apply size_N0_lt.
    by rewrite mulr0 scale0r addr0.
Qed.

Lemma hoDqp_Dqp'E n p :
  (Dqp \^ n) p = ((Dqp' \^ n) p).
Proof.
  elim: n => [|n IH] //=.
  by rewrite Dqp_Dqp'E IH.
Qed.

Lemma Dqp'_prod' p p' :
   Dqp' (p * p') = p * Dqp' p' + scale_var p' * Dqp' p.
Proof. by rewrite -!Dqp_Dqp'E Dqp_prod'. Qed.

Lemma Dqp'_DqE p x : x != 0 -> (Dqp' p).[x] = (Dq # p) x.
Proof.
  move=> Hx.
  rewrite /Dqp' /(_ # _) /Dq /dq.
  rewrite horner_poly !horner_coef.
  rewrite (sumW _ (fun i => (qnat i.+1 * p`_i.+1 * x ^+ i))).
  rewrite (sumW _ (fun i => p`_i * (q * x) ^+ i)).
  rewrite (sumW _ (fun i => p`_i * x ^+ i)).
  rewrite sum_sub.
  case Hsize : (size p == 0%N).
  - rewrite size_poly_eq0 in Hsize.
    move/eqP : (Hsize) ->.
    by rewrite size_poly0 !big_nil mul0r.
  - have Hsize' : (0 < size p)%N.
      rewrite ltn_neqAle.
      apply /andP; split => //.
      move: Hsize.
      by rewrite eq_sym => ->.
    rewrite mulrC -sum_distr.
    rewrite [RHS](@big_cat_nat _ _ _ 1 0 (size p)) //=.
    rewrite !big_nat1 !expr0 addrK' mul0r add0r.
    have -> : (1 = 0 + 1)%N by [].
    rewrite big_addn.
    rewrite (@big_cat_nat _ _ _ (size p - 1)) //=.
      have -> : \sum_(size p - 1 <= i < size p)
                  qnat i.+1 * p`_i.+1 * x ^+ i = 0.
        under eq_big_nat => i /andP [Hi Hi'].
          move : Hi.
          rewrite leq_subLR addnC addn1.
          move/leq_sizeP -> => //.
          rewrite mulr0 mul0r.
        over.
        by rewrite big1.
      rewrite addr0.
      apply eq_big_nat => i /andP [Hi Hi'].
      rewrite addn1 /qnat.
      have -> : (q * x) ^+ i.+1 = (q * x) ^ (Posz i.+1) by [].
      have -> : x ^+ i.+1 = 1 * x ^+ i.+1.
        by rewrite mul1r.
      have {5}-> : x = 1 * x.
        by rewrite mul1r.
      rewrite expfzMl -mulrBr -!mulrBl -mulf_div -!mulrA.
      rewrite [p`_i.+1 * x ^+ i]mulrC [RHS]mulrC !mulrA.
      congr (_ * _).
      rewrite [(q - 1)^-1 * (q ^ i.+1 - 1)]mulrC -!mulrA.
      congr (_ * _).
      congr (_ * _).
      by rewrite exprSzr -mulrA divff // mulr1.
    by rewrite leq_subLR.
Qed.

Lemma hoDqp'_DqE p x n : q != 0 -> x != 0 ->
  ((Dqp' \^ n) p).[x] = ((Dq \^ n) # p) x.
Proof.
  move=> Hq0 Hx.
  rewrite /(_ # _).
  elim: n x Hx => [|n IH] x Hx //=.
  rewrite Dqp'_DqE // {2}/Dq /dq -!IH //.
  by apply mulf_neq0 => //.
Qed.

Lemma Dqp'_islinear_add (p p' : {poly R}) : Dqp' (p + p') = Dqp' p + Dqp' p'.
Proof.
  rewrite /Dqp'.
  rewrite (polyW R (p + p') (maxn (size p) (size p'))); last apply size_add.
  rewrite (polyW R p (maxn (size p) (size p'))); last by apply leq_maxl.
  rewrite (polyW R p' (maxn (size p) (size p'))); last by apply leq_maxr.
  rewrite sum_add.
  by under eq_bigr do rewrite coefD mulrDr scalerDl.
Qed.

Lemma Dqp'_islinear_scale a p : Dqp' (a *: p) = a *: Dqp' p.
Proof.
  rewrite /Dqp'; apply polyP => j.
  case Ha : (a == 0).
  - move/eqP : Ha ->; rewrite !scale0r.
    by rewrite coef_poly size_poly0 //= coef0.
  - have Ha' : a != 0 by rewrite Ha.
    rewrite size_scale // coefZ !coef_poly.
    case : (j < size p)%N.
    + by rewrite scalerAr'.
    + by rewrite mulr0.
Qed.

Lemma Dqp'_islinear : islinear Dqp'.
Proof.
  move=> a b p p'.
  by rewrite Dqp'_islinear_add !Dqp'_islinear_scale.
Qed.

Lemma Dqp'_const a : Dqp' a%:P = 0.
Proof. by rewrite -Dqp_Dqp'E Dqp_const. Qed.

Lemma Dqp'X : Dqp' 'X = 1%:P.
Proof.
  rewrite /Dqp' poly_def size_polyX.
  rewrite (sumW _ (fun i => (qnat i.+1 * 'X`_i.+1) *: 'X^i)).
  rewrite (@big_cat_nat _ _ _ 1) //= !big_nat1.
  by rewrite !coefX /= mulr0 scale0r !qnat1 mulr1 scale1r addr0.
Qed.

Lemma Dqp'Xsub a : Dqp' ('X - a%:P) = 1%:P.
Proof. by rewrite Dqp'_islinear_add -polyCN Dqp'_const addr0 Dqp'X. Qed.

Lemma Dqp'_pow n : Dqp' ('X^n.+1) = (qnat n.+1) *: 'X^n.
Proof.
  elim: n => [|n IH].
  - by rewrite Dqp'X qnat1 scale1r.
  - rewrite exprS Dqp'_prod' IH Dqp'X mulrC.
    rewrite -mul_polyC -mulrA mul_polyC -exprSzr.
    rewrite [scale_var ('X^n.+1) * 1%:P]mulrC.
    by rewrite mul_polyC scale1r scale_varXn -scalerDl -qnat_catn.
Qed.

Fixpoint qbinom_pos_poly a n := match n with
  | 0 => 1
  | n.+1 => (qbinom_pos_poly a n) * ('X - (q ^ n * a)%:P)
  end.

Lemma qbinom_size a n : size (qbinom_pos_poly a n) = n.+1.
Proof.
  elim: n => [|n IH] => //=.
  - by rewrite size_poly1.
  - rewrite size_Mmonic.
        by rewrite IH size_XsubC addn2.
      by rewrite -size_poly_gt0 IH.
    by apply monicXsubC.
Qed.

Lemma qbinom_posE a n x :
  qbinom_pos a n x = (qbinom_pos_poly a n).[x].
Proof.
  elim: n => [|n IH] //=.
  - by rewrite hornerC.
  - by rewrite hornerM -IH hornerXsubC.
Qed.

Lemma Dqp'_qbinom_poly a n :
  Dqp' (qbinom_pos_poly a n.+1) = (qnat n.+1) *: (qbinom_pos_poly a n).
Proof.
  elim: n => [|n IH].
  - rewrite /qbinom_pos_poly.
    rewrite expr0z !mul1r /Dqp'.
    rewrite poly_def.
    have -> : size ('X - a%:P) = 2%N.
      by rewrite size_XsubC.
    have -> : \sum_(i < 2) (qnat i.+1 * ('X - a%:P)`_i.+1) *: 'X^i =
              \sum_(0 <= i < 2) (qnat i.+1 * ('X - a%:P)`_i.+1) *: 'X^i.
      by rewrite big_mkord.
    rewrite (@big_cat_nat _ _ _ 1) //= !big_nat1.
    rewrite !coefB !coefC /= !subr0.
    by rewrite !coefX /= scale_constpoly !mulr1 mulr0 scale0r addr0 alg_polyC.
  - have -> : qbinom_pos_poly a n.+2 =
              (qbinom_pos_poly a n.+1) * ('X - (q ^ n.+1 * a)%:P) by [].
    rewrite Dqp'_prod' Dqp'Xsub mulr1 scale_varX IH.
    rewrite exprSz -mulrA -scale_constpoly -scalerBr.
    rewrite -!mul_polyC mulrA mulrC23 -mulrA.
    rewrite [('X - (q ^ n * a)%:P) * qbinom_pos_poly a n]mulrC.
    rewrite -/(qbinom_pos_poly a n.+1).
    rewrite (mul_polyC q) scale_constpoly (mul_polyC (q * qnat n.+1)).
    rewrite -{1}(scale1r (qbinom_pos_poly a n.+1)) -scalerDl.
    by rewrite mul_polyC -qnat_cat1.
Qed.

Lemma Dqp'_isfderiv a : (forall n, qfact n != 0) ->
  isfderiv Dqp' (fun i : nat => qbinom_pos_poly a i / (qfact i)%:P).
Proof.
  move=> Hqnat.
  rewrite /isfderiv.
  destruct n => //.
  - have -> : (GRing.one (poly_ringType R) / 1%:P) = 1%:P.
      by rewrite polyCV mul1r invr1.
    rewrite /Dqp' (polyW _ _ 1).
      rewrite big_nat1.
      by rewrite coefC /= mulr0 scale0r.
    by apply size_polyC_leq1.
  - have -> : qbinom_pos_poly a n.+1 / (qfact n.+1)%:P =
              (qfact n.+1)^-1 *: qbinom_pos_poly a n.+1.
      by rewrite mulrC polyCV mul_polyC.
    rewrite Dqp'_islinear_scale -mul_polyC mulrC.
    rewrite Dqp'_qbinom_poly -mul_polyC.
    rewrite [(qnat n.+1)%:P * qbinom_pos_poly a n]mulrC.
    rewrite -polyCV -mulrA.
    f_equal.
    rewrite polyCV mul_polyC.
    rewrite scale_constpoly /=.
    rewrite -{1}(mul1r (qnat n.+1)).
    rewrite red_frac_r ?mul1r ?polyCV //.
    by apply qfact_nat_non0.
Qed.

Theorem q_Taylorp n (f : {poly R}) c :
  (forall n, qfact n != 0) ->
  size f = n.+1 ->
  f =
    \sum_(0 <= i < n.+1)
   ((Dqp' \^ i) f).[c] *: (qbinom_pos_poly c i / (qfact i)%:P).
Proof.
  move=> Hfact Hsizef.
  apply general_Taylor => //.
  - by apply Dqp'_islinear.
  - by apply Dqp'_isfderiv.
  - by rewrite invr1 mulr1 hornerC.
  - move=> m.
    by rewrite hornerM -qbinom_posE qbinomxa mul0r.
  - move=> m.
    rewrite polyCV mulrC size_Cmul.
      by rewrite qbinom_size.
    by apply /invr_neq0.
Qed.

Theorem q_Taylor n (f : {poly R}) x c :
  q != 0 ->
  c != 0 ->
  (forall n, qfact n != 0) ->
  size f = n.+1 ->
  f.[x] =  \sum_(0 <= i < n.+1)
             ((Dq \^ i) # f) c * qbinom_pos c i x / qfact i.
Proof.
  move=> Hq0 Ha Hfact Hsf.
  under eq_bigr do rewrite qbinom_posE.
  rewrite sum_poly_div.
  under eq_bigr do rewrite -hornerZ.
  rewrite -hornersumD.
  f_equal.
  under eq_bigr do rewrite -hoDqp'_DqE //.
  by apply q_Taylorp.
Qed.

Lemma hoDqp'_pow n j : qfact n != 0 -> (j <= n)%N ->
  (Dqp' \^ j) 'X^n = (qbicoef n j * qfact j) *: 'X^(n - j).
Proof.
  move=> Hn.
  elim: j => [|j IH] Hj /=.
  - by rewrite qbicoefn0 ?mul1r ?scale1r ?subn0.
  - rewrite IH; last by apply ltnW.
    rewrite Dqp'_islinear_scale.
    have -> : (n - j = (n - j.+1).+1)%N by rewrite subnSK.
    rewrite Dqp'_pow -mul_polyC -mul_polyC mulrA -[RHS]mul_polyC.
    f_equal.
    rewrite mul_polyC scale_constpoly.
    f_equal.
    by rewrite qbicoef_compute //.
Qed.

Lemma hoDqp'_pow1 n j : qfact n != 0 -> (j <= n)%N ->
  ((Dqp' \^ j) 'X^n).[1] = (qbicoef n j * qfact j).
Proof.
  move=> Hn Hj.
  by rewrite hoDqp'_pow // hornerZ hornerXn expr1n mulr1.
Qed.

Lemma q_Taylorp_pow n : (forall n, qfact n != 0) ->
  'X^n = \sum_(0 <= i < n.+1) (qbicoef n i *: qbinom_pos_poly 1 i).
Proof.
  move=> Hfact.
  rewrite (q_Taylorp n 'X^n 1) //; last by rewrite size_polyXn.
  under eq_big_nat => i /andP [_ Hi].
    rewrite hoDqp'_pow1 //.
    rewrite [(qbinom_pos_poly 1 i / (qfact i)%:P)]mulrC.
    rewrite polyCV scalerAl scale_constpoly -mulrA divff //.
    rewrite mulr1 mul_polyC.
  over.
  done.
Qed.

(* Lemma q_Taylor_pow x n : (forall n, qfact n != 0) ->
  x ^+ n = \sum_(0 <= i < n.+1) (qbicoef n i * qbinom_pos 1 i x). *)

Lemma hoDqp'_qbinom n j a : qfact n != 0 -> (j <= n)%N ->
  (Dqp' \^ j) (qbinom_pos_poly (- a) n) =
  (qbicoef n j * qfact j) *: (qbinom_pos_poly (-a) (n - j)).
Proof.
  move=> Hfact.
  elim: j => [|j IH] Hj /=.
  - by rewrite subn0 qbicoefn0 ?mulr1 ?scale1r.
  - rewrite IH; last by apply ltnW.
    rewrite Dqp'_islinear_scale.
    have -> : (n - j = (n - j.+1).+1)%N by rewrite subnSK.
    rewrite Dqp'_qbinom_poly -mul_polyC -mul_polyC mulrA -[RHS]mul_polyC.
    f_equal.
    rewrite mul_polyC scale_constpoly.
    f_equal.
    by rewrite qbicoef_compute //.
Qed.

Lemma qbinom_pos_qbinom0 a n :
  (qbinom_pos_poly (- a) n).[0] = q ^+ (n * (n - 1))./2 * a ^+ n.
Proof. by rewrite -qbinom_posE qbinomx0. Qed.

Lemma hoDqp'_qbinom0 n j a : qfact n != 0 -> (j <= n)%N ->
  ((Dqp' \^ j) (qbinom_pos_poly (- a) n)).[0] =
  (qbicoef n j * qfact j) *
   q ^+ ((n - j) * (n - j - 1))./2 * a ^+ (n - j).
Proof.
  move=> Hfact Hj.
  by rewrite hoDqp'_qbinom // hornerZ qbinom_pos_qbinom0 mulrA.
Qed.

Lemma qbinom_x0 n : qbinom_pos_poly 0 n = 'X^n.
Proof.
  elim: n => [|n IH] /=.
  - by rewrite expr0.
  - by rewrite IH mulr0 subr0 exprSr.
Qed.

Theorem Gauss_binomial a n : (forall n, qfact n != 0) ->
  qbinom_pos_poly (-a) n =
  \sum_(0 <= i < n.+1)
    (qbicoef n i * q ^+ (i * (i - 1))./2 * a ^+ i) *: 'X^(n - i).
Proof.
  move=> Hfact.
  rewrite big_nat_rev //=.
  under eq_big_nat => i /andP [_ Hi].
    rewrite add0n subSS subKn // qbicoefE //.
  over.
  rewrite (q_Taylorp n (qbinom_pos_poly (-a) n) 0) //; last by rewrite qbinom_size.
  under eq_big_nat => i /andP [_ Hi].
    rewrite hoDqp'_qbinom0 //.
    rewrite [(qbinom_pos_poly 0 i / (qfact i)%:P)]mulrC.
    rewrite polyCV scalerAl scale_constpoly.
    have -> : qbicoef n i * qfact i * q ^+ ((n - i) * (n - i - 1))./2 *
              a ^+ (n - i) / qfact i =
              qbicoef n i * q ^+ ((n - i) * (n - i - 1))./2 * a ^+ (n - i).
      rewrite -!mulrA; f_equal; f_equal.
      rewrite mulrC -mulrA; f_equal.
      by rewrite denomK.
    rewrite mul_polyC qbinom_x0.
  over.
  done.
Qed.

Lemma Gauss_binomialf a n x : (forall n, qfact n != 0) ->
  qbinom_pos (-a) n x =
  \sum_(0 <= i < n.+1)
    (qbicoef n i * q ^+ (i * (i - 1))./2 * a ^+ i) * x ^+ (n - i).
Proof.
  move=> Hfact.
  rewrite qbinom_posE Gauss_binomial // hornersumD.
  by under eq_big_nat do rewrite hornerZ hornerXn.
Qed.

End q_analogue.

Section q_chain_rule.
Local Open Scope ring_scope.
Variable (R : rcfType).

Lemma qchain q u f a b x : dq R q u x != 0 -> u = (fun x => a * x ^ b) ->
  Dq R q (f \o u) x = (Dq R (q^b) f (u x)) * (Dq R q u x).
Proof.
  move=> Hqu Hu.
  rewrite Hu /Dq /dq mulf_div /=.
  rewrite [(q ^ b * (a * x ^ b) - a * x ^ b) * (q * x - x)] mulrC.
  rewrite expfzMl !mulrA.
  rewrite [a * q ^ b] mulrC.
  rewrite red_frac_r //.
  move: Hqu.
  by rewrite /dq Hu expfzMl mulrA mulrC.
Qed.
End q_chain_rule.