(** printing \2/ $\cup$ #∪# *)
(** printing <2= $\subseteq$ #⊆# *)
(** printing forall $\forall$ #∀# *)
(** printing -> $\rightarrow$ #→# *)
(** printing /\ $\land$ #∧# *)

Require Import Setoid Program.
Require Import concurrency.paco.src.paco.

Section safety_equivalence.

  Context
  ( X Y:Type)
  ( halted: X -> Y -> Prop)
  ( int_step: X -> Y -> Y -> Prop)
  ( ext_step: X -> Y -> X -> Y -> Prop)
  ( valid: X -> Y -> Prop).

  Axiom determinism:
    forall x y y',
      valid x y  -> int_step x y y' ->
      forall x',
        valid x' y -> int_step x' y y'.

  Axiom valid_step:
    forall x y y',
      valid x y  -> int_step x y y' ->
      valid x y'.

  Section explicit_safety.

    (** *Normal explicit safety *)
    CoInductive exp_safety (x:X) (y:Y): Prop:=
    | halted_safety : halted x y -> exp_safety x y
    | internal_safety y': int_step x y y'  ->
                          (forall x',  valid x' y' -> exp_safety x' y') ->
                          exp_safety x y
    | external_safety x' y': ext_step x y x' y' ->
                             (forall x',  valid x' y' -> exp_safety x' y') ->
                             exp_safety x y.

    (*Parametrized version*)
    Inductive exp_safety_gen {_exp_safety} (x:X) (y:Y): Prop:=
    | paco_halted_safety : halted x y -> exp_safety_gen x y
    | paco_internal_safety y': int_step x y y'  ->
                               (forall x',  valid x' y' -> _exp_safety x' y') ->
                               exp_safety_gen x y
    | paco_external_safety x' y': ext_step x y x' y' ->
                                  (forall x',  valid x' y' -> _exp_safety x' y') ->
                                  exp_safety_gen x y.
    Definition paco_exp_safety := paco2 (@exp_safety_gen).

    (*Show that the paco representation is correct. *)
    Lemma exp_safety_paco_correct:
      forall x y, exp_safety x y <-> paco_exp_safety bot2 x y.
    Proof.
      intros x y; split; generalize x y; clear x y.
      - pcofix CO; intros x y HH.
        pfold. inversion HH;
          [ econstructor 1; eauto |
            econstructor 2; eauto |
            econstructor 3; eauto ]; intros x'' VAL'.
      - cofix CO; intros x y HH.
        inversion HH. inversion SIM;
          [ econstructor 1; eauto |
            econstructor 2; eauto |
            econstructor 3; eauto ]; intros x'' VAL'; eapply CO.
        + specialize (LE _ _ (H0 _ VAL')).
          destruct LE. 2: compute in *; tauto.
          apply H1.
        + specialize (LE _ _ (H0 _ VAL')).
          destruct LE. 2: compute in *; tauto.
          apply H1.
    Qed.

  End explicit_safety.

  Section explicit_safetyN.
    Inductive stepN x y y': nat -> Prop :=
    | trivial_step: y = y' -> stepN x y y' 0
    | _stepN n _y: int_step x y _y -> stepN x _y y' n -> stepN x y y' (S n).

    (** *Safety with stepN *)
    Inductive exp_safetyN_gen {_exp_safety} (x:X) (y:Y): Prop:=
    | paco_halted_safetyN : halted x y -> exp_safetyN_gen x y
    | paco_internal_safetyN y' n: stepN x y y' (S n)  ->
                                  (forall x',  valid x' y' -> _exp_safety x' y') ->
                                  exp_safetyN_gen x y
    | paco_external_safetyN x' y': ext_step x y x' y' ->
                                   (forall x',  valid x' y' -> _exp_safety x' y') ->
                                   exp_safetyN_gen x y.
    Definition paco_exp_safetyN := paco2 (@exp_safetyN_gen).

    Lemma determinismN:
      forall n,
      forall x y y',
        valid x y  -> stepN x y y' n ->
        forall x',
          valid x' y -> stepN x' y y' n.
    Proof. induction n.
           - intros; econstructor.
             inversion H0; assumption.
           - intros.
             inversion H0; subst.
             econstructor.
             eapply (determinism x y _y); eauto.
             eapply IHn; eauto.
             eapply valid_step; eauto.
             eapply valid_step; eauto.
             eapply (determinism x y _y); eauto.
    Qed.

    Lemma valid_stepN:
      forall n,
      forall x y y',
        valid x y  -> stepN x y y' n ->
        valid x y'.
    Proof. induction n; intros ? ? ? VAL HH; inversion HH; subst.
           - exact VAL.
           - apply (IHn _ _y); try assumption.
             apply (valid_step x y _y VAL H0).
    Qed.

    Lemma safetyN_equivalence:
      forall x y,
        valid x y ->
        paco_exp_safety bot2 x y <-> paco_exp_safetyN bot2 x y.
    Proof.
      intros x y VAL.
      split; generalize x y VAL; clear VAL x y.
      - pcofix CO.
        intros x y VAL HH.
        inversion HH.
        inversion SIM; subst; clear SIM.
        + pfold.
          econstructor 1; eassumption.
        + pfold.
          econstructor 2. apply (_stepN x y y' 0 y'); auto.
          constructor; reflexivity.
          intros x' AA.
          right.
          eapply CO; try assumption.
          specialize (LE _ _ (H0 _ AA)).
          destruct LE. 2: compute in *; tauto.
          unfold paco_exp_safety.
          apply H1.
        + pfold.
          econstructor 3. eauto.
          intros x'0 AA.
          right.
          eapply CO; try assumption.
          specialize (LE _ _ (H0 _ AA)).
          destruct LE. 2: compute in *; tauto.
          unfold paco_exp_safety.
          apply H1.
      - pcofix CO.
        intros x y VAL HH; inversion HH; clear HH.
        inversion SIM; subst; clear SIM.
        + pfold.
          econstructor 1; eassumption.
        + cut (valid x y').
          { intros VAL'.
            assert (LE':= LE).
            specialize (LE _ _ (H0 _ VAL')).
            destruct LE. 2: compute in *; tauto.
            generalize dependent y; generalize x.
            induction n.
            * (*base case*)
              intros ? ? VAL H; inversion H; inversion H4; subst; clear H H4.
              pfold. econstructor 2. eassumption.
              intros x' AA.
              right.
              eapply CO; try assumption.
              specialize (LE' _ _ (H0 _ AA)).
              destruct LE'; [ | compute in *; tauto].
              unfold paco_exp_safetyN.
              apply H.
            * (*inductive step*)
              intros. inversion H; subst; clear H.
              pfold; econstructor 2; eauto.
              intros.
              unfold upaco2.
              left; eapply IHn; eauto.
              eapply (determinismN _ x0 _y y' ) with (x'0:= x'); eauto.
              eapply valid_step; eauto.
          }
          { (*Prove the cut*)
            eapply valid_stepN; eauto.
          }
        + pfold.
          econstructor 3. eauto.
          intros x'0 AA.
          right.
          eapply CO; try assumption.
          specialize (LE _ _ (H0 _ AA)).
          destruct LE. 2: compute in *; tauto.
          unfold paco_exp_safety.
          apply H1.
    Qed.

  End explicit_safetyN.

  Section explicit_safetyN_stutter.

  Context {core_data: Type}
          {core_ord : core_data -> core_data -> Prop}
          (core_ord_wf: well_founded core_ord).

  (** *Safety with Stutter and stepN*)
  CoInductive exp_safetyN_stutter (cd:core_data) (x:X) (y:Y): Prop:=
  | halted_safetyN_stut : halted x y -> exp_safetyN_stutter cd x y
  | internal_safetyN_stut cd' y' n: stepN x y y' (S n)  ->
                            (forall x',  valid x' y' -> exp_safetyN_stutter cd' x' y') ->
                            exp_safetyN_stutter cd x y
  | external_safetyN_stut cd' x' y': ext_step x y x' y' ->
                            (forall x',  valid x' y' -> exp_safetyN_stutter cd' x' y') ->
                            exp_safetyN_stutter cd x y
  | stutter cd': core_ord cd' cd ->
                 exp_safetyN_stutter cd' x y ->
                 exp_safetyN_stutter cd x y.

  (*Paco version*)
  Inductive exp_safetyN_stutter_gen {_exp_safety} (cd:core_data) (x:X) (y:Y): Prop:=
  | paco_halted_safetyN_stut : halted x y -> exp_safetyN_stutter_gen cd x y
  | paco_internal_safetyN_stut cd' y' n: stepN x y y' (S n)  ->
                            (forall x',  valid x' y' -> _exp_safety cd' x' y') ->
                            exp_safetyN_stutter_gen cd x y
  | paco_external_safetyN_stut cd' x' y': ext_step x y x' y' ->
                            (forall x',  valid x' y' -> _exp_safety cd' x' y') ->
                            exp_safetyN_stutter_gen cd x y
  | paco_stutter cd': core_ord cd' cd ->
                 _exp_safety cd' x y ->
                 exp_safetyN_stutter_gen cd x y.
  Definition paco_exp_safetyN_stutter := paco3 (@exp_safetyN_stutter_gen).

  (*Show that the paco representation is correct. *)
  Lemma exp_safetyN_stutter_paco_correct:
    forall cd x y, exp_safetyN_stutter cd x y <-> paco_exp_safetyN_stutter bot3 cd x y.
  Proof.
    intros cd x y; split; generalize cd x y; clear cd x y.
    - pcofix CO; intros cd x y HH.
      pfold. inversion HH;
        [ econstructor 1; eauto |
            econstructor 2; eauto |
            econstructor 3; eauto |
            econstructor 4; eauto ]; intros x'' VAL'.
    - cofix CO; intros cd x y HH.
      inversion HH. inversion SIM;
        [ econstructor 1; eauto |
          econstructor 2; eauto |
          econstructor 3; eauto |
          econstructor 4; eauto ].
      + intros x'' VAL'; eapply CO.
        specialize (LE _ _ _ (H0 _ VAL')).
        destruct LE. 2: compute in *; tauto.
        apply H1.
      + intros x'' VAL'; eapply CO.
        specialize (LE _ _ _ (H0 _ VAL')).
          destruct LE. 2: compute in *; tauto.
          apply H1.
      + eapply CO .
        specialize (LE _ _ _ (H0)).
        destruct LE. 2: compute in *; tauto.
        apply H1.
  Qed.

  (*The stutter doesn't matter*)
  Lemma speach_therapy:
    forall cd x y,
      paco_exp_safetyN bot2 x y <->
      paco_exp_safetyN_stutter bot3 cd x y.
  Proof.
    intros cd x y.
    split; generalize cd x y; clear cd x y.
    - pcofix CO.
      intros cd x y HH; inversion HH; subst; clear HH.
      pfold.
      inversion SIM;
        [ econstructor 1; eauto |
          econstructor 2; eauto |
          econstructor 3; eauto ]; intros x0 VAL'.
      + specialize (LE _ _ (H0 _ VAL')).
        destruct LE; [| compute in *; tauto].
        unfold upaco3. right. apply CO. eapply H1.

      + specialize (LE _ _ (H0 _ VAL')).
        destruct LE; [| compute in *; tauto].
        unfold upaco3. right. apply CO. eapply H1.
    - pcofix CO.
      intros cd x y HH; pfold.
      generalize cd x y HH; clear HH y x cd.
      (*set up the well formed induction*)
      apply (@well_founded_ind _ core_ord core_ord_wf
                               (fun cd => forall (x : X) (y : Y),
                                      paco_exp_safetyN_stutter bot3 cd x y ->
                                      exp_safetyN_gen x y)); auto.

      (*now do teh cofixpoint induction*)

      intros x wf_ind x' y HH; inversion HH; subst; clear HH.
      inversion SIM; clear SIM;
        [ econstructor 1; eauto |
          econstructor 2; eauto |
          econstructor 3; eauto |].
      + intros x0 VAL'. specialize (LE _ _ _ (H0 _ VAL')).
        destruct LE; [| compute in *; tauto].
        unfold upaco3. right. eapply CO. eapply H1.
      + intros x0 VAL'. specialize (LE _ _ _ (H0 _ VAL')).
        destruct LE; [| compute in *; tauto].
        unfold upaco3. right. eapply CO. eapply H1.
      + eapply wf_ind in H; [ exact H|].
        pfold. specialize (LE _ _ _ (H0)).
        destruct LE; [| compute in *; tauto].
        simpl. punfold H1.
        {
          clear.
          unfold monotone3.
          intros.
          inversion IN;
        [ econstructor 1; eauto |
          econstructor 2; eauto |
          econstructor 3; eauto |
          econstructor 4; eauto ]. }
        Grab Existential Variables.
        assumption.
        assumption.
  Qed.
  End explicit_safetyN_stutter.

  Section The_Equivalence.

  Context (core_data: Type)
          (core_ord : core_data -> core_data -> Prop)
          (core_ord_wf: well_founded core_ord)
          (default: core_data).

  Theorem safety_stutter_stepN_equiv:
    forall x y,
      valid x y ->
      exp_safety x y <-> exists cd, @exp_safetyN_stutter _ core_ord cd x y.
  Proof.
    intros x y VAL; split; intros HH.
    - exists default.
      apply exp_safetyN_stutter_paco_correct.
      apply speach_therapy; [assumption|].
      apply safetyN_equivalence; [assumption|].
      apply exp_safety_paco_correct; assumption.
    - destruct HH as [cd HH].
      apply exp_safety_paco_correct.
      apply safetyN_equivalence; [assumption|].
      eapply speach_therapy with (cd0:=cd); [eassumption|].
      apply exp_safetyN_stutter_paco_correct; assumption.
  Qed.

  End The_Equivalence.

End safety_equivalence.


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

 The displayed bicategory of functors into categories

 In this file, we look at the displayed bicategory of functors into the category of strict categories.
 Note that here, we restrict ourselves to functors starting in strict categories.
 In addition, note that a functor into the category of strict categories is the same as a split opfibration on the source.

 Contents:
 1. Definition
 2. Properties

 ******************************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Setcategories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.categories.CategoryOfSetCategories.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Examples.StrictCats.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.

Local Open Scope cat.

(**
 1. Definition
 *)
Definition disp_cat_ob_mor_of_functors_into_cat
  : disp_cat_ob_mor bicat_of_strict_cats.
Proof.
  simple refine (_ ,, _).
  - exact (λ C, pr1 C ⟶ cat_of_setcategory).
  - exact (λ C₁ C₂ G₁ G₂ F, G₁ ⟹ F ∙ G₂).
Defined.

Definition disp_cat_id_comp_of_functors_into_cat
  : disp_cat_id_comp
      bicat_of_strict_cats
      disp_cat_ob_mor_of_functors_into_cat.
Proof.
  simple refine (_ ,, _).
  - exact (λ C G, nat_trans_id _).
  - exact (λ C₁ C₂ C₃ F₁ F₂ G₁ G₂ G₃ α β,
           nat_trans_comp
             _ _ _
             α
             (pre_whisker _ β)).
Defined.

Definition disp_cat_data_of_functors_into_cat
  : disp_cat_data bicat_of_strict_cats.
Proof.
  simple refine (_ ,, _).
  - exact disp_cat_ob_mor_of_functors_into_cat.
  - exact disp_cat_id_comp_of_functors_into_cat.
Defined.

Definition disp_prebicat_1_id_comp_cells_of_functors_into_cat
  : disp_prebicat_1_id_comp_cells bicat_of_strict_cats.
Proof.
  simple refine (_ ,, _).
  - exact disp_cat_data_of_functors_into_cat.
  - intros C₁ C₂ F₁ F₂ α G₁ G₂ β₁ β₂.
    exact (∏ (x : pr1 C₁), pr1 β₁ x · # (pr1 G₂) (pr1 α x) = pr1 β₂ x).
Defined.

Definition disp_prebicat_ops_of_functors_into_cat
  : disp_prebicat_ops
      disp_prebicat_1_id_comp_cells_of_functors_into_cat.
Proof.
  repeat split.
  - intros C₁ C₂ F G₁ G₂ α x ; cbn.
    etrans.
    {
      apply maponpaths.
      apply (functor_id G₂).
    }
    exact (id_right (pr1 α x)).
  - intros C₁ C₂ F G₁ G₂ α x ; cbn.
    etrans.
    {
      apply maponpaths.
      apply (functor_id G₂).
    }
    etrans.
    {
      apply maponpaths_2.
      exact (id_left (pr1 α x)).
    }
    exact (id_right (pr1 α x)).
  - intros C₁ C₂ F G₁ G₂ α x ; cbn.
    etrans.
    {
      apply maponpaths.
      apply (functor_id G₂).
    }
    etrans.
    {
      apply maponpaths_2.
      exact (id_right (pr1 α x)).
    }
    exact (id_right (pr1 α x)).
  - intros C₁ C₂ F G₁ G₂ α x ; cbn.
    etrans.
    {
      apply maponpaths.
      apply (functor_id G₂).
    }
    exact (id_right (pr1 α x) @ !(id_left (pr1 α x))).
  - intros C₁ C'_2 F G₁ G₂ α x ; cbn.
    apply maponpaths.
    apply (functor_id G₂).
  - intros C₁ C₂ C₃ C₄ F₁ F₂ F₃ G₁ G₂ G₃ G₄ α₁ α₂ α₃ x ; cbn.
    etrans.
    {
      apply maponpaths.
      apply (functor_id G₄).
    }
    etrans.
    {
      exact (id_right (pr1 α₁ _ · pr1 α₂ _ · pr1 α₃ _)).
    }
    rewrite !assoc'.
    apply idpath.
  - intros C₁ C₂ C₃ C₄ F₁ F₂ F₃ G₁ G₂ G₃ G₄ α₁ α₂ α₃ x ; cbn.
    etrans.
    {
      apply maponpaths.
      apply (functor_id G₄).
    }
    etrans.
    {
      exact (id_right (pr1 α₁ _ · (pr1 α₂ _ · pr1 α₃ _))).
    }
    rewrite !assoc.
    apply idpath.
  - intros C₁ C₂ F₁ F₂ F₃ α β G₁ G₂ γ₁ γ₂ γ₃ p₁ p₂ x ; cbn.
    etrans.
    {
      apply maponpaths.
      apply (functor_comp G₂).
    }
    refine (_ @ p₂ x).
    refine (_ @ maponpaths (λ z, z ∙ _) (p₁ x)).
    apply (assoc _ (# (pr1 G₂) (pr1 α x)) (# (pr1 G₂) (pr1 β x))).
  - intros C₁ C₂ C₃ F₁ F₂ F₃ α G₁ G₂ G₃ β₁ β₂ β₃ p x ; cbn.
    refine (assoc' (pr1 β₁ x) _ _ @ _).
    apply maponpaths.
    apply p.
  - intros C₁ C₂ C₃ F₁ F₂ F₃ α G₁ G₂ G₃ β₁ β₂ β₃ p x ; cbn.
    refine (!_).
    etrans.
    {
      apply maponpaths_2.
      exact (!(p _)).
    }
    refine (assoc' _ _ _ @ _ @ assoc (pr1 β₁ x) (pr1 β₃ (pr1 F₁ x)) _).
    apply maponpaths.
    apply (nat_trans_ax β₃).
Qed.

Definition disp_prebicat_data_of_functors_into_cat
  : disp_prebicat_data bicat_of_strict_cats.
Proof.
  simple refine (_ ,, _).
  - exact disp_prebicat_1_id_comp_cells_of_functors_into_cat.
  - exact disp_prebicat_ops_of_functors_into_cat.
Defined.

Definition isaprop_2cells_of_functors_into_cat
           {C₁ C₂ : bicat_of_strict_cats}
           {F₁ F₂ : C₁ --> C₂}
           (α : F₁ ==> F₂)
           {G₁ : disp_prebicat_data_of_functors_into_cat C₁}
           {G₂ : disp_prebicat_data_of_functors_into_cat C₂}
           (β₁ : G₁ -->[ F₁ ] G₂)
           (β₂ : G₁ -->[ F₂ ] G₂)
  : isaprop (β₁ ==>[ α ] β₂).
Proof.
  use impred ; intro.
  apply homset_property.
Qed.

Definition disp_prebicat_laws_of_functors_into_cat
  : disp_prebicat_laws disp_prebicat_data_of_functors_into_cat.
Proof.
  repeat split ; intro ; intros ; apply isaprop_2cells_of_functors_into_cat.
Qed.

Definition disp_prebicat_of_functors_into_cat
  : disp_prebicat bicat_of_strict_cats.
Proof.
  simple refine (_ ,, _).
  - exact disp_prebicat_data_of_functors_into_cat.
  - exact disp_prebicat_laws_of_functors_into_cat.
Defined.

Definition disp_bicat_of_functors_into_cat
  : disp_bicat bicat_of_strict_cats.
Proof.
  simple refine (_ ,, _).
  - exact disp_prebicat_of_functors_into_cat.
  - intros C₁ C₂ F₁ F₂ α G₁ G₂ β₁ β₂.
    apply isasetaprop.
    apply isaprop_2cells_of_functors_into_cat.
Defined.

(**
 2. Properties
 *)
Definition functors_into_cat_disp_2cells_isaprop
  : disp_2cells_isaprop disp_bicat_of_functors_into_cat.
Proof.
  intro ; intros.
  apply isaprop_2cells_of_functors_into_cat.
Qed.

Definition functors_into_cat_disp_locally_sym
  : disp_locally_sym disp_bicat_of_functors_into_cat.
Proof.
  intros C₁ C₂ F₁ F₂ α G₁ G₂ β₁ β₂ p x.
  etrans.
  {
    apply maponpaths_2.
    exact (!(p x)).
  }
  refine (assoc' (pr1 β₁ x) _ _ @ _ @ id_right _).
  apply maponpaths.
  refine (!(functor_comp G₂ _ _) @ _ @ functor_id G₂ _).
  apply maponpaths.
  exact (nat_trans_eq_pointwise (vcomp_rinv α) x).
Qed.

Definition functors_into_cat_disp_locally_groupoid
  : disp_locally_groupoid disp_bicat_of_functors_into_cat.
Proof.
  use make_disp_locally_groupoid.
  - exact functors_into_cat_disp_locally_sym.
  - exact functors_into_cat_disp_2cells_isaprop.
Defined.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)
(* begin hide *)
(* In this file a notion of morphism between two arbitrary real number
   structures, is introduced together with te proofs that this notion of
   morphism preserves the basic algebraic structure. *)

Require Import CoRN.reals.CReals.

(* This comes from CReals1.v *)
Definition Cauchy_Lim_prop2 (IR : CReals) (seq : nat -> IR)
  (y : IR) :=
  forall eps : IR,
  [0][<]eps ->
  {N : nat | forall m : nat, N <= m -> AbsSmall eps (seq m[-]y)}.

Section morphism.
Variables R1 R2 : CReals.

Section morphism_details.
Variable phi : R1 -> R2.

Variable p1 : R1 -> R1 -> CProp.
Variable p2 : R2 -> R2 -> CProp.
Variable f1 : R1 -> R1.
Variable f2 : R2 -> R2.
Variable g1 : R1 -> R1 -> R1.
Variable g2 : R2 -> R2 -> R2.

Definition fun_pres_relation := forall x y : R1, p1 x y -> p2 (phi x) (phi y).

Definition fun_pres_un_fun := forall x : R1, phi (f1 x)[=]f2 (phi x).

Definition fun_pres_bin_fun :=
  forall x y : R1, phi (g1 x y)[=]g2 (phi x) (phi y).

(*
Definition fun_pres_partial_fun:=(x:R1;H1:x[#][0];H2:(phi x)[#][0])
(phi (nzinj R1 (i1 (nzpro R1 x H1))))[=](nzinj R2 (i2 (nzpro R2 (phi x) H2))).
*)

Definition fun_pres_Lim :=
  forall (a : nat -> R1) (l_a : R1),
  Cauchy_Lim_prop2 R1 a l_a ->
  Cauchy_Lim_prop2 R2 (fun n : nat => phi (a n)) (phi l_a).

End morphism_details.

Record Homomorphism : Type :=
  {map :> R1 -> R2;
   map_strext : fun_strext map;
   map_pres_less :
    fun_pres_relation map (cof_less (c:=R1)) (cof_less (c:=R2));
   map_pres_plus : fun_pres_bin_fun map (csg_op (c:=R1)) (csg_op (c:=R2));
   map_pres_mult : fun_pres_bin_fun map (cr_mult (c:=R1)) (cr_mult (c:=R2));
   map_pres_Lim : fun_pres_Lim map}.

(* This might be useful later...
Definition Homo_as_CSetoid_fun:=
    [f:Homomorphism]
         (Build_CSetoid_fun R1 R2 f
           (fun_strext_imp_wd R1 R2 f (!map_strext f))
           (!map_strext f)
          ).
*****************)

Lemma map_strext_unfolded :
 forall (f : Homomorphism) (x y : R1), f x[#]f y -> x[#]y.
Proof.
 intro f.
 case f.
 intros. rename X into H.
 apply map_strext0.
 exact H.
Qed.

Lemma map_wd_unfolded :
 forall (f : Homomorphism) (x y : R1), x[=]y -> f x[=]f y.
Proof.
 intros.
 apply not_ap_imp_eq.
 intro H0.
 cut (Not (x[#]y)).
  intro H1.
  apply H1.
  apply map_strext_unfolded with (f := f).
  exact H0.
 apply eq_imp_not_ap.
 exact H.
Qed.

Lemma map_pres_less_unfolded :
 forall (f : Homomorphism) (x y : R1), x[<]y -> f x[<]f y.
Proof.
 intro f.
 case f.
 intros. rename X into H.
 apply map_pres_less.
 exact H.
Qed.

Lemma map_pres_plus_unfolded :
 forall (f : Homomorphism) (x y : R1), f (x[+]y)[=]f x[+]f y.
Proof.
 intros.
 case f.
 intros.
 apply map_pres_plus.
Qed.

Lemma map_pres_mult_unfolded :
 forall (f : Homomorphism) (x y : R1), f (x[*]y)[=]f x[*]f y.
Proof.
 intros.
 case f.
 intros.
 apply map_pres_mult.
Qed.

(* Now we start to derive some useful properties of a Homomorphism *)

Lemma map_pres_zero : forall f : Homomorphism, f (cm_unit R1)[=]cm_unit R2.
Proof.
 intros.
 apply cg_cancel_lft with (x := f [0]).
 apply eq_transitive_unfolded with (f [0]).
  apply eq_transitive_unfolded with (f ([0][+][0])).
   apply eq_symmetric_unfolded.
   apply map_pres_plus_unfolded.
  apply map_wd_unfolded with (f := f).
  algebra.
 algebra.
Qed.

Lemma map_pres_zero_unfolded : forall f : Homomorphism, f [0][=][0].
Proof.
 intro.
 apply map_pres_zero.
Qed.

Lemma map_pres_minus :
 forall f : Homomorphism, fun_pres_un_fun f (cg_inv (c:=R1)) (cg_inv (c:=R2)).
Proof.
 intro f.
 red in |- *.
 intro.
 apply cg_cancel_lft with (x := f x).
 astepr ([0]:R2).
 apply eq_transitive_unfolded with (f (x[+][--]x)).
  apply eq_symmetric_unfolded.
  apply map_pres_plus_unfolded.
 astepl (f [0]).
  apply map_pres_zero_unfolded.
 apply map_wd_unfolded.
 algebra.
Qed.

Lemma map_pres_minus_unfolded :
 forall (f : Homomorphism) (x : R1), f [--]x[=][--](f x).
Proof.
 exact map_pres_minus.
Qed.

Lemma map_pres_apartness :
 forall (f : Homomorphism) (x y : R1), x[#]y -> f x[#]f y.
Proof.
 intros f x y H.
 cut (x[<]y or y[<]x).
  intro H0.
  case H0.
   intro.
   apply less_imp_ap.
   apply map_pres_less_unfolded.
   assumption.
  intro H1.
  apply Greater_imp_ap.
  apply map_pres_less_unfolded.
  exact H1.
 apply ap_imp_less.
 exact H.
Qed.

     (* Merely a useful special case *)
Lemma map_pres_ap_zero :
 forall (f : Homomorphism) (x : R1), x[#][0] -> f x[#][0].
Proof.
 intros. rename X into H.
 apply ap_wdr_unfolded with (y := f [0]).
  apply map_pres_apartness with (y := [0]:R1).
  exact H.
 apply map_pres_zero_unfolded.
Qed.

Lemma map_pres_one : forall f : Homomorphism, f (cr_one R1)[=]cr_one R2.
Proof.
 intros.
 apply eq_symmetric_unfolded.
 apply mult_cancel_lft with (z := f [1]).
  apply map_pres_ap_zero.
  apply ring_non_triv.
 astepl (f [1]).
 astepl (f ([1][*][1])).
  apply map_pres_mult_unfolded.
 apply map_wd_unfolded with (f := f).
 algebra.
Qed.

Lemma map_pres_one_unfolded : forall f : Homomorphism, f [1][=][1].
Proof.
 intro.
 apply map_pres_one.
Qed.

(* I will not use the following lemma *)

Lemma map_pres_inv_unfolded :
 forall (f : Homomorphism) (x : R1) (H : x[#][0]),
 f ([1][/] x[//]H)[=]([1][/] f x[//]map_pres_ap_zero f x H).
Proof.
 intros.
 apply mult_cancel_lft with (z := f x).
  apply map_pres_ap_zero.
  assumption.
 rstepr ([1]:R2).
 astepl (f [1]).
  apply map_pres_one_unfolded.
 astepl (f (x[*]([1][/] x[//]H))).
  apply map_pres_mult_unfolded.
 apply map_wd_unfolded.
 rational.
Qed.

End morphism.

Section composition.
Variables R1 R2 R3 : CReals.
Variable f : Homomorphism R1 R2.
Variable g : Homomorphism R2 R3.

Definition compose (x : R1) := g (f x).

Lemma compose_strext : fun_strext compose.
Proof.
 red in |- *.
 unfold compose in |- *.
 case f.
 intro f_.
 intros f_1 f_2 f_3 f_4.
 case g.
 intro g_.
 intros g_1 g_2 g_3 g_4.
 intros. rename X into H.
 simpl in H.
 apply f_1.
 apply g_1.
 assumption.
Qed.

Lemma compose_pres_less :
 fun_pres_relation R1 R3 compose (cof_less (c:=R1)) (cof_less (c:=R3)).
Proof.
 red in |- *.
 unfold compose in |- *.
 case f.
 intro f_.
 intros f_1 f_2 f_3 f_4.
 case g.
 intro g_.
 intros g_1 g_2 g_3 g_4.
 intros.
 simpl in |- *.
 apply g_2.
 apply f_2.
 assumption.
Qed.

Lemma compose_pres_plus :
 fun_pres_bin_fun R1 R3 compose (csg_op (c:=R1)) (csg_op (c:=R3)).
Proof.
 red in |- *.
 unfold compose in |- *.
 case f.
 intro f_.
 intros f_1 f_2 f_3 f_4.
 cut (fun_wd g).
  case g.
  intro g_.
  intros g_1 g_2 g_3 g_4.
  intros.
  simpl in H.
  simpl in |- *.
  astepl (g_ (f_ x[+]f_ y)).
  apply g_3.
 red in |- *.
 intros.
 apply map_wd_unfolded.
 assumption.
Qed.

Lemma compose_pres_mult :
 fun_pres_bin_fun R1 R3 compose (cr_mult (c:=R1)) (cr_mult (c:=R3)).
Proof.
 red in |- *.
 unfold compose in |- *.
 case f.
 intro f_.
 intros f_1 f_2 f_3 f_4.
 cut (fun_wd g).
  case g.
  intro g_.
  intros g_1 g_2 g_3 g_4.
  intros.
  simpl in H.
  simpl in |- *.
  astepl (g_ (f_ x[*]f_ y)).
  apply g_4.
 red in |- *.
 intros.
 apply map_wd_unfolded.
 assumption.
Qed.

Lemma compose_pres_Lim : fun_pres_Lim R1 R3 compose.
Proof.
 red in |- *.
 unfold compose in |- *.
 case f.
 intro f_.
 intros f_1 f_2 f_3 f_4 f_5.
 case g.
 intro g_.
 intros g_1 g_2 g_3 g_4 g_5.
 intros.
 simpl in |- *.
 apply g_5 with (a := fun n : nat => f_ (a n)).
 apply f_5.
 assumption.
Qed.

Definition Compose :=
  Build_Homomorphism R1 R3 compose compose_strext compose_pres_less
    compose_pres_plus compose_pres_mult compose_pres_Lim.

End composition.

Section isomorphism.

Variables R1 R2 : CReals.

Section identity_map.
Variable R3 : CReals.
Variable f : R3 -> R3.

Definition map_is_id := forall x : R3, f x[=]x.

End identity_map.

Record Isomorphism : Type :=
  {iso_map_lft : Homomorphism R1 R2;
   iso_map_rht : Homomorphism R2 R1;
   inversity_lft : map_is_id R2 (Compose R2 R1 R2 iso_map_rht iso_map_lft);
   inversity_rht : map_is_id R1 (Compose R1 R2 R1 iso_map_lft iso_map_rht)}.

End isomorphism.

Section surjective_map.
Variables R1 R2 : CReals.
Variable f : R1 -> R2.

Definition map_is_surjective := forall y : R2, {x : R1 | y[=]f x}.

End surjective_map.

Section simplification.
Variables R1 R2 : CReals.
Variable f : R1 -> R2.

Hypothesis H1 : fun_strext f.

Lemma f_well_def : forall x y : R1, x[=]y -> f x[=]f y.
Proof.
 intros.
 apply not_ap_imp_eq.
 intro.
 cut (Not (x[#]y)).
  intro H2.
  apply H2.
  red in H1.
  apply H1.
  assumption.
 apply eq_imp_not_ap.
 assumption.
Qed.

Section with_less.

Hypothesis
  H2 : fun_pres_relation R1 R2 f (cof_less (c:=R1)) (cof_less (c:=R2)).

Lemma less_pres_f : forall x y : R1, f x[<]f y -> x[<]y.
Proof.
 intros.
 case (ap_imp_less R1 x y).
   red in H1.
   apply H1.
   apply less_imp_ap.
   assumption.
  intro.
  assumption.
 intro.
 exfalso.
 cut (f y[<]f x).
  change (Not (f y[<]f x)) in |- *.
  apply less_antisymmetric_unfolded.
  assumption.
 red in H2.
 apply H2.
 assumption.
Qed.

Lemma leEq_pres_f : forall x y : R1, f x[<=]f y -> x[<=]y.
Proof.
 intros; rewrite -> leEq_def; intro.
 apply less_irreflexive_unfolded with (x := f x).
 apply leEq_less_trans with (f y); auto.
Qed.

Lemma f_pres_leEq : forall x y : R1, x[<=]y -> f x[<=]f y.
Proof.
 intros; rewrite -> leEq_def; intro.
 apply less_irreflexive_unfolded with (x := x).
 apply leEq_less_trans with y; auto.
 apply less_pres_f; auto.
Qed.

Lemma f_pres_apartness : forall x y : R1, x[#]y -> f x[#]f y.
Proof.
 intros.
 cut (x[<]y or y[<]x).
  intro H0.
  case H0.
   intro.
   apply less_imp_ap.
   red in H2.
   apply H2.
   assumption.
  intro.
  apply Greater_imp_ap.
  red in H2.
  apply H2.
  assumption.
 apply ap_imp_less.
 assumption.
Qed.

End with_less.

Section with_plus.

Hypothesis H3 : fun_pres_bin_fun R1 R2 f (csg_op (c:=R1)) (csg_op (c:=R2)).

Lemma f_pres_One : f [0][=][0].
Proof.
 intros.
 apply cg_cancel_lft with (x := f [0]).
 astepr (f [0]).
 astepl (f ([0][+][0])).
 apply eq_symmetric_unfolded.
 red in H3.
 apply f_well_def.
 algebra.
Qed.

Lemma f_pres_minus : forall x : R1, f [--]x[=][--](f x).
Proof.
 intro.
 apply cg_cancel_lft with (x := f x).
 astepr ([0]:R2).
 astepl (f (x[+][--]x)).
 astepr (f [0]).
  apply f_well_def.
  algebra.
 apply f_pres_One.
Qed.

Lemma f_pres_min : forall x y : R1, f (x[-]y)[=]f x[-]f y.
Proof.
 intros.
 astepr (f (x[+][--]y)).
  apply f_well_def.
  algebra.
 astepr (f x[+][--](f y)).
 red in H3.
 astepr (f x[+]f [--]y).
  apply H3.
 apply bin_op_wd_unfolded.
  apply eq_reflexive_unfolded.
 apply f_pres_minus.
Qed.

End with_plus.

Section with_plus_less.

Hypothesis
  H2 : fun_pres_relation R1 R2 f (cof_less (c:=R1)) (cof_less (c:=R2)).

Hypothesis H3 : fun_pres_bin_fun R1 R2 f (csg_op (c:=R1)) (csg_op (c:=R2)).

Lemma f_pres_ap_zero : forall x : R1, x[#][0] -> f x[#][0].
Proof.
 intros.
 apply ap_wdr_unfolded with (y := f [0]).
  apply f_pres_apartness with (y := [0]:R1).
   assumption.
  assumption.
 apply f_pres_One.
 assumption.
Qed.

Section surjectivity_helps.
Hypothesis f_surj : map_is_surjective R1 R2 f.

Lemma f_pres_Lim : fun_pres_Lim R1 R2 f.
Proof.
 red in |- *.
 intros. rename X into H.
 unfold Cauchy_Lim_prop2 in |- *.
 intros e2 H0.
 red in f_surj.
 unfold Cauchy_Lim_prop2 in H.
 cut {x : R1 | e2[=]f x}.
  intro H4.
  case H4.
  intros e1 H5.
  cut {N : nat | forall m : nat, N <= m -> AbsSmall e1 (a m[-]l_a)}.
   intro H6.
   case H6.
   intro N.
   intros.
   exists N.
   intros.
   cut (AbsSmall e1 (a m[-]l_a)).
    intro.
    elim H8.
    intros.
    astepl (f e1).
    astepr (f (a m[-]l_a)).
     split.
      astepl (f [--]e1).
       apply f_pres_leEq.
        assumption.
       assumption.
      apply f_pres_minus.
      assumption.
     apply f_pres_leEq.
      assumption.
     assumption.
    apply f_pres_min.
    assumption.
   apply a0.
   assumption.
  apply H.
  apply less_pres_f.
   assumption.
  astepl ([0]:R2).
   astepr e2.
   assumption.
  apply eq_symmetric_unfolded.
  apply f_pres_One.
  assumption.
 apply f_surj.
Qed.

End surjectivity_helps.

Section with_mult_plus_less.

Hypothesis H4 : fun_pres_bin_fun R1 R2 f (cr_mult (c:=R1)) (cr_mult (c:=R2)).

Lemma f_pres_one : f [1][=][1].
Proof.
 intros.
 apply eq_symmetric_unfolded.
 apply mult_cancel_lft with (z := f [1]).
  apply f_pres_ap_zero.
  apply ring_non_triv.
 astepl (f [1]).
 astepr (f ([1][*][1])).
 apply f_well_def.
 algebra.
Qed.

Lemma f_pres_inv :
 forall (x : R1) (H : x[#][0]),
 f ([1][/] x[//]H)[=]([1][/] f x[//]f_pres_ap_zero x H).
Proof.
 intros.
 apply mult_cancel_lft with (z := f x).
  apply f_pres_ap_zero.
  assumption.
 rstepr ([1]:R2).
 astepr (f [1]).
  astepl (f (x[*]([1][/] x[//]H))).
  apply eq_symmetric_unfolded.
  apply f_well_def.
  rational.
 apply f_pres_one.
Qed.

Definition simplified_Homomorphism (f_surj : map_is_surjective R1 R2 f) :=
  Build_Homomorphism R1 R2 f H1 H2 H3 H4 (f_pres_Lim f_surj).

End with_mult_plus_less.

End with_plus_less.

End simplification.

(* end hide *)


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import Setoid_ring_theory.
Require Import Quote.

Set Implicit Arguments.

Lemma index_eq_prop : forall n m:index, Is_true (index_eq n m) -> n = m.
Proof.
  simple induction n; simple induction m; simpl;
   try reflexivity || contradiction.
  intros; rewrite (H i0); trivial.
  intros; rewrite (H i0); trivial.
Qed.

Section setoid.

Variable A : Type.
Variable Aequiv : A -> A -> Prop.
Variable Aplus : A -> A -> A.
Variable Amult : A -> A -> A.
Variable Aone : A.
Variable Azero : A.
Variable Aopp : A -> A.
Variable Aeq : A -> A -> bool.

Variable S : Setoid_Theory A Aequiv.

Add Setoid A Aequiv S as Asetoid.

Variable plus_morph :
 forall a a0:A, Aequiv a a0 ->
   forall a1 a2:A, Aequiv a1 a2 ->
     Aequiv (Aplus a a1)  (Aplus a0 a2).
Variable mult_morph :
 forall a a0:A, Aequiv a a0 ->
   forall a1 a2:A, Aequiv a1 a2 ->
     Aequiv (Amult a a1) (Amult a0 a2).
Variable opp_morph : forall a a0:A, Aequiv a a0 -> Aequiv (Aopp a) (Aopp a0).

Add Morphism Aplus : Aplus_ext.
intros; apply plus_morph; assumption.
Qed.

Add Morphism Amult : Amult_ext.
intros; apply mult_morph; assumption.
Qed.

Add Morphism Aopp : Aopp_ext.
exact opp_morph.
Qed.

Let equiv_refl := Seq_refl A Aequiv S.
Let equiv_sym := Seq_sym A Aequiv S.
Let equiv_trans := Seq_trans A Aequiv S.

Hint Resolve equiv_refl equiv_trans.
Hint Immediate equiv_sym.

Section semi_setoid_rings.

(* Section definitions. *)

(******************************************)
(* Normal abtract Polynomials             *)
(******************************************)
(* DEFINITIONS :
- A varlist is a sorted product of one or more variables : x, x*y*z
- A monom is a constant, a varlist or the product of a constant by a varlist
  variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT.
- A canonical sum is either a monom or an ordered sum of monoms
  (the order on monoms is defined later)
- A normal polynomial it either a constant or a canonical sum or a constant
  plus a canonical sum
*)

(* varlist is isomorphic to (list var), but we built a special inductive
   for efficiency *)
Inductive varlist : Type :=
  | Nil_var : varlist
  | Cons_var : index -> varlist -> varlist.

Inductive canonical_sum : Type :=
  | Nil_monom : canonical_sum
  | Cons_monom : A -> varlist -> canonical_sum -> canonical_sum
  | Cons_varlist : varlist -> canonical_sum -> canonical_sum.

(* Order on monoms *)

(* That's the lexicographic order on varlist, extended by :
  - A constant is less than every monom
  - The relation between two varlist is preserved by multiplication by a
  constant.

  Examples :
  3 < x < y
  x*y < x*y*y*z
  2*x*y < x*y*y*z
  x*y < 54*x*y*y*z
  4*x*y < 59*x*y*y*z
*)

Fixpoint varlist_eq (x y:varlist) {struct y} : bool :=
  match x, y with
  | Nil_var, Nil_var => true
  | Cons_var i xrest, Cons_var j yrest =>
      andb (index_eq i j) (varlist_eq xrest yrest)
  | _, _ => false
  end.

Fixpoint varlist_lt (x y:varlist) {struct y} : bool :=
  match x, y with
  | Nil_var, Cons_var _ _ => true
  | Cons_var i xrest, Cons_var j yrest =>
      if index_lt i j
      then true
      else andb (index_eq i j) (varlist_lt xrest yrest)
  | _, _ => false
  end.

(* merges two variables lists *)
Fixpoint varlist_merge (l1:varlist) : varlist -> varlist :=
  match l1 with
  | Cons_var v1 t1 =>
      (fix vm_aux (l2:varlist) : varlist :=
         match l2 with
         | Cons_var v2 t2 =>
             if index_lt v1 v2
             then Cons_var v1 (varlist_merge t1 l2)
             else Cons_var v2 (vm_aux t2)
         | Nil_var => l1
         end)
  | Nil_var => fun l2 => l2
  end.

(* returns the sum of two canonical sums  *)
Fixpoint canonical_sum_merge (s1:canonical_sum) :
 canonical_sum -> canonical_sum :=
  match s1 with
  | Cons_monom c1 l1 t1 =>
      (fix csm_aux (s2:canonical_sum) : canonical_sum :=
         match s2 with
         | Cons_monom c2 l2 t2 =>
             if varlist_eq l1 l2
             then Cons_monom (Aplus c1 c2) l1 (canonical_sum_merge t1 t2)
             else
              if varlist_lt l1 l2
              then Cons_monom c1 l1 (canonical_sum_merge t1 s2)
              else Cons_monom c2 l2 (csm_aux t2)
         | Cons_varlist l2 t2 =>
             if varlist_eq l1 l2
             then Cons_monom (Aplus c1 Aone) l1 (canonical_sum_merge t1 t2)
             else
              if varlist_lt l1 l2
              then Cons_monom c1 l1 (canonical_sum_merge t1 s2)
              else Cons_varlist l2 (csm_aux t2)
         | Nil_monom => s1
         end)
  | Cons_varlist l1 t1 =>
      (fix csm_aux2 (s2:canonical_sum) : canonical_sum :=
         match s2 with
         | Cons_monom c2 l2 t2 =>
             if varlist_eq l1 l2
             then Cons_monom (Aplus Aone c2) l1 (canonical_sum_merge t1 t2)
             else
              if varlist_lt l1 l2
              then Cons_varlist l1 (canonical_sum_merge t1 s2)
              else Cons_monom c2 l2 (csm_aux2 t2)
         | Cons_varlist l2 t2 =>
             if varlist_eq l1 l2
             then Cons_monom (Aplus Aone Aone) l1 (canonical_sum_merge t1 t2)
             else
              if varlist_lt l1 l2
              then Cons_varlist l1 (canonical_sum_merge t1 s2)
              else Cons_varlist l2 (csm_aux2 t2)
         | Nil_monom => s1
         end)
  | Nil_monom => fun s2 => s2
  end.

(* Insertion of a monom in a canonical sum *)
Fixpoint monom_insert (c1:A) (l1:varlist) (s2:canonical_sum) {struct s2} :
 canonical_sum :=
  match s2 with
  | Cons_monom c2 l2 t2 =>
      if varlist_eq l1 l2
      then Cons_monom (Aplus c1 c2) l1 t2
      else
       if varlist_lt l1 l2
       then Cons_monom c1 l1 s2
       else Cons_monom c2 l2 (monom_insert c1 l1 t2)
  | Cons_varlist l2 t2 =>
      if varlist_eq l1 l2
      then Cons_monom (Aplus c1 Aone) l1 t2
      else
       if varlist_lt l1 l2
       then Cons_monom c1 l1 s2
       else Cons_varlist l2 (monom_insert c1 l1 t2)
  | Nil_monom => Cons_monom c1 l1 Nil_monom
  end.

Fixpoint varlist_insert (l1:varlist) (s2:canonical_sum) {struct s2} :
 canonical_sum :=
  match s2 with
  | Cons_monom c2 l2 t2 =>
      if varlist_eq l1 l2
      then Cons_monom (Aplus Aone c2) l1 t2
      else
       if varlist_lt l1 l2
       then Cons_varlist l1 s2
       else Cons_monom c2 l2 (varlist_insert l1 t2)
  | Cons_varlist l2 t2 =>
      if varlist_eq l1 l2
      then Cons_monom (Aplus Aone Aone) l1 t2
      else
       if varlist_lt l1 l2
       then Cons_varlist l1 s2
       else Cons_varlist l2 (varlist_insert l1 t2)
  | Nil_monom => Cons_varlist l1 Nil_monom
  end.

(* Computes c0*s *)
Fixpoint canonical_sum_scalar (c0:A) (s:canonical_sum) {struct s} :
 canonical_sum :=
  match s with
  | Cons_monom c l t => Cons_monom (Amult c0 c) l (canonical_sum_scalar c0 t)
  | Cons_varlist l t => Cons_monom c0 l (canonical_sum_scalar c0 t)
  | Nil_monom => Nil_monom
  end.

(* Computes l0*s  *)
Fixpoint canonical_sum_scalar2 (l0:varlist) (s:canonical_sum) {struct s} :
 canonical_sum :=
  match s with
  | Cons_monom c l t =>
      monom_insert c (varlist_merge l0 l) (canonical_sum_scalar2 l0 t)
  | Cons_varlist l t =>
      varlist_insert (varlist_merge l0 l) (canonical_sum_scalar2 l0 t)
  | Nil_monom => Nil_monom
  end.

(* Computes c0*l0*s  *)
Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist)
 (s:canonical_sum) {struct s} : canonical_sum :=
  match s with
  | Cons_monom c l t =>
      monom_insert (Amult c0 c) (varlist_merge l0 l)
        (canonical_sum_scalar3 c0 l0 t)
  | Cons_varlist l t =>
      monom_insert c0 (varlist_merge l0 l) (canonical_sum_scalar3 c0 l0 t)
  | Nil_monom => Nil_monom
  end.

(* returns the product of two canonical sums *)
Fixpoint canonical_sum_prod (s1 s2:canonical_sum) {struct s1} :
 canonical_sum :=
  match s1 with
  | Cons_monom c1 l1 t1 =>
      canonical_sum_merge (canonical_sum_scalar3 c1 l1 s2)
        (canonical_sum_prod t1 s2)
  | Cons_varlist l1 t1 =>
      canonical_sum_merge (canonical_sum_scalar2 l1 s2)
        (canonical_sum_prod t1 s2)
  | Nil_monom => Nil_monom
  end.

(* The type to represent concrete semi-setoid-ring polynomials *)

Inductive setspolynomial : Type :=
  | SetSPvar : index -> setspolynomial
  | SetSPconst : A -> setspolynomial
  | SetSPplus : setspolynomial -> setspolynomial -> setspolynomial
  | SetSPmult : setspolynomial -> setspolynomial -> setspolynomial.

Fixpoint setspolynomial_normalize (p:setspolynomial) : canonical_sum :=
  match p with
  | SetSPplus l r =>
      canonical_sum_merge (setspolynomial_normalize l)
        (setspolynomial_normalize r)
  | SetSPmult l r =>
      canonical_sum_prod (setspolynomial_normalize l)
        (setspolynomial_normalize r)
  | SetSPconst c => Cons_monom c Nil_var Nil_monom
  | SetSPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom
  end.

Fixpoint canonical_sum_simplify (s:canonical_sum) : canonical_sum :=
  match s with
  | Cons_monom c l t =>
      if Aeq c Azero
      then canonical_sum_simplify t
      else
       if Aeq c Aone
       then Cons_varlist l (canonical_sum_simplify t)
       else Cons_monom c l (canonical_sum_simplify t)
  | Cons_varlist l t => Cons_varlist l (canonical_sum_simplify t)
  | Nil_monom => Nil_monom
  end.

Definition setspolynomial_simplify (x:setspolynomial) :=
  canonical_sum_simplify (setspolynomial_normalize x).

Variable vm : varmap A.

Definition interp_var (i:index) := varmap_find Azero i vm.

Definition ivl_aux :=
  (fix ivl_aux (x:index) (t:varlist) {struct t} : A :=
     match t with
     | Nil_var => interp_var x
     | Cons_var x' t' => Amult (interp_var x) (ivl_aux x' t')
     end).

Definition interp_vl (l:varlist) :=
  match l with
  | Nil_var => Aone
  | Cons_var x t => ivl_aux x t
  end.

Definition interp_m (c:A) (l:varlist) :=
  match l with
  | Nil_var => c
  | Cons_var x t => Amult c (ivl_aux x t)
  end.

Definition ics_aux :=
  (fix ics_aux (a:A) (s:canonical_sum) {struct s} : A :=
     match s with
     | Nil_monom => a
     | Cons_varlist l t => Aplus a (ics_aux (interp_vl l) t)
     | Cons_monom c l t => Aplus a (ics_aux (interp_m c l) t)
     end).

Definition interp_setcs (s:canonical_sum) : A :=
  match s with
  | Nil_monom => Azero
  | Cons_varlist l t => ics_aux (interp_vl l) t
  | Cons_monom c l t => ics_aux (interp_m c l) t
  end.

Fixpoint interp_setsp (p:setspolynomial) : A :=
  match p with
  | SetSPconst c => c
  | SetSPvar i => interp_var i
  | SetSPplus p1 p2 => Aplus (interp_setsp p1) (interp_setsp p2)
  | SetSPmult p1 p2 => Amult (interp_setsp p1) (interp_setsp p2)
  end.

(* End interpretation. *)

Unset Implicit Arguments.

(* Section properties. *)

Variable T : Semi_Setoid_Ring_Theory Aequiv Aplus Amult Aone Azero Aeq.

Hint Resolve (SSR_plus_comm T).
Hint Resolve (SSR_plus_assoc T).
Hint Resolve (SSR_plus_assoc2 S T).
Hint Resolve (SSR_mult_comm T).
Hint Resolve (SSR_mult_assoc T).
Hint Resolve (SSR_mult_assoc2 S T).
Hint Resolve (SSR_plus_zero_left T).
Hint Resolve (SSR_plus_zero_left2 S T).
Hint Resolve (SSR_mult_one_left T).
Hint Resolve (SSR_mult_one_left2 S T).
Hint Resolve (SSR_mult_zero_left T).
Hint Resolve (SSR_mult_zero_left2 S T).
Hint Resolve (SSR_distr_left T).
Hint Resolve (SSR_distr_left2 S T).
Hint Resolve (SSR_plus_reg_left T).
Hint Resolve (SSR_plus_permute S plus_morph T).
Hint Resolve (SSR_mult_permute S mult_morph T).
Hint Resolve (SSR_distr_right S plus_morph T).
Hint Resolve (SSR_distr_right2 S plus_morph T).
Hint Resolve (SSR_mult_zero_right S T).
Hint Resolve (SSR_mult_zero_right2 S T).
Hint Resolve (SSR_plus_zero_right S T).
Hint Resolve (SSR_plus_zero_right2 S T).
Hint Resolve (SSR_mult_one_right S T).
Hint Resolve (SSR_mult_one_right2 S T).
Hint Resolve (SSR_plus_reg_right S T).
Hint Resolve eq_refl eq_sym eq_trans.
Hint Immediate T.

Lemma varlist_eq_prop : forall x y:varlist, Is_true (varlist_eq x y) -> x = y.
Proof.
  simple induction x; simple induction y; contradiction || (try reflexivity).
  simpl; intros.
  generalize (andb_prop2 _ _ H1); intros; elim H2; intros.
  rewrite (index_eq_prop _ _ H3); rewrite (H v0 H4); reflexivity.
Qed.

Remark ivl_aux_ok :
 forall (v:varlist) (i:index),
   Aequiv (ivl_aux i v) (Amult (interp_var i) (interp_vl v)).
Proof.
  simple induction v; simpl; intros.
  trivial.
  rewrite (H i); trivial.
Qed.

Lemma varlist_merge_ok :
 forall x y:varlist,
   Aequiv (interp_vl (varlist_merge x y)) (Amult (interp_vl x) (interp_vl y)).
Proof.
  simple induction x.
  simpl; trivial.
  simple induction y.
  simpl; trivial.
  simpl; intros.
  elim (index_lt i i0); simpl; intros.

  rewrite (ivl_aux_ok v i).
  rewrite (ivl_aux_ok v0 i0).
  rewrite (ivl_aux_ok (varlist_merge v (Cons_var i0 v0)) i).
  rewrite (H (Cons_var i0 v0)).
  simpl.
  rewrite (ivl_aux_ok v0 i0).
  eauto.

  rewrite (ivl_aux_ok v i).
  rewrite (ivl_aux_ok v0 i0).
  rewrite
   (ivl_aux_ok
      ((fix vm_aux (l2:varlist) : varlist :=
          match l2 with
          | Nil_var => Cons_var i v
          | Cons_var v2 t2 =>
              if index_lt i v2
              then Cons_var i (varlist_merge v l2)
              else Cons_var v2 (vm_aux t2)
          end) v0) i0).
  rewrite H0.
  rewrite (ivl_aux_ok v i).
  eauto.
Qed.

Remark ics_aux_ok :
 forall (x:A) (s:canonical_sum),
   Aequiv (ics_aux x s) (Aplus x (interp_setcs s)).
Proof.
 simple induction s; simpl; intros; trivial.
Qed.

Remark interp_m_ok :
 forall (x:A) (l:varlist), Aequiv (interp_m x l) (Amult x (interp_vl l)).
Proof.
  destruct l as [| i v]; trivial.
Qed.

Hint Resolve ivl_aux_ok.
Hint Resolve ics_aux_ok.
Hint Resolve interp_m_ok.

(* Hints Resolve ivl_aux_ok ics_aux_ok interp_m_ok. *)

Lemma canonical_sum_merge_ok :
 forall x y:canonical_sum,
   Aequiv (interp_setcs (canonical_sum_merge x y))
     (Aplus (interp_setcs x) (interp_setcs y)).
Proof.
simple induction x; simpl.
trivial.

simple induction y; simpl; intros.
eauto.

generalize (varlist_eq_prop v v0).
elim (varlist_eq v v0).
intros; rewrite (H1 I).
simpl.
rewrite (ics_aux_ok (interp_m a v0) c).
rewrite (ics_aux_ok (interp_m a0 v0) c0).
rewrite (ics_aux_ok (interp_m (Aplus a a0) v0) (canonical_sum_merge c c0)).
rewrite (H c0).
rewrite (interp_m_ok (Aplus a a0) v0).
rewrite (interp_m_ok a v0).
rewrite (interp_m_ok a0 v0).
setoid_replace (Amult (Aplus a a0) (interp_vl v0)) with
 (Aplus (Amult a (interp_vl v0)) (Amult a0 (interp_vl v0)));
 [ idtac | trivial ].
setoid_replace
 (Aplus (Aplus (Amult a (interp_vl v0)) (Amult a0 (interp_vl v0)))
    (Aplus (interp_setcs c) (interp_setcs c0))) with
 (Aplus (Amult a (interp_vl v0))
    (Aplus (Amult a0 (interp_vl v0))
       (Aplus (interp_setcs c) (interp_setcs c0))));
 [ idtac | trivial ].
setoid_replace
 (Aplus (Aplus (Amult a (interp_vl v0)) (interp_setcs c))
    (Aplus (Amult a0 (interp_vl v0)) (interp_setcs c0))) with
 (Aplus (Amult a (interp_vl v0))
    (Aplus (interp_setcs c)
       (Aplus (Amult a0 (interp_vl v0)) (interp_setcs c0))));
 [ idtac | trivial ].
auto.

elim (varlist_lt v v0); simpl.
intro.
rewrite
 (ics_aux_ok (interp_m a v) (canonical_sum_merge c (Cons_monom a0 v0 c0)))
 .
rewrite (ics_aux_ok (interp_m a v) c).
rewrite (ics_aux_ok (interp_m a0 v0) c0).
rewrite (H (Cons_monom a0 v0 c0)); simpl.
rewrite (ics_aux_ok (interp_m a0 v0) c0); auto.

intro.
rewrite
 (ics_aux_ok (interp_m a0 v0)
    ((fix csm_aux (s2:canonical_sum) : canonical_sum :=
        match s2 with
        | Nil_monom => Cons_monom a v c
        | Cons_monom c2 l2 t2 =>
            if varlist_eq v l2
            then Cons_monom (Aplus a c2) v (canonical_sum_merge c t2)
            else
             if varlist_lt v l2
             then Cons_monom a v (canonical_sum_merge c s2)
             else Cons_monom c2 l2 (csm_aux t2)
        | Cons_varlist l2 t2 =>
            if varlist_eq v l2
            then Cons_monom (Aplus a Aone) v (canonical_sum_merge c t2)
            else
             if varlist_lt v l2
             then Cons_monom a v (canonical_sum_merge c s2)
             else Cons_varlist l2 (csm_aux t2)
        end) c0)).
rewrite H0.
rewrite (ics_aux_ok (interp_m a v) c);
 rewrite (ics_aux_ok (interp_m a0 v0) c0); simpl;
 auto.

generalize (varlist_eq_prop v v0).
elim (varlist_eq v v0).
intros; rewrite (H1 I).
simpl.
rewrite (ics_aux_ok (interp_m (Aplus a Aone) v0) (canonical_sum_merge c c0));
 rewrite (ics_aux_ok (interp_m a v0) c);
 rewrite (ics_aux_ok (interp_vl v0) c0).
rewrite (H c0).
rewrite (interp_m_ok (Aplus a Aone) v0).
rewrite (interp_m_ok a v0).
setoid_replace (Amult (Aplus a Aone) (interp_vl v0)) with
 (Aplus (Amult a (interp_vl v0)) (Amult Aone (interp_vl v0)));
 [ idtac | trivial ].
setoid_replace
 (Aplus (Aplus (Amult a (interp_vl v0)) (Amult Aone (interp_vl v0)))
    (Aplus (interp_setcs c) (interp_setcs c0))) with
 (Aplus (Amult a (interp_vl v0))
    (Aplus (Amult Aone (interp_vl v0))
       (Aplus (interp_setcs c) (interp_setcs c0))));
 [ idtac | trivial ].
setoid_replace
 (Aplus (Aplus (Amult a (interp_vl v0)) (interp_setcs c))
    (Aplus (interp_vl v0) (interp_setcs c0))) with
 (Aplus (Amult a (interp_vl v0))
    (Aplus (interp_setcs c) (Aplus (interp_vl v0) (interp_setcs c0))));
 [ idtac | trivial ].
setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0);
 [ idtac | trivial ].
auto.

elim (varlist_lt v v0); simpl.
intro.
rewrite
 (ics_aux_ok (interp_m a v) (canonical_sum_merge c (Cons_varlist v0 c0)))
 ; rewrite (ics_aux_ok (interp_m a v) c);
 rewrite (ics_aux_ok (interp_vl v0) c0).
rewrite (H (Cons_varlist v0 c0)); simpl.
rewrite (ics_aux_ok (interp_vl v0) c0).
auto.

intro.
rewrite
 (ics_aux_ok (interp_vl v0)
    ((fix csm_aux (s2:canonical_sum) : canonical_sum :=
        match s2 with
        | Nil_monom => Cons_monom a v c
        | Cons_monom c2 l2 t2 =>
            if varlist_eq v l2
            then Cons_monom (Aplus a c2) v (canonical_sum_merge c t2)
            else
             if varlist_lt v l2
             then Cons_monom a v (canonical_sum_merge c s2)
             else Cons_monom c2 l2 (csm_aux t2)
        | Cons_varlist l2 t2 =>
            if varlist_eq v l2
            then Cons_monom (Aplus a Aone) v (canonical_sum_merge c t2)
            else
             if varlist_lt v l2
             then Cons_monom a v (canonical_sum_merge c s2)
             else Cons_varlist l2 (csm_aux t2)
        end) c0)); rewrite H0.
rewrite (ics_aux_ok (interp_m a v) c); rewrite (ics_aux_ok (interp_vl v0) c0);
 simpl.
auto.

simple induction y; simpl; intros.
trivial.

generalize (varlist_eq_prop v v0).
elim (varlist_eq v v0).
intros; rewrite (H1 I).
simpl.
rewrite (ics_aux_ok (interp_m (Aplus Aone a) v0) (canonical_sum_merge c c0));
 rewrite (ics_aux_ok (interp_vl v0) c);
 rewrite (ics_aux_ok (interp_m a v0) c0); rewrite (H c0).
rewrite (interp_m_ok (Aplus Aone a) v0); rewrite (interp_m_ok a v0).
setoid_replace (Amult (Aplus Aone a) (interp_vl v0)) with
 (Aplus (Amult Aone (interp_vl v0)) (Amult a (interp_vl v0)));
 [ idtac | trivial ].
setoid_replace
 (Aplus (Aplus (Amult Aone (interp_vl v0)) (Amult a (interp_vl v0)))
    (Aplus (interp_setcs c) (interp_setcs c0))) with
 (Aplus (Amult Aone (interp_vl v0))
    (Aplus (Amult a (interp_vl v0))
       (Aplus (interp_setcs c) (interp_setcs c0))));
 [ idtac | trivial ].
setoid_replace
 (Aplus (Aplus (interp_vl v0) (interp_setcs c))
    (Aplus (Amult a (interp_vl v0)) (interp_setcs c0))) with
 (Aplus (interp_vl v0)
    (Aplus (interp_setcs c)
       (Aplus (Amult a (interp_vl v0)) (interp_setcs c0))));
 [ idtac | trivial ].
auto.

elim (varlist_lt v v0); simpl; intros.
rewrite
 (ics_aux_ok (interp_vl v) (canonical_sum_merge c (Cons_monom a v0 c0)))
 ; rewrite (ics_aux_ok (interp_vl v) c);
 rewrite (ics_aux_ok (interp_m a v0) c0).
rewrite (H (Cons_monom a v0 c0)); simpl.
rewrite (ics_aux_ok (interp_m a v0) c0); auto.

rewrite
 (ics_aux_ok (interp_m a v0)
    ((fix csm_aux2 (s2:canonical_sum) : canonical_sum :=
        match s2 with
        | Nil_monom => Cons_varlist v c
        | Cons_monom c2 l2 t2 =>
            if varlist_eq v l2
            then Cons_monom (Aplus Aone c2) v (canonical_sum_merge c t2)
            else
             if varlist_lt v l2
             then Cons_varlist v (canonical_sum_merge c s2)
             else Cons_monom c2 l2 (csm_aux2 t2)
        | Cons_varlist l2 t2 =>
            if varlist_eq v l2
            then Cons_monom (Aplus Aone Aone) v (canonical_sum_merge c t2)
            else
             if varlist_lt v l2
             then Cons_varlist v (canonical_sum_merge c s2)
             else Cons_varlist l2 (csm_aux2 t2)
        end) c0)); rewrite H0.
rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_m a v0) c0);
 simpl; auto.

generalize (varlist_eq_prop v v0).
elim (varlist_eq v v0); intros.
rewrite (H1 I); simpl.
rewrite
 (ics_aux_ok (interp_m (Aplus Aone Aone) v0) (canonical_sum_merge c c0))
 ; rewrite (ics_aux_ok (interp_vl v0) c);
 rewrite (ics_aux_ok (interp_vl v0) c0); rewrite (H c0).
rewrite (interp_m_ok (Aplus Aone Aone) v0).
setoid_replace (Amult (Aplus Aone Aone) (interp_vl v0)) with
 (Aplus (Amult Aone (interp_vl v0)) (Amult Aone (interp_vl v0)));
 [ idtac | trivial ].
setoid_replace
 (Aplus (Aplus (Amult Aone (interp_vl v0)) (Amult Aone (interp_vl v0)))
    (Aplus (interp_setcs c) (interp_setcs c0))) with
 (Aplus (Amult Aone (interp_vl v0))
    (Aplus (Amult Aone (interp_vl v0))
       (Aplus (interp_setcs c) (interp_setcs c0))));
 [ idtac | trivial ].
setoid_replace
 (Aplus (Aplus (interp_vl v0) (interp_setcs c))
    (Aplus (interp_vl v0) (interp_setcs c0))) with
 (Aplus (interp_vl v0)
    (Aplus (interp_setcs c) (Aplus (interp_vl v0) (interp_setcs c0))));
[ idtac | trivial ].
setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0); auto.

elim (varlist_lt v v0); simpl.
rewrite
 (ics_aux_ok (interp_vl v) (canonical_sum_merge c (Cons_varlist v0 c0)))
 ; rewrite (ics_aux_ok (interp_vl v) c);
 rewrite (ics_aux_ok (interp_vl v0) c0); rewrite (H (Cons_varlist v0 c0));
 simpl.
rewrite (ics_aux_ok (interp_vl v0) c0); auto.

rewrite
 (ics_aux_ok (interp_vl v0)
    ((fix csm_aux2 (s2:canonical_sum) : canonical_sum :=
        match s2 with
        | Nil_monom => Cons_varlist v c
        | Cons_monom c2 l2 t2 =>
            if varlist_eq v l2
            then Cons_monom (Aplus Aone c2) v (canonical_sum_merge c t2)
            else
             if varlist_lt v l2
             then Cons_varlist v (canonical_sum_merge c s2)
             else Cons_monom c2 l2 (csm_aux2 t2)
        | Cons_varlist l2 t2 =>
            if varlist_eq v l2
            then Cons_monom (Aplus Aone Aone) v (canonical_sum_merge c t2)
            else
             if varlist_lt v l2
             then Cons_varlist v (canonical_sum_merge c s2)
             else Cons_varlist l2 (csm_aux2 t2)
        end) c0)); rewrite H0.
rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_vl v0) c0);
 simpl; auto.
Qed.

Lemma monom_insert_ok :
 forall (a:A) (l:varlist) (s:canonical_sum),
   Aequiv (interp_setcs (monom_insert a l s))
     (Aplus (Amult a (interp_vl l)) (interp_setcs s)).
Proof.
simple induction s; intros.
simpl; rewrite (interp_m_ok a l); trivial.

simpl; generalize (varlist_eq_prop l v); elim (varlist_eq l v).
intro Hr; rewrite (Hr I); simpl.
rewrite (ics_aux_ok (interp_m (Aplus a a0) v) c);
 rewrite (ics_aux_ok (interp_m a0 v) c).
rewrite (interp_m_ok (Aplus a a0) v); rewrite (interp_m_ok a0 v).
setoid_replace (Amult (Aplus a a0) (interp_vl v)) with
 (Aplus (Amult a (interp_vl v)) (Amult a0 (interp_vl v)));
 [ idtac | trivial ].
auto.

elim (varlist_lt l v); simpl; intros.
rewrite (ics_aux_ok (interp_m a0 v) c).
rewrite (interp_m_ok a0 v); rewrite (interp_m_ok a l).
auto.

rewrite (ics_aux_ok (interp_m a0 v) (monom_insert a l c));
 rewrite (ics_aux_ok (interp_m a0 v) c); rewrite H.
auto.

simpl.
generalize (varlist_eq_prop l v); elim (varlist_eq l v).
intro Hr; rewrite (Hr I); simpl.
rewrite (ics_aux_ok (interp_m (Aplus a Aone) v) c);
 rewrite (ics_aux_ok (interp_vl v) c).
rewrite (interp_m_ok (Aplus a Aone) v).
setoid_replace (Amult (Aplus a Aone) (interp_vl v)) with
 (Aplus (Amult a (interp_vl v)) (Amult Aone (interp_vl v)));
 [ idtac | trivial ].
setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v);
 [ idtac | trivial ].
auto.

elim (varlist_lt l v); simpl; intros; auto.
rewrite (ics_aux_ok (interp_vl v) (monom_insert a l c)); rewrite H.
rewrite (ics_aux_ok (interp_vl v) c); auto.
Qed.

Lemma varlist_insert_ok :
 forall (l:varlist) (s:canonical_sum),
   Aequiv (interp_setcs (varlist_insert l s))
     (Aplus (interp_vl l) (interp_setcs s)).
Proof.
simple induction s; simpl; intros.
trivial.

generalize (varlist_eq_prop l v); elim (varlist_eq l v).
intro Hr; rewrite (Hr I); simpl.
rewrite (ics_aux_ok (interp_m (Aplus Aone a) v) c);
 rewrite (ics_aux_ok (interp_m a v) c).
rewrite (interp_m_ok (Aplus Aone a) v); rewrite (interp_m_ok a v).
setoid_replace (Amult (Aplus Aone a) (interp_vl v)) with
 (Aplus (Amult Aone (interp_vl v)) (Amult a (interp_vl v)));
 [ idtac | trivial ].
setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto.

elim (varlist_lt l v); simpl; intros; auto.
rewrite (ics_aux_ok (interp_m a v) (varlist_insert l c));
 rewrite (ics_aux_ok (interp_m a v) c).
rewrite (interp_m_ok a v).
rewrite H; auto.

generalize (varlist_eq_prop l v); elim (varlist_eq l v).
intro Hr; rewrite (Hr I); simpl.
rewrite (ics_aux_ok (interp_m (Aplus Aone Aone) v) c);
 rewrite (ics_aux_ok (interp_vl v) c).
rewrite (interp_m_ok (Aplus Aone Aone) v).
setoid_replace (Amult (Aplus Aone Aone) (interp_vl v)) with
 (Aplus (Amult Aone (interp_vl v)) (Amult Aone (interp_vl v)));
 [ idtac | trivial ].
setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto.

elim (varlist_lt l v); simpl; intros; auto.
rewrite (ics_aux_ok (interp_vl v) (varlist_insert l c)).
rewrite H.
rewrite (ics_aux_ok (interp_vl v) c); auto.
Qed.

Lemma canonical_sum_scalar_ok :
 forall (a:A) (s:canonical_sum),
   Aequiv (interp_setcs (canonical_sum_scalar a s))
     (Amult a (interp_setcs s)).
Proof.
simple induction s; simpl; intros.
trivial.

rewrite (ics_aux_ok (interp_m (Amult a a0) v) (canonical_sum_scalar a c));
 rewrite (ics_aux_ok (interp_m a0 v) c).
rewrite (interp_m_ok (Amult a a0) v); rewrite (interp_m_ok a0 v).
rewrite H.
setoid_replace (Amult a (Aplus (Amult a0 (interp_vl v)) (interp_setcs c)))
 with (Aplus (Amult a (Amult a0 (interp_vl v))) (Amult a (interp_setcs c)));
 [ idtac | trivial ].
auto.

rewrite (ics_aux_ok (interp_m a v) (canonical_sum_scalar a c));
 rewrite (ics_aux_ok (interp_vl v) c); rewrite H.
rewrite (interp_m_ok a v).
auto.
Qed.

Lemma canonical_sum_scalar2_ok :
 forall (l:varlist) (s:canonical_sum),
   Aequiv (interp_setcs (canonical_sum_scalar2 l s))
     (Amult (interp_vl l) (interp_setcs s)).
Proof.
simple induction s; simpl; intros; auto.
rewrite (monom_insert_ok a (varlist_merge l v) (canonical_sum_scalar2 l c)).
rewrite (ics_aux_ok (interp_m a v) c).
rewrite (interp_m_ok a v).
rewrite H.
rewrite (varlist_merge_ok l v).
setoid_replace
 (Amult (interp_vl l) (Aplus (Amult a (interp_vl v)) (interp_setcs c))) with
 (Aplus (Amult (interp_vl l) (Amult a (interp_vl v)))
    (Amult (interp_vl l) (interp_setcs c)));
 [ idtac | trivial ].
auto.

rewrite (varlist_insert_ok (varlist_merge l v) (canonical_sum_scalar2 l c)).
rewrite (ics_aux_ok (interp_vl v) c).
rewrite H.
rewrite (varlist_merge_ok l v).
auto.
Qed.

Lemma canonical_sum_scalar3_ok :
 forall (c:A) (l:varlist) (s:canonical_sum),
   Aequiv (interp_setcs (canonical_sum_scalar3 c l s))
     (Amult c (Amult (interp_vl l) (interp_setcs s))).
Proof.
simple induction s; simpl; intros.
rewrite (SSR_mult_zero_right S T (interp_vl l)).
auto.

rewrite
 (monom_insert_ok (Amult c a) (varlist_merge l v)
    (canonical_sum_scalar3 c l c0)).
rewrite (ics_aux_ok (interp_m a v) c0).
rewrite (interp_m_ok a v).
rewrite H.
rewrite (varlist_merge_ok l v).
setoid_replace
 (Amult (interp_vl l) (Aplus (Amult a (interp_vl v)) (interp_setcs c0))) with
 (Aplus (Amult (interp_vl l) (Amult a (interp_vl v)))
    (Amult (interp_vl l) (interp_setcs c0)));
 [ idtac | trivial ].
setoid_replace
 (Amult c
    (Aplus (Amult (interp_vl l) (Amult a (interp_vl v)))
       (Amult (interp_vl l) (interp_setcs c0)))) with
 (Aplus (Amult c (Amult (interp_vl l) (Amult a (interp_vl v))))
    (Amult c (Amult (interp_vl l) (interp_setcs c0))));
 [ idtac | trivial ].
setoid_replace (Amult (Amult c a) (Amult (interp_vl l) (interp_vl v))) with
 (Amult c (Amult a (Amult (interp_vl l) (interp_vl v))));
 [ idtac | trivial ].
auto.

rewrite
 (monom_insert_ok c (varlist_merge l v) (canonical_sum_scalar3 c l c0))
 .
rewrite (ics_aux_ok (interp_vl v) c0).
rewrite H.
rewrite (varlist_merge_ok l v).
setoid_replace
 (Aplus (Amult c (Amult (interp_vl l) (interp_vl v)))
    (Amult c (Amult (interp_vl l) (interp_setcs c0)))) with
 (Amult c
    (Aplus (Amult (interp_vl l) (interp_vl v))
       (Amult (interp_vl l) (interp_setcs c0))));
 [ idtac | trivial ].
auto.
Qed.

Lemma canonical_sum_prod_ok :
 forall x y:canonical_sum,
   Aequiv (interp_setcs (canonical_sum_prod x y))
     (Amult (interp_setcs x) (interp_setcs y)).
Proof.
simple induction x; simpl; intros.
trivial.

rewrite
 (canonical_sum_merge_ok (canonical_sum_scalar3 a v y)
    (canonical_sum_prod c y)).
rewrite (canonical_sum_scalar3_ok a v y).
rewrite (ics_aux_ok (interp_m a v) c).
rewrite (interp_m_ok a v).
rewrite (H y).
setoid_replace (Amult a (Amult (interp_vl v) (interp_setcs y))) with
 (Amult (Amult a (interp_vl v)) (interp_setcs y));
 [ idtac | trivial ].
setoid_replace
 (Amult (Aplus (Amult a (interp_vl v)) (interp_setcs c)) (interp_setcs y))
 with
 (Aplus (Amult (Amult a (interp_vl v)) (interp_setcs y))
    (Amult (interp_setcs c) (interp_setcs y)));
 [ idtac | trivial ].
trivial.

rewrite
 (canonical_sum_merge_ok (canonical_sum_scalar2 v y) (canonical_sum_prod c y))
 .
rewrite (canonical_sum_scalar2_ok v y).
rewrite (ics_aux_ok (interp_vl v) c).
rewrite (H y).
trivial.
Qed.

Theorem setspolynomial_normalize_ok :
 forall p:setspolynomial,
   Aequiv (interp_setcs (setspolynomial_normalize p)) (interp_setsp p).
Proof.
simple induction p; simpl; intros; trivial.
rewrite
 (canonical_sum_merge_ok (setspolynomial_normalize s)
    (setspolynomial_normalize s0)).
rewrite H; rewrite H0; trivial.

rewrite
 (canonical_sum_prod_ok (setspolynomial_normalize s)
    (setspolynomial_normalize s0)).
rewrite H; rewrite H0; trivial.
Qed.

Lemma canonical_sum_simplify_ok :
 forall s:canonical_sum,
   Aequiv (interp_setcs (canonical_sum_simplify s)) (interp_setcs s).
Proof.
simple induction s; simpl; intros.
trivial.

generalize (SSR_eq_prop T a Azero).
elim (Aeq a Azero).
simpl.
intros.
rewrite (ics_aux_ok (interp_m a v) c).
rewrite (interp_m_ok a v).
rewrite (H0 I).
setoid_replace (Amult Azero (interp_vl v)) with Azero;
 [ idtac | trivial ].
rewrite H.
trivial.

intros; simpl.
generalize (SSR_eq_prop T a Aone).
elim (Aeq a Aone).
intros.
rewrite (ics_aux_ok (interp_m a v) c).
rewrite (interp_m_ok a v).
rewrite (H1 I).
simpl.
rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)).
rewrite H.
auto.

simpl.
intros.
rewrite (ics_aux_ok (interp_m a v) (canonical_sum_simplify c)).
rewrite (ics_aux_ok (interp_m a v) c).
rewrite H; trivial.

rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)).
rewrite H.
auto.
Qed.

Theorem setspolynomial_simplify_ok :
 forall p:setspolynomial,
   Aequiv (interp_setcs (setspolynomial_simplify p)) (interp_setsp p).
Proof.
intro.
unfold setspolynomial_simplify.
rewrite (canonical_sum_simplify_ok (setspolynomial_normalize p)).
exact (setspolynomial_normalize_ok p).
Qed.

End semi_setoid_rings.

Arguments Cons_varlist : default implicits.
Arguments Cons_monom : default implicits.
Arguments SetSPconst : default implicits.
Arguments SetSPplus : default implicits.
Arguments SetSPmult : default implicits.

Section setoid_rings.

Set Implicit Arguments.

Variable vm : varmap A.
Variable T : Setoid_Ring_Theory Aequiv Aplus Amult Aone Azero Aopp Aeq.

Hint Resolve (STh_plus_comm T).
Hint Resolve (STh_plus_assoc T).
Hint Resolve (STh_plus_assoc2 S T).
Hint Resolve (STh_mult_comm T).
Hint Resolve (STh_mult_assoc T).
Hint Resolve (STh_mult_assoc2 S T).
Hint Resolve (STh_plus_zero_left T).
Hint Resolve (STh_plus_zero_left2 S T).
Hint Resolve (STh_mult_one_left T).
Hint Resolve (STh_mult_one_left2 S T).
Hint Resolve (STh_mult_zero_left S plus_morph mult_morph T).
Hint Resolve (STh_mult_zero_left2 S plus_morph mult_morph T).
Hint Resolve (STh_distr_left T).
Hint Resolve (STh_distr_left2 S T).
Hint Resolve (STh_plus_reg_left S plus_morph T).
Hint Resolve (STh_plus_permute S plus_morph T).
Hint Resolve (STh_mult_permute S mult_morph T).
Hint Resolve (STh_distr_right S plus_morph T).
Hint Resolve (STh_distr_right2 S plus_morph T).
Hint Resolve (STh_mult_zero_right S plus_morph mult_morph T).
Hint Resolve (STh_mult_zero_right2 S plus_morph mult_morph T).
Hint Resolve (STh_plus_zero_right S T).
Hint Resolve (STh_plus_zero_right2 S T).
Hint Resolve (STh_mult_one_right S T).
Hint Resolve (STh_mult_one_right2 S T).
Hint Resolve (STh_plus_reg_right S plus_morph T).
Hint Resolve eq_refl eq_sym eq_trans.
Hint Immediate T.

(*** Definitions *)

Inductive setpolynomial : Type :=
  | SetPvar : index -> setpolynomial
  | SetPconst : A -> setpolynomial
  | SetPplus : setpolynomial -> setpolynomial -> setpolynomial
  | SetPmult : setpolynomial -> setpolynomial -> setpolynomial
  | SetPopp : setpolynomial -> setpolynomial.

Fixpoint setpolynomial_normalize (x:setpolynomial) : canonical_sum :=
  match x with
  | SetPplus l r =>
      canonical_sum_merge (setpolynomial_normalize l)
        (setpolynomial_normalize r)
  | SetPmult l r =>
      canonical_sum_prod (setpolynomial_normalize l)
        (setpolynomial_normalize r)
  | SetPconst c => Cons_monom c Nil_var Nil_monom
  | SetPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom
  | SetPopp p =>
      canonical_sum_scalar3 (Aopp Aone) Nil_var (setpolynomial_normalize p)
  end.

Definition setpolynomial_simplify (x:setpolynomial) :=
  canonical_sum_simplify (setpolynomial_normalize x).

Fixpoint setspolynomial_of (x:setpolynomial) : setspolynomial :=
  match x with
  | SetPplus l r => SetSPplus (setspolynomial_of l) (setspolynomial_of r)
  | SetPmult l r => SetSPmult (setspolynomial_of l) (setspolynomial_of r)
  | SetPconst c => SetSPconst c
  | SetPvar i => SetSPvar i
  | SetPopp p => SetSPmult (SetSPconst (Aopp Aone)) (setspolynomial_of p)
  end.

(*** Interpretation *)

Fixpoint interp_setp (p:setpolynomial) : A :=
  match p with
  | SetPconst c => c
  | SetPvar i => varmap_find Azero i vm
  | SetPplus p1 p2 => Aplus (interp_setp p1) (interp_setp p2)
  | SetPmult p1 p2 => Amult (interp_setp p1) (interp_setp p2)
  | SetPopp p1 => Aopp (interp_setp p1)
  end.

(*** Properties *)

Unset Implicit Arguments.

Lemma setspolynomial_of_ok :
 forall p:setpolynomial,
   Aequiv (interp_setp p) (interp_setsp vm (setspolynomial_of p)).
simple induction p; trivial; simpl; intros.
rewrite H; rewrite H0; trivial.
rewrite H; rewrite H0; trivial.
rewrite H.
rewrite
 (STh_opp_mult_left2 S plus_morph mult_morph T Aone
    (interp_setsp vm (setspolynomial_of s))).
rewrite (STh_mult_one_left T (interp_setsp vm (setspolynomial_of s))).
trivial.
Qed.

Theorem setpolynomial_normalize_ok :
 forall p:setpolynomial,
   setpolynomial_normalize p = setspolynomial_normalize (setspolynomial_of p).
simple induction p; trivial; simpl; intros.
rewrite H; rewrite H0; reflexivity.
rewrite H; rewrite H0; reflexivity.
rewrite H; simpl.
elim
 (canonical_sum_scalar3 (Aopp Aone) Nil_var
    (setspolynomial_normalize (setspolynomial_of s)));
 [ reflexivity
 | simpl; intros; rewrite H0; reflexivity
 | simpl; intros; rewrite H0; reflexivity ].
Qed.

Theorem setpolynomial_simplify_ok :
 forall p:setpolynomial,
   Aequiv (interp_setcs vm (setpolynomial_simplify p)) (interp_setp p).
intro.
unfold setpolynomial_simplify.
rewrite (setspolynomial_of_ok p).
rewrite setpolynomial_normalize_ok.
rewrite
 (canonical_sum_simplify_ok vm
    (Semi_Setoid_Ring_Theory_of A Aequiv S Aplus Amult Aone Azero Aopp Aeq
       plus_morph mult_morph T)
    (setspolynomial_normalize (setspolynomial_of p)))
 .
rewrite
 (setspolynomial_normalize_ok vm
    (Semi_Setoid_Ring_Theory_of A Aequiv S Aplus Amult Aone Azero Aopp Aeq
       plus_morph mult_morph T) (setspolynomial_of p))
 .
trivial.
Qed.

End setoid_rings.

End setoid.