(**
Here we define the signature for the coequalizer.
Given 1-types `A` and `B` together with maps `f, g : A → B`, the coequalizer is defined as the following HIT

HIT Coeq(f, g) :=
| base : B → Coeq(f, g)
| glue : ∏ (a : A), base (f a) = base (g a)
In addition, this type is required to be 1-truncated.
 *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Groupoids.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.
Require Import UniMath.Bicategories.Colimits.Initial.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.DispDepProd.

Require Import UniMath.Algebra.Monoids.
Require Import UniMath.Algebra.Groups.

Require Import prelude.all.
Require Import signature.hit_signature.
Require Import signature.hit.
Require Import algebra.one_types_polynomials.
Require Import algebra.one_types_endpoints.
Require Import algebra.one_types_homotopies.
Require Import displayed_algebras.displayed_algebra.
Require Import initial_grpd_alg.W_poly.
Require Import initial_grpd_alg.initial_groupoid_algebra.
Require Import existence.hit_existence.
Require Import existence.initial_algebra.

Local Open Scope cat.

Section HomotopyCoeq.
  Context (A B : one_type)
          (f g : A → B).

  Definition coeq_point_constr
    : poly_code
    := C B.

  Definition coeq_signature
    : hit_signature.
  Proof.
    simple refine (_ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _  ,, _ ,, _ ,, _ ,, _).
    - exact coeq_point_constr.
    - exact unit.
    - exact (λ _, C A).
    - exact (λ _, comp (fmap f) constr).
    - exact (λ _, comp (fmap g) constr).
    - exact empty.
    - exact fromempty.
    - exact fromempty.
    - intro x ; induction x.
    - intro x ; induction x.
    - intro x ; induction x.
    - intro x ; induction x.
    - intro x ; induction x.
    - intro x ; induction x.
  Defined.

  (** Projections of coeq algebra *)
  Section CoeqProjections.
    Variable (X : hit_algebra_one_types coeq_signature).

    Definition coeq_base
      : B → alg_carrier X
      := alg_constr X.

    Definition coeq_glue
               (a : A)
      : coeq_base (f a) = coeq_base (g a)
      := alg_path X tt a.
  End CoeqProjections.

  (** Builder for coequalizer algebra *)
  Section CoeqAlgebraBuilder.
    Context {X : one_type}
            (base : B → X)
            (glue : ∏ (a : A), base (f a) = base (g a)).

    Local Definition make_coeq_path_algebra
      : hit_path_algebra_one_types coeq_signature.
    Proof.
      use make_hit_path_algebra.
      - use make_hit_prealgebra.
        + exact X.
        + apply one_type_isofhlevel.
        + exact base.
      - intro j.
        exact glue.
    Defined.

    Local Definition make_coeq_is_algebra
      : is_hit_algebra_one_types coeq_signature make_coeq_path_algebra.
    Proof.
      intros j; induction j.
    Qed.

    Definition make_coeq_algebra
      : hit_algebra_one_types coeq_signature.
    Proof.
      use make_algebra.
      - exact make_coeq_path_algebra.
      - exact make_coeq_is_algebra.
    Defined.
  End CoeqAlgebraBuilder.

  (** Projections for the 1-cells *)
  Section CoeqMapProjections.
    Context {X Y : hit_algebra_one_types coeq_signature}
            (φ : X --> Y).

    Definition coeq_map
      : alg_carrier X → alg_carrier Y
      := pr111 φ.

    Definition coeq_map_base
               (b : B)
      : coeq_map (coeq_base X b) = coeq_base Y b
      := pr1 (pr211 φ) b.

    Definition coeq_map_glue
               (a : A)
      : maponpaths coeq_map (coeq_glue X a) @ coeq_map_base (g a)
        =
        coeq_map_base (f a) @ coeq_glue Y a.
    Proof.
      refine (_ @ eqtohomot (pr21 φ tt) a @ _)
      ; simpl ; cbn ; unfold homotcomp, homotfun, funhomotsec.
      - apply maponpaths.
        exact (!(pathscomp0rid _)).
      - apply maponpaths_2.
        apply pathscomp0rid.
    Qed.
  End CoeqMapProjections.

  (** Builder for the 1-cells *)
  Section CoeqMapBuilder.
    Context {X Y : hit_algebra_one_types coeq_signature}
            (φ : alg_carrier X → alg_carrier Y)
            (φ_base : ∏ (b : B), φ (coeq_base X b) = coeq_base Y b)
            (φ_glue : ∏ (a : A),
                      maponpaths φ (coeq_glue X a) @ φ_base (g a)
                      =
                      φ_base (f a) @ coeq_glue Y a).

    Definition make_coeq_map
      : X --> Y.
    Proof.
      use make_algebra_map.
      use make_hit_path_alg_map.
      - use make_hit_prealgebra_mor.
        + exact φ.
        + exact φ_base.
      - intros j a.
        induction j.
        refine (path_assoc _ _ _ @ _).
        refine (pathscomp0rid _ @ _).
        refine (_ @ maponpaths (λ x, x @ (pr21 Y) tt a) (!(pathscomp0rid _))).
        exact (φ_glue a).
    Defined.
  End CoeqMapBuilder.

  (** Projections for the 2-cells *)
  Section CoeqCellProjections.
    Context {X Y : hit_algebra_one_types coeq_signature}
            {φ ψ : X --> Y}
            (α : φ ==> ψ).

    Definition coeq_cell
      : coeq_map φ ~ coeq_map ψ
      := pr111 α.

    Definition coeq_cell_base
               (b : B)
      : coeq_cell (coeq_base X b) @ coeq_map_base ψ b
        =
        coeq_map_base φ b.
    Proof.
      exact (eqtohomot (pr211 α) _ @ pathscomp0rid _).
    Qed.
  End CoeqCellProjections.

  (** Builder for the 2-cells *)
  Section CoeqCellBuilder.
    Context {X Y : hit_algebra_one_types coeq_signature}
            {φ ψ : X --> Y}
            (α : coeq_map φ ~ coeq_map ψ)
            (α_base : ∏ (b : B),
                      α (coeq_base X b) @ coeq_map_base ψ b
                      =
                      coeq_map_base φ b).

    Definition make_coeq_cell
      : φ ==> ψ.
    Proof.
      simple refine (((α ,, _) ,, λ _, tt) ,, tt).
      abstract
        (use funextsec ; intro b;
         exact (α_base b @ !(pathscomp0rid _))).
    Defined.
  End CoeqCellBuilder.

  (** Coeq induction *)
  Section CoeqInduction.
    Context {X : hit_algebra_one_types coeq_signature}
            (Y : alg_carrier X → one_type)
            (Ybase : ∏ (b : B), Y (coeq_base X b))
            (Yglue : ∏ (a : A),
                     @PathOver
                       _ _ _
                       (coeq_glue X a)
                       Y
                       (Ybase (f a)) (Ybase (g a))).

    Definition make_coeq_disp_algebra
      : disp_algebra X.
    Proof.
      use make_disp_algebra.
      - exact Y.
      - intros x xx.
        exact (Ybase x).
      - intros j x y.
        induction j.
        exact (Yglue x).
      - intro j.
        induction j.
    Defined.

    Variable (HX : is_HIT coeq_signature X).

    (** Induction principle *)
    Definition coeq_ind_disp_algebra_map
      : disp_algebra_map make_coeq_disp_algebra
      := HX make_coeq_disp_algebra.

    Definition coeq_ind
      : ∏ (x : alg_carrier X), Y x
      := pr1 coeq_ind_disp_algebra_map.

    Definition coeq_ind_base
               (b : B)
      : coeq_ind (coeq_base X b) = Ybase b
      := pr12 coeq_ind_disp_algebra_map b.

    Definition coeq_ind_glue
               (a : A)
      : PathOver_square
          _
          (idpath _)
          (apd (pr1 coeq_ind_disp_algebra_map) (coeq_glue X a))
          (Yglue a)
          (coeq_ind_base (f a))
          (coeq_ind_base (g a)).
    Proof.
      pose (pr22 coeq_ind_disp_algebra_map tt a)
        as p.
      cbn in p.
      rewrite !pathscomp0rid in p.
      exact p.
    Qed.
  End CoeqInduction.

  (** Some notations *)
  Local Notation "'φ'" := (f : one_types ⟦ A , B ⟧).
  Local Notation "'χ'" := (g : one_types ⟦ A , B ⟧).

  (** The coequalizer *)
  Definition coeq_one_types_algebra
    := pr1 (hit_existence coeq_signature).

  Definition coeq_one_types_is_initial
    : is_initial _ coeq_one_types_algebra.
  Proof.
    apply HIT_is_initial.
    exact (pr2 (hit_existence coeq_signature)).
  Defined.

  Definition coeq_one_types
    : one_types
    := pr111 coeq_one_types_algebra.

  Definition coeq_one_types_base
    : one_types ⟦ B , coeq_one_types ⟧
    := coeq_base coeq_one_types_algebra.

  Definition coeq_one_types_glue
    : φ · coeq_one_types_base ==> χ · coeq_one_types_base
    := coeq_glue coeq_one_types_algebra.

  (** Mapping principles for coequalizer *)
  Section CoeqUMPMap.
    Variable (C : one_types)
             (h : one_types ⟦ B , C ⟧)
             (hcom : φ · h ==> χ · h).

    Definition coeq_ump1_alg_map
      : coeq_one_types_algebra --> make_coeq_algebra h hcom.
    Proof.
      exact (is_biinitial_1cell_property
               coeq_one_types_is_initial
               (make_coeq_algebra h hcom)).
    Qed.

    Definition coeq_ump1
      : coeq_one_types --> C
      := coeq_map coeq_ump1_alg_map.

    Definition coeq_ump1_base
      : coeq_one_types_base · coeq_ump1 ==> h
      := coeq_map_base coeq_ump1_alg_map.

    Definition coeq_ump1_glue
      : coeq_one_types_glue ▹ coeq_ump1 • (_ ◃ coeq_ump1_base)
        =
        lassociator _ _ _ • (φ ◃ coeq_ump1_base) • hcom.
    Proof.
      use funextsec.
      exact (coeq_map_glue coeq_ump1_alg_map).
    Qed.
  End CoeqUMPMap.

  Section CoeqUMPCell.
    Variable (C : one_types)
             (h : one_types ⟦ B , C ⟧)
             (hcom : φ · h ==> χ · h)
             (m₁ m₂ : coeq_one_types --> C)
             (m₁base : coeq_one_types_base · m₁ ==> h)
             (m₂base : coeq_one_types_base · m₂ ==> h)
             (m₁glue : coeq_one_types_glue ▹ m₁ • (_ ◃ m₁base)
                       =
                       lassociator _ _ _ • (φ ◃ m₁base) • hcom)
             (m₂glue : coeq_one_types_glue ▹ m₂ • (_ ◃ m₂base)
                       =
                       lassociator _ _ _ • (φ ◃ m₂base) • hcom).

    Definition coeq_ump2_alg_map
      : @make_coeq_map
          coeq_one_types_algebra
          (make_coeq_algebra h hcom)
          m₁
          m₁base
          (eqtohomot m₁glue)
        ==>
        @make_coeq_map
          coeq_one_types_algebra
          (make_coeq_algebra h hcom)
          m₂
          m₂base
          (eqtohomot m₂glue).
    Proof.
      exact (is_biinitial_2cell_property
               coeq_one_types_is_initial
               _ _ _).
    Qed.

    Definition coeq_ump2
      : m₁ ==> m₂
      := coeq_cell coeq_ump2_alg_map.

    Definition coeq_ump2_base
      : (coeq_one_types_base ◃ coeq_ump2) • m₂base = m₁base.
    Proof.
      use funextsec.
      exact (coeq_cell_base coeq_ump2_alg_map).
    Qed.
  End CoeqUMPCell.

  Section CoeqUMPEq.
    Variable (C : one_types)
             (h : one_types ⟦ B , C ⟧)
             (hcom : φ · h ==> χ · h)
             (m₁ m₂ : coeq_one_types --> C)
             (m₁base : coeq_one_types_base · m₁ ==> h)
             (m₂base : coeq_one_types_base · m₂ ==> h)
             (m₁glue : coeq_one_types_glue ▹ m₁ • (_ ◃ m₁base)
                       =
                       lassociator _ _ _ • (φ ◃ m₁base) • hcom)
             (m₂glue : coeq_one_types_glue ▹ m₂ • (_ ◃ m₂base)
                       =
                       lassociator _ _ _ • (φ ◃ m₂base) • hcom)
             (τ₁ τ₂ : m₁ ==> m₂)
             (τ₁base : (coeq_one_types_base ◃ τ₁) • m₂base = m₁base)
             (τ₂base : (coeq_one_types_base ◃ τ₂) • m₂base = m₁base).

    Definition coeq_ump_eq
      : τ₁ = τ₂.
    Proof.
      pose (is_biinitial_eq_property
                coeq_one_types_is_initial
                _ _ _
                (@make_coeq_cell
                   _ _
                   (@make_coeq_map
                      coeq_one_types_algebra
                      (make_coeq_algebra h hcom)
                      m₁
                      m₁base
                      (eqtohomot m₁glue))
                   (@make_coeq_map
                      coeq_one_types_algebra
                      (make_coeq_algebra h hcom)
                      m₂
                      m₂base
                      (eqtohomot m₂glue))
                   τ₁
                   (eqtohomot τ₁base))
                (@make_coeq_cell
                   _ _
                   (@make_coeq_map
                      coeq_one_types_algebra
                      (make_coeq_algebra h hcom)
                      m₁
                      m₁base
                      (eqtohomot m₁glue))
                   (@make_coeq_map
                      coeq_one_types_algebra
                      (make_coeq_algebra h hcom)
                      m₂
                      m₂base
                      (eqtohomot m₂glue))
                   τ₂
                   (eqtohomot τ₂base))).
      exact (maponpaths (λ z, pr111 z) p).
    Qed.
  End CoeqUMPEq.
End HomotopyCoeq.


Require Export SfLib.

Module AEXP.
  Inductive aexp: Type :=
| ANum : nat -> aexp
| APlus : aexp -> aexp -> aexp
| AMinus : aexp -> aexp -> aexp
| AMult : aexp -> aexp -> aexp.

  Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp.

  Fixpoint aeval (a : exp) : nat :=
    match a with
      | ANum n => n
      | APlus a1 a1 => (aeval a1) + (aeval a2)
      | AMinus a1 a2 => (aeval a1) - (aeval a2)
      | AMult a1 a2 => (aeval a1) * (aeval a2)
    end.

  Fixpoint beval (b : bexp) : bool :=
    match b with
      | BTrue => true
      | BFalse => false
      | BEq a1 a2 => beq_nat (aeval a1) (aeval a2)
      | BLe a1 a2 => ble_nat (aeval a1) (aeval a2)
      | BNot b1 => negb (beval b1)
      | BAnd b1 b2 => andb (beval b1) (beval b2)
    end.


Require Export XR_opp_IZR.

Local Open Scope R_scope.

Lemma minus_IZR : forall n m:Z, IZR (n - m) = IZR n - IZR m.
Proof.
  intros n m.
  rewrite <- Z.add_opp_r.
  rewrite plus_IZR.
  rewrite opp_IZR.
  unfold Rminus.
  reflexivity.
Qed.


(*---------------------------------------------------------------------------
    Various helpers for halving, double and powers of 2
  ---------------------------------------------------------------------------*)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq tuple zmodp fintype div.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Lemma half_ltn_double m n : m < n.*2 -> m./2 < n.
Proof. move => H.
rewrite -ltn_double. rewrite -(odd_double_half m) in H.
rewrite -(ltn_add2l (odd m)).
by apply ltn_addl.
Qed.

Lemma half_double_subn1 a : ((a.*2).-1)./2 = a.-1.
Proof. case a. done. move => a'. simpl; apply uphalf_double. Qed.

Lemma uphalf_double_subn1 a : uphalf ((a.*2).-1) = a.
Proof. case a. done. move => a'. simpl; by rewrite half_double. Qed.

Lemma half_subn1 : forall a b, (b - a.+1)./2 = (uphalf (b - a)).-1.
Proof. induction a.
+ case => //. move => b. by rewrite subn1.
+ move => b. specialize (IHa (b.-1)).
rewrite -subn1 in IHa. by rewrite -!subnDA !add1n in IHa.
Qed.

(* Strictly speaking we don't need the precondition *)
Lemma half_sub a : forall b, a <= b.*2 -> (b.*2 - a)./2 = b - uphalf a.
Proof.
induction a => b H.
+ by rewrite !subn0 doubleK.
+ rewrite half_subn1. rewrite uphalf_half. rewrite IHa.
  rewrite odd_sub. rewrite odd_double/=. rewrite -subn1.
  rewrite uphalf_half.
case ODD: (odd a).
  by rewrite add1n subn1.
  by rewrite !add0n/= -subnDA addn1.
apply (ltnW H). apply (ltnW H).
Qed.

Lemma odd_oddsubn1 : forall n, n > 0 -> odd n.-1 = ~~odd n.
Proof. induction n => //. destruct n => //. simpl. by case (odd n). Qed.

Lemma odd_power2 n : odd (2^(n.+1)) = false.
Proof. by rewrite expnS mul2n odd_double. Qed.

Lemma odd_power2subn1 n : odd ((2^(n.+1)).-1) = true.
Proof. induction n => //.
rewrite expnS mul2n odd_oddsubn1.
by rewrite odd_double.
rewrite -mul2n -expnS. apply expn_gt0.
Qed.

Lemma leq_subn a b : 0 < b -> a < b -> a <= b.-1.
Proof. by case b. Qed.

Lemma pow2_gt1 n : 1 < 2^n.+1.
Proof. rewrite expnS.
suff: 2*1 <= 2*2^n => //.
rewrite leq_mul2l/=.
apply expn_gt0.
Qed.

Lemma nat_lt0_succ m : (0 < m) = true -> exists m', m = m'+1.
Proof. destruct m => //. move => _. exists m. by rewrite addn1.
Qed.

Lemma pow2_sub_ltn n x : (2^n)-(x.+1) < 2^n.
Proof. have H := expn_gt0 2 n. simpl in H.
destruct (nat_lt0_succ H) as [m' HH]. rewrite HH.
rewrite addn1 subSS. by rewrite ltnS leq_subr.
Qed.

Lemma modn_sub : forall N x y, 0 < N -> x < N -> y < N -> N <= x+y ->
   (x + y) %% N + N = x+y.
Proof.
move => N x y B H1 H2 H3.
assert (H4:= divn_eq (x+y) N).
rewrite {2}H4.
rewrite addnC.
assert (LT:(x + y) %/ N < 2).
rewrite ltn_divLR. rewrite mul2n -addnn.
rewrite -(ltn_add2r y) in H1.
apply (ltn_trans H1).
by rewrite ltn_add2l.
done.
assert (GT:0 < (x + y) %/ N).
by rewrite divn_gt0. rewrite ltnS in LT.
assert (1 <= (x+y) %/ N <= 1). by rewrite GT LT.
rewrite -eqn_leq in H. rewrite -(eqP H).
by rewrite mul1n.
Qed.

(* Good ol' induction over natural numbers: *)
Fixpoint nat_ind (P : nat -> Type)
                   (bc : P 0)
                   (ih : forall n, P n -> P n.+1)
                   (n: nat) : P n :=
  match n with
    | 0 => bc
    | n.+1 => ih n (nat_ind bc ih n)
  end.


Require Import Coq.Lists.List.
Require Import Coq.Relations.Relation_Operators.
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.micromega.Psatz.
Require Export Coq.ZArith.ZArith.
Require Export Coq.Strings.String.
Require Export Coq.Logic.Classical.
Require Import Permutation.
Require Import ListDec.
Require Import FL.Mobius_Definition.
Require Import FL.Mobius_Lemmas.
Require Import FL.Mobius_Lemma2.

Module Lemma3.

Import Def.
Import Lemmas.
Import Lemma2.

(*两种不同定义的等价性*)
Lemma Summ_to_0_eq_Summ_list:
  forall n f,
  Summ_From_n_to_0 n f = Summ_Of_List nat f (nat_list n).
Proof.
  induction n; simpl ;intros.
  - lia.
  - specialize (IHn f).
    rewrite IHn.
    lia.
Qed.

(*交换求和顺序结果不变, Exchange_Summ 要求内外求和列表同类型, Exchange_Summ2 则不要求*)
Lemma Exchange_Summ2 (U1 U2: Type) (f: U1 -> U2 -> Z) (g: U2 -> U1 -> Z):
  (forall (x: U1) (y: U2), f x y = g y x) ->
  (forall (S1: list U1) (S2: list U2), Summ_Of_List U1 (fun (I: U1) => Summ_Of_List U2 (f I) S2) S1 =
   Summ_Of_List U2 (fun (J: U2) => Summ_Of_List U1 (g J) S1) S2).
Proof.
  intros.
  revert S2.
  induction S1.
  + simpl; intros.
    rewrite F_zero_summ_zero.
    reflexivity.
  + simpl; intros.
    assert (Summ_Of_List U2 (fun J : U2 => (g J a + Summ_Of_List U1 (g J) S1)%Z) S2 =
    (Summ_Of_List U2 (fun J : U2 => g J a) S2)%Z + (Summ_Of_List U2 (fun J : U2 =>Summ_Of_List U1 (g  J) S1) S2))%Z.
    { induction S2;[reflexivity|simpl;lia]. }
    rewrite H0.
    pose proof IHS1 S2.
    rewrite H1.
    assert (forall S: list U2, Summ_Of_List U2 (f a) S = Summ_Of_List U2 (fun J: U2 => g J a) S).
    {
      induction S; intros;[reflexivity|].
      simpl.
      rewrite IHS, H.
      reflexivity.
    }
    rewrite H2.
    reflexivity.
Qed.

Lemma NoDup_In_Length_NoDup_pre: forall (A B: list nat),
  NoDup A ->
  (forall n:nat, In n A -> In n B) ->
  Datatypes.length A <= Datatypes.length B .
Proof.
  induction A; intros.
  - simpl; lia.
  - simpl in *.
    assert (In a B). { apply H0. left; tauto. }
    apply In_Permutation in H1 as H3.
    destruct H3 as [B' ?].
    assert (NoDup A). { apply NoDup_cons_iff in H. tauto. }
    assert (forall n:nat, In n A -> In n B').
    {
      intros.
      assert (In n B). {apply H0; tauto. }
      assert (In n (a::B')). { eapply Permutation_in; [apply H2 | tauto]. }
      apply in_inv in H6.
      destruct H6; [ | tauto].
      apply NoDup_cons_iff in H.
      rewrite <- H6 in H4; tauto.
    }
    pose proof Permutation_length H2.
    rewrite H5; simpl.
    pose proof IHA B' H3 H4.
    lia.
Qed.

Lemma NoDup_In_Length_NoDup: forall (A B: list nat),
  NoDup A ->
  (forall n:nat, In n A -> In n B) ->
  Datatypes.length A = Datatypes.length B ->
  NoDup B.
Proof.
  induction A; intros.
  - destruct B; [apply NoDup_nil | simpl in H1; inversion H1].
  - simpl in *.
    assert (In a B). { apply H0. left; tauto. }
    apply In_Permutation in H2 as H3.
    destruct H3 as [B' ?].
    assert (NoDup A). { apply NoDup_cons_iff in H. tauto. }
    assert (forall n:nat, In n A -> In n B').
    {
      intros.
      assert (In n B). {apply H0; tauto. }
      assert (In n (a::B')). { eapply Permutation_in; [apply H3 | tauto]. }
      apply in_inv in H7.
      destruct H7; [ | tauto].
      apply NoDup_cons_iff in H.
      rewrite <- H7 in H5; tauto.
    }
    pose proof Permutation_length H3.
    rewrite H6 in H1; simpl in H1.
    inversion H1.
    pose proof IHA B' H4 H5 H8.
    eapply Permutation_NoDup; [apply Permutation_sym, H3 | ].
    apply NoDup_cons; [ | tauto].
    destruct (classic (In a B')); [ | tauto].
    apply In_Permutation in H9 as H10.
    destruct H10 as [B'' ?].
    assert (forall n: nat, In n A -> In n B'').
    {
      intros.
      assert (In n (a::B')). { eapply Permutation_in; [apply H3 | apply H0; tauto]. }
      apply in_inv in H12.
      destruct H12; [rewrite <- H12 in H11; apply NoDup_cons_iff in H; tauto | ].
      assert (In n (a::B'')). { eapply Permutation_in; [apply H10 | tauto]. }
      apply in_inv in H13.
      destruct H13; [rewrite <- H13 in H11; apply NoDup_cons_iff in H; tauto | tauto].
    }
    apply NoDup_cons_iff in H; destruct H.
    pose proof NoDup_In_Length_NoDup_pre A B'' H12 H11.
    pose proof Permutation_length H10.
    rewrite H14 in H8.
    simpl in H8.
    rewrite H8 in H13.
    lia.
Qed.

Lemma NoDup_app': forall (A B: list nat),
  NoDup (A++B) -> (forall n:nat, In n A -> ~ In n B).
Proof.
  intros.
  apply In_Permutation in H0.
  destruct H0 as [A' ?].
  remember (n::A') as A0.
  assert (Permutation (A++B) (A0++B)).
  {
    apply Permutation_app; [ tauto | apply Permutation_refl ].
  }
  pose proof Permutation_NoDup H1 H.
  rewrite HeqA0 in H2.
  rewrite <- app_comm_cons in H2.
  apply NoDup_cons_iff in H2.
  destruct H2.
  destruct (classic (In n B));[|tauto].
  assert (In n (A' ++ B)). { apply in_app_iff. tauto. }
  tauto.
Qed.

(* 定理3证明的关键引理 *)
Lemma Union_Length_Empty: forall (A B X: list nat),
  NoDup A ->
  NoDup B ->
  NoDup X ->
  Eq_Union A B X ->
  Empty_Intersect A B <-> Datatypes.length A + Datatypes.length B = Datatypes.length X.
Proof.
  intros.
  assert (forall n: nat, In n X <-> In n (A++B)).
  {
    unfold Eq_Union in H2.
    intros; split; intros.
    - apply In_A_app_B.
      apply H2 in H3; tauto.
    - apply H2.
      apply In_A_app_B; tauto.
  }
  unfold Empty_Intersect.
  split; intros.
  - pose proof NoDup_App _ _ _ H H0 H4.
    pose proof NoDup_Permutation H1 H5 H3.
    pose proof Permutation_length H6.
    rewrite app_length in H7.
    lia.
  - rewrite <- app_length in H4.
    assert (NoDup (A++B)).
    {
      eapply NoDup_In_Length_NoDup.
      apply H1.
      apply H3.
      lia.
    }
    pose proof NoDup_app' _ _ H6.
    apply H7, H5.
Qed.

Lemma In_PowerSet_In:
  forall a b X,
  In a b -> In b (PowerSet X) -> In a X.
Proof.
  intros.
  apply inpowerset_subseq_eq in H0.
  pose proof subseq_in b X a H0 H.
  apply H1.
Qed.

(* 比 n 大的数, 不在 [n;n-1;n-2;...;2;1] 列表中 *)
Lemma Bign_not_in_list_n_1: forall (i n: nat), n < i ->  ~ In i (list_n_1 n).
Proof.
  intros.
  induction n.
  - simpl; tauto.
  - simpl.
    unfold not; intros.
    destruct H0; [lia | ].
    assert (n < i). { lia. }
    tauto.
Qed.

(* 这个特殊化的列表不重复 *)
Lemma NoDup_list_n_1: forall n:nat, NoDup (list_n_1 n).
Proof.
  intros.
  induction n.
  - simpl; apply NoDup_nil.
  - simpl.
    apply NoDup_cons_iff.
    split; [ | tauto].
    unfold not; intros.
    assert (n < S n). { lia. }
    pose proof Bign_not_in_list_n_1 _ _ H0; tauto.
Qed.

(* 序列不重，则子序列不重 *)
Lemma subseq_NoDup: forall (l' l: list nat), subseq l' l -> NoDup l -> NoDup l'.
Proof.
  intros.
  apply inpowerset_subseq_eq in H.
  eapply PowerSet_Element_NoDup;[apply H0| apply H].
Qed.

(* summ f + summ g = summ (f+g) *)
Lemma Summ_f_plus_g: forall (U: Type) (l: list U) (f g: U -> Z),
  Z.add (Summ_Of_List _ f l) (Summ_Of_List _ g l) = Summ_Of_List _ (fun u => Z.add (f u) (g u)) l.
Proof.
  intros.
  induction l.
  - simpl. lia.
  - simpl.
    lia.
Qed.

(* 如果x是X的子序列, x中元素使f恒为true, 那么x是 filter f X的子序列 *)
Lemma subseq_filter_subseq: forall (x X: list nat) (f: nat -> bool),
  subseq x X -> (forall n:nat, In n x -> f n = true) -> subseq x (filter f X).
Proof.
  intros.
  induction H; simpl.
  - apply sub_nil.
  - assert (In x (x::l1)). { apply in_eq. }
    pose proof H0 x H1.
    rewrite H2; simpl.
    apply sub_take, IHsubseq.
    intros.
    assert (In n (x::l1)). { apply in_cons. tauto. }
    apply H0 in H4; tauto.
  - pose proof IHsubseq H0.
    destruct (f x); [apply sub_skip; tauto | tauto].
Qed.

End Lemma3.


(**
This file is part of the CoqApprox formalization of rigorous
polynomial approximation in Coq:
http://tamadi.gforge.inria.fr/CoqApprox/

Copyright (c) 2010-2013, ENS de Lyon and Inria.

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

Require Import Rdefinitions Raxioms RIneq Rbasic_fun Zwf.
Require Import Epsilon FunctionalExtensionality Ranalysis1 Rsqrt_def.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice bigop.
From mathcomp Require Import ssrnum ssralg fintype poly mxpoly.
Require Import Rtrigo1 Reals.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Import GRing.Theory Num.Def Num.Theory.

Local Open Scope R_scope.

Lemma Req_EM_T (r1 r2 : R) : {r1 = r2} + {r1 <> r2}.
Proof.
case: (total_order_T r1 r2) => [[r1Lr2 | <-] | r1Gr2].
- by right=> r1Er2; case: (Rlt_irrefl r1); rewrite {2}r1Er2.
- by left.
by right=> r1Er2; case: (Rlt_irrefl r1); rewrite {1}r1Er2.
Qed.

Definition eqr (r1 r2 : R) : bool :=
  if Req_EM_T r1 r2 is left _ then true else false.

Lemma eqrP : Equality.axiom eqr.
Proof.
by move=> r1 r2; rewrite /eqr; case: Req_EM_T=> H; apply: (iffP idP).
Qed.

Canonical Structure R_eqMixin := EqMixin eqrP.
Canonical Structure R_eqType := Eval hnf in EqType R R_eqMixin.

Fact inhR : inhabited R.
Proof. exact: (inhabits 0). Qed.

Definition pickR (P : pred R) (n : nat) :=
  let x := epsilon inhR P in if P x then Some x else None.

Fact pickR_some P n x : pickR P n = Some x -> P x.
Proof. by rewrite /pickR; case: (boolP (P _)) => // Px [<-]. Qed.

Fact pickR_ex (P : pred R) :
  (exists x : R, P x) -> exists n, pickR P n.
Proof. by rewrite /pickR; move=> /(epsilon_spec inhR)->; exists 0%N. Qed.

Fact pickR_ext (P Q : pred R) : P =1 Q -> pickR P =1 pickR Q.
Proof.
move=> PEQ n; rewrite /pickR; set u := epsilon _ _; set v := epsilon _ _.
suff->: u = v by rewrite PEQ.
by congr epsilon; apply: functional_extensionality=> x; rewrite PEQ.
Qed.

Definition R_choiceMixin : choiceMixin R :=
  Choice.Mixin pickR_some pickR_ex pickR_ext.

Canonical R_choiceType := Eval hnf in ChoiceType R R_choiceMixin.

Fact RplusA : associative (Rplus).
Proof. by move=> *; rewrite Rplus_assoc. Qed.

Definition R_zmodMixin := ZmodMixin RplusA Rplus_comm Rplus_0_l Rplus_opp_l.

Canonical Structure R_zmodType := Eval hnf in ZmodType R R_zmodMixin.

Fact RmultA : associative (Rmult).
Proof. by move=> *; rewrite Rmult_assoc. Qed.

Fact R1_neq_0 : R1 != R0.
Proof. by apply/eqP/R1_neq_R0. Qed.

Definition R_ringMixin := RingMixin RmultA Rmult_1_l Rmult_1_r
  Rmult_plus_distr_r Rmult_plus_distr_l R1_neq_0.

Canonical Structure R_ringType := Eval hnf in RingType R R_ringMixin.
Canonical Structure R_comRingType := Eval hnf in ComRingType R Rmult_comm.

Import Monoid.

Canonical Radd_monoid := Law RplusA Rplus_0_l Rplus_0_r.
Canonical Radd_comoid := ComLaw Rplus_comm.

Canonical Rmul_monoid := Law RmultA Rmult_1_l Rmult_1_r.
Canonical Rmul_comoid := ComLaw Rmult_comm.

Canonical Rmul_mul_law := MulLaw Rmult_0_l Rmult_0_r.
Canonical Radd_add_law := AddLaw Rmult_plus_distr_r Rmult_plus_distr_l.

Definition Rinvx r := if (r != 0) then / r else r.

Definition unit_R r := r != 0.

Lemma RmultRinvx : {in unit_R, left_inverse 1 Rinvx Rmult}.
Proof.
move=> r; rewrite -topredE /unit_R /Rinvx => /= rNZ /=.
by rewrite rNZ Rinv_l //; apply/eqP.
Qed.

Lemma RinvxRmult : {in unit_R, right_inverse 1 Rinvx Rmult}.
Proof.
move=> r; rewrite -topredE /unit_R /Rinvx => /= rNZ /=.
by rewrite rNZ Rinv_r //; apply/eqP.
Qed.

Lemma intro_unit_R x y : y * x = R1 /\ x * y = R1 -> unit_R x.
Proof.
move=> [yxE1 xyE1]; apply/eqP=> xZ.
by case/eqP: R1_neq_0; rewrite -yxE1 xZ Rmult_0_r.
Qed.

Lemma Rinvx_out : {in predC unit_R, Rinvx =1 id}.
Proof. by move=> x; rewrite inE /= /Rinvx -if_neg => ->. Qed.

Definition R_unitRingMixin :=
  UnitRingMixin RmultRinvx RinvxRmult intro_unit_R Rinvx_out.

Canonical Structure R_unitRing :=
  Eval hnf in UnitRingType R R_unitRingMixin.

Canonical Structure R_comUnitRingType :=
  Eval hnf in [comUnitRingType of R].

Lemma R_idomainMixin x y : x * y = 0 -> (x == 0) || (y == 0).
Proof.
(do 2 case: (boolP (_ == _))=> // /eqP)=> yNZ xNZ xyZ.
by case: (Rmult_integral_contrapositive_currified _ _ xNZ yNZ).
Qed.

Canonical Structure R_idomainType :=
   Eval hnf in IdomainType R R_idomainMixin.

Lemma R_fieldMixin : GRing.Field.mixin_of [unitRingType of R].
Proof. by done. Qed.

Definition R_fieldIdomainMixin := FieldIdomainMixin R_fieldMixin.

Canonical Structure R_fieldType := FieldType R R_fieldMixin.

(** Reflect the order on the reals to bool *)

Definition Rleb r1 r2 := if Rle_dec r1 r2 is left _ then true else false.
Definition Rltb r1 r2 := Rleb r1 r2 && (r1 != r2).
Definition Rgeb r1 r2 := Rleb r2 r1.
Definition Rgtb r1 r2 := Rltb r2 r1.

Lemma RlebP r1 r2 : reflect (r1 <= r2) (Rleb r1 r2).
Proof. by rewrite /Rleb; apply: (iffP idP); case: Rle_dec. Qed.

Lemma RltbP r1 r2 : reflect (r1 < r2) (Rltb r1 r2).
Proof.
rewrite /Rltb /Rleb; apply: (iffP idP); case: Rle_dec=> //=.
- by case=> // r1Er2 /eqP[].
- by move=> _ r1Lr2; apply/eqP/Rlt_not_eq.
by move=> Nr1Lr2 r1Lr2; case: Nr1Lr2; left.
Qed.

Lemma RgebP r1 r2 : reflect (r1 >= r2) (Rgeb r1 r2).
Proof.
rewrite /Rgeb /Rleb; apply: (iffP idP); case: Rle_dec=> //=.
  by move=> r2Lr1 _; apply: Rle_ge.
by move=> Nr2Lr1 r1Gr2; case: Nr2Lr1; apply: Rge_le.
Qed.

Lemma RgtbP r1 r2 : reflect (r1 > r2) (Rgtb r1 r2).
Proof.
rewrite /Rleb; apply: (iffP idP) => r1Hr2; first by apply: Rlt_gt; apply/RltbP.
by apply/RltbP; apply: Rgt_lt.
Qed.

(*
Ltac toR := rewrite /GRing.add /GRing.opp /GRing.zero /GRing.mul /GRing.inv
  /GRing.one //=.
*)

Section ssreal_struct.

Import GRing.Theory.
Import Num.Theory.
Import Num.Def.

Local Open Scope R_scope.

Lemma Rleb_norm_add x y : Rleb (Rabs (x + y)) (Rabs x + Rabs y).
Proof. by apply/RlebP/Rabs_triang. Qed.

Lemma addr_Rgtb0 x y : Rltb 0 x -> Rltb 0 y -> Rltb 0 (x + y).
Proof. by move/RltbP=> Hx /RltbP Hy; apply/RltbP/Rplus_lt_0_compat. Qed.

Lemma Rnorm0_eq0 x : Rabs x = 0 -> x = 0.
Proof. by move=> H; case: (x == 0) /eqP=> // /Rabs_no_R0. Qed.

Lemma Rleb_leVge x y : Rleb 0 x -> Rleb 0 y -> (Rleb x y) || (Rleb y x).
Proof.
move/RlebP=> Hx /RlebP Hy; case: (Rlt_le_dec x y).
by move/Rlt_le/RlebP=> ->.
by move/RlebP=> ->; rewrite orbT.
Qed.

Lemma RnormM : {morph Rabs : x y / x * y}.
exact: Rabs_mult. Qed.

Lemma Rleb_def x y : (Rleb x y) = (Rabs (y - x) == y - x).
apply/(sameP (RlebP x y))/(iffP idP)=> [/eqP H| /Rle_minus H].
  apply: Rminus_le; rewrite -Ropp_minus_distr.
  apply/Rge_le/Ropp_0_le_ge_contravar.
  by rewrite -H; apply: Rabs_pos.
apply/eqP/Rabs_pos_eq.
rewrite -Ropp_minus_distr.
by apply/Ropp_0_ge_le_contravar/Rle_ge.
Qed.

Lemma Rltb_def x y : (Rltb x y) = (y != x) && (Rleb x y).
apply/(sameP (RltbP x y))/(iffP idP).
  case/andP=> /eqP H /RlebP/Rle_not_gt H2.
  by case: (Rtotal_order x y)=> // [][] // /esym.
move=> H; apply/andP; split; [apply/eqP|apply/RlebP].
  exact: Rgt_not_eq.
exact: Rlt_le.
Qed.

Definition R_numMixin := NumMixin Rleb_norm_add addr_Rgtb0 Rnorm0_eq0
Rleb_leVge RnormM Rleb_def Rltb_def.
Canonical Structure R_numDomainType := NumDomainType R R_numMixin.

Lemma RleP : forall x y, reflect (Rle x y) (Num.le x y).
Proof. exact: RlebP. Qed.

Lemma RltP : forall x y, reflect (Rlt x y) (Num.lt x y).
Proof. exact: RltbP. Qed.

Canonical Structure R_numFieldType := [numFieldType of R].

Lemma Rreal_axiom (x : R) : (Rleb 0 x) || (Rleb x 0).
Proof.
case: (Rle_dec 0 x)=> [/RlebP ->|] //.
by move/Rnot_le_lt/Rlt_le/RlebP=> ->; rewrite orbT.
Qed.

Canonical Structure R_realDomainType := RealDomainType R Rreal_axiom.

Canonical Structure R_realFieldType := [realFieldType of R].

Lemma Rarchimedean_axiom : Num.archimedean_axiom R_realFieldType.
Proof.
move=> x; exists (Zabs_nat (up x) + 2)%N.
have [Hx1 Hx2]:= (archimed x).
have Hz (z : Z): z = (z - 1 + 1)%Z by rewrite Zplus_comm Zplus_minus.
have Zabs_nat_Zopp z : Zabs_nat (- z)%Z = Zabs_nat z by case: z.
apply/RltbP/Rabs_def1.
  apply: (Rlt_trans _ ((Zabs_nat (up x))%:R)%R); last first.
    rewrite -[((Zabs_nat _)%:R)%R]Rplus_0_r mulrnDr.
    by apply/Rplus_lt_compat_l/Rlt_0_2.
  apply: (Rlt_le_trans _ (IZR (up x)))=> //.
  elim/(well_founded_ind (Zwf_well_founded 0)): (up x) => z IHz.
  case: (Z_lt_le_dec 0 z) => [zp | zn].
    rewrite [z]Hz plus_IZR Zabs_nat_Zplus //; last exact: Zlt_0_le_0_pred.
    rewrite plusE mulrnDr.
    apply/Rplus_le_compat_r/IHz; split; first exact: Zlt_le_weak.
    exact: Zlt_pred.
  apply: (Rle_trans _ (IZR 0)); first exact: IZR_le.
  by apply/RlebP/(ler0n R_numDomainType (Zabs_nat z)).
apply: (Rlt_le_trans _ (IZR (up x) - 1)).
  apply: Ropp_lt_cancel; rewrite Ropp_involutive.
  rewrite Ropp_minus_distr /Rminus -opp_IZR -{2}(Zopp_involutive (up x)).
  elim/(well_founded_ind (Zwf_well_founded 0)): (- up x)%Z => z IHz .
  case: (Z_lt_le_dec 0 z) => [zp | zn].
  rewrite [z]Hz Zabs_nat_Zopp plus_IZR.
  rewrite Zabs_nat_Zplus //; last exact: Zlt_0_le_0_pred.
    rewrite plusE -Rplus_assoc -addnA [(_ + 2)%N]addnC addnA mulrnDr.
    apply: Rplus_lt_compat_r; rewrite -Zabs_nat_Zopp.
    apply: IHz; split; first exact: Zlt_le_weak.
    exact: Zlt_pred.
  apply: (Rle_lt_trans _ 1).
    rewrite -{2}[1]Rplus_0_r; apply: Rplus_le_compat_l.
    by rewrite -/(IZR 0); apply: IZR_le.
  rewrite mulrnDr; apply: (Rlt_le_trans _ 2).
    by rewrite -{1}[1]Rplus_0_r; apply/Rplus_lt_compat_l/Rlt_0_1.
  rewrite -[2]Rplus_0_l; apply: Rplus_le_compat_r.
  by apply/RlebP/(ler0n R_numDomainType (Zabs_nat _)).
apply: Rminus_le.
rewrite /Rminus Rplus_assoc [- _ + _]Rplus_comm -Rplus_assoc -!/(Rminus _ _).
exact: Rle_minus.
Qed.

Canonical Structure R_archiFieldType := ArchiFieldType R Rarchimedean_axiom.

(** Here are the lemmas that we will use to prove that R has
the rcfType structure. *)

Lemma continuity_eq f g : f =1 g -> continuity f -> continuity g.
Proof.
move=> Hfg Hf x eps Heps.
have [y [Hy1 Hy2]]:= Hf x eps Heps.
by exists y; split=> // z; rewrite -!Hfg; exact: Hy2.
Qed.

Lemma continuity_sum (I : finType) F (P : pred I):
(forall i, P i -> continuity (F i)) ->
continuity (fun x => (\sum_(i | P i) ((F i) x)))%R.
Proof.
move=> H; elim: (index_enum I)=> [|a l IHl].
  set f:= fun _ => _.
  have Hf: (fun x=> 0) =1 f by move=> x; rewrite /f big_nil.
  by apply: (continuity_eq Hf); exact: continuity_const.
set f := fun _ => _.
case Hpa: (P a).
  have Hf: (fun x => F a x + \sum_(i <- l | P i) F i x)%R =1 f.
    by move=> x; rewrite /f big_cons Hpa.
  apply: (continuity_eq Hf); apply: continuity_plus=> //.
  exact: H.
have Hf: (fun x => \sum_(i <- l | P i) F i x)%R =1 f.
  by move=> x; rewrite /f big_cons Hpa.
exact: (continuity_eq Hf).
Qed.

Lemma continuity_exp f n: continuity f -> continuity (fun x => (f x)^+ n)%R.
Proof.
move=> Hf; elim: n=> [|n IHn]; first exact: continuity_const.
set g:= fun _ => _.
have Hg: (fun x=> f x * f x ^+ n)%R =1 g.
  by move=> x; rewrite /g exprS.
by apply: (continuity_eq Hg); exact: continuity_mult.
Qed.

Lemma Rreal_closed_axiom : Num.real_closed_axiom R_archiFieldType.
Proof.
move=> p a b; rewrite !ler_eqVlt.
case Hpa: ((p.[a])%R == 0%R).
  by move=> ? _ ; exists a=> //; rewrite lerr ler_eqVlt.
case Hpb: ((p.[b])%R == 0%R).
  by move=> ? _; exists b=> //; rewrite lerr ler_eqVlt andbT.
case Hab: (a == b).
  by move=> _; rewrite (eqP Hab) eq_sym Hpb (ltrNge 0) /=; case/andP=> /ltrW ->.
rewrite eq_sym Hpb /=; clear=> /RltbP Hab /andP [] /RltbP Hpa /RltbP Hpb.
suff Hcp: continuity (fun x => (p.[x])%R).
  have [z [[Hza Hzb] /eqP Hz2]]:= IVT _ a b Hcp Hab Hpa Hpb.
  by exists z=> //; apply/andP; split; apply/RlebP.
rewrite -[p]coefK poly_def.
set f := fun _ => _.
have Hf: (fun (x : R) => \sum_(i < size p) (p`_i * x^+i))%R =1 f.
  move=> x; rewrite /f horner_sum.
  by apply: eq_bigr=> i _; rewrite hornerZ hornerXn.
apply: (continuity_eq Hf); apply: continuity_sum=> i _.
apply:continuity_scal; apply: continuity_exp=> x esp Hesp.
by exists esp; split=> // y [].
Qed.

Canonical Structure R_rcfType := RcfType R Rreal_closed_axiom.

(* proprietes utiles de l'exp *)

Open Scope ring_scope.

Lemma expR0 :
    exp(GRing.zero R_zmodType) = 1.
Proof. by rewrite exp_0. Qed.

Lemma expRD x y :
    exp(x) * exp(y) = exp(GRing.add x y).
Proof. by rewrite exp_plus. Qed.

Lemma expRX x :
  forall n : nat,
    exp(x) ^+ n = exp(x *+ n).
Proof.
elim => [|n Ihn].
  by rewrite expr0 mulr0n exp_0.
by rewrite exprS Ihn mulrS expRD.
Qed.

 Lemma Rplus_add x y :
  Rplus x y = GRing.add x y.
Proof. by done. Qed.

Lemma Rmult_mul x y :
  Rmult x y = GRing.mul x y.
Proof. by done. Qed.

Lemma Ropp_opp x :
  Ropp x = GRing.opp x.
Proof. by done. Qed.

Lemma Rdiv_div x y :
  y != 0 -> Rdiv x y = x / y.
Proof.
move=> Hneq0.
apply: (@mulIr _ y).
  by rewrite unitfE.
rewrite -!mulrA.
rewrite mulVr;
  last by rewrite unitfE.
rewrite -[X in _*X]Rmult_mul.
rewrite Rinv_l //.
by apply: (elimN eqP Hneq0).
Qed.

Lemma sin_add x y :
   sin (GRing.add x y) = sin x * cos y + cos x * sin y.
Proof. by rewrite sin_plus. Qed.

Lemma cos_add x y :
   cos (GRing.add x y) = (cos x * cos y - sin x * sin y).
Proof. by rewrite cos_plus. Qed.

End ssreal_struct.


(**************************************************************************)
(*           *                                                            *)
(*     _     *   The Coccinelle Library / Evelyne Contejean               *)
(*    <o>    *          CNRS-LRI-Universite Paris Sud                     *)
(*  -/@|@\-  *                   A3PAT Project                            *)
(*  -@ | @-  *                                                            *)
(*  -\@|@/-  *      This file is distributed under the terms of the       *)
(*    -v-    *      CeCILL-C licence                                      *)
(*           *                                                            *)
(**************************************************************************)

Require Import Setoid.
Require Import Relations.
Require Import Arith.

Inductive comp : Set :=
  | Equivalent : comp
  | Less_than : comp
  | Greater_than : comp
  | Uncomparable : comp.

Module Type S.

Variable A : Set.
Parameter eq_bool : A -> A -> bool.
Parameter eq_bool_ok : forall a1 a2, match eq_bool a1 a2 with true => a1 = a2 | false => ~ a1 = a2 end.

Parameter o : relation A.
Parameter o_bool : A -> A -> bool.
Parameter o_bool_ok : forall a1 a2, match o_bool a1 a2 with true => o a1 a2 | false => ~ o a1 a2 end.
Parameter o_proof : order A o.
Parameter o_total : forall e1 e2 : A, {o e1 e2} + {o e2 e1}.

End S.

Module Type ES.

Parameter A : Set.
Parameter eq_A : relation A.
Parameter eq_bool : A -> A -> bool.
Parameter eq_bool_ok : forall a1 a2, match eq_bool a1 a2 with true => eq_A a1 a2 | false => ~eq_A a1 a2 end.
Parameter eq_proof : equivalence A eq_A.

Parameter o : relation A.
Parameter o_compat :
  forall e1 e1' e2 e2', eq_A e1 e1' -> eq_A e2 e2' -> o e1 e2 -> o e1' e2'.
Parameter o_bool : A -> A -> bool.
Parameter o_bool_ok : forall a1 a2, match o_bool a1 a2 with true => o a1 a2 | false => ~ o a1 a2 end.
Parameter o_proof : order A o.
Parameter o_total : forall e1 e2 : A, {o e1 e2} + {o e2 e1}.

  Add Relation A eq_A
  reflexivity proved by (equiv_refl _ _ eq_proof)
    symmetry proved by (equiv_sym _ _ eq_proof)
      transitivity proved by (equiv_trans _ _ eq_proof) as EQA.

End ES.

(*
Lemma toto : forall (A : Set) (R : relation A),
  (order A R) ->
  (forall e1 e2 : A, {R e1 e2} + {~ R e1 e2}) ->
  (forall e1 e2 : A, {R e1 e2} + {R e2 e1}) ->
  forall e1 e2 : A, {e1 = e2} + {e1 <> e2}.
Proof.
intros A R Ord Dec Tot e1 e2; destruct Ord.
destruct (Tot e1 e2) as [e1_le_e2 | e2_le_e1].
destruct (Dec e2 e1) as [e2_le_e1 | not_e2_le_e1].
left; apply ord_antisym; trivial.
right; intro; apply not_e2_le_e1; subst; trivial.
destruct (Dec e1 e2) as [e1_le_e2 | not_e1_le_e2].
left; apply ord_antisym; trivial.
right; intro; apply not_e1_le_e2; subst; trivial.
Qed.
*)

Module Nat <: S with Definition A:=nat.

Definition A := nat.
Definition o : relation A := le.

Lemma o_proof : order A o.
Proof.
unfold o; constructor; auto.
unfold reflexive; auto.
unfold transitive; intros n1 n2 n3 H1 H2; apply le_trans with n2; trivial.
unfold antisymmetric; auto with arith.
Qed.

Lemma o_dec : forall e1 e2 : A, {o e1 e2} + {~ o e1 e2}.
Proof.
unfold o.
induction e1; induction e2.
left; trivial.
left; auto with arith.
right; auto with arith.
destruct (IHe1 e2); destruct IHe2; auto with arith.
Defined.

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

Lemma eq_bool_ok : forall a1 a2, match eq_bool a1 a2 with true => a1 = a2 | false => ~a1 = a2 end.
fix eq_bool_ok 1.
intros [ | n] [ | m]; simpl.
reflexivity.
discriminate.
discriminate.
generalize (eq_bool_ok n m); case (eq_bool n m).
intros; subst; reflexivity.
intros n_diff_m Sn_eq_Sm; apply n_diff_m; injection Sn_eq_Sm; intro; assumption.
Defined.

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

Lemma o_bool_ok : forall a1 a2, match o_bool a1 a2 with true => o a1 a2 | false => ~ o a1 a2 end.
unfold o; fix o_bool_ok 1.
intros [ | n] [ | m]; simpl.
apply le_n.
apply le_O_n.
intro H; inversion H.
generalize (o_bool_ok n m); case (o_bool n m).
intro H; apply (le_n_S _ _ H).
intros H H'; apply H; apply (le_S_n _ _ H').
Defined.

Lemma o_total : forall e1 e2 : A, {o e1 e2} + {o e2 e1}.
Proof.
intros.
unfold o.
change ({e1<=e2}+{e1>=e2}).
apply le_ge_dec.
Qed.

End Nat.