Deplacement des fichiers ancienne syntaxe dans theories7, contrib7 et states7

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/coq/trunk@5026 85f007b7-540e-0410-9357-904b9bb8a0f7

39 files changed, 8578 insertions, 0 deletions

diff --git a/contrib7/correctness/.cvsignore b/contrib7/correctness/.cvsignore
new file mode 100644
index 0000000000..9408ea1c8b
--- /dev/null
+++ b/contrib7/correctness/.cvsignore
@@ -0,0 +1,2 @@
+psyntax.ppo
+*.v8
diff --git a/contrib7/correctness/ArrayPermut.v b/contrib7/correctness/ArrayPermut.v
new file mode 100644
index 0000000000..55259b943d
--- /dev/null
+++ b/contrib7/correctness/ArrayPermut.v
@@ -0,0 +1,183 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id$ *)
+
+(****************************************************************************)
+(*                    Permutations of elements in arrays                    *)
+(*                        Definition and properties                         *)
+(****************************************************************************)
+
+Require ProgInt.
+Require Arrays.
+Require Export Exchange.
+
+Require Omega.
+
+Set Implicit Arguments.
+
+(* We define "permut" as the smallest equivalence relation which contains
+ * transpositions i.e. exchange of two elements.
+ *)
+
+Inductive permut [n:Z; A:Set] : (array n A)->(array n A)->Prop :=
+    exchange_is_permut : 
+      (t,t':(array n A))(i,j:Z)(exchange t t' i j) -> (permut t t')
+  | permut_refl : 
+      (t:(array n A))(permut t t)
+  | permut_sym : 
+      (t,t':(array n A))(permut t t') -> (permut t' t)
+  | permut_trans : 
+      (t,t',t'':(array n A))
+      (permut t t') -> (permut t' t'') -> (permut t t'').
+
+Hints Resolve exchange_is_permut permut_refl permut_sym permut_trans : v62 datatypes.
+
+(* We also define the permutation on a segment of an array, "sub_permut",
+ * the other parts of the array being unchanged
+ *
+ * One again we define it as the smallest equivalence relation containing
+ * transpositions on the given segment.
+ *)
+
+Inductive sub_permut [n:Z; A:Set; g,d:Z] : (array n A)->(array n A)->Prop :=
+    exchange_is_sub_permut : 
+      (t,t':(array n A))(i,j:Z)`g <= i <= d` -> `g <= j <= d`
+      -> (exchange t t' i j) -> (sub_permut g d t t')
+  | sub_permut_refl : 
+      (t:(array n A))(sub_permut g d t t)
+  | sub_permut_sym : 
+      (t,t':(array n A))(sub_permut g d t t') -> (sub_permut g d t' t)
+  | sub_permut_trans : 
+      (t,t',t'':(array n A))
+      (sub_permut g d t t') -> (sub_permut g d t' t'') 
+      -> (sub_permut g d t t'').
+
+Hints Resolve exchange_is_sub_permut sub_permut_refl sub_permut_sym sub_permut_trans
+  : v62 datatypes.
+
+(* To express that some parts of arrays are equal we introduce the
+ * property "array_id" which says that a segment is the same on two
+ * arrays.
+ *)
+
+Definition array_id := [n:Z][A:Set][t,t':(array n A)][g,d:Z]
+  (i:Z) `g <= i <= d` -> #t[i] = #t'[i].
+
+(* array_id is an equivalence relation *)
+
+Lemma array_id_refl : 
+  (n:Z)(A:Set)(t:(array n A))(g,d:Z)
+  (array_id t t g d).
+Proof.
+Unfold array_id.
+Auto with datatypes.
+Save.
+
+Hints Resolve array_id_refl : v62 datatypes.
+
+Lemma array_id_sym :
+  (n:Z)(A:Set)(t,t':(array n A))(g,d:Z)
+  (array_id t t' g d)
+  -> (array_id t' t g d).
+Proof.
+Unfold array_id. Intros.
+Symmetry; Auto with datatypes.
+Save.
+
+Hints Resolve  array_id_sym : v62 datatypes.
+
+Lemma array_id_trans :
+  (n:Z)(A:Set)(t,t',t'':(array n A))(g,d:Z)
+  (array_id t t' g d)
+  -> (array_id t' t'' g d)
+    -> (array_id t t'' g d).
+Proof.
+Unfold array_id. Intros.
+Apply trans_eq with y:=#t'[i]; Auto with datatypes.
+Save.
+
+Hints Resolve array_id_trans: v62 datatypes.
+
+(* Outside the segment [g,d] the elements are equal *)
+
+Lemma sub_permut_id :
+  (n:Z)(A:Set)(t,t':(array n A))(g,d:Z)
+  (sub_permut g d t t') ->
+  (array_id t t' `0` `g-1`) /\ (array_id t t' `d+1` `n-1`).
+Proof.
+Intros n A t t' g d. Induction 1; Intros.
+Elim H2; Intros.
+Unfold array_id; Split; Intros.
+Apply H7; Omega.
+Apply H7; Omega.
+Auto with datatypes.
+Decompose [and] H1; Auto with datatypes.
+Decompose [and] H1; Decompose [and] H3; EAuto with datatypes.
+Save.
+
+Hints Resolve sub_permut_id.
+
+Lemma sub_permut_eq :
+  (n:Z)(A:Set)(t,t':(array n A))(g,d:Z)
+  (sub_permut g d t t') ->
+  (i:Z) (`0<=i<g` \/ `d<i<n`) -> #t[i]=#t'[i].
+Proof.
+Intros n A t t' g d Htt' i Hi.
+Elim (sub_permut_id Htt'). Unfold array_id. 
+Intros.
+Elim Hi; [ Intro; Apply H; Omega | Intro; Apply H0; Omega ].
+Save.
+
+(* sub_permut is a particular case of permutation *)
+
+Lemma sub_permut_is_permut :
+  (n:Z)(A:Set)(t,t':(array n A))(g,d:Z)
+  (sub_permut g d t t') ->
+  (permut t t').
+Proof.
+Intros n A t t' g d. Induction 1; Intros; EAuto with datatypes.
+Save.
+
+Hints Resolve sub_permut_is_permut.
+
+(* If we have a sub-permutation on an empty segment, then we have a 
+ * sub-permutation on any segment.
+ *)
+
+Lemma sub_permut_void :
+  (N:Z)(A:Set)(t,t':(array N A))
+  (g,g',d,d':Z) `d < g`
+   -> (sub_permut g d t t') -> (sub_permut g' d' t t').
+Proof.
+Intros N A t t' g g' d d' Hdg.
+(Induction 1; Intros).
+(Absurd `g <= d`; Omega).
+Auto with datatypes.
+Auto with datatypes.
+EAuto with datatypes.
+Save.
+
+(* A sub-permutation on a segment may be extended to any segment that
+ * contains the first one.
+ *)
+
+Lemma sub_permut_extension :
+  (N:Z)(A:Set)(t,t':(array N A))
+  (g,g',d,d':Z) `g' <= g` -> `d <= d'`
+   -> (sub_permut g d t t') -> (sub_permut g' d' t t').
+Proof.
+Intros N A t t' g g' d d' Hgg' Hdd'.
+(Induction 1; Intros).
+Apply exchange_is_sub_permut with i:=i j:=j; [ Omega | Omega | Assumption ].
+Auto with datatypes.
+Auto with datatypes.
+EAuto with datatypes.
+Save.
diff --git a/contrib7/correctness/Arrays.v b/contrib7/correctness/Arrays.v
new file mode 100644
index 0000000000..40b19e74f4
--- /dev/null
+++ b/contrib7/correctness/Arrays.v
@@ -0,0 +1,75 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id$ *)
+
+(**********************************************)
+(* Functional arrays, for use in Correctness. *)
+(**********************************************)
+
+(* This is an axiomatization of arrays.
+ *
+ * The type (array N T) is the type of arrays ranging from 0 to N-1 
+ * which elements are of type T.
+ *
+ * Arrays are created with new, accessed with access and modified with store. 
+ *
+ * Operations of accessing and storing are not guarded, but axioms are.
+ * So these arrays can be viewed as arrays where accessing and storing
+ * out of the bounds has no effect.
+ *)
+
+
+Require Export ProgInt.
+
+Set Implicit Arguments.
+
+
+(* The type of arrays *)
+
+Parameter array : Z -> Set -> Set.
+
+
+(* Functions to create, access and modify arrays *)
+
+Parameter new : (n:Z)(T:Set) T -> (array n T).
+
+Parameter access : (n:Z)(T:Set) (array n T) -> Z -> T.
+
+Parameter store : (n:Z)(T:Set) (array n T) -> Z -> T -> (array n T).
+
+
+(* Axioms *)
+
+Axiom new_def : (n:Z)(T:Set)(v0:T)
+                (i:Z) `0<=i<n` -> (access (new n v0) i) = v0.
+
+Axiom store_def_1 : (n:Z)(T:Set)(t:(array n T))(v:T)
+                    (i:Z) `0<=i<n` ->
+                    (access (store t i v) i) = v.
+
+Axiom store_def_2 : (n:Z)(T:Set)(t:(array n T))(v:T)
+                    (i:Z)(j:Z) `0<=i<n` -> `0<=j<n` ->
+		    `i <> j` ->
+                    (access (store t i v) j) = (access t j).
+
+Hints Resolve new_def store_def_1 store_def_2 : datatypes v62.
+
+(* A tactic to simplify access in arrays *)
+
+Tactic Definition ArrayAccess i j H :=
+    Elim (Z_eq_dec i j); [ 
+      Intro H; Rewrite H; Rewrite store_def_1
+    | Intro H; Rewrite store_def_2; [ Idtac | Idtac | Idtac | Exact H ] ].
+
+(* Symbolic notation for access *)
+
+Notation "# t [ c ]" := (access t c) (at level 0, t ident)
+  V8only (at level 0, t at level 0).
diff --git a/contrib7/correctness/Arrays_stuff.v b/contrib7/correctness/Arrays_stuff.v
new file mode 100644
index 0000000000..184602c573
--- /dev/null
+++ b/contrib7/correctness/Arrays_stuff.v
@@ -0,0 +1,16 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id$ *)
+
+Require Export Exchange.
+Require Export ArrayPermut.
+Require Export Sorted.
+
diff --git a/contrib7/correctness/Correctness.v b/contrib7/correctness/Correctness.v
new file mode 100644
index 0000000000..8f3f90b95e
--- /dev/null
+++ b/contrib7/correctness/Correctness.v
@@ -0,0 +1,25 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id$ *)
+
+(* Correctness is base on the tactic Refine (developped on purpose) *)
+
+Require Export Tuples.
+
+Require Export ProgInt.
+Require Export ProgBool.
+Require Export Zwf.
+
+Require Export Arrays.
+
+(*
+Token "'".
+*)
diff --git a/contrib7/correctness/Exchange.v b/contrib7/correctness/Exchange.v
new file mode 100644
index 0000000000..85c19b48bc
--- /dev/null
+++ b/contrib7/correctness/Exchange.v
@@ -0,0 +1,94 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id$ *)
+
+(****************************************************************************)
+(*                   Exchange of two elements in an array                   *)
+(*                        Definition and properties                         *)
+(****************************************************************************)
+
+Require ProgInt.
+Require Arrays.
+
+Set Implicit Arguments.
+
+(* Definition *)
+
+Inductive exchange [n:Z; A:Set; t,t':(array n A); i,j:Z] : Prop :=
+  exchange_c :
+    `0<=i<n` -> `0<=j<n` ->
+    (#t[i] = #t'[j]) ->
+    (#t[j] = #t'[i]) ->
+    ((k:Z)`0<=k<n` -> `k<>i` -> `k<>j` -> #t[k] = #t'[k]) ->
+    (exchange t t' i j).
+    
+(* Properties about exchanges *)
+
+Lemma exchange_1 : (n:Z)(A:Set)(t:(array n A))
+  (i,j:Z) `0<=i<n` -> `0<=j<n` ->
+  (access (store (store t i #t[j]) j #t[i]) i) = #t[j].
+Proof.
+Intros n A t i j H_i H_j.
+Case (dec_eq j i).
+Intro eq_i_j. Rewrite eq_i_j.
+Auto with datatypes.
+Intro not_j_i.
+Rewrite (store_def_2 (store t i #t[j]) #t[i] H_j H_i not_j_i).
+Auto with datatypes.
+Save.
+
+Hints Resolve exchange_1 : v62 datatypes.
+
+
+Lemma exchange_proof :
+  (n:Z)(A:Set)(t:(array n A))
+  (i,j:Z) `0<=i<n` -> `0<=j<n` ->
+  (exchange (store (store t i (access t j)) j (access t i)) t i j).
+Proof.
+Intros n A t i j H_i H_j.
+Apply exchange_c; Auto with datatypes.
+Intros k H_k not_k_i not_k_j.
+Cut ~j=k; Auto with datatypes. Intro not_j_k.
+Rewrite (store_def_2 (store t i (access t j)) (access t i) H_j H_k not_j_k).
+Auto with datatypes.
+Save.
+
+Hints Resolve exchange_proof : v62 datatypes.
+
+
+Lemma exchange_sym :
+  (n:Z)(A:Set)(t,t':(array n A))(i,j:Z)
+  (exchange t t' i j) -> (exchange t' t i j).
+Proof.
+Intros n A t t' i j H1.
+Elim H1. Clear H1. Intros.
+Constructor 1; Auto with datatypes.
+Intros. Rewrite (H3 k); Auto with datatypes.
+Save.
+
+Hints Resolve exchange_sym : v62 datatypes.
+
+
+Lemma exchange_id :
+  (n:Z)(A:Set)(t,t':(array n A))(i,j:Z)
+  (exchange t t' i j) -> 
+  i=j ->
+  (k:Z) `0 <= k < n` -> (access t k)=(access t' k).
+Proof.
+Intros n A t t' i j Hex Heq k Hk.
+Elim Hex. Clear Hex. Intros.
+Rewrite Heq in H1. Rewrite Heq in H2.
+Case (Z_eq_dec k j). 
+  Intro Heq'. Rewrite Heq'. Assumption.
+  Intro Hnoteq. Apply (H3 k); Auto with datatypes. Rewrite Heq. Assumption.
+Save.
+
+Hints Resolve exchange_id : v62 datatypes.
diff --git a/contrib7/correctness/ProgBool.v b/contrib7/correctness/ProgBool.v
new file mode 100644
index 0000000000..364cc8d6a4
--- /dev/null
+++ b/contrib7/correctness/ProgBool.v
@@ -0,0 +1,66 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id$ *)
+
+Require ZArith.
+Require Export Bool_nat.
+Require Export Sumbool.
+
+Definition annot_bool :
+  (b:bool) { b':bool | if b' then b=true else b=false }.
+Proof.
+Intro b.
+Exists b. Case b; Trivial.
+Save.
+
+
+(* Logical connectives *)
+
+Definition spec_and := [A,B,C,D:Prop][b:bool]if b then A /\ C else B \/ D.
+
+Definition prog_bool_and :
+  (Q1,Q2:bool->Prop) (sig bool Q1) -> (sig bool Q2)
+  -> { b:bool | if b then (Q1 true) /\ (Q2 true)
+                     else (Q1 false) \/ (Q2 false) }.
+Proof.
+Intros Q1 Q2 H1 H2.
+Elim H1. Intro b1. Elim H2. Intro b2. 
+Case b1; Case b2; Intros.
+Exists true; Auto.
+Exists false; Auto. Exists false; Auto. Exists false; Auto.
+Save.
+
+Definition spec_or := [A,B,C,D:Prop][b:bool]if b then A \/ C else B /\ D.
+
+Definition prog_bool_or :
+  (Q1,Q2:bool->Prop) (sig bool Q1) -> (sig bool Q2)
+  -> { b:bool | if b then (Q1 true) \/ (Q2 true)
+                     else (Q1 false) /\ (Q2 false) }.
+Proof.
+Intros Q1 Q2 H1 H2.
+Elim H1. Intro b1. Elim H2. Intro b2. 
+Case b1; Case b2; Intros.
+Exists true; Auto. Exists true; Auto. Exists true; Auto.
+Exists false; Auto.
+Save.
+
+Definition spec_not:= [A,B:Prop][b:bool]if b then B else A.
+
+Definition prog_bool_not :
+  (Q:bool->Prop) (sig bool Q)
+  -> { b:bool | if b then (Q false) else (Q true) }.
+Proof.
+Intros Q H.
+Elim H. Intro b.
+Case b; Intro.
+Exists false; Auto. Exists true; Auto.
+Save.
+
diff --git a/contrib7/correctness/ProgInt.v b/contrib7/correctness/ProgInt.v
new file mode 100644
index 0000000000..ec46e2de62
--- /dev/null
+++ b/contrib7/correctness/ProgInt.v
@@ -0,0 +1,19 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id$ *)
+
+Require Export ZArith.
+Require Export ZArith_dec.
+
+Theorem Znotzero : (x:Z){`x<>0`}+{`x=0`}.
+Proof.
+Intro x. Elim (Z_eq_dec x `0`) ; Auto.
+Save.
diff --git a/contrib7/correctness/ProgramsExtraction.v b/contrib7/correctness/ProgramsExtraction.v
new file mode 100644
index 0000000000..8458105b4d
--- /dev/null
+++ b/contrib7/correctness/ProgramsExtraction.v
@@ -0,0 +1,30 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id$ *)
+
+Require Export Extraction.
+
+Extract Inductive unit => unit [ "()" ].
+Extract Inductive bool => bool [ true false ].
+Extract Inductive sumbool => bool [ true false ].
+
+Require Export Correctness.
+
+Declare ML Module "pextract".
+
+Grammar vernac vernac : ast :=
+  imperative_ocaml [ "Write" "Caml" "File" stringarg($file) 
+    "[" ne_identarg_list($idl) "]" "." ]
+     -> [ (IMPERATIVEEXTRACTION $file (VERNACARGLIST ($LIST $idl))) ]
+
+| initialize [ "Initialize" identarg($id) "with" comarg($c) "." ]
+     -> [ (INITIALIZE $id $c) ]
+.
diff --git a/contrib7/correctness/Programs_stuff.v b/contrib7/correctness/Programs_stuff.v
new file mode 100644
index 0000000000..0fe6921670
--- /dev/null
+++ b/contrib7/correctness/Programs_stuff.v
@@ -0,0 +1,13 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id$ *)
+
+Require Export Arrays_stuff.
diff --git a/contrib7/correctness/Sorted.v b/contrib7/correctness/Sorted.v
new file mode 100644
index 0000000000..7e656ae1b3
--- /dev/null
+++ b/contrib7/correctness/Sorted.v
@@ -0,0 +1,198 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(*  Library about sorted (sub-)arrays / Nicolas Magaud, July 1998 *)
+
+(* $Id$ *)
+
+Require Export Arrays.
+Require ArrayPermut.
+
+Require ZArithRing.
+Require Omega.
+V7only [Import Z_scope.].
+Open Local Scope Z_scope.
+
+Set Implicit Arguments.
+
+(* Definition *)
+
+Definition sorted_array :=
+  [N:Z][A:(array N Z)][deb:Z][fin:Z]
+     `deb<=fin` -> (x:Z) `x>=deb` -> `x<fin` -> (Zle #A[x] #A[`x+1`]).
+
+(* Elements of a sorted sub-array are in increasing order *)
+
+(* one element and the next one *)
+
+Lemma sorted_elements_1 :
+  (N:Z)(A:(array N Z))(n:Z)(m:Z)
+  (sorted_array A n m)
+  -> (k:Z)`k>=n`
+  -> (i:Z) `0<=i` -> `k+i<=m`
+  -> (Zle (access A k) (access A `k+i`)).
+Proof.
+Intros N A n m H_sorted k H_k i H_i.
+Pattern i. Apply natlike_ind.
+Intro.
+Replace `k+0` with k; Omega. (*** Ring `k+0` => BUG ***)
+
+Intros.
+Apply Zle_trans with m:=(access A `k+x`).
+Apply H0 ; Omega.
+
+Unfold Zs.
+Replace `k+(x+1)` with `(k+x)+1`.
+Unfold sorted_array in H_sorted.
+Apply H_sorted ; Omega.
+
+Omega.
+
+Assumption.
+Save.
+
+(* one element and any of the following *)
+
+Lemma sorted_elements :
+  (N:Z)(A:(array N Z))(n:Z)(m:Z)(k:Z)(l:Z)
+  (sorted_array A n m)
+  -> `k>=n` -> `l<N` -> `k<=l` -> `l<=m`
+  -> (Zle (access A k) (access A l)).
+Proof.
+Intros.
+Replace l with `k+(l-k)`.
+Apply sorted_elements_1 with n:=n m:=m; [Assumption | Omega | Omega | Omega].
+Omega.
+Save.
+
+Hints Resolve sorted_elements : datatypes v62.
+
+(* A sub-array of a sorted array is sorted *)
+
+Lemma sub_sorted_array : (N:Z)(A:(array N Z))(deb:Z)(fin:Z)(i:Z)(j:Z)
+      (sorted_array A deb fin) -> 
+        (`i>=deb` -> `j<=fin` -> `i<=j` -> (sorted_array A i j)).
+Proof.
+Unfold sorted_array.
+Intros.
+Apply H ; Omega.
+Save.
+
+Hints Resolve sub_sorted_array : datatypes v62.
+
+(* Extension on the left of the property of being sorted *)
+
+Lemma left_extension : (N:Z)(A:(array N Z))(i:Z)(j:Z)
+   `i>0` -> `j<N` -> (sorted_array A i j) 
+   -> (Zle #A[`i-1`]  #A[i]) -> (sorted_array A `i-1` j).
+Proof.
+(Intros; Unfold sorted_array ; Intros).
+Elim (Z_ge_lt_dec x i).   (* (`x >= i`) + (`x < i`) *)
+Intro Hcut.
+Apply H1 ; Omega.
+
+Intro Hcut.
+Replace x with `i-1`.
+Replace `i-1+1` with i ; [Assumption | Omega].
+
+Omega.
+Save.
+
+(* Extension on the right *)
+
+Lemma right_extension : (N:Z)(A:(array N Z))(i:Z)(j:Z)
+   `i>=0` -> `j<N-1` -> (sorted_array A i j) 
+   -> (Zle #A[j]  #A[`j+1`]) -> (sorted_array A i `j+1`).
+Proof.
+(Intros; Unfold sorted_array ; Intros).
+Elim (Z_lt_ge_dec x j).
+Intro Hcut. 
+Apply H1 ; Omega.
+
+Intro HCut.
+Replace x with j ; [Assumption | Omega].
+Save.
+
+(* Substitution of the leftmost value by a smaller value *) 
+
+Lemma left_substitution : 
+   (N:Z)(A:(array N Z))(i:Z)(j:Z)(v:Z)
+   `i>=0`  -> `j<N`  -> (sorted_array A i j)
+   -> (Zle v #A[i])
+   -> (sorted_array (store A i v) i j).
+Proof.
+Intros N A i j v H_i H_j H_sorted H_v.
+Unfold sorted_array ; Intros.
+
+Cut `x = i`\/`x > i`.
+(Intro Hcut ; Elim Hcut ; Clear Hcut ; Intro).
+Rewrite H2.
+Rewrite store_def_1 ; Try Omega.
+Rewrite store_def_2 ; Try Omega.
+Apply Zle_trans with m:=(access A i) ; [Assumption | Apply H_sorted ; Omega].
+
+(Rewrite store_def_2; Try Omega).
+(Rewrite store_def_2; Try Omega).
+Apply H_sorted ; Omega.
+Omega.
+Save.
+
+(* Substitution of the rightmost value by a larger value *)
+
+Lemma right_substitution : 
+   (N:Z)(A:(array N Z))(i:Z)(j:Z)(v:Z)
+   `i>=0`  -> `j<N`  -> (sorted_array A i j)
+   -> (Zle #A[j] v)
+   -> (sorted_array (store A j v) i j).
+Proof.
+Intros N A i j v H_i H_j H_sorted H_v.
+Unfold sorted_array ; Intros.
+
+Cut `x = j-1`\/`x < j-1`.
+(Intro Hcut ; Elim Hcut ; Clear Hcut ; Intro).
+Rewrite H2.
+Replace `j-1+1` with j; [ Idtac | Omega ]. (*** Ring `j-1+1`. => BUG ***)
+Rewrite store_def_2 ; Try Omega.
+Rewrite store_def_1 ; Try Omega.
+Apply Zle_trans with m:=(access A j). 
+Apply sorted_elements with n:=i m:=j ; Try Omega ; Assumption.
+Assumption.
+
+(Rewrite store_def_2; Try Omega).
+(Rewrite store_def_2; Try Omega).
+Apply H_sorted ; Omega.
+
+Omega.
+Save.
+
+(* Affectation outside of the sorted region *)
+
+Lemma no_effect : 
+   (N:Z)(A:(array N Z))(i:Z)(j:Z)(k:Z)(v:Z)
+   `i>=0`  -> `j<N`  -> (sorted_array A i j)
+   -> `0<=k<i`\/`j<k<N`
+   -> (sorted_array (store A k v) i j).
+Proof.
+Intros.
+Unfold sorted_array ; Intros. 
+Rewrite store_def_2 ; Try Omega.
+Rewrite store_def_2 ; Try Omega.
+Apply H1 ; Assumption.
+Save.
+
+Lemma sorted_array_id : (N:Z)(t1,t2:(array N Z))(g,d:Z)
+  (sorted_array t1 g d) -> (array_id t1 t2 g d) -> (sorted_array t2 g d).
+Proof.
+Intros N t1 t2 g d Hsorted Hid.
+Unfold array_id in Hid.
+Unfold sorted_array in Hsorted. Unfold sorted_array.
+Intros Hgd x H1x H2x.
+Rewrite <- (Hid x); [ Idtac | Omega ].
+Rewrite <- (Hid `x+1`); [ Idtac | Omega ].
+Apply Hsorted; Assumption.
+Save.
diff --git a/contrib7/correctness/Tuples.v b/contrib7/correctness/Tuples.v
new file mode 100644
index 0000000000..f9a3b56b77
--- /dev/null
+++ b/contrib7/correctness/Tuples.v
@@ -0,0 +1,106 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id$ *)
+
+(* Tuples *)
+
+Definition tuple_1 := [X:Set]X.
+Definition tuple_2 := prod.
+Definition Build_tuple_2 := pair.
+Definition proj_2_1 := fst.
+Definition proj_2_2 := snd.
+
+Record tuple_3 [ T1,T2,T3 : Set ] : Set := 
+  { proj_3_1 : T1 ;
+    proj_3_2 : T2 ;
+    proj_3_3 : T3 }.
+
+Record tuple_4 [ T1,T2,T3,T4 : Set ] : Set := 
+  { proj_4_1 : T1 ;
+    proj_4_2 : T2 ;
+    proj_4_3 : T3 ;
+    proj_4_4 : T4 }.
+
+Record tuple_5 [ T1,T2,T3,T4,T5 : Set ] : Set :=
+  { proj_5_1 : T1 ;
+    proj_5_2 : T2 ;
+    proj_5_3 : T3 ;
+    proj_5_4 : T4 ;
+    proj_5_5 : T5 }.
+
+Record tuple_6 [ T1,T2,T3,T4,T5,T6 : Set ] : Set :=
+  { proj_6_1 : T1 ;
+    proj_6_2 : T2 ;
+    proj_6_3 : T3 ;
+    proj_6_4 : T4 ;
+    proj_6_5 : T5 ;
+    proj_6_6 : T6 }.
+
+Record tuple_7 [ T1,T2,T3,T4,T5,T6,T7 : Set ] : Set :=
+  { proj_7_1 : T1 ;
+    proj_7_2 : T2 ;
+    proj_7_3 : T3 ;
+    proj_7_4 : T4 ;
+    proj_7_5 : T5 ;
+    proj_7_6 : T6 ;
+    proj_7_7 : T7 }.
+
+
+(* Existentials *)
+
+Definition sig_1 := sig.
+Definition exist_1 := exist.
+
+Inductive sig_2 [ T1,T2 : Set; P:T1->T2->Prop ] : Set := 
+  exist_2 : (x1:T1)(x2:T2)(P x1 x2) -> (sig_2 T1 T2 P).
+
+Inductive sig_3 [ T1,T2,T3 : Set; P:T1->T2->T3->Prop ] : Set := 
+  exist_3 : (x1:T1)(x2:T2)(x3:T3)(P x1 x2 x3) -> (sig_3 T1 T2 T3 P).
+
+
+Inductive sig_4 [ T1,T2,T3,T4 : Set;
+                  P:T1->T2->T3->T4->Prop ] : Set :=
+  exist_4 : (x1:T1)(x2:T2)(x3:T3)(x4:T4)
+             (P x1 x2 x3 x4)
+          -> (sig_4 T1 T2 T3 T4 P).
+
+Inductive sig_5 [ T1,T2,T3,T4,T5 : Set;
+                  P:T1->T2->T3->T4->T5->Prop ] : Set :=
+  exist_5 : (x1:T1)(x2:T2)(x3:T3)(x4:T4)(x5:T5)
+             (P x1 x2 x3 x4 x5)
+          -> (sig_5 T1 T2 T3 T4 T5 P).
+
+Inductive sig_6 [ T1,T2,T3,T4,T5,T6 : Set;
+                  P:T1->T2->T3->T4->T5->T6->Prop ] : Set :=
+  exist_6 : (x1:T1)(x2:T2)(x3:T3)(x4:T4)(x5:T5)(x6:T6)
+             (P x1 x2 x3 x4 x5 x6)
+          -> (sig_6 T1 T2 T3 T4 T5 T6 P).
+
+Inductive sig_7 [ T1,T2,T3,T4,T5,T6,T7 : Set;
+                  P:T1->T2->T3->T4->T5->T6->T7->Prop ] : Set :=
+  exist_7 : (x1:T1)(x2:T2)(x3:T3)(x4:T4)(x5:T5)(x6:T6)(x7:T7)
+             (P x1 x2 x3 x4 x5 x6 x7)
+          -> (sig_7 T1 T2 T3 T4 T5 T6 T7 P).
+
+Inductive sig_8 [ T1,T2,T3,T4,T5,T6,T7,T8 : Set;
+                  P:T1->T2->T3->T4->T5->T6->T7->T8->Prop ] : Set :=
+  exist_8 : (x1:T1)(x2:T2)(x3:T3)(x4:T4)(x5:T5)(x6:T6)(x7:T7)(x8:T8)
+             (P x1 x2 x3 x4 x5 x6 x7 x8)
+          -> (sig_8 T1 T2 T3 T4 T5 T6 T7 T8 P).      
+
+Inductive dep_tuple_2 [ T1,T2 : Set; P:T1->T2->Set ] : Set := 
+  Build_dep_tuple_2 : (x1:T1)(x2:T2)(P x1 x2) -> (dep_tuple_2 T1 T2 P).
+
+Inductive dep_tuple_3 [ T1,T2,T3 : Set; P:T1->T2->T3->Set ] : Set := 
+  Build_dep_tuple_3 : (x1:T1)(x2:T2)(x3:T3)(P x1 x2 x3)
+      	       	   -> (dep_tuple_3 T1 T2 T3 P).
+
+
diff --git a/contrib7/correctness/preuves.v b/contrib7/correctness/preuves.v
new file mode 100644
index 0000000000..33659b4360
--- /dev/null
+++ b/contrib7/correctness/preuves.v
@@ -0,0 +1,128 @@
+
+(* Quelques preuves sur des programmes simples,
+ * juste histoire d'avoir un petit bench.
+ *)
+
+Require Correctness.
+Require Omega.
+
+Global Variable x : Z ref.
+Global Variable y : Z ref.
+Global Variable z : Z ref.
+Global Variable i : Z ref.
+Global Variable j : Z ref.
+Global Variable n : Z ref.
+Global Variable m : Z ref.
+Variable r : Z.
+Variable N : Z.
+Global Variable t : array N of Z.
+
+(**********************************************************************)
+
+Require Exchange.
+Require ArrayPermut.
+
+Correctness swap
+  fun (N:Z)(t:array N of Z)(i,j:Z) ->
+    { `0 <= i < N` /\ `0 <= j < N` }
+    (let v = t[i] in
+     begin
+       t[i] := t[j];
+       t[j] := v
+     end)
+    { (exchange t t@ i j) }.
+Proof.
+Auto with datatypes.
+Save.
+
+Correctness downheap
+  let rec downheap (N:Z)(t:array N of Z) : unit { variant `0` } =
+    (swap N t 0 0) { True }
+.
+
+(**********************************************************************)
+
+Global Variable x : Z ref.
+Debug on.
+Correctness assign0 (x := 0) { `x=0` }.
+Save.
+
+(**********************************************************************)
+
+Global Variable i : Z ref.
+Debug on.
+Correctness assign1 { `0 <= i` } (i := !i + 1) { `0 < i` }.
+Omega.
+Save.
+
+(**********************************************************************)
+
+Global Variable i : Z ref.
+Debug on.
+Correctness if0 { `0 <= i` } (if !i>0 then i:=!i-1 else tt) { `0 <= i` }.
+Omega.
+Save.
+
+(**********************************************************************)
+
+Global Variable i : Z ref.
+Debug on.
+Correctness assert0 { `0 <= i` } begin assert { `i=2` }; i:=!i-1 end { `i=1` }.
+
+(**********************************************************************)
+
+Correctness echange
+  { `0 <= i < N` /\ `0 <= j < N` }
+  begin
+    label B;
+    x := t[!i]; t[!i] := t[!j]; t[!j] := !x;
+    assert { #t[i] = #t@B[j] /\ #t[j] = #t@B[i] }
+  end.
+Proof.
+Auto with datatypes.
+Save.
+
+  
+(**********************************************************************)
+
+(*
+ *   while x <= y do x := x+1 done { y < x }
+ *)
+
+Correctness incrementation
+  while !x < !y do
+    { invariant True variant `(Zs y)-x` }
+    x := !x + 1
+  done
+  { `y < x` }.
+Proof.
+Exact (Zwf_well_founded `0`).
+Unfold Zwf. Omega.
+Exact I.
+Save.
+
+
+(************************************************************************)
+
+Correctness pivot1
+  begin
+    while (Z_lt_ge_dec !i r) do
+      { invariant True variant (Zminus (Zs r) i) } i := (Zs !i)
+    done;
+    while (Z_lt_ge_dec r !j) do
+      { invariant True variant (Zminus (Zs j) r) } j := (Zpred !j)
+    done
+  end
+  { `j <= r` /\ `r <= i` }.
+Proof.
+Exact (Zwf_well_founded `0`).
+Unfold Zwf. Omega.
+Exact I.
+Exact (Zwf_well_founded `0`).
+Unfold Zwf. Unfold Zpred. Omega.
+Exact I.
+Omega.
+Save.
+
+
+
diff --git a/contrib7/field/.cvsignore b/contrib7/field/.cvsignore
new file mode 100644
index 0000000000..c446fcb878
--- /dev/null
+++ b/contrib7/field/.cvsignore
@@ -0,0 +1 @@
+*.v8
diff --git a/contrib7/field/Field.v b/contrib7/field/Field.v
new file mode 100644
index 0000000000..df2a44f3e7
--- /dev/null
+++ b/contrib7/field/Field.v
@@ -0,0 +1,15 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+Require Export Field_Compl.
+Require Export Field_Theory.
+Require Export Field_Tactic.
+
+(* Command declarations are moved to the ML side *)
diff --git a/contrib7/field/Field_Compl.v b/contrib7/field/Field_Compl.v
new file mode 100644
index 0000000000..aa3a991470
--- /dev/null
+++ b/contrib7/field/Field_Compl.v
@@ -0,0 +1,62 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+Inductive listT [A:Type] : Type :=
+  nilT : (listT A) | consT : A->(listT A)->(listT A).
+
+Fixpoint appT [A:Type][l:(listT A)] : (listT A) -> (listT A) :=
+  [m:(listT A)]
+  Cases l of
+  | nilT => m 
+  | (consT a l1) => (consT A a (appT A l1 m))
+  end.
+
+Inductive prodT [A,B:Type] : Type :=
+  pairT: A->B->(prodT A B).
+
+Definition assoc_2nd :=
+Fix assoc_2nd_rec
+  {assoc_2nd_rec 
+   [A:Type;B:Set;eq_dec:(e1,e2:B){e1=e2}+{~e1=e2};lst:(listT (prodT A B))]
+   : B->A->A:=
+  [key:B;default:A]
+  Cases lst of
+  | nilT => default
+  | (consT (pairT v e) l) =>
+    (Cases (eq_dec e key) of
+    | (left _) => v
+    | (right _) => (assoc_2nd_rec A B eq_dec l key default)
+    end)
+  end}.
+
+Definition fstT [A,B:Type;c:(prodT A B)] :=
+  Cases c of
+  | (pairT a _) => a
+  end.
+
+Definition sndT [A,B:Type;c:(prodT A B)] :=
+  Cases c of
+  | (pairT _ a) => a
+  end.
+
+Definition mem :=
+Fix mem {mem [A:Set;eq_dec:(e1,e2:A){e1=e2}+{~e1=e2};a:A;l:(listT A)] : bool :=
+  Cases l of
+  | nilT => false
+  | (consT a1 l1) =>
+    Cases (eq_dec a a1) of
+    | (left _) => true
+    | (right _) => (mem A eq_dec a l1)
+    end
+  end}.
+
+Inductive option [A:Type] : Type :=
+  | None : (option A)
+  | Some : (A -> A -> A) -> (option A).
diff --git a/contrib7/field/Field_Tactic.v b/contrib7/field/Field_Tactic.v
new file mode 100644
index 0000000000..cd382bc393
--- /dev/null
+++ b/contrib7/field/Field_Tactic.v
@@ -0,0 +1,397 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+Require Ring.
+Require Export Field_Compl.
+Require Export Field_Theory.
+
+(**** Interpretation A --> ExprA ****)
+
+Recursive Tactic Definition MemAssoc var lvar :=
+  Match lvar With
+  | [(nilT ?)] -> false
+  | [(consT ? ?1 ?2)] ->
+    (Match ?1=var With
+     | [?1=?1] -> true
+     | _ -> (MemAssoc var ?2)).
+
+Recursive Tactic Definition SeekVarAux FT lvar trm :=
+  Let AT     = Eval Cbv Beta Delta [A] Iota in (A FT)
+  And AzeroT = Eval Cbv Beta Delta [Azero] Iota in (Azero FT)
+  And AoneT  = Eval Cbv Beta Delta [Aone] Iota in (Aone FT)
+  And AplusT = Eval Cbv Beta Delta [Aplus] Iota in (Aplus FT)
+  And AmultT = Eval Cbv Beta Delta [Amult] Iota in (Amult FT)
+  And AoppT  = Eval Cbv Beta Delta [Aopp] Iota in (Aopp FT)
+  And AinvT  = Eval Cbv Beta Delta [Ainv] Iota in (Ainv FT) In 
+  Match trm With
+  | [(AzeroT)] -> lvar
+  | [(AoneT)] -> lvar
+  | [(AplusT ?1 ?2)] ->
+    Let l1 = (SeekVarAux FT lvar ?1) In
+    (SeekVarAux FT l1 ?2)
+  | [(AmultT ?1 ?2)] ->
+    Let l1 = (SeekVarAux FT lvar ?1) In
+    (SeekVarAux FT l1 ?2)
+  | [(AoppT ?1)] -> (SeekVarAux FT lvar ?1)
+  | [(AinvT ?1)] -> (SeekVarAux FT lvar ?1)
+  | [?1] ->
+    Let res = (MemAssoc ?1 lvar) In
+    Match res With
+    | [(true)] -> lvar
+    | [(false)] -> '(consT AT ?1 lvar).
+
+Tactic Definition SeekVar FT trm :=
+  Let AT = Eval Cbv Beta Delta [A] Iota in (A FT) In
+  (SeekVarAux FT '(nilT AT) trm).
+
+Recursive Tactic Definition NumberAux lvar cpt :=
+  Match lvar With
+  | [(nilT ?1)] -> '(nilT (prodT ?1 nat))
+  | [(consT ?1 ?2 ?3)] ->
+    Let l2 = (NumberAux ?3 '(S cpt)) In
+    '(consT (prodT ?1 nat) (pairT ?1 nat ?2 cpt) l2).
+
+Tactic Definition Number lvar := (NumberAux lvar O).
+
+Tactic Definition BuildVarList FT trm :=
+  Let lvar = (SeekVar FT trm) In
+  (Number lvar).
+V7only [
+(*Used by contrib Maple *)
+Tactic Definition build_var_list := BuildVarList.
+].
+
+Recursive Tactic Definition Assoc elt lst :=
+  Match lst With
+  | [(nilT ?)] -> Fail
+  | [(consT (prodT ? nat) (pairT ? nat ?1 ?2) ?3)] ->
+    Match elt= ?1 With
+    | [?1= ?1] -> ?2
+    | _ -> (Assoc elt ?3).
+
+Recursive Meta Definition interp_A FT lvar trm :=
+  Let AT     = Eval Cbv Beta Delta [A] Iota in (A FT)
+  And AzeroT = Eval Cbv Beta Delta [Azero] Iota in (Azero FT)
+  And AoneT  = Eval Cbv Beta Delta [Aone] Iota in (Aone FT)
+  And AplusT = Eval Cbv Beta Delta [Aplus] Iota in (Aplus FT)
+  And AmultT = Eval Cbv Beta Delta [Amult] Iota in (Amult FT)
+  And AoppT  = Eval Cbv Beta Delta [Aopp] Iota in (Aopp FT)
+  And AinvT  = Eval Cbv Beta Delta [Ainv] Iota in (Ainv FT) In
+  Match trm With
+  | [(AzeroT)] -> EAzero
+  | [(AoneT)] -> EAone
+  | [(AplusT ?1 ?2)] ->
+    Let e1 = (interp_A FT lvar ?1)
+    And e2 = (interp_A FT lvar ?2) In
+    '(EAplus e1 e2)
+  | [(AmultT ?1 ?2)] ->
+    Let e1 = (interp_A FT lvar ?1)
+    And e2 = (interp_A FT lvar ?2) In
+    '(EAmult e1 e2)
+  | [(AoppT ?1)] ->
+    Let e = (interp_A FT lvar ?1) In
+    '(EAopp e)
+  | [(AinvT ?1)] ->
+    Let e = (interp_A FT lvar ?1) In
+    '(EAinv e)
+  | [?1] ->
+    Let idx = (Assoc ?1 lvar) In
+    '(EAvar idx).
+
+(************************)
+(*    Simplification    *)
+(************************)
+
+(**** Generation of the multiplier ****)
+
+Recursive Tactic Definition Remove e l :=
+  Match l With
+  | [(nilT ?)] -> l
+  | [(consT ?1 e ?2)] -> ?2
+  | [(consT ?1 ?2 ?3)] ->
+    Let nl = (Remove e ?3) In
+    '(consT ?1 ?2 nl).
+
+Recursive Tactic Definition Union l1 l2 :=
+  Match l1 With
+  | [(nilT ?)] -> l2
+  | [(consT ?1 ?2 ?3)] ->
+    Let nl2 = (Remove ?2 l2) In
+    Let nl = (Union ?3 nl2) In
+    '(consT ?1 ?2 nl).
+
+Recursive Tactic Definition RawGiveMult trm :=
+  Match trm With
+  | [(EAinv ?1)] -> '(consT ExprA ?1 (nilT ExprA))
+  | [(EAopp ?1)] -> (RawGiveMult ?1)
+  | [(EAplus ?1 ?2)] ->
+    Let l1 = (RawGiveMult ?1)
+    And l2 = (RawGiveMult ?2) In
+    (Union l1 l2)
+  | [(EAmult ?1 ?2)] ->
+    Let l1 = (RawGiveMult ?1)
+    And l2 = (RawGiveMult ?2) In
+    Eval Compute in (appT ExprA l1 l2)
+  | _ -> '(nilT ExprA).
+
+Tactic Definition GiveMult trm :=
+  Let ltrm = (RawGiveMult trm) In
+  '(mult_of_list ltrm).
+
+(**** Associativity ****)
+
+Tactic Definition ApplyAssoc FT lvar trm :=
+  Let t=Eval Compute in (assoc trm) In
+  Match t=trm With
+  | [ ?1=?1 ] -> Idtac
+  | _ -> Rewrite <- (assoc_correct FT trm); Change (assoc trm) with t.
+
+(**** Distribution *****)
+
+Tactic Definition ApplyDistrib FT lvar trm :=
+  Let t=Eval Compute in (distrib trm) In
+  Match t=trm With
+  | [ ?1=?1 ] -> Idtac
+  | _ -> Rewrite <- (distrib_correct FT trm); Change (distrib trm) with t.
+
+(**** Multiplication by the inverse product ****)
+
+Tactic Definition GrepMult :=
+  Match Context With
+    | [ id: ~(interp_ExprA ? ? ?)= ? |- ?] -> id.
+
+Tactic Definition WeakReduce :=
+  Match Context With
+  | [|-[(interp_ExprA ?1 ?2 ?)]] ->
+    Cbv Beta Delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list ?1 ?2 A
+                    Azero Aone Aplus Amult Aopp Ainv] Zeta Iota.
+
+Tactic Definition Multiply mul :=
+  Match Context With
+  | [|-(interp_ExprA ?1 ?2 ?3)=(interp_ExprA ?1 ?2 ?4)] ->
+    Let AzeroT = Eval Cbv Beta Delta [Azero ?1] Iota in (Azero ?1) In
+    Cut ~(interp_ExprA ?1 ?2 mul)=AzeroT;
+    [Intro;
+     Let id = GrepMult In
+     Apply (mult_eq ?1 ?3 ?4 mul ?2 id)
+    |WeakReduce;
+     Let AoneT  = Eval Cbv Beta Delta [Aone ?1] Iota in (Aone ?1)
+     And AmultT = Eval Cbv Beta Delta [Amult ?1] Iota in (Amult ?1) In
+     Try (Match Context With
+          | [|-[(AmultT ? AoneT)]] -> Rewrite (AmultT_1r ?1));Clear ?1 ?2].
+
+Tactic Definition ApplyMultiply FT lvar trm :=
+  Let t=Eval Compute in (multiply trm) In
+  Match t=trm With
+  | [ ?1=?1 ] -> Idtac
+  | _ -> Rewrite <- (multiply_correct FT trm); Change (multiply trm) with t.
+
+(**** Permutations and simplification ****)
+
+Tactic Definition ApplyInverse mul FT lvar trm :=
+  Let t=Eval Compute in (inverse_simplif mul trm) In
+  Match t=trm With
+  | [ ?1=?1 ] -> Idtac
+  | _ -> Rewrite <- (inverse_correct FT trm mul);
+         [Change (inverse_simplif mul trm) with t|Assumption].
+(**** Inverse test ****)
+
+Tactic Definition StrongFail tac := First [tac|Fail 2].
+
+Recursive Tactic Definition InverseTestAux FT trm :=
+  Let AplusT = Eval Cbv Beta Delta [Aplus] Iota in (Aplus FT)
+  And AmultT = Eval Cbv Beta Delta [Amult] Iota in (Amult FT)
+  And AoppT  = Eval Cbv Beta Delta [Aopp] Iota in (Aopp FT)
+  And AinvT  = Eval Cbv Beta Delta [Ainv] Iota in (Ainv FT) In
+  Match trm With
+  | [(AinvT ?)] -> Fail 1
+  | [(AoppT ?1)] -> StrongFail ((InverseTestAux FT ?1);Idtac)
+  | [(AplusT ?1 ?2)] ->
+    StrongFail ((InverseTestAux FT ?1);(InverseTestAux FT ?2))
+  | [(AmultT ?1 ?2)] ->
+    StrongFail ((InverseTestAux FT ?1);(InverseTestAux FT ?2))
+  | _ -> Idtac.
+
+Tactic Definition InverseTest FT :=
+  Let AplusT = Eval Cbv Beta Delta [Aplus] Iota in (Aplus FT) In
+  Match Context With
+  | [|- ?1=?2] -> (InverseTestAux FT '(AplusT ?1 ?2)).
+
+(**** Field itself ****)
+
+Tactic Definition ApplySimplif sfun :=
+  (Match Context With
+   | [|- (interp_ExprA ?1 ?2 ?3)=(interp_ExprA ? ? ?)] ->
+     (sfun ?1 ?2 ?3));
+  (Match Context With
+   | [|- (interp_ExprA ? ? ?)=(interp_ExprA ?1 ?2 ?3)] ->
+     (sfun ?1 ?2 ?3)).
+
+Tactic Definition Unfolds FT :=
+  (Match Eval Cbv Beta Delta [Aminus] Iota in (Aminus FT) With
+   | [(Some ? ?1)] -> Unfold ?1
+   | _ -> Idtac);
+  (Match Eval Cbv Beta Delta [Adiv] Iota in (Adiv FT) With
+   | [(Some ? ?1)] -> Unfold ?1
+   | _ -> Idtac).
+
+Tactic Definition Reduce FT :=
+  Let AzeroT = Eval Cbv Beta Delta [Azero] Iota in (Azero FT)
+  And AoneT  = Eval Cbv Beta Delta [Aone] Iota in (Aone FT)
+  And AplusT = Eval Cbv Beta Delta [Aplus] Iota in (Aplus FT)
+  And AmultT = Eval Cbv Beta Delta [Amult] Iota in (Amult FT)
+  And AoppT  = Eval Cbv Beta Delta [Aopp] Iota in (Aopp FT)
+  And AinvT  = Eval Cbv Beta Delta [Ainv] Iota in (Ainv FT) In
+  Cbv Beta Delta -[AzeroT AoneT AplusT AmultT AoppT AinvT] Zeta Iota
+  Orelse Compute.
+
+Recursive Tactic Definition Field_Gen_Aux FT :=
+  Let AplusT = Eval Cbv Beta Delta [Aplus] Iota in (Aplus FT) In
+  Match Context With
+  | [|- ?1=?2] ->
+    Let lvar = (BuildVarList FT '(AplusT ?1 ?2)) In
+    Let trm1 = (interp_A FT lvar ?1)
+    And trm2 = (interp_A FT lvar ?2) In
+    Let mul = (GiveMult '(EAplus trm1 trm2)) In
+    Cut [ft:=FT][vm:=lvar](interp_ExprA ft vm trm1)=(interp_ExprA ft vm trm2);
+    [Compute;Auto
+    |Intros ft vm;(ApplySimplif ApplyDistrib);(ApplySimplif ApplyAssoc);
+     (Multiply mul);[(ApplySimplif ApplyMultiply);
+       (ApplySimplif (ApplyInverse mul));
+       (Let id = GrepMult In Clear id);WeakReduce;Clear ft vm;
+       First [(InverseTest FT);Ring|(Field_Gen_Aux FT)]|Idtac]].
+
+Tactic Definition Field_Gen FT :=
+  Unfolds FT;((InverseTest FT);Ring) Orelse (Field_Gen_Aux FT).
+V7only [Tactic Definition field_gen := Field_Gen.].
+
+(*****************************)
+(*    Term Simplification    *)
+(*****************************)
+
+(**** Minus and division expansions ****)
+
+Meta Definition InitExp FT trm :=
+  Let e =
+    (Match Eval Cbv Beta Delta [Aminus] Iota in (Aminus FT) With
+     | [(Some ? ?1)] -> Eval Cbv Beta Delta [?1] in trm
+     | _ -> trm) In
+  Match Eval Cbv Beta Delta [Adiv] Iota in (Adiv FT) With
+  | [(Some ? ?1)] -> Eval Cbv Beta Delta [?1] in e
+  | _ -> e.
+V7only [
+(*Used by contrib Maple *)
+Tactic Definition init_exp := InitExp.
+].
+
+(**** Inverses simplification ****)
+
+Recursive Meta Definition SimplInv trm:=
+  Match trm With
+  | [(EAplus ?1 ?2)] ->
+    Let e1 = (SimplInv ?1)
+    And e2 = (SimplInv ?2) In
+    '(EAplus e1 e2)
+  | [(EAmult ?1 ?2)] ->
+    Let e1 = (SimplInv ?1)
+    And e2 = (SimplInv ?2) In
+    '(EAmult e1 e2)
+  | [(EAopp ?1)] -> Let e = (SimplInv ?1) In '(EAopp e)
+  | [(EAinv ?1)] -> (SimplInvAux ?1)
+  | [?1] -> ?1
+And SimplInvAux trm :=
+  Match trm With
+  | [(EAinv ?1)] -> (SimplInv ?1)
+  | [(EAmult ?1 ?2)] ->
+    Let e1 = (SimplInv '(EAinv ?1))
+    And e2 = (SimplInv '(EAinv ?2)) In
+    '(EAmult e1 e2)
+  | [?1] -> Let e = (SimplInv ?1) In '(EAinv e).
+
+(**** Monom simplification ****)
+
+Recursive Meta Definition Map fcn lst :=
+  Match lst With
+  | [(nilT ?)] -> lst
+  | [(consT ?1 ?2 ?3)] ->
+    Let r = (fcn ?2)
+    And t = (Map fcn ?3) In
+    '(consT ?1 r t).
+
+Recursive Meta Definition BuildMonomAux lst trm :=
+  Match lst With
+  | [(nilT ?)] -> Eval Compute in (assoc trm)
+  | [(consT ? ?1 ?2)] -> BuildMonomAux ?2 '(EAmult trm ?1).
+
+Recursive Meta Definition BuildMonom lnum lden :=
+  Let ildn = (Map (Fun e -> '(EAinv e)) lden) In
+  Let ltot = Eval Compute in (appT ExprA lnum ildn) In
+  Let trm = (BuildMonomAux ltot EAone) In
+  Match trm With
+  | [(EAmult ? ?1)] -> ?1
+  | [?1] -> ?1.
+
+Recursive Meta Definition SimplMonomAux lnum lden trm :=
+  Match trm With
+  | [(EAmult (EAinv ?1) ?2)] ->
+    Let mma = (MemAssoc ?1 lnum) In
+    (Match mma With
+     | [true] ->
+       Let newlnum = (Remove ?1 lnum) In SimplMonomAux newlnum lden ?2
+     | [false] -> SimplMonomAux lnum '(consT ExprA ?1 lden) ?2)
+  | [(EAmult ?1 ?2)] ->
+    Let mma = (MemAssoc ?1 lden) In
+    (Match mma With
+     | [true] ->
+       Let newlden = (Remove ?1 lden) In SimplMonomAux lnum newlden ?2
+     | [false] -> SimplMonomAux '(consT ExprA ?1 lnum) lden ?2)
+  | [(EAinv ?1)] ->
+    Let mma = (MemAssoc ?1 lnum) In
+    (Match mma With
+     | [true] ->
+       Let newlnum = (Remove ?1 lnum) In BuildMonom newlnum lden
+     | [false] -> BuildMonom lnum '(consT ExprA ?1 lden))
+  | [?1] ->
+    Let mma = (MemAssoc ?1 lden) In
+    (Match mma With
+     | [true] ->
+       Let newlden = (Remove ?1 lden) In BuildMonom lnum newlden
+     | [false] -> BuildMonom '(consT ExprA ?1 lnum) lden).
+
+Meta Definition SimplMonom trm :=
+  SimplMonomAux '(nilT ExprA) '(nilT ExprA) trm.
+
+Recursive Meta Definition SimplAllMonoms trm :=
+  Match trm With
+  | [(EAplus ?1 ?2)] ->
+    Let e1 = (SimplMonom ?1)
+    And e2 = (SimplAllMonoms ?2) In
+    '(EAplus e1 e2)
+  | [?1] -> SimplMonom ?1.
+
+(**** Associativity and distribution ****)
+
+Meta Definition AssocDistrib trm := Eval Compute in (assoc (distrib trm)).
+
+(**** The tactic Field_Term ****)
+
+Tactic Definition EvalWeakReduce trm :=
+  Eval Cbv Beta Delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list A Azero
+                       Aone Aplus Amult Aopp Ainv] Zeta Iota in trm.
+
+Tactic Definition Field_Term FT exp :=
+  Let newexp = (InitExp FT exp) In
+  Let lvar = (BuildVarList FT newexp) In
+  Let trm = (interp_A FT lvar newexp) In
+  Let tma = Eval Compute in (assoc trm) In
+  Let tsmp = (SimplAllMonoms (AssocDistrib (SimplAllMonoms
+                (SimplInv tma)))) In
+  Let trep = (EvalWeakReduce '(interp_ExprA FT lvar tsmp)) In
+  Replace exp with trep;[Ring trep|Field_Gen FT].
diff --git a/contrib7/field/Field_Theory.v b/contrib7/field/Field_Theory.v
new file mode 100644
index 0000000000..e2710260f9
--- /dev/null
+++ b/contrib7/field/Field_Theory.v
@@ -0,0 +1,612 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+Require Peano_dec.
+Require Ring.
+Require Field_Compl.
+
+Record Field_Theory : Type :=
+{ A : Type;
+  Aplus : A -> A -> A;
+  Amult : A -> A -> A;
+  Aone : A;
+  Azero : A;
+  Aopp : A -> A;
+  Aeq : A -> A -> bool;
+  Ainv : A -> A;
+  Aminus : (option A);
+  Adiv : (option A);
+  RT : (Ring_Theory Aplus Amult Aone Azero Aopp Aeq);
+  Th_inv_def : (n:A)~(n=Azero)->(Amult (Ainv n) n)=Aone
+}.
+
+(* The reflexion structure *)
+Inductive ExprA : Set :=
+| EAzero    : ExprA
+| EAone    : ExprA
+| EAplus : ExprA -> ExprA -> ExprA
+| EAmult : ExprA -> ExprA -> ExprA
+| EAopp  : ExprA -> ExprA
+| EAinv  : ExprA -> ExprA
+| EAvar  : nat -> ExprA.
+
+(**** Decidability of equality ****)
+
+Lemma eqExprA_O:(e1,e2:ExprA){e1=e2}+{~e1=e2}.
+Proof.
+  Double Induction e1 e2;Try Intros;
+   Try (Left;Reflexivity) Orelse Try (Right;Discriminate).
+  Elim (H1 e0);Intro y;Elim (H2 e);Intro y0;
+    Try (Left; Rewrite y; Rewrite y0;Auto)
+    Orelse (Right;Red;Intro;Inversion H3;Auto).
+  Elim (H1 e0);Intro y;Elim (H2 e);Intro y0;
+    Try (Left; Rewrite y; Rewrite y0;Auto)
+    Orelse (Right;Red;Intro;Inversion H3;Auto).
+  Elim (H0 e);Intro y.
+  Left; Rewrite y; Auto.
+  Right;Red; Intro;Inversion H1;Auto.
+  Elim (H0 e);Intro y.
+  Left; Rewrite y; Auto.
+  Right;Red; Intro;Inversion H1;Auto.
+  Elim (eq_nat_dec n n0);Intro y.
+  Left; Rewrite y; Auto.
+  Right;Red;Intro;Inversion H;Auto. 
+Defined.
+
+Definition eq_nat_dec := Eval Compute in Peano_dec.eq_nat_dec.
+Definition eqExprA := Eval Compute in eqExprA_O.
+
+(**** Generation of the multiplier ****)
+
+Fixpoint mult_of_list [e:(listT ExprA)]: ExprA :=
+  Cases e of
+  | nilT => EAone
+  | (consT e1 l1) => (EAmult e1 (mult_of_list l1))
+  end.
+
+Section Theory_of_fields.
+
+Variable T : Field_Theory.
+
+Local AT := (A T).
+Local AplusT := (Aplus T).
+Local AmultT := (Amult T).
+Local AoneT := (Aone T).
+Local AzeroT := (Azero T).
+Local AoppT := (Aopp T).
+Local AeqT := (Aeq T).
+Local AinvT := (Ainv T).
+Local RTT := (RT T).
+Local Th_inv_defT := (Th_inv_def T).
+
+Add Abstract Ring (A T) (Aplus T) (Amult T) (Aone T) (Azero T) (Aopp T) 
+  (Aeq T) (RT T).
+
+Add Abstract Ring AT AplusT AmultT AoneT AzeroT AoppT AeqT RTT.
+
+(***************************)
+(*    Lemmas to be used    *)
+(***************************)
+
+Lemma AplusT_sym:(r1,r2:AT)(AplusT r1 r2)=(AplusT r2 r1).
+Proof.
+  Intros;Ring.
+Save.
+
+Lemma AplusT_assoc:(r1,r2,r3:AT)(AplusT (AplusT r1 r2) r3)=
+                                (AplusT r1 (AplusT r2 r3)).
+Proof.
+  Intros;Ring.
+Save.
+
+Lemma AmultT_sym:(r1,r2:AT)(AmultT r1 r2)=(AmultT r2 r1).
+Proof.
+  Intros;Ring.
+Save.
+
+Lemma AmultT_assoc:(r1,r2,r3:AT)(AmultT (AmultT r1 r2) r3)=
+                                (AmultT r1 (AmultT r2 r3)).
+Proof.
+  Intros;Ring.
+Save.
+
+Lemma AplusT_Ol:(r:AT)(AplusT AzeroT r)=r.
+Proof.
+  Intros;Ring.
+Save.
+
+Lemma AmultT_1l:(r:AT)(AmultT AoneT r)=r.
+Proof.
+  Intros;Ring.
+Save.
+
+Lemma AplusT_AoppT_r:(r:AT)(AplusT r (AoppT r))=AzeroT.
+Proof.
+  Intros;Ring.
+Save.
+
+Lemma AmultT_AplusT_distr:(r1,r2,r3:AT)(AmultT r1 (AplusT r2 r3))=
+                        (AplusT (AmultT r1 r2) (AmultT r1 r3)).
+Proof.
+  Intros;Ring.
+Save.
+
+Lemma r_AplusT_plus:(r,r1,r2:AT)(AplusT r r1)=(AplusT r r2)->r1=r2.
+Proof.
+  Intros; Transitivity (AplusT (AplusT (AoppT r) r) r1).
+  Ring.
+  Transitivity (AplusT (AplusT (AoppT r) r) r2).
+  Repeat Rewrite -> AplusT_assoc; Rewrite <- H; Reflexivity.
+  Ring.
+Save.
+ 
+Lemma r_AmultT_mult:
+  (r,r1,r2:AT)(AmultT r r1)=(AmultT r r2)->~r=AzeroT->r1=r2.
+Proof.
+  Intros; Transitivity (AmultT (AmultT (AinvT r) r) r1).
+  Rewrite Th_inv_defT;[Symmetry; Apply AmultT_1l;Auto|Auto].
+  Transitivity (AmultT (AmultT (AinvT r) r) r2).
+  Repeat Rewrite AmultT_assoc; Rewrite H; Trivial.
+  Rewrite Th_inv_defT;[Apply AmultT_1l;Auto|Auto].
+Save.
+
+Lemma AmultT_Or:(r:AT) (AmultT r AzeroT)=AzeroT.
+Proof.
+  Intro; Ring.
+Save.
+ 
+Lemma AmultT_Ol:(r:AT)(AmultT AzeroT r)=AzeroT.
+Proof.
+  Intro; Ring.
+Save.
+ 
+Lemma AmultT_1r:(r:AT)(AmultT r AoneT)=r.
+Proof.
+  Intro; Ring.
+Save.
+ 
+Lemma AinvT_r:(r:AT)~r=AzeroT->(AmultT r (AinvT r))=AoneT.
+Proof.
+  Intros; Rewrite -> AmultT_sym; Apply Th_inv_defT; Auto.
+Save.
+ 
+Lemma without_div_O_contr:
+  (r1,r2:AT)~(AmultT r1 r2)=AzeroT ->~r1=AzeroT/\~r2=AzeroT.
+Proof.
+  Intros r1 r2 H; Split; Red; Intro; Apply H; Rewrite H0; Ring.
+Save.
+
+(************************)
+(*    Interpretation    *)
+(************************)
+
+(**** ExprA --> A ****)
+
+Fixpoint interp_ExprA [lvar:(listT (prodT AT nat));e:ExprA] : AT :=
+  Cases e of
+  | EAzero         => AzeroT
+  | EAone          => AoneT
+  | (EAplus e1 e2) => (AplusT (interp_ExprA lvar e1) (interp_ExprA lvar e2))
+  | (EAmult e1 e2) => (AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2))
+  | (EAopp e)      => ((Aopp T) (interp_ExprA lvar e))
+  | (EAinv e)      => ((Ainv T) (interp_ExprA lvar e))
+  | (EAvar n)      => (assoc_2nd AT nat eq_nat_dec lvar n AzeroT)
+  end.
+
+(************************)
+(*    Simplification    *)
+(************************)
+
+(**** Associativity ****)
+
+Definition merge_mult :=
+  Fix merge_mult {merge_mult [e1:ExprA] : ExprA -> ExprA :=
+  [e2:ExprA]Cases e1 of
+  | (EAmult t1 t2) =>
+    Cases t2 of
+    | (EAmult t2 t3) => (EAmult t1 (EAmult t2 (merge_mult t3 e2)))
+    | _ => (EAmult t1 (EAmult t2 e2))
+    end
+  | _ => (EAmult e1 e2)
+  end}.
+
+Fixpoint assoc_mult [e:ExprA] : ExprA :=
+  Cases e of
+  | (EAmult e1 e3) =>
+    Cases e1 of
+    | (EAmult e1 e2) =>
+      (merge_mult (merge_mult (assoc_mult e1) (assoc_mult e2))
+        (assoc_mult e3))
+    | _ => (EAmult e1 (assoc_mult e3))
+    end
+  | _ => e
+  end.
+
+Definition merge_plus :=
+  Fix merge_plus {merge_plus [e1:ExprA]:ExprA->ExprA:=
+  [e2:ExprA]Cases e1 of
+  | (EAplus t1 t2) =>
+    Cases t2 of
+    | (EAplus t2 t3) => (EAplus t1 (EAplus t2 (merge_plus t3 e2)))
+    | _ => (EAplus t1 (EAplus t2 e2))
+    end
+  | _ => (EAplus e1 e2)
+  end}.
+
+Fixpoint assoc [e:ExprA] : ExprA :=
+  Cases e of
+  | (EAplus e1 e3) =>
+    Cases e1 of
+    | (EAplus e1 e2) =>
+      (merge_plus (merge_plus (assoc e1) (assoc e2)) (assoc e3))
+    | _ => (EAplus (assoc_mult e1) (assoc e3))
+    end
+  | _ => (assoc_mult e)
+  end.
+
+Lemma merge_mult_correct1:
+  (e1,e2,e3:ExprA)(lvar:(listT (prodT AT nat)))
+  (interp_ExprA lvar (merge_mult (EAmult e1 e2) e3))=
+  (interp_ExprA lvar (EAmult e1 (merge_mult e2 e3))).
+Proof.
+Intros e1 e2;Generalize e1;Generalize e2;Clear e1 e2.
+Induction e2;Auto;Intros.
+Unfold 1 merge_mult;Fold merge_mult;
+ Unfold 2 interp_ExprA;Fold interp_ExprA;
+ Rewrite (H0 e e3 lvar);
+ Unfold 1 interp_ExprA;Fold interp_ExprA;
+ Unfold 5 interp_ExprA;Fold interp_ExprA;Auto.
+Save.
+
+Lemma merge_mult_correct:
+  (e1,e2:ExprA)(lvar:(listT (prodT AT nat)))
+    (interp_ExprA lvar (merge_mult e1 e2))=
+    (interp_ExprA lvar (EAmult e1 e2)).
+Proof.
+Induction e1;Auto;Intros.
+Elim e0;Try (Intros;Simpl;Ring).
+Unfold interp_ExprA in H2;Fold interp_ExprA in H2;
+ Cut (AmultT (interp_ExprA lvar e2) (AmultT (interp_ExprA lvar e4) 
+       (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e3))))=
+       (AmultT (AmultT (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e4)) 
+       (interp_ExprA lvar e2)) (interp_ExprA lvar e3)).
+Intro H3;Rewrite H3;Rewrite <-H2;
+ Rewrite merge_mult_correct1;Simpl;Ring.
+Ring.
+Save.
+
+Lemma assoc_mult_correct1:(e1,e2:ExprA)(lvar:(listT (prodT AT nat)))
+  (AmultT (interp_ExprA lvar (assoc_mult e1)) 
+         (interp_ExprA lvar (assoc_mult e2)))=
+  (interp_ExprA lvar (assoc_mult (EAmult e1 e2))).
+Proof.
+Induction e1;Auto;Intros.
+Rewrite <-(H e0 lvar);Simpl;Rewrite merge_mult_correct;Simpl;
+ Rewrite merge_mult_correct;Simpl;Auto.
+Save.
+
+Lemma assoc_mult_correct:
+  (e:ExprA)(lvar:(listT (prodT AT nat)))
+    (interp_ExprA lvar (assoc_mult e))=(interp_ExprA lvar e).
+Proof.
+Induction e;Auto;Intros.
+Elim e0;Intros.
+Intros;Simpl;Ring.
+Simpl;Rewrite (AmultT_1l (interp_ExprA lvar (assoc_mult e1)));
+ Rewrite (AmultT_1l (interp_ExprA lvar e1)); Apply H0.
+Simpl;Rewrite (H0 lvar);Auto.
+Simpl;Rewrite merge_mult_correct;Simpl;Rewrite merge_mult_correct;Simpl;
+ Rewrite AmultT_assoc;Rewrite assoc_mult_correct1;Rewrite H2;Simpl;
+ Rewrite <-assoc_mult_correct1 in H1;
+ Unfold 3 interp_ExprA in H1;Fold interp_ExprA in H1;
+ Rewrite (H0 lvar) in H1;
+ Rewrite (AmultT_sym (interp_ExprA lvar e3) (interp_ExprA lvar e1));
+ Rewrite <-AmultT_assoc;Rewrite H1;Rewrite AmultT_assoc;Ring.
+Simpl;Rewrite (H0 lvar);Auto.
+Simpl;Rewrite (H0 lvar);Auto.
+Simpl;Rewrite (H0 lvar);Auto.
+Save.
+
+Lemma merge_plus_correct1:
+  (e1,e2,e3:ExprA)(lvar:(listT (prodT AT nat)))
+  (interp_ExprA lvar (merge_plus (EAplus e1 e2) e3))=
+  (interp_ExprA lvar (EAplus e1 (merge_plus e2 e3))).
+Proof.
+Intros e1 e2;Generalize e1;Generalize e2;Clear e1 e2.
+Induction e2;Auto;Intros.
+Unfold 1 merge_plus;Fold merge_plus;
+ Unfold 2 interp_ExprA;Fold interp_ExprA;
+ Rewrite (H0 e e3 lvar);
+ Unfold 1 interp_ExprA;Fold interp_ExprA;
+ Unfold 5 interp_ExprA;Fold interp_ExprA;Auto.
+Save.
+
+Lemma merge_plus_correct:
+  (e1,e2:ExprA)(lvar:(listT (prodT AT nat)))
+    (interp_ExprA lvar (merge_plus e1 e2))=
+    (interp_ExprA lvar (EAplus e1 e2)).
+Proof.
+Induction e1;Auto;Intros.
+Elim e0;Try Intros;Try (Simpl;Ring).
+Unfold interp_ExprA in H2;Fold interp_ExprA in H2;
+  Cut (AplusT (interp_ExprA lvar e2) (AplusT (interp_ExprA lvar e4) 
+        (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e3))))=
+        (AplusT (AplusT (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e4)) 
+       (interp_ExprA lvar e2)) (interp_ExprA lvar e3)).
+Intro H3;Rewrite H3;Rewrite <-H2;Rewrite merge_plus_correct1;Simpl;Ring.
+Ring.
+Save.
+
+Lemma assoc_plus_correct:(e1,e2:ExprA)(lvar:(listT (prodT AT nat)))
+  (AplusT (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2)))=
+  (interp_ExprA lvar (assoc (EAplus e1 e2))).
+Proof.
+Induction e1;Auto;Intros.
+Rewrite <-(H e0 lvar);Simpl;Rewrite merge_plus_correct;Simpl;
+ Rewrite merge_plus_correct;Simpl;Auto.
+Save.
+
+Lemma assoc_correct:
+  (e:ExprA)(lvar:(listT (prodT AT nat)))
+    (interp_ExprA lvar (assoc e))=(interp_ExprA lvar e).
+Proof.
+Induction e;Auto;Intros.
+Elim e0;Intros.
+Simpl;Rewrite (H0 lvar);Auto.
+Simpl;Rewrite (H0 lvar);Auto.
+Simpl;Rewrite merge_plus_correct;Simpl;Rewrite merge_plus_correct;
+ Simpl;Rewrite AplusT_assoc;Rewrite assoc_plus_correct;Rewrite H2;
+ Simpl;Apply (r_AplusT_plus (interp_ExprA lvar (assoc e1))
+   (AplusT (interp_ExprA lvar (assoc e2))
+     (AplusT (interp_ExprA lvar e3) (interp_ExprA lvar e1)))
+   (AplusT (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e3))
+        (interp_ExprA lvar e1)));Rewrite <-AplusT_assoc; 
+ Rewrite (AplusT_sym (interp_ExprA lvar (assoc e1)) 
+                    (interp_ExprA lvar (assoc e2)));
+ Rewrite assoc_plus_correct;Rewrite H1;Simpl;Rewrite (H0 lvar);
+ Rewrite <-(AplusT_assoc (AplusT (interp_ExprA lvar e2) 
+            (interp_ExprA lvar e1))
+ (interp_ExprA lvar e3) (interp_ExprA lvar e1));
+ Rewrite (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e1)
+                      (interp_ExprA lvar e3));
+ Rewrite (AplusT_sym (interp_ExprA lvar e1) (interp_ExprA lvar e3));
+ Rewrite <-(AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e3)
+                        (interp_ExprA lvar e1));Apply AplusT_sym.
+Unfold assoc;Fold assoc;Unfold interp_ExprA;Fold interp_ExprA;
+ Rewrite assoc_mult_correct;Rewrite (H0 lvar);Simpl;Auto.
+Simpl;Rewrite (H0 lvar);Auto.
+Simpl;Rewrite (H0 lvar);Auto.
+Simpl;Rewrite (H0 lvar);Auto.
+Unfold assoc;Fold assoc;Unfold interp_ExprA;Fold interp_ExprA;
+ Rewrite assoc_mult_correct;Simpl;Auto.
+Save.
+
+(**** Distribution *****)
+
+Fixpoint distrib_EAopp [e:ExprA] : ExprA :=
+  Cases e of
+  | (EAplus e1 e2) => (EAplus (distrib_EAopp e1) (distrib_EAopp e2))
+  | (EAmult e1 e2) => (EAmult (distrib_EAopp e1) (distrib_EAopp e2))
+  | (EAopp e) => (EAmult (EAopp EAone) (distrib_EAopp e))
+  | e => e
+  end.
+
+Definition distrib_mult_right :=
+  Fix distrib_mult_right {distrib_mult_right [e1:ExprA]:ExprA->ExprA:=
+  [e2:ExprA]Cases e1 of
+  | (EAplus t1 t2) =>
+    (EAplus (distrib_mult_right t1 e2) (distrib_mult_right t2 e2))
+  | _ => (EAmult e1 e2)
+  end}.
+
+Fixpoint distrib_mult_left [e1:ExprA] : ExprA->ExprA :=
+  [e2:ExprA]
+  Cases e1 of
+  | (EAplus t1 t2) =>
+    (EAplus (distrib_mult_left t1 e2) (distrib_mult_left t2 e2))
+  | _ => (distrib_mult_right e2 e1)
+  end.
+
+Fixpoint distrib_main [e:ExprA] : ExprA :=
+  Cases e of
+  | (EAmult e1 e2) => (distrib_mult_left (distrib_main e1) (distrib_main e2))
+  | (EAplus e1 e2) => (EAplus (distrib_main e1) (distrib_main e2))
+  | (EAopp e) => (EAopp (distrib_main e))
+  | _ => e
+  end.
+
+Definition distrib [e:ExprA] : ExprA := (distrib_main (distrib_EAopp e)).
+
+Lemma distrib_mult_right_correct:
+  (e1,e2:ExprA)(lvar:(listT (prodT AT nat)))
+     (interp_ExprA lvar (distrib_mult_right e1 e2))=
+     (AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2)).
+Proof.
+Induction e1;Try Intros;Simpl;Auto.
+Rewrite AmultT_sym;Rewrite AmultT_AplusT_distr;
+ Rewrite (H e2 lvar);Rewrite (H0 e2 lvar);Ring.
+Save.
+
+Lemma distrib_mult_left_correct:
+  (e1,e2:ExprA)(lvar:(listT (prodT AT nat)))
+     (interp_ExprA lvar (distrib_mult_left e1 e2))=
+     (AmultT (interp_ExprA lvar e1)  (interp_ExprA lvar e2)).
+Proof.
+Induction e1;Try Intros;Simpl.
+Rewrite AmultT_Ol;Rewrite distrib_mult_right_correct;Simpl;Apply AmultT_Or.
+Rewrite distrib_mult_right_correct;Simpl;
+ Apply AmultT_sym. 
+Rewrite AmultT_sym;
+ Rewrite (AmultT_AplusT_distr (interp_ExprA lvar e2) (interp_ExprA lvar e)
+  (interp_ExprA lvar e0)); 
+ Rewrite (AmultT_sym (interp_ExprA lvar e2) (interp_ExprA lvar e));
+ Rewrite (AmultT_sym (interp_ExprA lvar e2) (interp_ExprA lvar e0));
+ Rewrite (H e2 lvar);Rewrite (H0 e2 lvar);Auto.
+Rewrite distrib_mult_right_correct;Simpl;Apply AmultT_sym.
+Rewrite distrib_mult_right_correct;Simpl;Apply AmultT_sym.
+Rewrite distrib_mult_right_correct;Simpl;Apply AmultT_sym.
+Rewrite distrib_mult_right_correct;Simpl;Apply AmultT_sym.
+Save.
+
+Lemma distrib_correct:
+  (e:ExprA)(lvar:(listT (prodT AT nat)))
+    (interp_ExprA lvar (distrib e))=(interp_ExprA lvar e).
+Proof.
+Induction e;Intros;Auto.
+Simpl;Rewrite <- (H lvar);Rewrite <- (H0 lvar); Unfold distrib;Simpl;Auto.
+Simpl;Rewrite <- (H lvar);Rewrite <- (H0 lvar); Unfold distrib;Simpl;
+ Apply distrib_mult_left_correct.
+Simpl;Fold AoppT;Rewrite <- (H lvar);Unfold distrib;Simpl; 
+ Rewrite distrib_mult_right_correct;
+ Simpl;Fold AoppT;Ring.
+Save.
+
+(**** Multiplication by the inverse product ****)
+
+Lemma mult_eq:
+  (e1,e2,a:ExprA)(lvar:(listT (prodT AT nat)))
+    ~((interp_ExprA lvar a)=AzeroT)->
+      (interp_ExprA lvar (EAmult a e1))=(interp_ExprA lvar (EAmult a e2))->
+        (interp_ExprA lvar e1)=(interp_ExprA lvar e2).
+Proof.
+  Simpl;Intros;
+    Apply (r_AmultT_mult (interp_ExprA lvar a) (interp_ExprA lvar e1)
+      (interp_ExprA lvar e2));Assumption.
+Save.
+
+Fixpoint multiply_aux [a,e:ExprA] : ExprA :=
+  Cases e of
+  | (EAplus e1 e2) =>
+    (EAplus (EAmult a e1) (multiply_aux a e2))
+  | _ => (EAmult a e)
+  end.
+
+Definition multiply [e:ExprA] : ExprA :=
+  Cases e of
+  | (EAmult a e1) => (multiply_aux a e1)
+  | _ => e
+  end.
+
+Lemma multiply_aux_correct:
+  (a,e:ExprA)(lvar:(listT (prodT AT nat)))
+    (interp_ExprA lvar (multiply_aux a e))=
+    (AmultT (interp_ExprA lvar a) (interp_ExprA lvar e)).
+Proof.
+Induction e;Simpl;Intros;Try (Rewrite merge_mult_correct);Auto.
+  Simpl;Rewrite (H0 lvar);Ring.
+Save.
+
+Lemma multiply_correct:
+  (e:ExprA)(lvar:(listT (prodT AT nat)))
+    (interp_ExprA lvar (multiply e))=(interp_ExprA lvar e).
+Proof.
+  Induction e;Simpl;Auto.
+  Intros;Apply multiply_aux_correct.
+Save.
+
+(**** Permutations and simplification ****)
+
+Fixpoint monom_remove [a,m:ExprA] : ExprA :=
+  Cases m of
+  | (EAmult m0 m1) =>
+    (Cases (eqExprA m0 (EAinv a)) of
+     | (left _) => m1
+     | (right _) => (EAmult m0 (monom_remove a m1))
+     end)
+  | _ =>
+    (Cases (eqExprA m (EAinv a)) of
+     | (left _) => EAone
+     | (right _) => (EAmult a m)
+     end)
+  end.
+
+Definition monom_simplif_rem := 
+  Fix monom_simplif_rem {monom_simplif_rem/1:ExprA->ExprA->ExprA:=
+  [a,m:ExprA] 
+  Cases a of
+  | (EAmult a0 a1) => (monom_simplif_rem a1 (monom_remove a0 m))
+  | _ => (monom_remove a m)
+  end}.
+
+Definition monom_simplif [a,m:ExprA] : ExprA :=
+  Cases m of
+  | (EAmult a' m') =>
+    (Cases (eqExprA a a') of
+     | (left _) => (monom_simplif_rem a m')
+     | (right _) => m
+     end)
+  | _ => m
+  end.
+
+Fixpoint inverse_simplif [a,e:ExprA] : ExprA :=
+  Cases e of
+  | (EAplus e1 e2) => (EAplus (monom_simplif a e1) (inverse_simplif a e2))
+  | _ => (monom_simplif a e)
+  end.
+
+Lemma monom_remove_correct:(e,a:ExprA)
+  (lvar:(listT (prodT AT nat)))~((interp_ExprA lvar a)=AzeroT)->
+  (interp_ExprA lvar (monom_remove a e))=
+  (AmultT (interp_ExprA lvar a) (interp_ExprA lvar e)).
+Proof.
+Induction e; Intros.
+Simpl;Case (eqExprA EAzero (EAinv a));Intros;[Inversion e0|Simpl;Trivial].
+Simpl;Case (eqExprA EAone (EAinv a));Intros;[Inversion e0|Simpl;Trivial].
+Simpl;Case (eqExprA (EAplus e0 e1) (EAinv a));Intros;[Inversion e2|
+ Simpl;Trivial].
+Simpl;Case (eqExprA e0 (EAinv a));Intros.
+Rewrite e2;Simpl;Fold AinvT.
+Rewrite <-(AmultT_assoc (interp_ExprA lvar a) (AinvT (interp_ExprA lvar a))
+             (interp_ExprA lvar e1));
+  Rewrite AinvT_r;[Ring|Assumption].
+Simpl;Rewrite H0;Auto; Ring.
+Simpl;Fold AoppT;Case (eqExprA (EAopp e0) (EAinv a));Intros;[Inversion e1|
+ Simpl;Trivial].
+Unfold monom_remove;Case (eqExprA (EAinv e0) (EAinv a));Intros.
+Case (eqExprA e0 a);Intros.
+Rewrite e2;Simpl;Fold AinvT;Rewrite AinvT_r;Auto.
+Inversion e1;Simpl;ElimType False;Auto.
+Simpl;Trivial.
+Unfold monom_remove;Case (eqExprA (EAvar n) (EAinv a));Intros;
+ [Inversion e0|Simpl;Trivial].
+Save.
+
+Lemma monom_simplif_rem_correct:(a,e:ExprA)
+  (lvar:(listT (prodT AT nat)))~((interp_ExprA lvar a)=AzeroT)->
+  (interp_ExprA lvar (monom_simplif_rem a e))=
+  (AmultT (interp_ExprA lvar a) (interp_ExprA lvar e)).
+Proof.
+Induction a;Simpl;Intros; Try Rewrite monom_remove_correct;Auto.
+Elim (without_div_O_contr (interp_ExprA lvar e) 
+                          (interp_ExprA lvar e0) H1);Intros.
+Rewrite (H0 (monom_remove e e1) lvar H3);Rewrite monom_remove_correct;Auto.
+Ring.
+Save.
+
+Lemma monom_simplif_correct:(e,a:ExprA)
+  (lvar:(listT (prodT AT nat)))~((interp_ExprA lvar a)=AzeroT)->
+  (interp_ExprA lvar (monom_simplif a e))=(interp_ExprA lvar e).
+Proof.
+Induction e;Intros;Auto.
+Simpl;Case (eqExprA a e0);Intros.
+Rewrite <-e2;Apply monom_simplif_rem_correct;Auto. 
+Simpl;Trivial.
+Save.
+
+Lemma inverse_correct:
+  (e,a:ExprA)(lvar:(listT (prodT AT nat)))~((interp_ExprA lvar a)=AzeroT)->
+    (interp_ExprA lvar (inverse_simplif a e))=(interp_ExprA lvar e).
+Proof.
+Induction e;Intros;Auto.
+Simpl;Rewrite (H0 a lvar H1); Rewrite monom_simplif_correct ; Auto.
+Unfold inverse_simplif;Rewrite monom_simplif_correct ; Auto.
+Save.
+
+End Theory_of_fields.
diff --git a/contrib7/fourier/.cvsignore b/contrib7/fourier/.cvsignore
new file mode 100644
index 0000000000..c446fcb878
--- /dev/null
+++ b/contrib7/fourier/.cvsignore
@@ -0,0 +1 @@
+*.v8
diff --git a/contrib7/fourier/Fourier.v b/contrib7/fourier/Fourier.v
new file mode 100644
index 0000000000..b02688de63
--- /dev/null
+++ b/contrib7/fourier/Fourier.v
@@ -0,0 +1,28 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* "Fourier's method to solve linear inequations/equations systems.".*)
+
+Declare ML Module "quote".
+Declare ML Module "ring".
+Declare ML Module "fourier".
+Declare ML Module "fourierR".
+Declare ML Module "field".
+
+Require Export Fourier_util.
+Require Export Field.
+Require Export DiscrR.
+
+Tactic Definition Fourier  :=
+  Abstract (FourierZ;Field;DiscrR).
+
+Tactic Definition FourierEq  :=
+  Apply Rge_ge_eq ; Fourier.
+
diff --git a/contrib7/fourier/Fourier_util.v b/contrib7/fourier/Fourier_util.v
new file mode 100644
index 0000000000..0f36eda8cb
--- /dev/null
+++ b/contrib7/fourier/Fourier_util.v
@@ -0,0 +1,241 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+Require Export Rbase.
+Comments "Lemmas used by the tactic Fourier".
+
+Open Scope R_scope.
+ 
+Lemma Rfourier_lt:
+ (x1, y1, a : R) (Rlt x1 y1) -> (Rlt R0 a) ->  (Rlt (Rmult a x1) (Rmult a y1)).
+Intros; Apply Rlt_monotony; Assumption.
+Qed.
+ 
+Lemma Rfourier_le:
+ (x1, y1, a : R) (Rle x1 y1) -> (Rlt R0 a) ->  (Rle (Rmult a x1) (Rmult a y1)).
+Red.
+Intros.
+Case H; Auto with real.
+Qed.
+ 
+Lemma Rfourier_lt_lt:
+ (x1, y1, x2, y2, a : R)
+ (Rlt x1 y1) ->
+ (Rlt x2 y2) ->
+ (Rlt R0 a) ->  (Rlt (Rplus x1 (Rmult a x2)) (Rplus y1 (Rmult a y2))).
+Intros x1 y1 x2 y2 a H H0 H1; Try Assumption.
+Apply Rplus_lt.
+Try Exact H.
+Apply Rfourier_lt.
+Try Exact H0.
+Try Exact H1.
+Qed.
+ 
+Lemma Rfourier_lt_le:
+ (x1, y1, x2, y2, a : R)
+ (Rlt x1 y1) ->
+ (Rle x2 y2) ->
+ (Rlt R0 a) ->  (Rlt (Rplus x1 (Rmult a x2)) (Rplus y1 (Rmult a y2))).
+Intros x1 y1 x2 y2 a H H0 H1; Try Assumption.
+Case H0; Intros.
+Apply Rplus_lt.
+Try Exact H.
+Apply Rfourier_lt; Auto with real.
+Rewrite H2.
+Rewrite (Rplus_sym y1 (Rmult a y2)).
+Rewrite (Rplus_sym x1 (Rmult a y2)).
+Apply Rlt_compatibility.
+Try Exact H.
+Qed.
+ 
+Lemma Rfourier_le_lt:
+ (x1, y1, x2, y2, a : R)
+ (Rle x1 y1) ->
+ (Rlt x2 y2) ->
+ (Rlt R0 a) ->  (Rlt (Rplus x1 (Rmult a x2)) (Rplus y1 (Rmult a y2))).
+Intros x1 y1 x2 y2 a H H0 H1; Try Assumption.
+Case H; Intros.
+Apply Rfourier_lt_le; Auto with real.
+Rewrite H2.
+Apply Rlt_compatibility.
+Apply Rfourier_lt; Auto with real.
+Qed.
+ 
+Lemma Rfourier_le_le:
+ (x1, y1, x2, y2, a : R)
+ (Rle x1 y1) ->
+ (Rle x2 y2) ->
+ (Rlt R0 a) ->  (Rle (Rplus x1 (Rmult a x2)) (Rplus y1 (Rmult a y2))).
+Intros x1 y1 x2 y2 a H H0 H1; Try Assumption.
+Case H0; Intros.
+Red.
+Left; Try Assumption.
+Apply Rfourier_le_lt; Auto with real.
+Rewrite H2.
+Case H; Intros.
+Red.
+Left; Try Assumption.
+Rewrite (Rplus_sym x1 (Rmult a y2)).
+Rewrite (Rplus_sym y1 (Rmult a y2)).
+Apply Rlt_compatibility.
+Try Exact H3.
+Rewrite H3.
+Red.
+Right; Try Assumption.
+Auto with real.
+Qed.
+ 
+Lemma Rlt_zero_pos_plus1: (x : R) (Rlt R0 x) ->  (Rlt R0 (Rplus R1 x)).
+Intros x H; Try Assumption.
+Rewrite Rplus_sym.
+Apply Rlt_r_plus_R1.
+Red; Auto with real.
+Qed.
+ 
+Lemma Rlt_mult_inv_pos:
+ (x, y : R) (Rlt R0 x) -> (Rlt R0 y) ->  (Rlt R0 (Rmult x (Rinv y))).
+Intros x y H H0; Try Assumption.
+Replace R0 with (Rmult x R0).
+Apply Rlt_monotony; Auto with real.
+Ring.
+Qed.
+ 
+Lemma Rlt_zero_1: (Rlt R0 R1).
+Exact Rlt_R0_R1.
+Qed.
+ 
+Lemma Rle_zero_pos_plus1: (x : R) (Rle R0 x) ->  (Rle R0 (Rplus R1 x)).
+Intros x H; Try Assumption.
+Case H; Intros.
+Red.
+Left; Try Assumption.
+Apply Rlt_zero_pos_plus1; Auto with real.
+Rewrite <- H0.
+Replace (Rplus R1 R0) with R1.
+Red; Left.
+Exact Rlt_zero_1.
+Ring.
+Qed.
+ 
+Lemma Rle_mult_inv_pos:
+ (x, y : R) (Rle R0 x) -> (Rlt R0 y) ->  (Rle R0 (Rmult x (Rinv y))).
+Intros x y H H0; Try Assumption.
+Case H; Intros.
+Red; Left.
+Apply Rlt_mult_inv_pos; Auto with real.
+Rewrite <- H1.
+Red; Right; Ring.
+Qed.
+ 
+Lemma Rle_zero_1: (Rle R0 R1).
+Red; Left.
+Exact Rlt_zero_1.
+Qed.
+ 
+Lemma Rle_not_lt:
+ (n, d : R) (Rle R0 (Rmult n (Rinv d))) ->  ~ (Rlt R0 (Rmult (Ropp n) (Rinv d))).
+Intros n d H; Red; Intros H0; Try Exact H0.
+Generalize (Rle_not R0 (Rmult n (Rinv d))).
+Intros H1; Elim H1; Try Assumption.
+Replace (Rmult n (Rinv d)) with (Ropp (Ropp (Rmult n (Rinv d)))).
+Replace R0 with (Ropp (Ropp R0)).
+Replace (Ropp (Rmult n (Rinv d))) with (Rmult (Ropp n) (Rinv d)).
+Replace (Ropp R0) with R0.
+Red.
+Try Exact H0.
+Apply Rgt_Ropp.
+Replace (Ropp (Rmult n (Rinv d))) with (Rmult (Ropp n) (Rinv d)).
+Replace (Ropp R0) with R0.
+Red.
+Try Exact H0.
+Ring.
+Ring.
+Ring.
+Ring.
+Ring.
+Ring.
+Qed.
+ 
+Lemma Rnot_lt0: (x : R)  ~ (Rlt R0 (Rmult R0 x)).
+Intros x; Try Assumption.
+Replace (Rmult R0 x) with R0.
+Apply Rlt_antirefl.
+Ring.
+Qed.
+ 
+Lemma Rlt_not_le:
+ (n, d : R) (Rlt R0 (Rmult n (Rinv d))) ->  ~ (Rle R0 (Rmult (Ropp n) (Rinv d))).
+Intros n d H; Try Assumption.
+Apply Rle_not.
+Replace R0 with (Ropp R0).
+Replace (Rmult (Ropp n) (Rinv d)) with (Ropp (Rmult n (Rinv d))).
+Apply Rlt_Ropp.
+Try Exact H.
+Ring.
+Ring.
+Qed.
+ 
+Lemma Rnot_lt_lt: (x, y : R) ~ (Rlt R0 (Rminus y x)) ->  ~ (Rlt x y).
+Unfold not; Intros.
+Apply H.
+Apply Rlt_anti_compatibility with x.
+Replace (Rplus x R0) with x.
+Replace (Rplus x (Rminus y x)) with y.
+Try Exact H0.
+Ring.
+Ring.
+Qed.
+ 
+Lemma Rnot_le_le: (x, y : R) ~ (Rle R0 (Rminus y x)) ->  ~ (Rle x y).
+Unfold not; Intros.
+Apply H.
+Case H0; Intros.
+Left.
+Apply Rlt_anti_compatibility with x.
+Replace (Rplus x R0) with x.
+Replace (Rplus x (Rminus y x)) with y.
+Try Exact H1.
+Ring.
+Ring.
+Right.
+Rewrite H1; Ring.
+Qed.
+ 
+Lemma Rfourier_gt_to_lt: (x, y : R) (Rgt y x) ->  (Rlt x y).
+Unfold Rgt; Intros; Assumption.
+Qed.
+ 
+Lemma Rfourier_ge_to_le: (x, y : R) (Rge y x) ->  (Rle x y).
+Intros x y; Exact (Rge_le y x).
+Qed.
+ 
+Lemma Rfourier_eqLR_to_le: (x, y : R) x == y ->  (Rle x y).
+Exact eq_Rle.
+Qed.
+ 
+Lemma Rfourier_eqRL_to_le: (x, y : R) y == x ->  (Rle x y).
+Exact eq_Rle_sym.
+Qed.
+ 
+Lemma Rfourier_not_ge_lt: (x, y : R) ((Rge x y) ->  False) ->  (Rlt x y).
+Exact not_Rge.
+Qed.
+ 
+Lemma Rfourier_not_gt_le: (x, y : R) ((Rgt x y) ->  False) ->  (Rle x y).
+Exact Rgt_not_le.
+Qed.
+ 
+Lemma Rfourier_not_le_gt: (x, y : R) ((Rle x y) ->  False) ->  (Rgt x y).
+Exact not_Rle.
+Qed.
+ 
+Lemma Rfourier_not_lt_ge: (x, y : R) ((Rlt x y) ->  False) ->  (Rge x y).
+Exact Rlt_not_ge.
+Qed.
diff --git a/contrib7/omega/.cvsignore b/contrib7/omega/.cvsignore
new file mode 100644
index 0000000000..c446fcb878
--- /dev/null
+++ b/contrib7/omega/.cvsignore
@@ -0,0 +1 @@
+*.v8
diff --git a/contrib7/omega/Omega.v b/contrib7/omega/Omega.v
new file mode 100644
index 0000000000..480f7594be
--- /dev/null
+++ b/contrib7/omega/Omega.v
@@ -0,0 +1,57 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+(**************************************************************************)
+(*                                                                        *)
+(* Omega: a solver of quantifier-free problems in Presburger Arithmetic   *)
+(*                                                                        *)
+(* Pierre Crégut (CNET, Lannion, France)                                  *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* $Id$ *)
+
+(* We do not require [ZArith] anymore, but only what's necessary for Omega *)
+Require Export ZArith_base.
+Require Export OmegaLemmas.
+
+Hints Resolve Zle_n Zplus_sym Zplus_assoc Zmult_sym Zmult_assoc
+  Zero_left Zero_right Zmult_one Zplus_inverse_l Zplus_inverse_r 
+  Zmult_plus_distr_l Zmult_plus_distr_r : zarith.
+
+Require Export Zhints.
+
+(*
+(* The constant minus is required in coq_omega.ml *)
+Require Minus.
+*)
+
+Hint eq_nat_Omega : zarith := Extern 10 (eq nat ? ?) Abstract Omega.
+Hint le_Omega : zarith := Extern 10 (le ? ?) Abstract Omega.
+Hint lt_Omega : zarith := Extern 10 (lt ? ?) Abstract Omega.
+Hint ge_Omega : zarith := Extern 10 (ge ? ?) Abstract Omega.
+Hint gt_Omega : zarith := Extern 10 (gt ? ?) Abstract Omega.
+
+Hint not_eq_nat_Omega : zarith := Extern 10 ~(eq nat ? ?) Abstract Omega.
+Hint not_le_Omega : zarith := Extern 10 ~(le ? ?) Abstract Omega.
+Hint not_lt_Omega : zarith := Extern 10 ~(lt ? ?) Abstract Omega.
+Hint not_ge_Omega : zarith := Extern 10 ~(ge ? ?) Abstract Omega.
+Hint not_gt_Omega : zarith := Extern 10 ~(gt ? ?) Abstract Omega.
+
+Hint eq_Z_Omega : zarith := Extern 10 (eq Z ? ?) Abstract Omega.
+Hint Zle_Omega : zarith := Extern 10 (Zle ? ?) Abstract Omega.
+Hint Zlt_Omega : zarith := Extern 10 (Zlt ? ?) Abstract Omega.
+Hint Zge_Omega : zarith := Extern 10 (Zge ? ?) Abstract Omega.
+Hint Zgt_Omega : zarith := Extern 10 (Zgt ? ?) Abstract Omega.
+
+Hint not_eq_nat_Omega : zarith := Extern 10 ~(eq Z ? ?) Abstract Omega.
+Hint not_Zle_Omega : zarith := Extern 10 ~(Zle ? ?) Abstract Omega.
+Hint not_Zlt_Omega : zarith := Extern 10 ~(Zlt ? ?) Abstract Omega.
+Hint not_Zge_Omega : zarith := Extern 10 ~(Zge ? ?) Abstract Omega.
+Hint not_Zgt_Omega : zarith := Extern 10 ~(Zgt ? ?) Abstract Omega.
+
+Hint false_Omega : zarith := Extern 10 False Abstract Omega.
diff --git a/contrib7/omega/OmegaLemmas.v b/contrib7/omega/OmegaLemmas.v
new file mode 100644
index 0000000000..c292240699
--- /dev/null
+++ b/contrib7/omega/OmegaLemmas.v
@@ -0,0 +1,399 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(*i $Id$ i*)
+
+Require ZArith_base.
+
+(** These are specific variants of theorems dedicated for the Omega tactic *)
+
+Lemma new_var: (x:Z) (EX y:Z |(x=y)).
+Intros x; Exists x; Trivial with arith. 
+Qed.
+
+Lemma OMEGA1 : (x,y:Z) (x=y) -> (Zle ZERO x) -> (Zle ZERO y).
+Intros x y H; Rewrite H; Auto with arith.
+Qed.
+
+Lemma OMEGA2 : (x,y:Z) (Zle ZERO x) -> (Zle ZERO y) -> (Zle ZERO (Zplus x y)).
+Exact Zle_0_plus.
+Qed. 
+
+Lemma OMEGA3 : 
+  (x,y,k:Z)(Zgt k ZERO)-> (x=(Zmult y k)) -> (x=ZERO) -> (y=ZERO).
+
+Intros x y k H1 H2 H3; Apply (Zmult_eq k); [
+  Unfold not ; Intros H4; Absurd (Zgt k ZERO); [
+    Rewrite H4; Unfold Zgt ; Simpl; Discriminate | Assumption]
+  | Rewrite <- H2; Assumption].
+Qed.
+
+Lemma OMEGA4 :
+  (x,y,z:Z)(Zgt x ZERO) -> (Zgt y x) -> ~(Zplus (Zmult z y) x) = ZERO.
+
+Unfold not ; Intros x y z H1 H2 H3; Cut (Zgt y ZERO); [
+  Intros H4; Cut (Zle ZERO (Zplus (Zmult z y) x)); [
+    Intros H5; Generalize (Zmult_le_approx y z x H4 H2 H5) ; Intros H6;
+    Absurd (Zgt (Zplus (Zmult z y) x) ZERO); [
+      Rewrite -> H3; Unfold Zgt ; Simpl; Discriminate
+    | Apply Zle_gt_trans with x ; [
+        Pattern 1 x ; Rewrite <- (Zero_left x); Apply Zle_reg_r;
+        Rewrite -> Zmult_sym; Generalize H4 ; Unfold Zgt;
+        Case y; [
+          Simpl; Intros H7; Discriminate H7
+        | Intros p H7; Rewrite <- (Zero_mult_right (POS p));
+          Unfold Zle ; Rewrite -> Zcompare_Zmult_compatible; Exact H6
+        | Simpl; Intros p H7; Discriminate H7]
+      | Assumption]]
+    | Rewrite -> H3; Unfold Zle ; Simpl; Discriminate]
+  | Apply Zgt_trans with x ; [ Assumption | Assumption]].
+Qed.
+
+Lemma OMEGA5: (x,y,z:Z)(x=ZERO) -> (y=ZERO) -> (Zplus x (Zmult y z)) = ZERO.
+
+Intros x y z H1 H2; Rewrite H1; Rewrite H2; Simpl; Trivial with arith.
+Qed.
+
+Lemma OMEGA6:
+  (x,y,z:Z)(Zle ZERO x) -> (y=ZERO) -> (Zle ZERO (Zplus x (Zmult y z))).
+
+Intros x y z H1 H2; Rewrite H2; Simpl; Rewrite Zero_right; Assumption.
+Qed.
+
+Lemma OMEGA7:
+  (x,y,z,t:Z)(Zgt z ZERO) -> (Zgt t ZERO) -> (Zle ZERO x) -> (Zle ZERO y) -> 
+    (Zle ZERO (Zplus (Zmult x z) (Zmult y t))).
+
+Intros x y z t H1 H2 H3 H4; Rewrite <- (Zero_left ZERO);
+Apply Zle_plus_plus; Apply Zle_mult; Assumption.
+Qed.
+
+Lemma OMEGA8: 
+  (x,y:Z) (Zle ZERO x) -> (Zle ZERO y) -> x = (Zopp y) -> x = ZERO.
+
+Intros x y H1 H2 H3; Elim (Zle_lt_or_eq ZERO x H1); [
+  Intros H4; Absurd (Zlt ZERO x); [
+    Change (Zge ZERO x); Apply Zle_ge; Apply Zsimpl_le_plus_l with y;
+    Rewrite -> H3; Rewrite Zplus_inverse_r; Rewrite Zero_right; Assumption
+  | Assumption]
+| Intros H4; Rewrite -> H4; Trivial with arith].
+Qed.
+
+Lemma OMEGA9:(x,y,z,t:Z) y=ZERO -> x = z -> 
+  (Zplus y (Zmult (Zplus (Zopp x) z) t)) = ZERO.
+
+Intros x y z t H1 H2; Rewrite H2; Rewrite Zplus_inverse_l; 
+Rewrite Zero_mult_left;  Rewrite Zero_right; Assumption.
+Qed.
+
+Lemma OMEGA10:(v,c1,c2,l1,l2,k1,k2:Z)
+  (Zplus (Zmult (Zplus (Zmult v c1) l1) k1) (Zmult (Zplus (Zmult v c2) l2) k2))
+  = (Zplus (Zmult v (Zplus (Zmult c1 k1) (Zmult c2 k2)))
+           (Zplus (Zmult l1 k1) (Zmult l2 k2))).
+
+Intros; Repeat (Rewrite Zmult_plus_distr_l Orelse Rewrite Zmult_plus_distr_r);
+Repeat Rewrite Zmult_assoc; Repeat Elim Zplus_assoc; 
+Rewrite (Zplus_permute (Zmult l1 k1) (Zmult (Zmult v c2) k2)); Trivial with arith.
+Qed.
+
+Lemma OMEGA11:(v1,c1,l1,l2,k1:Z)
+  (Zplus (Zmult (Zplus (Zmult v1 c1) l1) k1) l2)
+  = (Zplus (Zmult v1 (Zmult c1 k1)) (Zplus (Zmult l1 k1) l2)).
+
+Intros; Repeat (Rewrite Zmult_plus_distr_l Orelse Rewrite Zmult_plus_distr_r);
+Repeat Rewrite Zmult_assoc; Repeat Elim Zplus_assoc; Trivial with arith.
+Qed.
+
+Lemma OMEGA12:(v2,c2,l1,l2,k2:Z)
+  (Zplus l1 (Zmult (Zplus (Zmult v2 c2) l2) k2))
+  = (Zplus (Zmult v2 (Zmult c2 k2)) (Zplus l1 (Zmult l2 k2))).
+
+Intros; Repeat (Rewrite Zmult_plus_distr_l Orelse Rewrite Zmult_plus_distr_r);
+Repeat Rewrite Zmult_assoc; Repeat Elim Zplus_assoc; Rewrite Zplus_permute;
+Trivial with arith.
+Qed.
+
+Lemma OMEGA13:(v,l1,l2:Z)(x:positive)
+  (Zplus (Zplus (Zmult v (POS x)) l1) (Zplus (Zmult v (NEG x)) l2))
+  = (Zplus l1 l2).
+
+Intros; Rewrite  Zplus_assoc; Rewrite (Zplus_sym (Zmult v (POS x)) l1);
+Rewrite (Zplus_assoc_r l1); Rewrite <- Zmult_plus_distr_r;
+Rewrite <- Zopp_NEG; Rewrite (Zplus_sym (Zopp (NEG x)) (NEG x));
+Rewrite Zplus_inverse_r; Rewrite  Zero_mult_right; Rewrite Zero_right; Trivial with arith.
+Qed.
+ 
+Lemma OMEGA14:(v,l1,l2:Z)(x:positive)
+  (Zplus (Zplus (Zmult v (NEG x)) l1) (Zplus (Zmult v (POS x)) l2))
+  = (Zplus l1 l2).
+
+Intros; Rewrite  Zplus_assoc; Rewrite (Zplus_sym (Zmult v (NEG x)) l1);
+Rewrite (Zplus_assoc_r l1); Rewrite <- Zmult_plus_distr_r;
+Rewrite <- Zopp_NEG; Rewrite  Zplus_inverse_r; Rewrite  Zero_mult_right;
+Rewrite Zero_right; Trivial with arith.
+Qed.
+Lemma OMEGA15:(v,c1,c2,l1,l2,k2:Z)
+  (Zplus (Zplus (Zmult v c1) l1) (Zmult (Zplus (Zmult v c2) l2) k2))
+  = (Zplus (Zmult v (Zplus c1  (Zmult c2 k2)))
+           (Zplus l1 (Zmult l2 k2))).
+
+Intros; Repeat (Rewrite Zmult_plus_distr_l Orelse Rewrite Zmult_plus_distr_r);
+Repeat Rewrite Zmult_assoc; Repeat Elim Zplus_assoc; 
+Rewrite (Zplus_permute l1 (Zmult (Zmult v c2) k2)); Trivial with arith.
+Qed.
+
+Lemma OMEGA16:
+  (v,c,l,k:Z)
+   (Zmult (Zplus (Zmult v c) l) k) = (Zplus (Zmult v (Zmult c k)) (Zmult l k)).
+
+Intros; Repeat (Rewrite Zmult_plus_distr_l Orelse Rewrite Zmult_plus_distr_r);
+Repeat Rewrite Zmult_assoc; Repeat Elim Zplus_assoc; Trivial with arith.
+Qed.
+
+Lemma OMEGA17: 
+  (x,y,z:Z)(Zne x ZERO) -> (y=ZERO) -> (Zne (Zplus x (Zmult y z)) ZERO).
+
+Unfold Zne not; Intros x y z H1 H2 H3; Apply H1; 
+Apply Zsimpl_plus_l with (Zmult y z); Rewrite Zplus_sym; Rewrite H3; 
+Rewrite H2; Auto with arith.
+Qed.
+
+Lemma OMEGA18:
+  (x,y,k:Z) x=(Zmult y k) -> (Zne x ZERO) -> (Zne y ZERO).
+
+Unfold Zne not; Intros x y k H1 H2 H3; Apply H2; Rewrite H1; Rewrite H3; Auto with arith.
+Qed.
+
+Lemma OMEGA19:
+  (x:Z) (Zne x ZERO) -> 
+    (Zle ZERO (Zplus x (NEG xH))) \/ (Zle ZERO (Zplus (Zmult x (NEG xH)) (NEG xH))).
+
+Unfold Zne ; Intros x H; Elim (Zle_or_lt ZERO x); [
+  Intros H1; Elim Zle_lt_or_eq with 1:=H1; [
+    Intros H2; Left;  Change (Zle ZERO (Zpred x)); Apply Zle_S_n;
+    Rewrite <- Zs_pred; Apply Zlt_le_S; Assumption
+  | Intros H2; Absurd x=ZERO; Auto with arith]
+| Intros H1; Right; Rewrite <- Zopp_one; Rewrite Zplus_sym;
+  Apply Zle_left; Apply Zle_S_n; Simpl; Apply Zlt_le_S; Auto with arith].
+Qed.
+
+Lemma OMEGA20:
+  (x,y,z:Z)(Zne x  ZERO) -> (y=ZERO) -> (Zne (Zplus x (Zmult y z)) ZERO).
+
+Unfold Zne not; Intros x y z H1 H2 H3; Apply H1; Rewrite H2 in H3;
+Simpl in H3; Rewrite Zero_right in H3; Trivial with arith.
+Qed.
+
+Definition fast_Zplus_sym := 
+[x,y:Z][P:Z -> Prop][H: (P (Zplus y x))]
+  (eq_ind_r Z (Zplus y x) P H (Zplus x y) (Zplus_sym x y)).
+
+Definition fast_Zplus_assoc_r :=
+[n,m,p:Z][P:Z -> Prop][H : (P (Zplus n (Zplus m p)))]
+ (eq_ind_r Z (Zplus n (Zplus m p)) P H (Zplus (Zplus n m) p) (Zplus_assoc_r n m p)).
+
+Definition fast_Zplus_assoc_l :=
+[n,m,p:Z][P:Z -> Prop][H : (P (Zplus (Zplus n m) p))]
+ (eq_ind_r Z (Zplus (Zplus n m) p) P H (Zplus n (Zplus m p)) 
+           (Zplus_assoc_l n m p)).
+
+Definition fast_Zplus_permute :=
+[n,m,p:Z][P:Z -> Prop][H : (P (Zplus m (Zplus n p)))]
+ (eq_ind_r Z (Zplus m (Zplus n p)) P H (Zplus n (Zplus m p))
+           (Zplus_permute n m p)).
+
+Definition fast_OMEGA10 := 
+[v,c1,c2,l1,l2,k1,k2:Z][P:Z -> Prop]
+[H : (P (Zplus (Zmult v (Zplus (Zmult c1 k1) (Zmult c2 k2)))
+               (Zplus (Zmult l1 k1) (Zmult l2 k2))))]
+ (eq_ind_r Z 
+           (Zplus (Zmult v (Zplus (Zmult c1 k1) (Zmult c2 k2)))
+            (Zplus (Zmult l1 k1) (Zmult l2 k2)))
+           P H 
+          (Zplus (Zmult (Zplus (Zmult v c1) l1) k1)
+                 (Zmult (Zplus (Zmult v c2) l2) k2))
+        (OMEGA10 v c1 c2 l1 l2 k1 k2)).
+
+Definition fast_OMEGA11 := 
+[v1,c1,l1,l2,k1:Z][P:Z -> Prop]
+[H : (P (Zplus (Zmult v1 (Zmult c1 k1)) (Zplus (Zmult l1 k1) l2)))]
+ (eq_ind_r Z 
+   (Zplus (Zmult v1 (Zmult c1 k1)) (Zplus (Zmult l1 k1) l2))
+   P H 
+   (Zplus (Zmult (Zplus (Zmult v1 c1) l1) k1) l2)
+   (OMEGA11 v1 c1 l1 l2 k1)).
+Definition fast_OMEGA12 := 
+[v2,c2,l1,l2,k2:Z][P:Z -> Prop]
+[H : (P (Zplus (Zmult v2 (Zmult c2 k2)) (Zplus l1 (Zmult l2 k2))))]
+ (eq_ind_r Z 
+   (Zplus (Zmult v2 (Zmult c2 k2)) (Zplus l1 (Zmult l2 k2)))
+   P H 
+   (Zplus l1 (Zmult (Zplus (Zmult v2 c2) l2) k2))
+   (OMEGA12 v2 c2 l1 l2 k2)).
+
+Definition fast_OMEGA15 :=
+[v,c1,c2,l1,l2,k2 :Z][P:Z -> Prop]
+[H : (P (Zplus (Zmult v (Zplus c1 (Zmult c2 k2))) (Zplus l1 (Zmult l2 k2))))]
+ (eq_ind_r Z 
+   (Zplus (Zmult v (Zplus c1 (Zmult c2 k2))) (Zplus l1 (Zmult l2 k2)))
+   P H 
+   (Zplus (Zplus (Zmult v c1) l1) (Zmult (Zplus (Zmult v c2) l2) k2))
+   (OMEGA15 v c1 c2 l1 l2 k2)).
+Definition fast_OMEGA16 :=
+[v,c,l,k :Z][P:Z -> Prop]
+[H : (P (Zplus (Zmult v (Zmult c k)) (Zmult l k)))]
+ (eq_ind_r Z 
+   (Zplus (Zmult v (Zmult c k)) (Zmult l k))
+   P H 
+   (Zmult (Zplus (Zmult v c) l) k)
+   (OMEGA16 v c l k)).
+
+Definition fast_OMEGA13 :=
+[v,l1,l2 :Z][x:positive][P:Z -> Prop]
+[H : (P (Zplus l1 l2))]
+ (eq_ind_r Z 
+   (Zplus l1 l2)
+   P H 
+   (Zplus (Zplus (Zmult v (POS x)) l1) (Zplus (Zmult v (NEG x)) l2))
+   (OMEGA13 v l1 l2 x )).
+
+Definition fast_OMEGA14 :=
+[v,l1,l2 :Z][x:positive][P:Z -> Prop]
+[H : (P (Zplus l1 l2))]
+ (eq_ind_r Z 
+   (Zplus l1 l2)
+   P H 
+   (Zplus (Zplus (Zmult v (NEG x)) l1) (Zplus (Zmult v (POS x)) l2))
+   (OMEGA14 v l1 l2 x )).
+Definition fast_Zred_factor0:=
+[x:Z][P:Z -> Prop]
+[H : (P (Zmult x (POS xH)) )]
+ (eq_ind_r Z 
+   (Zmult x (POS xH))
+   P H 
+   x
+   (Zred_factor0 x)).
+
+Definition fast_Zopp_one :=
+[x:Z][P:Z -> Prop]
+[H : (P (Zmult x (NEG xH)))]
+ (eq_ind_r Z 
+   (Zmult x (NEG xH))
+   P H 
+   (Zopp x)
+   (Zopp_one x)).
+
+Definition fast_Zmult_sym :=
+[x,y :Z][P:Z -> Prop]
+[H : (P (Zmult y x))]
+ (eq_ind_r Z 
+(Zmult y x)
+   P H 
+(Zmult x y)
+   (Zmult_sym x y )).
+
+Definition fast_Zopp_Zplus :=
+[x,y :Z][P:Z -> Prop]
+[H : (P (Zplus (Zopp x) (Zopp y)) )]
+ (eq_ind_r Z 
+   (Zplus (Zopp x) (Zopp y))
+   P H 
+   (Zopp (Zplus x y))
+   (Zopp_Zplus x y )).
+
+Definition fast_Zopp_Zopp :=
+[x:Z][P:Z -> Prop]
+[H : (P x )] (eq_ind_r Z x P H (Zopp (Zopp x)) (Zopp_Zopp x)).
+
+Definition fast_Zopp_Zmult_r :=
+[x,y:Z][P:Z -> Prop]
+[H : (P (Zmult x (Zopp y)))]
+ (eq_ind_r Z 
+   (Zmult x (Zopp y))
+   P H 
+   (Zopp (Zmult x y))
+   (Zopp_Zmult_r x y )).
+
+Definition fast_Zmult_plus_distr :=
+[n,m,p:Z][P:Z -> Prop]
+[H : (P (Zplus (Zmult n p) (Zmult m p)))]
+ (eq_ind_r Z 
+   (Zplus (Zmult n p) (Zmult m p))
+   P H 
+   (Zmult (Zplus n m) p)
+   (Zmult_plus_distr_l n m p)).
+Definition fast_Zmult_Zopp_left:=
+[x,y:Z][P:Z -> Prop]
+[H : (P (Zmult x (Zopp y)))]
+ (eq_ind_r Z 
+   (Zmult x (Zopp y))
+   P H 
+   (Zmult (Zopp x) y)
+   (Zmult_Zopp_left x y)).
+
+Definition fast_Zmult_assoc_r :=
+[n,m,p :Z][P:Z -> Prop]
+[H : (P (Zmult n (Zmult m p)))]
+ (eq_ind_r Z 
+   (Zmult n (Zmult m p))
+   P H 
+   (Zmult (Zmult n m) p)
+   (Zmult_assoc_r n m p)).
+
+Definition fast_Zred_factor1 :=
+[x:Z][P:Z -> Prop]
+[H : (P (Zmult x (POS (xO xH))) )]
+ (eq_ind_r Z 
+   (Zmult x (POS (xO xH)))
+   P H 
+   (Zplus x x)
+   (Zred_factor1 x)).
+
+Definition fast_Zred_factor2 :=
+[x,y:Z][P:Z -> Prop]
+[H : (P (Zmult x (Zplus (POS xH) y)))]
+ (eq_ind_r Z 
+   (Zmult x (Zplus (POS xH) y))
+   P H 
+   (Zplus x (Zmult x y))
+   (Zred_factor2 x y)).
+Definition fast_Zred_factor3 :=
+[x,y:Z][P:Z -> Prop]
+[H : (P (Zmult x (Zplus (POS xH) y)))]
+ (eq_ind_r Z 
+   (Zmult x (Zplus (POS xH) y))
+   P H 
+   (Zplus (Zmult x y) x)
+   (Zred_factor3 x y)).
+
+Definition fast_Zred_factor4 :=
+[x,y,z:Z][P:Z -> Prop]
+[H : (P (Zmult x (Zplus y z)))]
+ (eq_ind_r Z 
+   (Zmult x (Zplus y z))
+   P H 
+   (Zplus (Zmult x y) (Zmult x z))
+   (Zred_factor4 x y z)).
+
+Definition fast_Zred_factor5 :=
+[x,y:Z][P:Z -> Prop]
+[H : (P y)]
+ (eq_ind_r Z 
+   y
+   P H 
+   (Zplus (Zmult x ZERO) y)
+   (Zred_factor5 x y)).
+
+Definition fast_Zred_factor6 :=
+[x :Z][P:Z -> Prop]
+[H : (P(Zplus x ZERO) )]
+ (eq_ind_r Z 
+   (Zplus x ZERO)
+   P H 
+   x
+   (Zred_factor6 x )).
diff --git a/contrib7/ring/.cvsignore b/contrib7/ring/.cvsignore
new file mode 100644
index 0000000000..c446fcb878
--- /dev/null
+++ b/contrib7/ring/.cvsignore
@@ -0,0 +1 @@
+*.v8
diff --git a/contrib7/ring/ArithRing.v b/contrib7/ring/ArithRing.v
new file mode 100644
index 0000000000..0a49ecb476
--- /dev/null
+++ b/contrib7/ring/ArithRing.v
@@ -0,0 +1,81 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Instantiation of the Ring tactic for the naturals of Arith $*)
+
+Require Export Ring.
+Require Export Arith.
+Require Eqdep_dec.
+
+V7only [Import nat_scope.].
+Open Local Scope nat_scope.
+
+Fixpoint nateq [n,m:nat] : bool :=
+  Cases n m of
+  | O O => true
+  | (S n') (S m') => (nateq n' m')
+  | _ _ => false
+  end.
+
+Lemma nateq_prop : (n,m:nat)(Is_true (nateq n m))->n==m.
+Proof.
+  Induction n; Induction m; Intros; Try Contradiction.
+  Trivial.
+  Unfold Is_true in H1.
+  Rewrite (H n1 H1).
+  Trivial.
+Save.
+
+Hints Resolve nateq_prop eq2eqT : arithring.
+
+Definition NatTheory : (Semi_Ring_Theory plus mult (1) (0) nateq).
+  Split; Intros; Auto with arith arithring.
+  Apply eq2eqT; Apply simpl_plus_l with n:=n.
+  Apply eqT2eq; Trivial.
+Defined.
+
+
+Add Semi Ring nat plus mult (1) (0) nateq NatTheory [O S].
+
+Goal (n:nat)(S n)=(plus (S O) n).
+Intro; Reflexivity.
+Save S_to_plus_one.
+
+(* Replace all occurrences of (S exp) by (plus (S O) exp), except when
+   exp is already O and only for those occurrences than can be reached by going
+   down plus and mult operations  *)
+Recursive Meta Definition S_to_plus t :=
+   Match t With 
+   | [(S O)] -> '(S O)
+   | [(S ?1)] -> Let t1 = (S_to_plus ?1) In
+                 '(plus (S O) t1)
+   | [(plus ?1 ?2)] -> Let t1 = (S_to_plus ?1) 
+                     And t2 = (S_to_plus ?2) In
+                     '(plus t1 t2)
+   | [(mult ?1 ?2)] -> Let t1 = (S_to_plus ?1)
+                     And t2 = (S_to_plus ?2) In
+                     '(mult t1 t2)
+   | [?] -> 't.
+
+(* Apply S_to_plus on both sides of an equality *)
+Tactic Definition S_to_plus_eq :=
+   Match Context With
+   | [ |- ?1 = ?2 ] -> 
+      (**) Try (**)
+      Let t1 = (S_to_plus ?1)
+      And t2 = (S_to_plus ?2) In
+        Change t1=t2
+   | [ |- ?1 == ?2 ] ->
+      (**) Try (**)
+      Let t1 = (S_to_plus ?1)
+      And t2 = (S_to_plus ?2) In
+        Change (t1==t2).
+
+Tactic Definition NatRing := S_to_plus_eq;Ring.
diff --git a/contrib7/ring/NArithRing.v b/contrib7/ring/NArithRing.v
new file mode 100644
index 0000000000..65814a1400
--- /dev/null
+++ b/contrib7/ring/NArithRing.v
@@ -0,0 +1,44 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Instantiation of the Ring tactic for the binary natural numbers *)
+
+Require Export Ring.
+Require Export ZArith_base.
+Require NArith.
+Require Eqdep_dec.
+
+Definition Neq := [n,m:entier]
+  Cases (Ncompare n m) of
+    EGAL => true
+  | _ => false
+  end.
+
+Lemma Neq_prop : (n,m:entier)(Is_true (Neq n m)) -> n=m.
+  Intros n m H; Unfold Neq in H.
+  Apply Ncompare_Eq_eq.
+  NewDestruct (Ncompare n m); [Reflexivity | Contradiction | Contradiction ].
+Save.
+
+Definition NTheory : (Semi_Ring_Theory Nplus Nmult (Pos xH) Nul Neq).
+  Split.
+    Apply Nplus_comm.
+    Apply Nplus_assoc.
+    Apply Nmult_comm.
+    Apply Nmult_assoc.
+    Apply Nplus_0_l.
+    Apply Nmult_1_l.
+    Apply Nmult_0_l.
+    Apply Nmult_plus_distr_r.
+    Apply Nplus_reg_l.
+    Apply Neq_prop.
+Save.
+
+Add Semi Ring entier Nplus Nmult (Pos xH) Nul Neq NTheory [Pos Nul xO xI xH].
diff --git a/contrib7/ring/Quote.v b/contrib7/ring/Quote.v
new file mode 100644
index 0000000000..e2bd0c5378
--- /dev/null
+++ b/contrib7/ring/Quote.v
@@ -0,0 +1,85 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(***********************************************************************
+  The "abstract" type index is defined to represent variables.
+
+  index : Set
+  index_eq : index -> bool
+  index_eq_prop: (n,m:index)(index_eq n m)=true -> n=m
+  index_lt : index -> bool
+  varmap : Type -> Type.	
+  varmap_find : (A:Type)A -> index -> (varmap A) -> A.
+
+  The first arg. of varmap_find is the default value to take
+  if the object is not found in the varmap.
+
+  index_lt defines a total well-founded order, but we don't prove that.
+
+***********************************************************************)
+
+Set Implicit Arguments.
+
+Section variables_map.
+
+Variable A : Type.
+
+Inductive varmap : Type :=
+  Empty_vm : varmap
+| Node_vm : A->varmap->varmap->varmap.
+
+Inductive index : Set := 
+| Left_idx : index -> index
+| Right_idx : index -> index
+| End_idx : index
+.
+
+Fixpoint varmap_find [default_value:A; i:index; v:varmap] : A :=
+  Cases i v of
+    End_idx (Node_vm x _ _) => x
+  | (Right_idx i1) (Node_vm x v1 v2) => (varmap_find default_value i1 v2)
+  | (Left_idx i1) (Node_vm x v1 v2) => (varmap_find default_value i1 v1)
+  | _ _ => default_value
+  end.
+
+Fixpoint index_eq [n,m:index] : bool :=
+  Cases n m of
+  | End_idx End_idx => true
+  | (Left_idx n') (Left_idx m') => (index_eq n' m')
+  | (Right_idx n') (Right_idx m') => (index_eq n' m')
+  | _ _ => false
+  end.
+
+Fixpoint index_lt[n,m:index] : bool :=
+  Cases n m of
+  | End_idx (Left_idx _) => true
+  | End_idx (Right_idx _) => true
+  | (Left_idx n') (Right_idx m') => true
+  | (Right_idx n') (Right_idx m') => (index_lt n' m') 
+  | (Left_idx n') (Left_idx m') => (index_lt n' m') 
+  | _ _ => false
+  end.
+
+Lemma index_eq_prop : (n,m:index)(index_eq n m)=true -> n=m.
+  Induction n; Induction m; Simpl; Intros.
+  Rewrite (H i0 H1); Reflexivity.
+  Discriminate.
+  Discriminate.
+  Discriminate.
+  Rewrite (H i0 H1); Reflexivity.
+  Discriminate.
+  Discriminate.
+  Discriminate.
+  Reflexivity.
+Save.
+
+End variables_map.
+
+Unset Implicit Arguments.
diff --git a/contrib7/ring/Ring.v b/contrib7/ring/Ring.v
new file mode 100644
index 0000000000..fa2ba1ca0c
--- /dev/null
+++ b/contrib7/ring/Ring.v
@@ -0,0 +1,34 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+Require Export Bool.
+Require Export Ring_theory.
+Require Export Quote.
+Require Export Ring_normalize.
+Require Export Ring_abstract.
+
+(* As an example, we provide an instantation for bool. *)
+(* Other instatiations are given in ArithRing and ZArithRing in the
+   same directory *)
+
+Definition BoolTheory : (Ring_Theory xorb andb true false [b:bool]b eqb).
+Split; Simpl.
+NewDestruct n; NewDestruct m; Reflexivity.
+NewDestruct n; NewDestruct m; NewDestruct p; Reflexivity.
+NewDestruct n; NewDestruct m; Reflexivity.
+NewDestruct n; NewDestruct m; NewDestruct p; Reflexivity.
+NewDestruct n; Reflexivity.
+NewDestruct n; Reflexivity.
+NewDestruct n; Reflexivity.
+NewDestruct n; NewDestruct m; NewDestruct p; Reflexivity.
+NewDestruct x; NewDestruct y; Reflexivity Orelse Simpl; Tauto.
+Defined.
+
+Add Ring bool xorb andb true false [b:bool]b eqb BoolTheory [ true false ].
diff --git a/contrib7/ring/Ring_abstract.v b/contrib7/ring/Ring_abstract.v
new file mode 100644
index 0000000000..98b4cb858d
--- /dev/null
+++ b/contrib7/ring/Ring_abstract.v
@@ -0,0 +1,699 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+Require Ring_theory.
+Require Quote.
+Require Ring_normalize.
+
+Section abstract_semi_rings.
+
+Inductive Type aspolynomial :=
+  ASPvar : index -> aspolynomial
+| ASP0 : aspolynomial
+| ASP1 : aspolynomial
+| ASPplus : aspolynomial -> aspolynomial -> aspolynomial
+| ASPmult : aspolynomial -> aspolynomial -> aspolynomial
+.
+
+Inductive abstract_sum : Type := 
+| Nil_acs : abstract_sum
+| Cons_acs : varlist -> abstract_sum -> abstract_sum
+.
+
+Fixpoint abstract_sum_merge [s1:abstract_sum] 
+      	 : abstract_sum -> abstract_sum :=
+Cases s1 of
+| (Cons_acs l1 t1) =>      
+     Fix asm_aux{asm_aux[s2:abstract_sum] : abstract_sum :=
+           Cases s2 of
+      	   | (Cons_acs l2 t2) =>
+	       if (varlist_lt l1 l2)
+	       then (Cons_acs l1 (abstract_sum_merge t1 s2))
+	       else (Cons_acs l2 (asm_aux t2))
+	   | Nil_acs => s1
+	   end}
+| Nil_acs => [s2]s2
+end.
+
+Fixpoint abstract_varlist_insert [l1:varlist; s2:abstract_sum] 
+      : abstract_sum :=
+  Cases s2 of
+  | (Cons_acs l2 t2) =>
+       if (varlist_lt l1 l2)
+       then (Cons_acs l1 s2)
+       else (Cons_acs l2 (abstract_varlist_insert l1 t2))
+  | Nil_acs => (Cons_acs l1 Nil_acs)
+  end.
+
+Fixpoint abstract_sum_scalar [l1:varlist; s2:abstract_sum] 
+      : abstract_sum :=
+  Cases s2 of
+  | (Cons_acs l2 t2) => (abstract_varlist_insert (varlist_merge l1 l2) 
+                                (abstract_sum_scalar l1 t2))
+  | Nil_acs => Nil_acs
+  end.
+
+Fixpoint abstract_sum_prod [s1:abstract_sum] 
+      	 : abstract_sum -> abstract_sum := 
+    [s2]Cases s1 of
+    | (Cons_acs l1 t1) =>
+	(abstract_sum_merge (abstract_sum_scalar l1 s2) 
+			     (abstract_sum_prod t1 s2))
+    | Nil_acs => Nil_acs
+    end.
+
+Fixpoint aspolynomial_normalize[p:aspolynomial] : abstract_sum :=
+  Cases p of
+  | (ASPvar i) => (Cons_acs (Cons_var i Nil_var) Nil_acs)
+  | ASP1 => (Cons_acs Nil_var Nil_acs)
+  | ASP0 => Nil_acs
+  | (ASPplus l r) => (abstract_sum_merge (aspolynomial_normalize l) 
+      	       	       	       	       	 (aspolynomial_normalize r))
+  | (ASPmult l r) => (abstract_sum_prod (aspolynomial_normalize l) 
+      	       	       	       	        (aspolynomial_normalize r))
+  end.
+
+
+
+Variable A : Type.
+Variable Aplus : A -> A -> A.
+Variable Amult : A -> A -> A.
+Variable Aone : A.
+Variable Azero : A.
+Variable Aeq : A -> A -> bool.
+Variable vm : (varmap A).
+Variable T : (Semi_Ring_Theory Aplus Amult Aone Azero Aeq).
+
+Fixpoint interp_asp [p:aspolynomial] : A :=
+  Cases p of
+  | (ASPvar i) => (interp_var Azero vm i)
+  | ASP0 => Azero
+  | ASP1 => Aone
+  | (ASPplus l r) => (Aplus (interp_asp l) (interp_asp r))
+  | (ASPmult l r) => (Amult (interp_asp l) (interp_asp r))
+  end.
+
+(* Local *) Definition iacs_aux := Fix iacs_aux{iacs_aux [a:A; s:abstract_sum] : A :=  
+  Cases s of
+  | Nil_acs => a
+  | (Cons_acs l t) => (Aplus a (iacs_aux (interp_vl Amult Aone Azero vm l) t))
+  end}.
+
+Definition interp_acs [s:abstract_sum] : A :=
+  Cases s of
+  | (Cons_acs l t) => (iacs_aux (interp_vl Amult Aone Azero vm l) t)
+  | Nil_acs => Azero
+  end.
+
+Hint SR_plus_sym_T := Resolve (SR_plus_sym T).
+Hint SR_plus_assoc_T := Resolve (SR_plus_assoc T).
+Hint SR_plus_assoc2_T := Resolve (SR_plus_assoc2 T).
+Hint SR_mult_sym_T := Resolve (SR_mult_sym T).
+Hint SR_mult_assoc_T := Resolve (SR_mult_assoc T).
+Hint SR_mult_assoc2_T := Resolve (SR_mult_assoc2 T).
+Hint SR_plus_zero_left_T := Resolve (SR_plus_zero_left T).
+Hint SR_plus_zero_left2_T := Resolve (SR_plus_zero_left2 T).
+Hint SR_mult_one_left_T := Resolve (SR_mult_one_left T).
+Hint SR_mult_one_left2_T := Resolve (SR_mult_one_left2 T).
+Hint SR_mult_zero_left_T := Resolve (SR_mult_zero_left T).
+Hint SR_mult_zero_left2_T := Resolve (SR_mult_zero_left2 T).
+Hint SR_distr_left_T := Resolve (SR_distr_left T).
+Hint SR_distr_left2_T := Resolve (SR_distr_left2 T).
+Hint SR_plus_reg_left_T := Resolve (SR_plus_reg_left T).
+Hint SR_plus_permute_T := Resolve (SR_plus_permute T).
+Hint SR_mult_permute_T := Resolve (SR_mult_permute T).
+Hint SR_distr_right_T := Resolve (SR_distr_right T).
+Hint SR_distr_right2_T := Resolve (SR_distr_right2 T).
+Hint SR_mult_zero_right_T := Resolve (SR_mult_zero_right T).
+Hint SR_mult_zero_right2_T := Resolve (SR_mult_zero_right2 T).
+Hint SR_plus_zero_right_T := Resolve (SR_plus_zero_right T).
+Hint SR_plus_zero_right2_T := Resolve (SR_plus_zero_right2 T).
+Hint SR_mult_one_right_T := Resolve (SR_mult_one_right T).
+Hint SR_mult_one_right2_T := Resolve (SR_mult_one_right2 T).
+Hint SR_plus_reg_right_T := Resolve (SR_plus_reg_right T).
+Hints Resolve refl_equal sym_equal trans_equal.
+(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
+Hints Immediate T.
+
+Remark iacs_aux_ok : (x:A)(s:abstract_sum)
+  (iacs_aux x s)==(Aplus x (interp_acs s)).
+Proof.
+  Induction s; Simpl; Intros.
+  Trivial.
+  Reflexivity.
+Save.
+
+Hint rew_iacs_aux : core := Extern 10 (eqT A ? ?) Rewrite iacs_aux_ok.
+
+Lemma abstract_varlist_insert_ok : (l:varlist)(s:abstract_sum)
+  (interp_acs (abstract_varlist_insert l s)) 
+   ==(Aplus (interp_vl Amult Aone Azero vm l) (interp_acs s)).
+
+  Induction s.
+  Trivial.
+
+  Simpl; Intros.
+  Elim (varlist_lt l v); Simpl.  	
+  EAuto.
+  Rewrite iacs_aux_ok.
+  Rewrite H; Auto.
+
+Save.
+
+Lemma abstract_sum_merge_ok : (x,y:abstract_sum)
+  (interp_acs (abstract_sum_merge x y))
+  ==(Aplus (interp_acs x) (interp_acs y)).
+
+Proof.  
+  Induction x.
+  Trivial.
+  Induction y; Intros.
+
+  Auto.
+
+  Simpl; Elim (varlist_lt v v0); Simpl.
+  Repeat Rewrite iacs_aux_ok.
+  Rewrite H;  Simpl; Auto.
+
+  Simpl in H0.
+  Repeat Rewrite iacs_aux_ok.
+  Rewrite H0. Simpl; Auto.
+Save.
+
+Lemma abstract_sum_scalar_ok : (l:varlist)(s:abstract_sum)
+  (interp_acs (abstract_sum_scalar l s)) 
+   == (Amult (interp_vl Amult Aone Azero vm l) (interp_acs s)).
+Proof.
+  Induction s.
+  Simpl; EAuto.
+
+  Simpl; Intros.
+  Rewrite iacs_aux_ok.
+  Rewrite abstract_varlist_insert_ok.
+  Rewrite H.
+  Rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
+  Auto.
+Save.
+
+Lemma abstract_sum_prod_ok : (x,y:abstract_sum)
+  (interp_acs (abstract_sum_prod x y)) 
+   == (Amult (interp_acs x) (interp_acs y)).
+
+Proof.
+  Induction x.
+  Intros; Simpl; EAuto.
+
+  NewDestruct y; Intros.
+
+  Simpl; Rewrite H; EAuto.
+
+  Unfold abstract_sum_prod; Fold abstract_sum_prod.
+  Rewrite abstract_sum_merge_ok.
+  Rewrite abstract_sum_scalar_ok.
+  Rewrite H; Simpl; Auto.
+Save.
+
+Theorem aspolynomial_normalize_ok : (x:aspolynomial)
+	(interp_asp x)==(interp_acs (aspolynomial_normalize x)).
+Proof.
+  Induction x; Simpl; Intros; Trivial.
+  Rewrite abstract_sum_merge_ok.
+  Rewrite H; Rewrite H0; EAuto.
+  Rewrite abstract_sum_prod_ok.
+  Rewrite H; Rewrite H0; EAuto.
+Save.
+
+End abstract_semi_rings.
+
+Section abstract_rings.
+
+(* In abstract polynomials there is no constants other
+   than 0 and 1. An abstract ring is a ring whose operations plus, 
+   and mult are not functions but  constructors. In other words,
+   when c1 and c2 are closed,  (plus c1 c2) doesn't reduce to a closed
+   term. "closed" mean here "without plus and mult". *)
+
+(* this section is not parametrized by a (semi-)ring.
+   Nevertheless, they are two different types for semi-rings and rings 
+   and there will be 2 correction theorems *)
+
+Inductive Type apolynomial :=
+  APvar : index -> apolynomial
+| AP0 : apolynomial
+| AP1 : apolynomial
+| APplus : apolynomial -> apolynomial -> apolynomial
+| APmult : apolynomial -> apolynomial -> apolynomial
+| APopp : apolynomial -> apolynomial
+.
+
+(* A canonical "abstract" sum is a list of varlist with the sign "+" or "-".
+   Invariant : the list is sorted and there is no varlist is present
+   with both signs. +x +x +x -x is forbidden => the canonical form is +x+x *)
+
+Inductive signed_sum : Type := 
+| Nil_varlist : signed_sum
+| Plus_varlist : varlist -> signed_sum -> signed_sum
+| Minus_varlist : varlist -> signed_sum -> signed_sum
+.
+
+Fixpoint signed_sum_merge [s1:signed_sum] 
+      	 : signed_sum -> signed_sum :=
+Cases s1 of
+| (Plus_varlist l1 t1) =>      
+     Fix ssm_aux{ssm_aux[s2:signed_sum] : signed_sum :=
+           Cases s2 of
+      	   | (Plus_varlist l2 t2) =>
+	       if (varlist_lt l1 l2)
+	       then (Plus_varlist l1 (signed_sum_merge t1 s2))
+	       else (Plus_varlist l2 (ssm_aux t2))
+      	   | (Minus_varlist l2 t2) =>
+      	       if (varlist_eq l1 l2)
+	       then (signed_sum_merge t1 t2)
+	       else if (varlist_lt l1 l2)
+	       then (Plus_varlist l1 (signed_sum_merge t1 s2))
+	       else (Minus_varlist l2 (ssm_aux t2))
+	   | Nil_varlist => s1
+	   end}
+| (Minus_varlist l1 t1) =>
+     Fix ssm_aux2{ssm_aux2[s2:signed_sum] : signed_sum :=
+           Cases s2 of
+      	   | (Plus_varlist l2 t2) =>
+      	       if (varlist_eq l1 l2)
+	       then (signed_sum_merge t1 t2)
+	       else if (varlist_lt l1 l2)
+	       then (Minus_varlist l1 (signed_sum_merge t1 s2))
+	       else (Plus_varlist l2 (ssm_aux2 t2))
+      	   | (Minus_varlist l2 t2) =>
+	       if (varlist_lt l1 l2)
+	       then (Minus_varlist l1 (signed_sum_merge t1 s2))
+	       else (Minus_varlist l2 (ssm_aux2 t2))
+	   | Nil_varlist => s1
+	   end}
+| Nil_varlist => [s2]s2
+end.
+
+Fixpoint plus_varlist_insert [l1:varlist; s2:signed_sum] 
+      : signed_sum :=
+  Cases s2 of
+  | (Plus_varlist l2 t2) =>
+       if (varlist_lt l1 l2)
+       then (Plus_varlist l1 s2)
+       else (Plus_varlist l2 (plus_varlist_insert l1 t2))
+  | (Minus_varlist l2 t2) =>
+       if (varlist_eq l1 l2)
+       then t2
+       else if (varlist_lt l1 l2)
+       then (Plus_varlist l1 s2)
+       else (Minus_varlist l2 (plus_varlist_insert l1 t2))
+  | Nil_varlist => (Plus_varlist l1 Nil_varlist)
+  end.
+
+Fixpoint minus_varlist_insert [l1:varlist; s2:signed_sum] 
+      : signed_sum :=
+  Cases s2 of
+  | (Plus_varlist l2 t2) =>
+       if (varlist_eq l1 l2)
+       then t2
+       else if (varlist_lt l1 l2)
+       then (Minus_varlist l1 s2)
+       else (Plus_varlist l2 (minus_varlist_insert l1 t2))
+  | (Minus_varlist l2 t2) =>
+       if (varlist_lt l1 l2)
+       then (Minus_varlist l1 s2)
+       else (Minus_varlist l2 (minus_varlist_insert l1 t2))
+  | Nil_varlist => (Minus_varlist l1 Nil_varlist)
+  end.
+
+Fixpoint signed_sum_opp [s:signed_sum] : signed_sum :=
+  Cases s of
+  | (Plus_varlist l2 t2) => (Minus_varlist l2 (signed_sum_opp t2))
+  | (Minus_varlist l2 t2) => (Plus_varlist l2 (signed_sum_opp t2))
+  | Nil_varlist => Nil_varlist
+  end.
+
+
+Fixpoint plus_sum_scalar [l1:varlist; s2:signed_sum] 
+      : signed_sum :=
+  Cases s2 of
+  | (Plus_varlist l2 t2) => (plus_varlist_insert (varlist_merge l1 l2) 
+                                (plus_sum_scalar l1 t2))
+  | (Minus_varlist l2 t2) => (minus_varlist_insert (varlist_merge l1 l2) 
+                                (plus_sum_scalar l1 t2))
+  | Nil_varlist => Nil_varlist
+  end.
+
+Fixpoint minus_sum_scalar [l1:varlist; s2:signed_sum] 
+      : signed_sum :=
+  Cases s2 of
+  | (Plus_varlist l2 t2) => (minus_varlist_insert (varlist_merge l1 l2) 
+                                (minus_sum_scalar l1 t2))
+  | (Minus_varlist l2 t2) => (plus_varlist_insert (varlist_merge l1 l2) 
+                                (minus_sum_scalar l1 t2))
+  | Nil_varlist => Nil_varlist
+  end.
+
+Fixpoint signed_sum_prod [s1:signed_sum] 
+      	 : signed_sum -> signed_sum := 
+    [s2]Cases s1 of
+    | (Plus_varlist l1 t1) =>
+	(signed_sum_merge (plus_sum_scalar l1 s2) 
+			     (signed_sum_prod t1 s2))
+    | (Minus_varlist l1 t1) =>
+	(signed_sum_merge (minus_sum_scalar l1 s2) 
+			     (signed_sum_prod t1 s2))
+    | Nil_varlist => Nil_varlist
+    end.
+
+Fixpoint apolynomial_normalize[p:apolynomial] : signed_sum :=
+  Cases p of
+  | (APvar i) => (Plus_varlist (Cons_var i Nil_var) Nil_varlist)
+  | AP1 => (Plus_varlist Nil_var Nil_varlist)
+  | AP0 => Nil_varlist
+  | (APplus l r) => (signed_sum_merge (apolynomial_normalize l) 
+      	       	       	       	       	 (apolynomial_normalize r))
+  | (APmult l r) => (signed_sum_prod (apolynomial_normalize l) 
+      	       	       	       	        (apolynomial_normalize r))
+  | (APopp q) => (signed_sum_opp (apolynomial_normalize q))
+  end.
+
+
+Variable A : Type.
+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 vm : (varmap A).
+Variable T : (Ring_Theory Aplus Amult Aone Azero Aopp Aeq).
+
+(* Local *) Definition isacs_aux := Fix isacs_aux{isacs_aux [a:A; s:signed_sum] : A :=  
+  Cases s of
+  | Nil_varlist => a
+  | (Plus_varlist l t) => 
+	(Aplus a (isacs_aux (interp_vl Amult Aone Azero vm l) t))
+  | (Minus_varlist l t) => 
+	(Aplus a (isacs_aux (Aopp (interp_vl Amult Aone Azero vm l)) t))
+  end}.
+
+Definition interp_sacs [s:signed_sum] : A :=
+  Cases s of
+  | (Plus_varlist l t) => (isacs_aux (interp_vl Amult Aone Azero vm l) t)
+  | (Minus_varlist l t) => 
+	(isacs_aux (Aopp (interp_vl Amult Aone Azero vm l)) t)
+  | Nil_varlist => Azero
+  end.
+
+Fixpoint interp_ap [p:apolynomial] : A :=
+  Cases p of
+  | (APvar i) => (interp_var Azero vm i)
+  | AP0 => Azero
+  | AP1 => Aone
+  | (APplus l r) => (Aplus (interp_ap l) (interp_ap r))
+  | (APmult l r) => (Amult (interp_ap l) (interp_ap r))
+  | (APopp q) => (Aopp (interp_ap q))
+  end.
+
+Hint Th_plus_sym_T := Resolve (Th_plus_sym T).
+Hint Th_plus_assoc_T := Resolve (Th_plus_assoc T).
+Hint Th_plus_assoc2_T := Resolve (Th_plus_assoc2 T).
+Hint Th_mult_sym_T := Resolve (Th_mult_sym T).
+Hint Th_mult_assoc_T := Resolve (Th_mult_assoc T).
+Hint Th_mult_assoc2_T := Resolve (Th_mult_assoc2 T).
+Hint Th_plus_zero_left_T := Resolve (Th_plus_zero_left T).
+Hint Th_plus_zero_left2_T := Resolve (Th_plus_zero_left2 T).
+Hint Th_mult_one_left_T := Resolve (Th_mult_one_left T).
+Hint Th_mult_one_left2_T := Resolve (Th_mult_one_left2 T).
+Hint Th_mult_zero_left_T := Resolve (Th_mult_zero_left T).
+Hint Th_mult_zero_left2_T := Resolve (Th_mult_zero_left2 T).
+Hint Th_distr_left_T := Resolve (Th_distr_left T).
+Hint Th_distr_left2_T := Resolve (Th_distr_left2 T).
+Hint Th_plus_reg_left_T := Resolve (Th_plus_reg_left T).
+Hint Th_plus_permute_T := Resolve (Th_plus_permute T).
+Hint Th_mult_permute_T := Resolve (Th_mult_permute T).
+Hint Th_distr_right_T := Resolve (Th_distr_right T).
+Hint Th_distr_right2_T := Resolve (Th_distr_right2 T).
+Hint Th_mult_zero_right2_T := Resolve (Th_mult_zero_right2 T).
+Hint Th_plus_zero_right_T := Resolve (Th_plus_zero_right T).
+Hint Th_plus_zero_right2_T := Resolve (Th_plus_zero_right2 T).
+Hint Th_mult_one_right_T := Resolve (Th_mult_one_right T).
+Hint Th_mult_one_right2_T := Resolve (Th_mult_one_right2 T).
+Hint Th_plus_reg_right_T := Resolve (Th_plus_reg_right T).
+Hints Resolve refl_equal sym_equal trans_equal.
+(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
+Hints Immediate T.
+
+Lemma isacs_aux_ok : (x:A)(s:signed_sum)
+  (isacs_aux x s)==(Aplus x (interp_sacs s)).
+Proof.
+  Induction s; Simpl; Intros.
+  Trivial.
+  Reflexivity.
+  Reflexivity.
+Save.
+
+Hint rew_isacs_aux : core := Extern 10 (eqT A ? ?) Rewrite isacs_aux_ok.
+
+Tactic Definition Solve1 v v0 H H0 := 
+  Simpl; Elim (varlist_lt v v0); Simpl; Rewrite isacs_aux_ok;
+    [Rewrite H; Simpl; Auto
+    |Simpl in H0; Rewrite H0; Auto ].
+
+Lemma signed_sum_merge_ok : (x,y:signed_sum)
+  (interp_sacs (signed_sum_merge x y))
+  ==(Aplus (interp_sacs x) (interp_sacs y)).
+
+  Induction x.
+  Intro; Simpl; Auto.
+
+  Induction y; Intros.
+
+  Auto.
+
+  Solve1 v v0 H H0.
+
+  Simpl; Generalize (varlist_eq_prop v v0).
+  Elim (varlist_eq v v0); Simpl.
+
+  Intro Heq; Rewrite (Heq I).
+  Rewrite H.
+  Repeat Rewrite isacs_aux_ok.
+  Rewrite (Th_plus_permute T). 
+  Repeat Rewrite (Th_plus_assoc T).
+  Rewrite (Th_plus_sym T (Aopp (interp_vl Amult Aone Azero vm v0))
+                         (interp_vl Amult Aone Azero vm v0)).
+  Rewrite (Th_opp_def T).
+  Rewrite (Th_plus_zero_left T).
+  Reflexivity.
+
+  Solve1 v v0 H H0.
+
+  Induction y; Intros.
+
+  Auto.
+
+  Simpl; Generalize (varlist_eq_prop v v0).
+  Elim (varlist_eq v v0); Simpl.
+
+  Intro Heq; Rewrite (Heq I).
+  Rewrite H.
+  Repeat Rewrite isacs_aux_ok.
+  Rewrite (Th_plus_permute T). 
+  Repeat Rewrite (Th_plus_assoc T).
+  Rewrite (Th_opp_def T).
+  Rewrite (Th_plus_zero_left T).
+  Reflexivity.
+
+  Solve1 v v0 H H0.
+
+  Solve1 v v0 H H0.
+
+Save.
+
+Tactic Definition Solve2 l v H :=
+ 	Elim (varlist_lt l v); Simpl; Rewrite isacs_aux_ok;
+  	[ Auto
+  	| Rewrite H; Auto ].
+
+Lemma plus_varlist_insert_ok : (l:varlist)(s:signed_sum)
+	(interp_sacs (plus_varlist_insert l s)) 
+	== (Aplus (interp_vl  Amult Aone Azero vm l) (interp_sacs s)).
+Proof.
+
+  Induction s.
+  Trivial.
+
+  Simpl; Intros.
+  Solve2 l v H.
+
+  Simpl; Intros.
+  Generalize (varlist_eq_prop l v).
+  Elim (varlist_eq l v); Simpl.
+
+  Intro Heq; Rewrite (Heq I).
+  Repeat Rewrite isacs_aux_ok.
+  Repeat Rewrite (Th_plus_assoc T).
+  Rewrite (Th_opp_def T).
+  Rewrite (Th_plus_zero_left T).
+  Reflexivity.
+
+  Solve2 l v H.
+
+Save.
+
+Lemma minus_varlist_insert_ok : (l:varlist)(s:signed_sum)
+	(interp_sacs (minus_varlist_insert l s)) 
+	== (Aplus (Aopp (interp_vl  Amult Aone Azero vm l)) (interp_sacs s)).
+Proof.
+
+  Induction s.
+  Trivial.
+
+  Simpl; Intros.
+  Generalize (varlist_eq_prop l v).
+  Elim (varlist_eq l v); Simpl.
+
+  Intro Heq; Rewrite (Heq I).
+  Repeat Rewrite isacs_aux_ok.
+  Repeat Rewrite (Th_plus_assoc T).
+  Rewrite (Th_plus_sym T (Aopp (interp_vl Amult Aone Azero vm v))
+         (interp_vl Amult Aone Azero vm v)).
+  Rewrite (Th_opp_def T).
+  Auto.
+
+  Simpl; Intros.
+  Solve2 l v H.
+
+  Simpl; Intros; Solve2 l v H.
+
+Save.
+
+Lemma signed_sum_opp_ok : (s:signed_sum)
+	(interp_sacs (signed_sum_opp s)) 
+	== (Aopp (interp_sacs s)).
+Proof.
+
+  Induction s; Simpl; Intros.
+
+  Symmetry; Apply (Th_opp_zero T).
+
+  Repeat Rewrite isacs_aux_ok.
+  Rewrite H.
+  Rewrite (Th_plus_opp_opp T).
+  Reflexivity.
+
+  Repeat Rewrite isacs_aux_ok.
+  Rewrite H.
+  Rewrite <- (Th_plus_opp_opp T).
+  Rewrite (Th_opp_opp T).
+  Reflexivity.
+
+Save.
+
+Lemma plus_sum_scalar_ok : (l:varlist)(s:signed_sum)
+	(interp_sacs (plus_sum_scalar l s)) 
+	== (Amult (interp_vl  Amult Aone Azero vm l) (interp_sacs s)).
+Proof.
+
+  Induction s.
+  Trivial.
+
+  Simpl; Intros.
+  Rewrite plus_varlist_insert_ok.
+  Rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
+  Repeat Rewrite isacs_aux_ok.
+  Rewrite H.
+  Auto.
+
+  Simpl; Intros.
+  Rewrite minus_varlist_insert_ok.
+  Repeat Rewrite isacs_aux_ok.
+  Rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
+  Rewrite H.
+  Rewrite (Th_distr_right T).
+  Rewrite <- (Th_opp_mult_right T).
+  Reflexivity.
+
+Save.
+
+Lemma minus_sum_scalar_ok : (l:varlist)(s:signed_sum)
+	(interp_sacs (minus_sum_scalar l s)) 
+	== (Aopp (Amult (interp_vl  Amult Aone Azero vm l) (interp_sacs s))).
+Proof.
+
+  Induction s; Simpl; Intros.
+
+  Rewrite (Th_mult_zero_right T); Symmetry; Apply (Th_opp_zero T).
+
+  Simpl; Intros.
+  Rewrite minus_varlist_insert_ok.
+  Rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
+  Repeat Rewrite isacs_aux_ok.
+  Rewrite H.
+  Rewrite (Th_distr_right T).
+  Rewrite (Th_plus_opp_opp T).
+  Reflexivity.
+
+  Simpl; Intros.
+  Rewrite plus_varlist_insert_ok.
+  Repeat Rewrite isacs_aux_ok.
+  Rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
+  Rewrite H.
+  Rewrite (Th_distr_right T).
+  Rewrite <- (Th_opp_mult_right T).
+  Rewrite <- (Th_plus_opp_opp T).
+  Rewrite (Th_opp_opp T).
+  Reflexivity.
+
+Save.
+
+Lemma signed_sum_prod_ok : (x,y:signed_sum)
+	(interp_sacs (signed_sum_prod x y)) ==
+		(Amult (interp_sacs x) (interp_sacs y)).
+Proof.
+
+  Induction x.
+
+  Simpl; EAuto 1.
+
+  Intros; Simpl.
+  Rewrite signed_sum_merge_ok.
+  Rewrite plus_sum_scalar_ok.
+  Repeat Rewrite isacs_aux_ok.
+  Rewrite H.
+  Auto.
+
+  Intros; Simpl.
+  Repeat Rewrite isacs_aux_ok.
+  Rewrite signed_sum_merge_ok.
+  Rewrite minus_sum_scalar_ok.
+  Rewrite H.
+  Rewrite (Th_distr_left T).
+  Rewrite (Th_opp_mult_left T).
+  Reflexivity.
+
+Save.
+
+Theorem apolynomial_normalize_ok : (p:apolynomial)
+	(interp_sacs (apolynomial_normalize p))==(interp_ap p).
+Proof.
+  Induction p; Simpl; Auto 1.
+  Intros.
+    Rewrite signed_sum_merge_ok.
+    Rewrite H; Rewrite H0; Reflexivity.
+  Intros.
+    Rewrite signed_sum_prod_ok.
+    Rewrite H; Rewrite H0; Reflexivity.
+  Intros.
+    Rewrite signed_sum_opp_ok.
+    Rewrite H; Reflexivity.
+Save.  
+
+End abstract_rings.
diff --git a/contrib7/ring/Ring_normalize.v b/contrib7/ring/Ring_normalize.v
new file mode 100644
index 0000000000..94ad71ffc8
--- /dev/null
+++ b/contrib7/ring/Ring_normalize.v
@@ -0,0 +1,893 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+Require Ring_theory.
+Require Quote.
+
+Set Implicit Arguments.
+
+Lemma index_eq_prop: (n,m:index)(Is_true (index_eq n m)) -> n=m.
+Proof.
+  Intros.
+  Apply Quote.index_eq_prop.
+  Generalize H.
+  Case (index_eq n m); Simpl; Trivial; Intros.
+  Contradiction.
+Save.
+
+Section semi_rings.
+
+Variable A : Type.
+Variable Aplus : A -> A -> A.
+Variable Amult : A -> A -> A.
+Variable Aone : A.
+Variable Azero : A.
+Variable Aeq : A -> A -> bool.
+
+(* 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] : bool :=
+  Cases x y of
+  | 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] : bool :=
+  Cases x y of 
+  | 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 :=
+  Cases l1 of	
+  | (Cons_var v1 t1) => 
+      Fix vm_aux {vm_aux [l2:varlist] : varlist :=
+	Cases l2 of
+	| (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 => [l2]l2
+  end.
+
+(* returns the sum of two canonical sums  *)
+Fixpoint canonical_sum_merge [s1:canonical_sum] 
+      	 : canonical_sum -> canonical_sum :=
+Cases s1 of
+| (Cons_monom c1 l1 t1) =>      
+     Fix csm_aux{csm_aux[s2:canonical_sum] : canonical_sum :=
+           Cases s2 of
+      	   | (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{csm_aux2[s2:canonical_sum] : canonical_sum :=
+           Cases s2 of
+      	   | (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 => [s2]s2
+end.
+
+(* Insertion of a monom in a canonical sum *)
+Fixpoint monom_insert [c1:A; l1:varlist; s2 : canonical_sum] 
+      : canonical_sum := 
+  Cases s2 of
+  | (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] 
+      : canonical_sum :=
+  Cases s2 of
+  | (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] : canonical_sum :=
+    Cases s of
+    | (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] 
+      	       	       	      : canonical_sum :=
+    Cases s of
+    | (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] 
+      	       	       	      : canonical_sum :=
+    Cases s of
+    | (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:canonical_sum] 
+      	 : canonical_sum -> canonical_sum := 
+    [s2]Cases s1 of
+    | (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-ring polynomials *)
+Inductive Type spolynomial :=
+  SPvar : index -> spolynomial
+| SPconst : A -> spolynomial
+| SPplus : spolynomial -> spolynomial -> spolynomial
+| SPmult : spolynomial -> spolynomial -> spolynomial.
+
+Fixpoint spolynomial_normalize[p:spolynomial] : canonical_sum :=
+  Cases p of
+  | (SPvar i) => (Cons_varlist (Cons_var i Nil_var) Nil_monom)
+  | (SPconst c) => (Cons_monom c Nil_var Nil_monom)
+  | (SPplus l r) => (canonical_sum_merge (spolynomial_normalize l) 
+      	       	       	       	       	 (spolynomial_normalize r))
+  | (SPmult l r) => (canonical_sum_prod (spolynomial_normalize l) 
+      	       	       	       	        (spolynomial_normalize r))
+  end.
+
+(* Deletion of useless 0 and 1 in canonical sums *)
+Fixpoint canonical_sum_simplify [ s:canonical_sum] : canonical_sum :=
+  Cases s of
+  | (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 spolynomial_simplify :=
+  [x:spolynomial](canonical_sum_simplify (spolynomial_normalize x)).
+
+(* End definitions. *)
+
+(* Section interpretation. *)
+
+(*** Here a variable map is defined and the interpetation of a spolynom
+  acording to a certain variables map. Once again the choosen definition
+  is generic and could be changed ****)
+
+Variable vm : (varmap A).
+
+(* Interpretation of list of variables 
+ * [x1; ... ; xn ] is interpreted as (find v x1)* ... *(find v xn)
+ * The unbound variables are mapped to 0. Normally this case sould
+ * never occur. Since we want only to prove correctness theorems, which form
+ * is : for any varmap and any spolynom ... this is a safe and pain-saving
+ * choice *)
+Definition interp_var [i:index] := (varmap_find Azero i vm).
+
+(* Local *) Definition ivl_aux := Fix ivl_aux {ivl_aux[x:index; t:varlist] : A := 
+  Cases t of
+  | Nil_var => (interp_var x)
+  | (Cons_var x' t') => (Amult (interp_var x) (ivl_aux x' t'))
+  end}.
+
+Definition interp_vl :=  [l:varlist] 
+  Cases l of
+  | Nil_var => Aone
+  | (Cons_var x t) => (ivl_aux x t)
+  end.
+
+(* Local *) Definition interp_m := [c:A][l:varlist] 
+  Cases l of
+  | Nil_var => c
+  | (Cons_var x t) => 
+      (Amult c (ivl_aux x t))
+  end.
+
+(* Local *) Definition ics_aux := Fix ics_aux{ics_aux[a:A; s:canonical_sum] : A :=  
+  Cases s of
+  | 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}.
+
+(* Interpretation of a canonical sum *)
+Definition interp_cs : canonical_sum -> A  := 
+  [s]Cases s of 
+  | 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_sp [p:spolynomial] : A :=
+  Cases p of
+    (SPconst c) => c
+  | (SPvar i) => (interp_var i)
+  | (SPplus p1 p2) => (Aplus (interp_sp p1) (interp_sp p2))
+  | (SPmult p1 p2) => (Amult (interp_sp p1) (interp_sp p2))
+  end.
+
+
+(* End interpretation. *)
+
+Unset Implicit Arguments.
+
+(* Section properties. *)
+
+Variable T : (Semi_Ring_Theory Aplus Amult Aone Azero Aeq).
+
+Hint SR_plus_sym_T := Resolve (SR_plus_sym T).
+Hint SR_plus_assoc_T := Resolve (SR_plus_assoc T).
+Hint SR_plus_assoc2_T := Resolve (SR_plus_assoc2 T).
+Hint SR_mult_sym_T := Resolve (SR_mult_sym T).
+Hint SR_mult_assoc_T := Resolve (SR_mult_assoc T).
+Hint SR_mult_assoc2_T := Resolve (SR_mult_assoc2 T).
+Hint SR_plus_zero_left_T := Resolve (SR_plus_zero_left T).
+Hint SR_plus_zero_left2_T := Resolve (SR_plus_zero_left2 T).
+Hint SR_mult_one_left_T := Resolve (SR_mult_one_left T).
+Hint SR_mult_one_left2_T := Resolve (SR_mult_one_left2 T).
+Hint SR_mult_zero_left_T := Resolve (SR_mult_zero_left T).
+Hint SR_mult_zero_left2_T := Resolve (SR_mult_zero_left2 T).
+Hint SR_distr_left_T := Resolve (SR_distr_left T).
+Hint SR_distr_left2_T := Resolve (SR_distr_left2 T).
+Hint SR_plus_reg_left_T := Resolve (SR_plus_reg_left T).
+Hint SR_plus_permute_T := Resolve (SR_plus_permute T).
+Hint SR_mult_permute_T := Resolve (SR_mult_permute T).
+Hint SR_distr_right_T := Resolve (SR_distr_right T).
+Hint SR_distr_right2_T := Resolve (SR_distr_right2 T).
+Hint SR_mult_zero_right_T := Resolve (SR_mult_zero_right T).
+Hint SR_mult_zero_right2_T := Resolve (SR_mult_zero_right2 T).
+Hint SR_plus_zero_right_T := Resolve (SR_plus_zero_right T).
+Hint SR_plus_zero_right2_T := Resolve (SR_plus_zero_right2 T).
+Hint SR_mult_one_right_T := Resolve (SR_mult_one_right T).
+Hint SR_mult_one_right2_T := Resolve (SR_mult_one_right2 T).
+Hint SR_plus_reg_right_T := Resolve (SR_plus_reg_right T).
+Hints Resolve refl_equal sym_equal trans_equal.
+(* Hints Resolve refl_eqT sym_eqT trans_eqT. *)
+Hints Immediate T.
+
+Lemma varlist_eq_prop : (x,y:varlist)
+  (Is_true (varlist_eq x y))->x==y.
+Proof.
+  Induction x; Induction y; Contradiction Orelse Try Reflexivity.
+  Simpl; Intros.
+  Generalize (andb_prop2 ? ? H1); Intros; Elim H2; Intros.
+  Rewrite (index_eq_prop H3); Rewrite (H v0 H4); Reflexivity.
+Save.
+
+Remark ivl_aux_ok : (v:varlist)(i:index)
+  (ivl_aux i v)==(Amult (interp_var i) (interp_vl v)).
+Proof.
+  Induction v; Simpl; Intros.
+  Trivial.
+  Rewrite H; Trivial.
+Save.
+
+Lemma varlist_merge_ok : (x,y:varlist)
+  (interp_vl (varlist_merge x y))
+  ==(Amult (interp_vl x) (interp_vl y)).
+Proof.
+  Induction x.
+  Simpl; Trivial.
+  Induction y.
+  Simpl; Trivial.
+  Simpl; Intros.
+  Elim (index_lt i i0); Simpl; Intros.
+
+  Repeat Rewrite ivl_aux_ok.
+  Rewrite H. Simpl.
+  Rewrite ivl_aux_ok.
+  EAuto.
+
+  Repeat Rewrite ivl_aux_ok.
+  Rewrite H0.
+  Rewrite ivl_aux_ok.
+  EAuto.
+Save.
+
+Remark ics_aux_ok : (x:A)(s:canonical_sum)
+  (ics_aux x s)==(Aplus x (interp_cs s)).
+Proof.
+  Induction s; Simpl; Intros.
+  Trivial.
+  Reflexivity.
+  Reflexivity.
+Save.
+
+Remark interp_m_ok : (x:A)(l:varlist)
+  (interp_m x l)==(Amult x (interp_vl l)).
+Proof.
+  NewDestruct l.
+  Simpl; Trivial.
+  Reflexivity.
+Save.
+
+Lemma canonical_sum_merge_ok : (x,y:canonical_sum)
+  (interp_cs (canonical_sum_merge x y))
+  ==(Aplus (interp_cs x) (interp_cs y)).
+
+Induction x; Simpl.
+Trivial.
+
+Induction y; Simpl; Intros.
+(* monom and nil *)
+EAuto.
+
+(* monom and monom *)
+Generalize (varlist_eq_prop v v0).
+Elim (varlist_eq v v0).
+Intros; Rewrite (H1 I).
+Simpl; Repeat Rewrite ics_aux_ok; Rewrite H.
+Repeat Rewrite interp_m_ok.
+Rewrite (SR_distr_left T).
+Repeat Rewrite <- (SR_plus_assoc T).
+Apply congr_eqT with f:=(Aplus (Amult a (interp_vl v0))).
+Trivial.
+
+Elim (varlist_lt v v0); Simpl.
+Repeat Rewrite ics_aux_ok.
+Rewrite H; Simpl; Rewrite ics_aux_ok; EAuto.
+
+Rewrite ics_aux_ok; Rewrite H0; Repeat Rewrite ics_aux_ok; Simpl; EAuto.
+
+(* monom and varlist *)
+Generalize (varlist_eq_prop v v0).
+Elim (varlist_eq v v0).
+Intros; Rewrite (H1 I).
+Simpl; Repeat Rewrite ics_aux_ok; Rewrite H.
+Repeat Rewrite interp_m_ok.
+Rewrite (SR_distr_left T).
+Repeat Rewrite <- (SR_plus_assoc T).
+Apply congr_eqT with f:=(Aplus (Amult a (interp_vl v0))).
+Rewrite (SR_mult_one_left T).
+Trivial.
+
+Elim (varlist_lt v v0); Simpl.
+Repeat Rewrite ics_aux_ok.
+Rewrite H; Simpl; Rewrite ics_aux_ok; EAuto.
+Rewrite ics_aux_ok; Rewrite H0; Repeat Rewrite ics_aux_ok; Simpl; EAuto.
+
+Induction y; Simpl; Intros.
+(* varlist and nil *)
+Trivial.
+
+(* varlist and monom *)
+Generalize (varlist_eq_prop v v0).
+Elim (varlist_eq v v0).
+Intros; Rewrite (H1 I).
+Simpl; Repeat Rewrite ics_aux_ok; Rewrite H.
+Repeat Rewrite interp_m_ok.
+Rewrite (SR_distr_left T).
+Repeat Rewrite <- (SR_plus_assoc T).
+Rewrite (SR_mult_one_left T).
+Apply congr_eqT with f:=(Aplus (interp_vl v0)).
+Trivial.
+
+Elim (varlist_lt v v0); Simpl.
+Repeat Rewrite ics_aux_ok.
+Rewrite H; Simpl; Rewrite ics_aux_ok; EAuto.
+Rewrite ics_aux_ok; Rewrite H0; Repeat Rewrite ics_aux_ok; Simpl; EAuto.
+
+(* varlist and varlist *)
+Generalize (varlist_eq_prop v v0).
+Elim (varlist_eq v v0).
+Intros; Rewrite (H1 I).
+Simpl; Repeat Rewrite ics_aux_ok; Rewrite H.
+Repeat Rewrite interp_m_ok.
+Rewrite (SR_distr_left T).
+Repeat Rewrite <- (SR_plus_assoc T).
+Rewrite (SR_mult_one_left T).
+Apply congr_eqT with f:=(Aplus (interp_vl v0)).
+Trivial.
+
+Elim (varlist_lt v v0); Simpl.
+Repeat Rewrite ics_aux_ok.
+Rewrite H; Simpl; Rewrite ics_aux_ok; EAuto.
+Rewrite ics_aux_ok; Rewrite H0; Repeat Rewrite ics_aux_ok; Simpl; EAuto.
+Save.
+
+Lemma monom_insert_ok: (a:A)(l:varlist)(s:canonical_sum)
+  (interp_cs (monom_insert a l s)) 
+  == (Aplus (Amult a (interp_vl l)) (interp_cs s)).
+Intros; Generalize s; Induction s0.
+
+Simpl; Rewrite interp_m_ok; Trivial.
+
+Simpl; Intros.
+Generalize (varlist_eq_prop  l v); Elim (varlist_eq l v).
+Intro Hr; Rewrite (Hr I); Simpl; Rewrite interp_m_ok; 
+  Repeat Rewrite ics_aux_ok; Rewrite interp_m_ok;
+  Rewrite (SR_distr_left T); EAuto.
+Elim (varlist_lt l v); Simpl; 
+[ Repeat Rewrite interp_m_ok; Rewrite ics_aux_ok; EAuto
+| Repeat Rewrite interp_m_ok; Rewrite ics_aux_ok;
+  Rewrite H; Rewrite ics_aux_ok; EAuto].
+
+Simpl; Intros.
+Generalize (varlist_eq_prop  l v); Elim (varlist_eq l v).
+Intro Hr; Rewrite (Hr I); Simpl;  Rewrite interp_m_ok; 
+  Repeat Rewrite ics_aux_ok; 
+  Rewrite (SR_distr_left T); Rewrite (SR_mult_one_left T); EAuto.
+Elim (varlist_lt l v); Simpl; 
+[ Repeat Rewrite interp_m_ok; Rewrite ics_aux_ok; EAuto
+| Repeat Rewrite interp_m_ok; Rewrite ics_aux_ok;
+  Rewrite H; Rewrite ics_aux_ok; EAuto].
+Save.
+
+Lemma varlist_insert_ok :
+ (l:varlist)(s:canonical_sum)
+  (interp_cs (varlist_insert l s)) 
+  == (Aplus (interp_vl l) (interp_cs s)).
+Intros; Generalize s; Induction s0.
+
+Simpl; Trivial.
+
+Simpl; Intros.
+Generalize (varlist_eq_prop  l v); Elim (varlist_eq l v).
+Intro Hr; Rewrite (Hr I); Simpl; Rewrite interp_m_ok; 
+  Repeat Rewrite ics_aux_ok; Rewrite interp_m_ok;
+  Rewrite (SR_distr_left T); Rewrite (SR_mult_one_left T); EAuto.
+Elim (varlist_lt l v); Simpl; 
+[ Repeat Rewrite interp_m_ok; Rewrite ics_aux_ok; EAuto
+| Repeat Rewrite interp_m_ok; Rewrite ics_aux_ok;
+  Rewrite H; Rewrite ics_aux_ok; EAuto].
+
+Simpl; Intros.
+Generalize (varlist_eq_prop  l v); Elim (varlist_eq l v).
+Intro Hr; Rewrite (Hr I); Simpl;  Rewrite interp_m_ok; 
+  Repeat Rewrite ics_aux_ok; 
+  Rewrite (SR_distr_left T); Rewrite (SR_mult_one_left T); EAuto.
+Elim (varlist_lt l v); Simpl; 
+[ Repeat Rewrite interp_m_ok; Rewrite ics_aux_ok; EAuto
+| Repeat Rewrite interp_m_ok; Rewrite ics_aux_ok;
+  Rewrite H; Rewrite ics_aux_ok; EAuto].
+Save.
+
+Lemma canonical_sum_scalar_ok : (a:A)(s:canonical_sum)
+  (interp_cs (canonical_sum_scalar a s))
+  ==(Amult a (interp_cs s)).
+Induction s.
+Simpl; EAuto.
+
+Simpl; Intros.
+Repeat Rewrite ics_aux_ok.
+Repeat Rewrite interp_m_ok.
+Rewrite H.
+Rewrite (SR_distr_right T).
+Repeat Rewrite <- (SR_mult_assoc T).
+Reflexivity.
+
+Simpl; Intros.
+Repeat Rewrite ics_aux_ok.
+Repeat Rewrite interp_m_ok.
+Rewrite H.
+Rewrite (SR_distr_right T).
+Repeat Rewrite <- (SR_mult_assoc T).
+Reflexivity.
+Save.
+
+Lemma canonical_sum_scalar2_ok : (l:varlist; s:canonical_sum)
+  (interp_cs (canonical_sum_scalar2 l s))
+   ==(Amult (interp_vl l) (interp_cs s)).
+Induction s.
+Simpl; Trivial.
+
+Simpl; Intros.
+Rewrite monom_insert_ok.
+Repeat Rewrite ics_aux_ok.
+Repeat Rewrite interp_m_ok.
+Rewrite H.
+Rewrite varlist_merge_ok.
+Repeat Rewrite (SR_distr_right T). 
+Repeat Rewrite <- (SR_mult_assoc T).
+Repeat Rewrite <- (SR_plus_assoc T).
+Rewrite (SR_mult_permute T  a (interp_vl l) (interp_vl v)).
+Reflexivity.
+
+Simpl; Intros.
+Rewrite varlist_insert_ok.
+Repeat Rewrite ics_aux_ok.
+Repeat Rewrite interp_m_ok.
+Rewrite H.
+Rewrite varlist_merge_ok.
+Repeat Rewrite (SR_distr_right T). 
+Repeat Rewrite <- (SR_mult_assoc T).
+Repeat Rewrite <- (SR_plus_assoc T).
+Reflexivity.
+Save.
+
+Lemma canonical_sum_scalar3_ok : (c:A; l:varlist; s:canonical_sum)
+  (interp_cs (canonical_sum_scalar3 c l s))
+   ==(Amult c (Amult (interp_vl l) (interp_cs s))).
+Induction s.
+Simpl; Repeat Rewrite (SR_mult_zero_right T); Reflexivity.
+
+Simpl; Intros.
+Rewrite monom_insert_ok.
+Repeat Rewrite ics_aux_ok.
+Repeat Rewrite interp_m_ok.
+Rewrite H.
+Rewrite varlist_merge_ok.
+Repeat Rewrite (SR_distr_right T). 
+Repeat Rewrite <- (SR_mult_assoc T).
+Repeat Rewrite <- (SR_plus_assoc T).
+Rewrite (SR_mult_permute T  a (interp_vl l) (interp_vl v)).
+Reflexivity.
+
+Simpl; Intros.
+Rewrite monom_insert_ok.
+Repeat Rewrite ics_aux_ok.
+Repeat Rewrite interp_m_ok.
+Rewrite H.
+Rewrite varlist_merge_ok.
+Repeat Rewrite (SR_distr_right T). 
+Repeat Rewrite <- (SR_mult_assoc T).
+Repeat Rewrite <- (SR_plus_assoc T).
+Rewrite (SR_mult_permute T c (interp_vl l) (interp_vl v)).
+Reflexivity.
+Save.
+
+Lemma canonical_sum_prod_ok : (x,y:canonical_sum)
+  (interp_cs (canonical_sum_prod x y))
+  ==(Amult (interp_cs x) (interp_cs y)).
+Induction x; Simpl; Intros.
+Trivial.
+
+Rewrite canonical_sum_merge_ok.
+Rewrite canonical_sum_scalar3_ok.
+Rewrite ics_aux_ok.
+Rewrite interp_m_ok.
+Rewrite H.
+Rewrite (SR_mult_assoc T a (interp_vl v) (interp_cs y)).
+Symmetry.
+EAuto.
+
+Rewrite canonical_sum_merge_ok.
+Rewrite canonical_sum_scalar2_ok.
+Rewrite ics_aux_ok.
+Rewrite H.
+Trivial.
+Save.
+
+Theorem spolynomial_normalize_ok : (p:spolynomial)
+  (interp_cs (spolynomial_normalize p)) == (interp_sp p).
+Induction p; Simpl; Intros.
+
+Reflexivity.
+Reflexivity.
+
+Rewrite canonical_sum_merge_ok.
+Rewrite H; Rewrite H0.
+Reflexivity.
+
+Rewrite canonical_sum_prod_ok.
+Rewrite H; Rewrite H0.
+Reflexivity.
+Save.
+
+Lemma canonical_sum_simplify_ok : (s:canonical_sum)
+  (interp_cs (canonical_sum_simplify s)) == (interp_cs s).
+Induction s.
+
+Reflexivity.
+
+(* cons_monom *)
+Simpl; Intros.
+Generalize (SR_eq_prop T 8!a 9!Azero).
+Elim (Aeq a Azero).
+Intro Heq; Rewrite (Heq I).
+Rewrite H.
+Rewrite ics_aux_ok.
+Rewrite interp_m_ok.
+Rewrite (SR_mult_zero_left T).
+Trivial.
+
+Intros; Simpl.
+Generalize (SR_eq_prop T 8!a 9!Aone).
+Elim (Aeq a Aone).
+Intro Heq; Rewrite (Heq I).
+Simpl.
+Repeat Rewrite ics_aux_ok.
+Rewrite interp_m_ok.
+Rewrite H.
+Rewrite (SR_mult_one_left T).
+Reflexivity.
+
+Simpl.
+Repeat Rewrite ics_aux_ok.
+Rewrite interp_m_ok.
+Rewrite H.
+Reflexivity.
+
+(* cons_varlist *)
+Simpl; Intros.
+Repeat Rewrite ics_aux_ok.
+Rewrite H.
+Reflexivity.
+
+Save.
+
+Theorem spolynomial_simplify_ok : (p:spolynomial)
+  (interp_cs (spolynomial_simplify p)) == (interp_sp p).
+Intro.
+Unfold spolynomial_simplify.
+Rewrite canonical_sum_simplify_ok.
+Apply spolynomial_normalize_ok.
+Save.
+
+(* End properties. *)
+End semi_rings.
+
+Implicits Cons_varlist.
+Implicits Cons_monom.
+Implicits SPconst.
+Implicits SPplus.
+Implicits SPmult.
+
+Section rings.
+
+(* Here the coercion between Ring and Semi-Ring will be useful *)
+
+Set Implicit Arguments.
+
+Variable A : Type.
+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 vm : (varmap A).
+Variable T : (Ring_Theory Aplus Amult Aone Azero Aopp Aeq).
+
+Hint Th_plus_sym_T := Resolve (Th_plus_sym T).
+Hint Th_plus_assoc_T := Resolve (Th_plus_assoc T).
+Hint Th_plus_assoc2_T := Resolve (Th_plus_assoc2 T).
+Hint Th_mult_sym_T := Resolve (Th_mult_sym T).
+Hint Th_mult_assoc_T := Resolve (Th_mult_assoc T).
+Hint Th_mult_assoc2_T := Resolve (Th_mult_assoc2 T).
+Hint Th_plus_zero_left_T := Resolve (Th_plus_zero_left T).
+Hint Th_plus_zero_left2_T := Resolve (Th_plus_zero_left2 T).
+Hint Th_mult_one_left_T := Resolve (Th_mult_one_left T).
+Hint Th_mult_one_left2_T := Resolve (Th_mult_one_left2 T).
+Hint Th_mult_zero_left_T := Resolve (Th_mult_zero_left T).
+Hint Th_mult_zero_left2_T := Resolve (Th_mult_zero_left2 T).
+Hint Th_distr_left_T := Resolve (Th_distr_left T).
+Hint Th_distr_left2_T := Resolve (Th_distr_left2 T).
+Hint Th_plus_reg_left_T := Resolve (Th_plus_reg_left T).
+Hint Th_plus_permute_T := Resolve (Th_plus_permute T).
+Hint Th_mult_permute_T := Resolve (Th_mult_permute T).
+Hint Th_distr_right_T := Resolve (Th_distr_right T).
+Hint Th_distr_right2_T := Resolve (Th_distr_right2 T).
+Hint Th_mult_zero_right_T := Resolve (Th_mult_zero_right T).
+Hint Th_mult_zero_right2_T := Resolve (Th_mult_zero_right2 T).
+Hint Th_plus_zero_right_T := Resolve (Th_plus_zero_right T).
+Hint Th_plus_zero_right2_T := Resolve (Th_plus_zero_right2 T).
+Hint Th_mult_one_right_T := Resolve (Th_mult_one_right T).
+Hint Th_mult_one_right2_T := Resolve (Th_mult_one_right2 T).
+Hint Th_plus_reg_right_T := Resolve (Th_plus_reg_right T).
+Hints Resolve refl_equal sym_equal trans_equal.
+(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
+Hints Immediate T.
+
+(*** Definitions *)
+
+Inductive Type polynomial := 
+  Pvar : index -> polynomial
+| Pconst : A -> polynomial
+| Pplus : polynomial -> polynomial -> polynomial
+| Pmult : polynomial -> polynomial -> polynomial
+| Popp : polynomial -> polynomial.
+
+Fixpoint polynomial_normalize [x:polynomial] : (canonical_sum A) :=
+  Cases x of
+    (Pplus l r) => (canonical_sum_merge Aplus Aone
+      	       	       	       	(polynomial_normalize l) 
+                                (polynomial_normalize r))
+  | (Pmult l r) => (canonical_sum_prod Aplus Amult Aone 
+      	       	       	       	(polynomial_normalize l)
+                                (polynomial_normalize r))
+  | (Pconst c)  => (Cons_monom c Nil_var (Nil_monom A))
+  | (Pvar i)    => (Cons_varlist (Cons_var i Nil_var) (Nil_monom A))
+  | (Popp p)    => (canonical_sum_scalar3 Aplus Amult Aone
+                                     (Aopp Aone) Nil_var
+                                     (polynomial_normalize p))
+  end.
+
+Definition polynomial_simplify :=
+  [x:polynomial](canonical_sum_simplify Aone Azero Aeq 
+      	       	       	(polynomial_normalize x)).
+
+Fixpoint spolynomial_of [x:polynomial] : (spolynomial A) :=
+  Cases x of 
+    (Pplus l r) => (SPplus (spolynomial_of l) (spolynomial_of r))
+  | (Pmult l r) => (SPmult (spolynomial_of l) (spolynomial_of r))
+  | (Pconst c)  => (SPconst c)
+  | (Pvar i)    => (SPvar A i)
+  | (Popp p)    => (SPmult (SPconst (Aopp Aone)) (spolynomial_of p))
+  end.
+
+(*** Interpretation *)
+
+Fixpoint interp_p [p:polynomial] : A :=
+  Cases p of
+    (Pconst c)    => c
+  | (Pvar i)      => (varmap_find Azero i vm)
+  | (Pplus p1 p2) => (Aplus (interp_p p1) (interp_p p2))
+  | (Pmult p1 p2) => (Amult (interp_p p1) (interp_p p2))
+  | (Popp p1)     => (Aopp (interp_p p1))
+  end.
+
+(*** Properties *)
+
+Unset Implicit Arguments.
+
+Lemma spolynomial_of_ok : (p:polynomial)
+  (interp_p p)==(interp_sp Aplus Amult Azero vm (spolynomial_of p)).
+Induction p; Reflexivity Orelse (Simpl; Intros).
+Rewrite H; Rewrite H0; Reflexivity.
+Rewrite H; Rewrite H0; Reflexivity.
+Rewrite H.
+Rewrite (Th_opp_mult_left2 T).
+Rewrite (Th_mult_one_left T).
+Reflexivity.
+Save.
+
+Theorem polynomial_normalize_ok : (p:polynomial)
+  (polynomial_normalize p)
+  ==(spolynomial_normalize Aplus Amult Aone (spolynomial_of p)).
+Induction p; Reflexivity Orelse (Simpl; Intros).
+Rewrite H; Rewrite H0; Reflexivity.
+Rewrite H; Rewrite H0; Reflexivity.
+Rewrite H; Simpl.
+Elim (canonical_sum_scalar3 Aplus Amult Aone (Aopp Aone) Nil_var
+     (spolynomial_normalize Aplus Amult Aone (spolynomial_of p0)));
+[ Reflexivity
+| Simpl; Intros; Rewrite H0; Reflexivity
+| Simpl; Intros; Rewrite H0; Reflexivity ].
+Save.
+
+Theorem polynomial_simplify_ok : (p:polynomial)
+  (interp_cs Aplus Amult Aone Azero vm (polynomial_simplify p))
+  ==(interp_p p).
+Intro.
+Unfold polynomial_simplify.
+Rewrite spolynomial_of_ok.
+Rewrite polynomial_normalize_ok.
+Rewrite (canonical_sum_simplify_ok A Aplus Amult Aone Azero Aeq vm T).
+Rewrite (spolynomial_normalize_ok A Aplus Amult Aone Azero Aeq vm T).
+Reflexivity.
+Save.
+
+End rings.
+
+V8Infix "+" Pplus : ring_scope.
+V8Infix "*" Pmult : ring_scope.
+V8Notation "- x" := (Popp x) : ring_scope.
+V8Notation "[ x ]" := (Pvar x) (at level 1) : ring_scope.
+
+Delimits Scope ring_scope with ring.
diff --git a/contrib7/ring/Ring_theory.v b/contrib7/ring/Ring_theory.v
new file mode 100644
index 0000000000..ddc52f8127
--- /dev/null
+++ b/contrib7/ring/Ring_theory.v
@@ -0,0 +1,384 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+Require Export Bool.
+
+Set Implicit Arguments.
+
+Section Theory_of_semi_rings.
+
+Variable A : Type.
+Variable Aplus : A -> A -> A.
+Variable Amult : A -> A -> A.
+Variable Aone : A.
+Variable Azero : A.
+(* There is also a "weakly decidable" equality on A. That means 
+  that if (A_eq x y)=true then x=y but x=y can arise when 
+  (A_eq x y)=false. On an abstract ring the function [x,y:A]false
+  is a good choice. The proof of A_eq_prop is in this case easy. *)
+Variable Aeq : A -> A -> bool.
+
+Infix 4 "+" Aplus V8only 50 (left associativity).
+Infix 4 "*" Amult V8only 40 (left associativity).
+Notation "0" := Azero.
+Notation "1" := Aone.
+
+Record Semi_Ring_Theory : Prop :=
+{ SR_plus_sym  : (n,m:A) n + m == m + n;
+  SR_plus_assoc : (n,m,p:A) n + (m + p) == (n + m) + p;
+  SR_mult_sym : (n,m:A) n*m == m*n;
+  SR_mult_assoc : (n,m,p:A) n*(m*p) == (n*m)*p;
+  SR_plus_zero_left :(n:A) 0 + n == n;
+  SR_mult_one_left : (n:A) 1*n == n;
+  SR_mult_zero_left : (n:A) 0*n == 0;
+  SR_distr_left   : (n,m,p:A) (n + m)*p == n*p + m*p;
+  SR_plus_reg_left : (n,m,p:A) n + m == n + p -> m==p;
+  SR_eq_prop : (x,y:A) (Is_true (Aeq x y)) -> x==y
+}.
+
+Variable T : Semi_Ring_Theory.
+
+Local plus_sym  := (SR_plus_sym T).
+Local plus_assoc := (SR_plus_assoc T).
+Local mult_sym  := ( SR_mult_sym T).
+Local mult_assoc := (SR_mult_assoc T).
+Local plus_zero_left := (SR_plus_zero_left T).
+Local mult_one_left := (SR_mult_one_left T). 
+Local mult_zero_left := (SR_mult_zero_left T).
+Local distr_left := (SR_distr_left T).
+Local plus_reg_left := (SR_plus_reg_left T).
+
+Hints Resolve  plus_sym plus_assoc mult_sym mult_assoc
+  plus_zero_left mult_one_left mult_zero_left distr_left
+  plus_reg_left.
+
+(* Lemmas whose form is x=y are also provided in form y=x because Auto does
+  not symmetry *) 
+Lemma SR_mult_assoc2 : (n,m,p:A) (n * m) * p == n * (m * p).
+Symmetry; EAuto. Qed.
+
+Lemma SR_plus_assoc2 : (n,m,p:A) (n + m) + p == n + (m + p).
+Symmetry; EAuto. Qed.
+
+Lemma SR_plus_zero_left2 : (n:A) n == 0 + n.
+Symmetry; EAuto. Qed.
+
+Lemma SR_mult_one_left2 : (n:A) n == 1*n.
+Symmetry; EAuto. Qed.
+
+Lemma SR_mult_zero_left2 : (n:A) 0 == 0*n.
+Symmetry; EAuto. Qed.
+
+Lemma SR_distr_left2 : (n,m,p:A) n*p + m*p  == (n + m)*p.
+Symmetry; EAuto. Qed.
+
+Lemma SR_plus_permute : (n,m,p:A) n + (m + p) == m + (n + p).
+Intros.
+Rewrite -> plus_assoc.
+Elim (plus_sym m n).
+Rewrite <- plus_assoc.
+Reflexivity.
+Qed.
+
+Lemma SR_mult_permute : (n,m,p:A) n*(m*p) == m*(n*p).
+Intros.
+Rewrite -> mult_assoc.
+Elim (mult_sym m n).
+Rewrite <- mult_assoc.
+Reflexivity.
+Qed.
+
+Hints Resolve SR_plus_permute SR_mult_permute.
+
+Lemma SR_distr_right : (n,m,p:A) n*(m + p) == (n*m) + (n*p).
+Intros.
+Repeat Rewrite -> (mult_sym n).
+EAuto.
+Qed.
+
+Lemma SR_distr_right2 : (n,m,p:A) (n*m) + (n*p) == n*(m + p).
+Symmetry; Apply SR_distr_right. Qed.
+
+Lemma SR_mult_zero_right : (n:A) n*0 == 0.
+Intro; Rewrite mult_sym; EAuto.
+Qed.
+
+Lemma SR_mult_zero_right2 : (n:A) 0 == n*0.
+Intro; Rewrite mult_sym; EAuto.
+Qed.
+
+Lemma SR_plus_zero_right :(n:A) n + 0 == n.
+Intro; Rewrite plus_sym; EAuto.
+Qed.
+Lemma SR_plus_zero_right2 :(n:A) n == n + 0.
+Intro; Rewrite plus_sym; EAuto.
+Qed.
+
+Lemma SR_mult_one_right : (n:A) n*1 == n.
+Intro; Elim mult_sym; Auto.
+Qed.
+
+Lemma SR_mult_one_right2 : (n:A) n == n*1.
+Intro; Elim mult_sym; Auto.
+Qed.
+
+Lemma SR_plus_reg_right : (n,m,p:A) m + n == p + n -> m==p.
+Intros n m p; Rewrite (plus_sym m n); Rewrite (plus_sym p n); EAuto.
+Qed.
+
+End Theory_of_semi_rings.
+
+Section Theory_of_rings.
+
+Variable A : Type.
+
+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.
+
+Infix 4 "+" Aplus V8only 50 (left associativity).
+Infix 4 "*" Amult V8only 40 (left associativity).
+Notation "0" := Azero.
+Notation "1" := Aone.
+Notation "- x" := (Aopp x) (at level 0) V8only.
+
+Record Ring_Theory : Prop :=
+{ Th_plus_sym  : (n,m:A) n + m == m + n;
+  Th_plus_assoc : (n,m,p:A) n + (m + p) == (n + m) + p;
+  Th_mult_sym : (n,m:A) n*m == m*n;
+  Th_mult_assoc : (n,m,p:A) n*(m*p) == (n*m)*p;
+  Th_plus_zero_left :(n:A) 0 + n == n;
+  Th_mult_one_left : (n:A) 1*n == n;
+  Th_opp_def : (n:A) n + (-n) == 0;
+  Th_distr_left : (n,m,p:A) (n + m)*p == n*p + m*p;
+  Th_eq_prop : (x,y:A) (Is_true (Aeq x y)) -> x==y
+}.
+
+Variable T : Ring_Theory.
+
+Local plus_sym  := (Th_plus_sym T).
+Local plus_assoc := (Th_plus_assoc T).
+Local mult_sym  := ( Th_mult_sym T).
+Local mult_assoc := (Th_mult_assoc T).
+Local plus_zero_left := (Th_plus_zero_left T).
+Local mult_one_left := (Th_mult_one_left T). 
+Local opp_def := (Th_opp_def T).
+Local distr_left := (Th_distr_left T).
+
+Hints Resolve plus_sym plus_assoc mult_sym mult_assoc
+  plus_zero_left mult_one_left opp_def distr_left.
+
+(* Lemmas whose form is x=y are also provided in form y=x because Auto does
+  not symmetry *) 
+Lemma Th_mult_assoc2 : (n,m,p:A) (n * m) * p == n * (m * p).
+Symmetry; EAuto. Qed.
+
+Lemma Th_plus_assoc2 : (n,m,p:A) (n + m) + p == n + (m + p).
+Symmetry; EAuto. Qed.
+
+Lemma Th_plus_zero_left2 : (n:A) n == 0 + n.
+Symmetry; EAuto. Qed.
+
+Lemma Th_mult_one_left2 : (n:A) n == 1*n.
+Symmetry; EAuto. Qed.
+
+Lemma Th_distr_left2 : (n,m,p:A) n*p + m*p  == (n + m)*p.
+Symmetry; EAuto. Qed.
+
+Lemma Th_opp_def2 : (n:A) 0 == n + (-n).
+Symmetry; EAuto. Qed.
+
+Lemma Th_plus_permute : (n,m,p:A) n + (m + p) == m + (n + p).
+Intros.
+Rewrite -> plus_assoc.
+Elim (plus_sym m n).
+Rewrite <- plus_assoc.
+Reflexivity.
+Qed.
+
+Lemma Th_mult_permute : (n,m,p:A) n*(m*p) == m*(n*p).
+Intros.
+Rewrite -> mult_assoc.
+Elim (mult_sym m n).
+Rewrite <- mult_assoc.
+Reflexivity.
+Qed.
+
+Hints Resolve Th_plus_permute Th_mult_permute.
+
+Lemma aux1 : (a:A) a + a == a -> a == 0.
+Intros.
+Generalize (opp_def a).
+Pattern 1 a.
+Rewrite <- H.
+Rewrite <- plus_assoc.
+Rewrite -> opp_def.
+Elim plus_sym.
+Rewrite plus_zero_left.
+Trivial.
+Qed.
+
+Lemma Th_mult_zero_left :(n:A) 0*n == 0.
+Intros.
+Apply aux1.
+Rewrite <- distr_left.
+Rewrite plus_zero_left.
+Reflexivity.
+Qed.
+Hints Resolve Th_mult_zero_left.
+
+Lemma Th_mult_zero_left2 : (n:A) 0 == 0*n.
+Symmetry; EAuto. Qed.
+
+Lemma aux2 : (x,y,z:A) x+y==0 -> x+z==0 -> y==z.
+Intros.
+Rewrite <- (plus_zero_left y).
+Elim H0.
+Elim plus_assoc.
+Elim (plus_sym y z).
+Rewrite -> plus_assoc.
+Rewrite -> H.
+Rewrite plus_zero_left.
+Reflexivity.
+Qed.
+
+Lemma Th_opp_mult_left : (x,y:A) -(x*y) == (-x)*y.
+Intros.
+Apply (aux2 1!x*y);
+[ Apply opp_def
+| Rewrite <- distr_left;
+  Rewrite -> opp_def;
+  Auto].
+Qed.
+Hints Resolve Th_opp_mult_left.
+
+Lemma Th_opp_mult_left2 : (x,y:A) (-x)*y == -(x*y).
+Symmetry; EAuto. Qed.
+
+Lemma Th_mult_zero_right : (n:A) n*0 == 0.
+Intro; Elim mult_sym; EAuto.
+Qed.
+
+Lemma Th_mult_zero_right2 : (n:A) 0 == n*0.
+Intro; Elim mult_sym; EAuto.
+Qed.
+
+Lemma Th_plus_zero_right :(n:A) n + 0 == n.
+Intro; Rewrite plus_sym; EAuto.
+Qed.
+
+Lemma Th_plus_zero_right2 :(n:A) n == n + 0.
+Intro; Rewrite plus_sym; EAuto.
+Qed.
+
+Lemma Th_mult_one_right : (n:A) n*1 == n.
+Intro;Elim mult_sym; EAuto.
+Qed.
+
+Lemma Th_mult_one_right2  : (n:A) n == n*1.
+Intro;Elim mult_sym; EAuto.
+Qed.
+
+Lemma Th_opp_mult_right : (x,y:A) -(x*y) == x*(-y).
+Intros; Do 2 Rewrite -> (mult_sym x); Auto.
+Qed.
+
+Lemma Th_opp_mult_right2 : (x,y:A) x*(-y) == -(x*y).
+Intros; Do 2 Rewrite -> (mult_sym x); Auto.
+Qed.
+
+Lemma Th_plus_opp_opp : (x,y:A) (-x) + (-y) == -(x+y).
+Intros.
+Apply (aux2 1! x + y);
+[ Elim plus_assoc;
+  Rewrite -> (Th_plus_permute y (-x)); Rewrite -> plus_assoc;
+  Rewrite -> opp_def;  Rewrite plus_zero_left; Auto
+| Auto ].
+Qed.
+
+Lemma Th_plus_permute_opp: (n,m,p:A) (-m)+(n+p) == n+((-m)+p).
+EAuto. Qed.
+
+Lemma Th_opp_opp : (n:A) -(-n) == n.
+Intro; Apply (aux2 1! -n); 
+  [ Auto | Elim plus_sym; Auto ].
+Qed.
+Hints Resolve Th_opp_opp.
+
+Lemma Th_opp_opp2 : (n:A) n == -(-n).
+Symmetry; EAuto. Qed.
+
+Lemma Th_mult_opp_opp : (x,y:A) (-x)*(-y) == x*y.
+Intros; Rewrite <- Th_opp_mult_left; Rewrite <- Th_opp_mult_right; Auto.
+Qed.
+
+Lemma Th_mult_opp_opp2 : (x,y:A) x*y == (-x)*(-y).
+Symmetry; Apply Th_mult_opp_opp. Qed.
+
+Lemma Th_opp_zero : -0 == 0.
+Rewrite <- (plus_zero_left (-0)).
+Auto. Qed.
+
+Lemma Th_plus_reg_left : (n,m,p:A) n + m == n + p -> m==p.
+Intros; Generalize (congr_eqT ? ? [z] (-n)+z ? ? H).
+Repeat Rewrite plus_assoc.
+Rewrite (plus_sym (-n) n).
+Rewrite opp_def.
+Repeat Rewrite Th_plus_zero_left; EAuto.
+Qed.
+
+Lemma Th_plus_reg_right : (n,m,p:A) m + n == p + n -> m==p.
+Intros.
+EApply Th_plus_reg_left with n. 
+Rewrite (plus_sym n m).
+Rewrite (plus_sym n p).
+Auto.
+Qed.
+
+Lemma Th_distr_right : (n,m,p:A)  n*(m + p) == (n*m) + (n*p).
+Intros.
+Repeat Rewrite -> (mult_sym n).
+EAuto.
+Qed.
+
+Lemma Th_distr_right2  : (n,m,p:A) (n*m) + (n*p) == n*(m + p).
+Symmetry; Apply Th_distr_right.
+Qed.
+
+End Theory_of_rings.
+
+Hints Resolve Th_mult_zero_left Th_plus_reg_left : core.
+
+Unset Implicit Arguments.
+
+Definition Semi_Ring_Theory_of :
+  (A:Type)(Aplus : A -> A -> A)(Amult : A -> A -> A)(Aone : A)
+  (Azero : A)(Aopp : A -> A)(Aeq : A -> A -> bool)
+  (Ring_Theory Aplus Amult Aone Azero Aopp Aeq)
+    ->(Semi_Ring_Theory Aplus Amult Aone Azero Aeq).
+Intros until 1; Case H.
+Split; Intros; Simpl; EAuto.
+Defined.
+
+(* Every ring can be viewed as a semi-ring : this property will be used
+  in Abstract_polynom. *)
+Coercion Semi_Ring_Theory_of : Ring_Theory >-> Semi_Ring_Theory.
+
+
+Section product_ring.
+
+End product_ring.
+
+Section power_ring.
+
+End power_ring.
diff --git a/contrib7/ring/Setoid_ring.v b/contrib7/ring/Setoid_ring.v
new file mode 100644
index 0000000000..567517e984
--- /dev/null
+++ b/contrib7/ring/Setoid_ring.v
@@ -0,0 +1,13 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+Require Export Setoid_ring_theory.
+Require Export Quote.
+Require Export Setoid_ring_normalize.
diff --git a/contrib7/ring/Setoid_ring_normalize.v b/contrib7/ring/Setoid_ring_normalize.v
new file mode 100644
index 0000000000..bbebde4223
--- /dev/null
+++ b/contrib7/ring/Setoid_ring_normalize.v
@@ -0,0 +1,1141 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+Require Setoid_ring_theory.
+Require Quote.
+
+Set Implicit Arguments.
+
+Lemma index_eq_prop: (n,m:index)(Is_true (index_eq n m)) -> n=m.
+Proof.
+  Induction n; Induction m; Simpl; Try (Reflexivity Orelse Contradiction).
+  Intros; Rewrite (H i0); Trivial.
+  Intros; Rewrite (H i0); Trivial.
+Save.
+
+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.
+
+Variable plus_morph : (a,a0,a1,a2:A)
+ (Aequiv a a0)->(Aequiv a1 a2)->(Aequiv (Aplus a a1) (Aplus a0 a2)).
+Variable mult_morph : (a,a0,a1,a2:A)
+ (Aequiv a a0)->(Aequiv a1 a2)->(Aequiv (Amult a a1) (Amult a0 a2)).
+Variable opp_morph : (a,a0:A)
+ (Aequiv a a0)->(Aequiv (Aopp a) (Aopp a0)).
+
+Add Morphism Aplus : Aplus_ext.
+Exact plus_morph.
+Save.
+
+Add Morphism Amult : Amult_ext.
+Exact mult_morph.
+Save.
+
+Add Morphism Aopp : Aopp_ext.
+Exact opp_morph.
+Save.
+
+Local equiv_refl := (Seq_refl A Aequiv S).
+Local equiv_sym := (Seq_sym A Aequiv S).
+Local equiv_trans := (Seq_trans A Aequiv S).
+
+Hints Resolve equiv_refl equiv_trans.
+Hints 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] : bool :=
+  Cases x y of
+  | 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] : bool :=
+  Cases x y of 
+  | 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 :=
+  Cases l1 of	
+  | (Cons_var v1 t1) => 
+      Fix vm_aux {vm_aux [l2:varlist] : varlist :=
+	Cases l2 of
+	| (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 => [l2]l2
+  end.
+
+(* returns the sum of two canonical sums  *)
+Fixpoint canonical_sum_merge [s1:canonical_sum] 
+      	 : canonical_sum -> canonical_sum :=
+Cases s1 of
+| (Cons_monom c1 l1 t1) =>      
+     Fix csm_aux{csm_aux[s2:canonical_sum] : canonical_sum :=
+           Cases s2 of
+      	   | (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{csm_aux2[s2:canonical_sum] : canonical_sum :=
+           Cases s2 of
+      	   | (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 => [s2]s2
+end.
+
+(* Insertion of a monom in a canonical sum *)
+Fixpoint monom_insert [c1:A; l1:varlist; s2 : canonical_sum] 
+      : canonical_sum := 
+  Cases s2 of
+  | (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] 
+      : canonical_sum :=
+  Cases s2 of
+  | (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] : canonical_sum :=
+    Cases s of
+    | (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] 
+      	       	       	      : canonical_sum :=
+    Cases s of
+    | (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] 
+      	       	       	      : canonical_sum :=
+    Cases s of
+    | (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:canonical_sum] 
+      	 : canonical_sum -> canonical_sum := 
+    [s2]Cases s1 of
+    | (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 Type setspolynomial :=
+  SetSPvar : index -> setspolynomial
+| SetSPconst : A -> setspolynomial
+| SetSPplus : setspolynomial -> setspolynomial -> setspolynomial
+| SetSPmult : setspolynomial -> setspolynomial -> setspolynomial.
+
+Fixpoint setspolynomial_normalize [p:setspolynomial] : canonical_sum :=
+ Cases p of
+ | (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 :=
+  Cases s of
+  | (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 {ivl_aux[x:index; t:varlist] : A := 
+  Cases t of
+  | Nil_var => (interp_var x)
+  | (Cons_var x' t') => (Amult (interp_var x) (ivl_aux x' t'))
+  end}.
+
+Definition interp_vl :=  [l:varlist] 
+  Cases l of
+  | Nil_var => Aone
+  | (Cons_var x t) => (ivl_aux x t)
+  end.
+
+Definition interp_m := [c:A][l:varlist] 
+  Cases l of
+  | Nil_var => c
+  | (Cons_var x t) => 
+      (Amult c (ivl_aux x t))
+  end.
+
+Definition ics_aux := Fix ics_aux{ics_aux[a:A; s:canonical_sum] : A :=  
+  Cases s of
+  | 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 : canonical_sum -> A  := 
+  [s]Cases s of 
+  | 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 :=
+ Cases p of
+ | (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 SSR_plus_sym_T := Resolve (SSR_plus_sym T).
+Hint SSR_plus_assoc_T := Resolve (SSR_plus_assoc T).
+Hint SSR_plus_assoc2_T := Resolve (SSR_plus_assoc2 S T).
+Hint SSR_mult_sym_T := Resolve (SSR_mult_sym T).
+Hint SSR_mult_assoc_T := Resolve (SSR_mult_assoc T).
+Hint SSR_mult_assoc2_T := Resolve (SSR_mult_assoc2 S T).
+Hint SSR_plus_zero_left_T := Resolve (SSR_plus_zero_left T).
+Hint SSR_plus_zero_left2_T := Resolve (SSR_plus_zero_left2 S T).
+Hint SSR_mult_one_left_T := Resolve (SSR_mult_one_left T).
+Hint SSR_mult_one_left2_T := Resolve (SSR_mult_one_left2 S T).
+Hint SSR_mult_zero_left_T := Resolve (SSR_mult_zero_left T).
+Hint SSR_mult_zero_left2_T := Resolve (SSR_mult_zero_left2 S T).
+Hint SSR_distr_left_T := Resolve (SSR_distr_left T).
+Hint SSR_distr_left2_T := Resolve (SSR_distr_left2 S T).
+Hint SSR_plus_reg_left_T := Resolve (SSR_plus_reg_left T).
+Hint SSR_plus_permute_T := Resolve (SSR_plus_permute S plus_morph T).
+Hint SSR_mult_permute_T := Resolve (SSR_mult_permute S mult_morph T).
+Hint SSR_distr_right_T := Resolve (SSR_distr_right S plus_morph T).
+Hint SSR_distr_right2_T := Resolve (SSR_distr_right2 S plus_morph T).
+Hint SSR_mult_zero_right_T := Resolve (SSR_mult_zero_right S T).
+Hint SSR_mult_zero_right2_T := Resolve (SSR_mult_zero_right2 S T).
+Hint SSR_plus_zero_right_T := Resolve (SSR_plus_zero_right S T).
+Hint SSR_plus_zero_right2_T := Resolve (SSR_plus_zero_right2 S T).
+Hint SSR_mult_one_right_T := Resolve (SSR_mult_one_right S T).
+Hint SSR_mult_one_right2_T := Resolve (SSR_mult_one_right2 S T).
+Hint SSR_plus_reg_right_T := Resolve (SSR_plus_reg_right S T).
+Hints Resolve refl_equal sym_equal trans_equal.
+(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
+Hints Immediate T.
+
+Lemma varlist_eq_prop : (x,y:varlist)
+  (Is_true (varlist_eq x y))->x==y.
+Proof.
+  Induction x; Induction y; Contradiction Orelse Try Reflexivity.
+  Simpl; Intros.
+  Generalize (andb_prop2 ? ? H1); Intros; Elim H2; Intros.
+  Rewrite (index_eq_prop H3); Rewrite (H v0 H4); Reflexivity.
+Save.
+
+Remark ivl_aux_ok : (v:varlist)(i:index)
+  (Aequiv (ivl_aux i v) (Amult (interp_var i) (interp_vl v))).
+Proof.
+  Induction v; Simpl; Intros.
+  Trivial.
+  Rewrite (H i); Trivial.
+Save.
+
+Lemma varlist_merge_ok : (x,y:varlist)
+  (Aequiv (interp_vl (varlist_merge x y)) (Amult (interp_vl x) (interp_vl y))).
+Proof.
+  Induction x.
+  Simpl; Trivial.
+  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
+                    {vm_aux [l2:varlist] : varlist :=
+                       Cases (l2) of
+                         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.
+Save.
+
+Remark ics_aux_ok : (x:A)(s:canonical_sum)
+  (Aequiv (ics_aux x s) (Aplus x (interp_setcs s))).
+Proof.
+ Induction s; Simpl; Intros;Trivial.
+Save.
+
+Remark interp_m_ok : (x:A)(l:varlist)
+  (Aequiv (interp_m x l) (Amult x (interp_vl l))).
+Proof.
+  NewDestruct l;Trivial.
+Save.
+
+Hint ivl_aux_ok_ := Resolve ivl_aux_ok.
+Hint ics_aux_ok_ := Resolve ics_aux_ok.
+Hint interp_m_ok_ := Resolve interp_m_ok.
+
+(* Hints Resolve ivl_aux_ok ics_aux_ok interp_m_ok. *)
+
+Lemma canonical_sum_merge_ok : (x,y:canonical_sum)
+  (Aequiv (interp_setcs (canonical_sum_merge x y))
+  (Aplus (interp_setcs x) (interp_setcs y))).
+Proof.
+Induction x; Simpl.
+Trivial.
+
+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))).
+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)))).
+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)))).
+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
+                    {csm_aux [s2:canonical_sum] : canonical_sum :=
+                       Cases (s2) of
+                         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))).
+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)))).
+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)))).
+Setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0).
+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
+                    {csm_aux [s2:canonical_sum] : canonical_sum :=
+                       Cases (s2) of
+                         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.
+
+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)));
+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))));
+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)))).
+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
+                    {csm_aux2 [s2:canonical_sum] : canonical_sum :=
+                       Cases (s2) of
+                         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)));
+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))));
+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)))).
+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
+                    {csm_aux2 [s2:canonical_sum] : canonical_sum :=
+                       Cases (s2) of
+                         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.
+Save.
+
+Lemma monom_insert_ok: (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.
+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))).
+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))).
+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) (monom_insert a l c));
+Rewrite H.
+Rewrite (ics_aux_ok (interp_vl v) c); Auto.
+Save.
+
+Lemma varlist_insert_ok :
+ (l:varlist)(s:canonical_sum)
+ (Aequiv (interp_setcs (varlist_insert l s)) 
+   (Aplus (interp_vl l) (interp_setcs s))).
+Proof.
+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))).
+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))).
+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.
+Save.
+
+Lemma canonical_sum_scalar_ok : (a:A)(s:canonical_sum)
+  (Aequiv (interp_setcs (canonical_sum_scalar a s)) (Amult a (interp_setcs s))).
+Proof.
+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))).
+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.
+Save.
+
+Lemma canonical_sum_scalar2_ok : (l:varlist; s:canonical_sum)
+  (Aequiv (interp_setcs (canonical_sum_scalar2 l s)) (Amult (interp_vl l) (interp_setcs s))).
+Proof.
+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))).
+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.
+Save.
+
+Lemma canonical_sum_scalar3_ok : (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.
+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))).
+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)))).
+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)))).
+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)))).
+Auto.
+Save.
+
+Lemma canonical_sum_prod_ok : (x,y:canonical_sum)
+  (Aequiv (interp_setcs (canonical_sum_prod x y)) (Amult (interp_setcs x) (interp_setcs y))).
+Proof.
+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)).
+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))).
+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.
+Save.
+
+Theorem setspolynomial_normalize_ok : (p:setspolynomial)
+  (Aequiv (interp_setcs (setspolynomial_normalize p)) (interp_setsp p)).
+Proof.
+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.
+Save.
+
+Lemma canonical_sum_simplify_ok : (s:canonical_sum)
+  (Aequiv (interp_setcs (canonical_sum_simplify s)) (interp_setcs s)).
+Proof.
+Induction s; Simpl; Intros.
+Trivial.
+
+Generalize (SSR_eq_prop T 9!a 10!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.
+Rewrite H.
+Trivial.
+
+Intros; Simpl.
+Generalize (SSR_eq_prop T 9!a 10!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.
+Save.
+
+Theorem setspolynomial_simplify_ok : (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).
+Save.
+
+End semi_setoid_rings.
+
+Implicits Cons_varlist.
+Implicits Cons_monom.
+Implicits SetSPconst.
+Implicits SetSPplus.
+Implicits SetSPmult.
+
+
+
+Section setoid_rings.
+
+Set Implicit Arguments.
+
+Variable vm : (varmap A).
+Variable T : (Setoid_Ring_Theory Aequiv Aplus Amult Aone Azero Aopp Aeq).
+
+Hint STh_plus_sym_T := Resolve (STh_plus_sym T).
+Hint STh_plus_assoc_T := Resolve (STh_plus_assoc T).
+Hint STh_plus_assoc2_T := Resolve (STh_plus_assoc2 S T).
+Hint STh_mult_sym_T := Resolve (STh_mult_sym T).
+Hint STh_mult_assoc_T := Resolve (STh_mult_assoc T).
+Hint STh_mult_assoc2_T := Resolve (STh_mult_assoc2 S T).
+Hint STh_plus_zero_left_T := Resolve (STh_plus_zero_left T).
+Hint STh_plus_zero_left2_T := Resolve (STh_plus_zero_left2 S T).
+Hint STh_mult_one_left_T := Resolve (STh_mult_one_left T).
+Hint STh_mult_one_left2_T := Resolve (STh_mult_one_left2 S T).
+Hint STh_mult_zero_left_T := Resolve (STh_mult_zero_left S plus_morph mult_morph T).
+Hint STh_mult_zero_left2_T := Resolve (STh_mult_zero_left2 S plus_morph mult_morph T).
+Hint STh_distr_left_T := Resolve (STh_distr_left T).
+Hint STh_distr_left2_T := Resolve (STh_distr_left2 S T).
+Hint STh_plus_reg_left_T := Resolve (STh_plus_reg_left S plus_morph T).
+Hint STh_plus_permute_T := Resolve (STh_plus_permute S plus_morph T).
+Hint STh_mult_permute_T := Resolve (STh_mult_permute S mult_morph T).
+Hint STh_distr_right_T := Resolve (STh_distr_right S plus_morph T).
+Hint STh_distr_right2_T := Resolve (STh_distr_right2 S plus_morph T).
+Hint STh_mult_zero_right_T := Resolve (STh_mult_zero_right S plus_morph mult_morph T).
+Hint STh_mult_zero_right2_T := Resolve (STh_mult_zero_right2 S plus_morph mult_morph T).
+Hint STh_plus_zero_right_T := Resolve (STh_plus_zero_right S T).
+Hint STh_plus_zero_right2_T := Resolve (STh_plus_zero_right2 S T).
+Hint STh_mult_one_right_T := Resolve (STh_mult_one_right S T).
+Hint STh_mult_one_right2_T := Resolve (STh_mult_one_right2 S T).
+Hint STh_plus_reg_right_T := Resolve (STh_plus_reg_right S plus_morph T).
+Hints Resolve refl_equal sym_equal trans_equal.
+(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
+Hints Immediate T.
+
+
+(*** Definitions *)
+
+Inductive Type setpolynomial := 
+  SetPvar : index -> setpolynomial
+| SetPconst : A -> setpolynomial
+| SetPplus : setpolynomial -> setpolynomial -> setpolynomial
+| SetPmult : setpolynomial -> setpolynomial -> setpolynomial
+| SetPopp : setpolynomial -> setpolynomial.
+
+Fixpoint setpolynomial_normalize [x:setpolynomial] : canonical_sum :=
+ Cases x of
+ | (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 :=
+ Cases x of 
+ | (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 :=
+ Cases p of
+ | (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 : (p:setpolynomial)
+ (Aequiv (interp_setp p) (interp_setsp vm (setspolynomial_of p))).
+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.
+Save.
+
+Theorem setpolynomial_normalize_ok : (p:setpolynomial)
+ (setpolynomial_normalize p)
+  ==(setspolynomial_normalize (setspolynomial_of p)).
+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 ].
+Save.
+
+Theorem setpolynomial_simplify_ok : (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.
+Save.
+
+End setoid_rings.
+
+End setoid.
diff --git a/contrib7/ring/Setoid_ring_theory.v b/contrib7/ring/Setoid_ring_theory.v
new file mode 100644
index 0000000000..d6c19410f2
--- /dev/null
+++ b/contrib7/ring/Setoid_ring_theory.v
@@ -0,0 +1,429 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+Require Export Bool.
+Require Export Setoid.
+
+Set Implicit Arguments.
+
+Section Setoid_rings.
+
+Variable A : Type.
+Variable Aequiv : A -> A -> Prop.
+
+Infix Local "==" Aequiv (at level 5, no associativity).
+
+Variable S : (Setoid_Theory A Aequiv).
+
+Add Setoid A Aequiv S.
+
+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.
+
+Infix 4 "+" Aplus V8only 50 (left associativity).
+Infix 4 "*" Amult V8only 40 (left associativity).
+Notation "0" := Azero.
+Notation "1" := Aone.
+Notation "- x" := (Aopp x) (at level 0) V8only.
+
+Variable plus_morph : (a,a0,a1,a2:A) a == a0 -> a1 == a2 -> a+a1 == a0+a2.
+Variable mult_morph : (a,a0,a1,a2:A) a == a0 -> a1 == a2 -> a*a1 == a0*a2.
+Variable opp_morph : (a,a0:A) a == a0 -> -a == -a0.
+
+Add Morphism Aplus : Aplus_ext.
+Exact plus_morph.
+Save.
+
+Add Morphism Amult : Amult_ext.
+Exact mult_morph.
+Save.
+
+Add Morphism Aopp : Aopp_ext.
+Exact opp_morph.
+Save.
+
+Section Theory_of_semi_setoid_rings.
+
+Record Semi_Setoid_Ring_Theory : Prop :=
+{ SSR_plus_sym  : (n,m:A) n + m == m + n;
+  SSR_plus_assoc : (n,m,p:A) n + (m + p) == (n + m) + p;
+  SSR_mult_sym : (n,m:A) n*m == m*n;
+  SSR_mult_assoc : (n,m,p:A) n*(m*p) == (n*m)*p;
+  SSR_plus_zero_left :(n:A) 0 + n == n;
+  SSR_mult_one_left : (n:A) 1*n == n;
+  SSR_mult_zero_left : (n:A) 0*n == 0;
+  SSR_distr_left : (n,m,p:A) (n + m)*p == n*p + m*p;
+  SSR_plus_reg_left : (n,m,p:A)n + m == n + p -> m == p;
+  SSR_eq_prop : (x,y:A) (Is_true (Aeq x y)) -> x == y
+}.
+
+Variable T : Semi_Setoid_Ring_Theory.
+
+Local plus_sym  := (SSR_plus_sym T).
+Local plus_assoc := (SSR_plus_assoc T).
+Local mult_sym  := ( SSR_mult_sym T).
+Local mult_assoc := (SSR_mult_assoc T).
+Local plus_zero_left := (SSR_plus_zero_left T).
+Local mult_one_left := (SSR_mult_one_left T). 
+Local mult_zero_left := (SSR_mult_zero_left T).
+Local distr_left := (SSR_distr_left T).
+Local plus_reg_left := (SSR_plus_reg_left T).
+Local equiv_refl := (Seq_refl A Aequiv S).
+Local equiv_sym := (Seq_sym A Aequiv S).
+Local equiv_trans := (Seq_trans A Aequiv S).
+
+Hints Resolve plus_sym plus_assoc mult_sym mult_assoc
+  plus_zero_left mult_one_left mult_zero_left distr_left
+  plus_reg_left equiv_refl (*equiv_sym*).
+Hints Immediate equiv_sym.
+
+(* Lemmas whose form is x=y are also provided in form y=x because
+  Auto does not symmetry *) 
+Lemma SSR_mult_assoc2 : (n,m,p:A) (n * m) * p == n * (m * p).
+Auto. Save.
+
+Lemma SSR_plus_assoc2 : (n,m,p:A) (n + m) + p == n + (m + p).
+Auto. Save.
+
+Lemma SSR_plus_zero_left2 : (n:A) n == 0 + n.
+Auto. Save.
+
+Lemma SSR_mult_one_left2 : (n:A) n == 1*n.
+Auto. Save.
+
+Lemma SSR_mult_zero_left2 : (n:A) 0 == 0*n.
+Auto. Save.
+
+Lemma SSR_distr_left2 : (n,m,p:A) n*p + m*p  == (n + m)*p.
+Auto. Save.
+
+Lemma SSR_plus_permute : (n,m,p:A) n+(m+p) == m+(n+p).
+Intros.
+Rewrite (plus_assoc n m p).
+Rewrite (plus_sym n m).
+Rewrite <- (plus_assoc m n p).
+Trivial.
+Save.
+
+Lemma SSR_mult_permute : (n,m,p:A) n*(m*p) == m*(n*p).
+Intros.
+Rewrite (mult_assoc n m p).
+Rewrite (mult_sym n m).
+Rewrite <- (mult_assoc m n p).
+Trivial.
+Save.
+
+Hints Resolve SSR_plus_permute SSR_mult_permute.
+
+Lemma SSR_distr_right : (n,m,p:A) n*(m+p) == (n*m) + (n*p).
+Intros.
+Rewrite (mult_sym n (Aplus m p)).
+Rewrite (mult_sym n m).
+Rewrite (mult_sym n p).
+Auto.
+Save.
+
+Lemma SSR_distr_right2 : (n,m,p:A) (n*m) + (n*p) == n*(m + p).
+Intros.
+Apply equiv_sym.
+Apply SSR_distr_right.
+Save.
+
+Lemma SSR_mult_zero_right : (n:A) n*0 == 0.
+Intro; Rewrite (mult_sym n Azero); Auto.
+Save.
+
+Lemma SSR_mult_zero_right2 : (n:A) 0 == n*0.
+Intro; Rewrite (mult_sym n Azero); Auto.
+Save.
+
+Lemma SSR_plus_zero_right :(n:A) n + 0 == n.
+Intro; Rewrite (plus_sym n Azero); Auto.
+Save.
+
+Lemma SSR_plus_zero_right2 :(n:A) n == n + 0.
+Intro; Rewrite (plus_sym n Azero); Auto.
+Save.
+
+Lemma SSR_mult_one_right : (n:A) n*1 == n.
+Intro; Rewrite (mult_sym n Aone); Auto.
+Save.
+
+Lemma SSR_mult_one_right2 : (n:A) n == n*1.
+Intro; Rewrite (mult_sym n Aone); Auto.
+Save.
+
+Lemma SSR_plus_reg_right : (n,m,p:A) m+n == p+n -> m==p.
+Intros n m p; Rewrite (plus_sym m n); Rewrite (plus_sym p n).
+Intro; Apply plus_reg_left with n; Trivial.
+Save.
+
+End Theory_of_semi_setoid_rings.
+
+Section Theory_of_setoid_rings.
+
+Record Setoid_Ring_Theory : Prop :=
+{ STh_plus_sym  : (n,m:A) n + m == m + n;
+  STh_plus_assoc : (n,m,p:A) n + (m + p) == (n + m) + p;
+  STh_mult_sym : (n,m:A) n*m == m*n;
+  STh_mult_assoc : (n,m,p:A) n*(m*p) == (n*m)*p;
+  STh_plus_zero_left :(n:A) 0 + n == n;
+  STh_mult_one_left : (n:A) 1*n == n;
+  STh_opp_def : (n:A)  n + (-n) == 0;
+  STh_distr_left : (n,m,p:A) (n + m)*p == n*p + m*p;
+  STh_eq_prop : (x,y:A) (Is_true (Aeq x y)) -> x == y
+}.
+
+Variable T : Setoid_Ring_Theory.
+
+Local plus_sym  := (STh_plus_sym T).
+Local plus_assoc := (STh_plus_assoc T).
+Local mult_sym  := (STh_mult_sym T).
+Local mult_assoc := (STh_mult_assoc T).
+Local plus_zero_left := (STh_plus_zero_left T).
+Local mult_one_left := (STh_mult_one_left T). 
+Local opp_def := (STh_opp_def T).
+Local distr_left := (STh_distr_left T).
+Local equiv_refl := (Seq_refl A Aequiv S).
+Local equiv_sym := (Seq_sym A Aequiv S).
+Local equiv_trans := (Seq_trans A Aequiv S).
+
+Hints Resolve plus_sym plus_assoc mult_sym mult_assoc
+  plus_zero_left mult_one_left opp_def distr_left
+  equiv_refl equiv_sym.
+
+(* Lemmas whose form is x=y are also provided in form y=x because Auto does
+  not symmetry *)
+
+Lemma STh_mult_assoc2 : (n,m,p:A) (n * m) * p == n * (m * p).
+Auto. Save.
+
+Lemma STh_plus_assoc2 : (n,m,p:A) (n + m) + p == n + (m + p).
+Auto. Save.
+
+Lemma STh_plus_zero_left2 : (n:A) n == 0 + n.
+Auto. Save.
+
+Lemma STh_mult_one_left2 : (n:A) n == 1*n.
+Auto. Save.
+
+Lemma STh_distr_left2 : (n,m,p:A) n*p + m*p  == (n + m)*p.
+Auto. Save.
+
+Lemma STh_opp_def2 : (n:A) 0 == n + (-n).
+Auto. Save.
+
+Lemma STh_plus_permute : (n,m,p:A) n + (m + p) == m + (n + p).
+Intros.
+Rewrite (plus_assoc n m p).
+Rewrite (plus_sym n m).
+Rewrite <- (plus_assoc m n p).
+Trivial.
+Save.
+
+Lemma STh_mult_permute : (n,m,p:A) n*(m*p) == m*(n*p).
+Intros.
+Rewrite (mult_assoc n m p).
+Rewrite (mult_sym n m).
+Rewrite <- (mult_assoc m n p).
+Trivial.
+Save.
+
+Hints Resolve STh_plus_permute STh_mult_permute.
+
+Lemma Saux1 : (a:A)  a + a == a -> a == 0.
+Intros.
+Rewrite <- (plus_zero_left a).
+Rewrite (plus_sym Azero a).
+Setoid_replace (Aplus a Azero) with (Aplus a (Aplus a (Aopp a))); Auto.
+Rewrite (plus_assoc a a (Aopp a)).
+Rewrite H.
+Apply opp_def.
+Save.
+
+Lemma STh_mult_zero_left :(n:A) 0*n == 0.
+Intros.
+Apply Saux1.
+Rewrite <- (distr_left Azero Azero n).
+Rewrite (plus_zero_left Azero).
+Trivial.
+Save.
+Hints Resolve STh_mult_zero_left.
+
+Lemma STh_mult_zero_left2 : (n:A) 0 == 0*n.
+Auto.
+Save.
+
+Lemma Saux2 : (x,y,z:A) x+y==0 -> x+z==0 -> y == z.
+Intros.
+Rewrite <- (plus_zero_left y).
+Rewrite <- H0.
+Rewrite <- (plus_assoc x z y).
+Rewrite (plus_sym z y).
+Rewrite (plus_assoc x y z).
+Rewrite H.
+Auto.
+Save.
+
+Lemma STh_opp_mult_left : (x,y:A) -(x*y) == (-x)*y.
+Intros.
+Apply Saux2 with (Amult x y); Auto.
+Rewrite <- (distr_left x (Aopp x) y).
+Rewrite (opp_def x).
+Auto.
+Save.
+Hints Resolve STh_opp_mult_left.
+
+Lemma STh_opp_mult_left2 : (x,y:A) (-x)*y == -(x*y) .
+Auto.
+Save.
+
+Lemma STh_mult_zero_right : (n:A) n*0 == 0.
+Intro; Rewrite (mult_sym n Azero); Auto.
+Save.
+
+Lemma STh_mult_zero_right2 : (n:A) 0 == n*0.
+Intro; Rewrite (mult_sym n Azero); Auto.
+Save.
+
+Lemma STh_plus_zero_right :(n:A) n + 0 == n.
+Intro; Rewrite (plus_sym n Azero); Auto.
+Save.
+
+Lemma STh_plus_zero_right2 :(n:A) n == n + 0.
+Intro; Rewrite (plus_sym n Azero); Auto.
+Save.
+
+Lemma STh_mult_one_right : (n:A) n*1 == n.
+Intro; Rewrite (mult_sym n Aone); Auto.
+Save.
+
+Lemma STh_mult_one_right2  : (n:A) n == n*1.
+Intro; Rewrite (mult_sym n Aone); Auto.
+Save.
+
+Lemma STh_opp_mult_right : (x,y:A) -(x*y) == x*(-y).
+Intros.
+Rewrite (mult_sym x y).
+Rewrite (mult_sym x (Aopp y)).
+Auto.
+Save.
+
+Lemma STh_opp_mult_right2 : (x,y:A) x*(-y) == -(x*y).
+Intros.
+Rewrite (mult_sym x y).
+Rewrite (mult_sym x (Aopp y)).
+Auto.
+Save.
+
+Lemma STh_plus_opp_opp : (x,y:A) (-x) + (-y) == -(x+y).
+Intros.
+Apply Saux2 with (Aplus x y); Auto.
+Rewrite (STh_plus_permute (Aplus x y) (Aopp x) (Aopp y)).
+Rewrite <- (plus_assoc x y (Aopp y)).
+Rewrite (opp_def y); Rewrite (STh_plus_zero_right x).
+Rewrite (STh_opp_def2 x); Trivial.
+Save.
+
+Lemma STh_plus_permute_opp: (n,m,p:A) (-m)+(n+p) == n+((-m)+p).
+Auto.
+Save.
+
+Lemma STh_opp_opp : (n:A) -(-n) == n.
+Intro.
+Apply Saux2 with (Aopp n); Auto.
+Rewrite (plus_sym (Aopp n) n); Auto.
+Save.
+Hints Resolve STh_opp_opp.
+
+Lemma STh_opp_opp2 : (n:A) n == -(-n).
+Auto.
+Save.
+
+Lemma STh_mult_opp_opp : (x,y:A) (-x)*(-y) == x*y.
+Intros.
+Rewrite (STh_opp_mult_left2 x (Aopp y)).
+Rewrite (STh_opp_mult_right2 x y).
+Trivial.
+Save.
+
+Lemma STh_mult_opp_opp2 : (x,y:A) x*y == (-x)*(-y).
+Intros.
+Apply equiv_sym.
+Apply STh_mult_opp_opp.
+Save.
+
+Lemma STh_opp_zero : -0 == 0.
+Rewrite <- (plus_zero_left (Aopp Azero)).
+Trivial.
+Save.
+
+Lemma STh_plus_reg_left : (n,m,p:A) n+m == n+p -> m==p.
+Intros.
+Rewrite <- (plus_zero_left m).
+Rewrite <- (plus_zero_left p).
+Rewrite <- (opp_def n).
+Rewrite (plus_sym n (Aopp n)).
+Rewrite <- (plus_assoc (Aopp n) n m).
+Rewrite <- (plus_assoc (Aopp n) n p).
+Auto.
+Save.
+
+Lemma STh_plus_reg_right : (n,m,p:A) m+n == p+n -> m==p.
+Intros.
+Apply STh_plus_reg_left with n.
+Rewrite (plus_sym n m); Rewrite (plus_sym n p);
+Assumption.
+Save.
+
+Lemma STh_distr_right : (n,m,p:A) n*(m+p) == (n*m)+(n*p).
+Intros.
+Rewrite (mult_sym n (Aplus m p)).
+Rewrite (mult_sym n m).
+Rewrite (mult_sym n p).
+Trivial.
+Save.
+
+Lemma STh_distr_right2 : (n,m,p:A) (n*m)+(n*p) == n*(m+p).
+Intros.
+Apply equiv_sym.
+Apply STh_distr_right.
+Save.
+
+End Theory_of_setoid_rings.
+
+Hints Resolve STh_mult_zero_left STh_plus_reg_left : core.
+
+Unset Implicit Arguments.
+
+Definition Semi_Setoid_Ring_Theory_of :
+  Setoid_Ring_Theory -> Semi_Setoid_Ring_Theory.
+Intros until 1; Case H.
+Split; Intros; Simpl; EAuto.
+Defined.
+
+Coercion Semi_Setoid_Ring_Theory_of :
+  Setoid_Ring_Theory >-> Semi_Setoid_Ring_Theory.
+
+
+
+Section product_ring.
+
+End product_ring.
+
+Section power_ring.
+
+End power_ring.
+
+End Setoid_rings.
diff --git a/contrib7/ring/ZArithRing.v b/contrib7/ring/ZArithRing.v
new file mode 100644
index 0000000000..cf5e18c5ea
--- /dev/null
+++ b/contrib7/ring/ZArithRing.v
@@ -0,0 +1,35 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Instantiation of the Ring tactic for the binary integers of ZArith *)
+
+Require Export ArithRing.
+Require Export ZArith_base.
+Require Eqdep_dec.
+
+Definition Zeq := [x,y:Z]
+  Cases `x ?= y ` of
+    EGAL => true
+  | _ => false
+  end.
+
+Lemma Zeq_prop : (x,y:Z)(Is_true (Zeq x y)) -> x==y.
+  Intros x y H; Unfold Zeq in H.
+  Apply Zcompare_EGAL_eq.
+  NewDestruct (Zcompare x y); [Reflexivity | Contradiction | Contradiction ].
+Save.
+
+Definition ZTheory : (Ring_Theory Zplus Zmult `1` `0` Zopp Zeq).
+  Split; Intros; Apply eq2eqT; EAuto with zarith.
+  Apply eqT2eq; Apply Zeq_prop; Assumption.
+Save.
+
+(* NatConstants and NatTheory are defined in Ring_theory.v *)
+Add Ring Z Zplus Zmult `1` `0` Zopp Zeq ZTheory [POS NEG ZERO xO xI xH].
diff --git a/contrib7/romega/.cvsignore b/contrib7/romega/.cvsignore
new file mode 100644
index 0000000000..c446fcb878
--- /dev/null
+++ b/contrib7/romega/.cvsignore
@@ -0,0 +1 @@
+*.v8
diff --git a/contrib7/romega/ROmega.v b/contrib7/romega/ROmega.v
new file mode 100644
index 0000000000..ba02b232e0
--- /dev/null
+++ b/contrib7/romega/ROmega.v
@@ -0,0 +1,10 @@
+(*************************************************************************
+
+   PROJET RNRT Calife - 2001
+   Author: Pierre Crégut - France Télécom R&D
+   Licence : LGPL version 2.1
+
+ *************************************************************************)
+
+Require Omega.
+Require ReflOmegaCore.
diff --git a/contrib7/romega/ReflOmegaCore.v b/contrib7/romega/ReflOmegaCore.v
new file mode 100644
index 0000000000..fa49badbf3
--- /dev/null
+++ b/contrib7/romega/ReflOmegaCore.v
@@ -0,0 +1,1959 @@
+(*************************************************************************
+
+   PROJET RNRT Calife - 2001
+   Author: Pierre Crégut - France Télécom R&D
+   Licence : LGPL version 2.1
+
+ *************************************************************************)
+
+Require Arith.
+Require PolyList.
+Require Bool.
+Require ZArith_base.
+Require OmegaLemmas.
+
+(* \subsection{Définition des types} *)
+
+(* \subsubsection{Définition des termes dans Z réifiés}
+   Les termes comprennent les entiers relatifs [Tint] et les 
+   variables [Tvar] ainsi que les opérations de base sur Z (addition,
+   multiplication, opposé et soustraction). Les deux denières sont
+   rapidement traduites dans les deux premières durant la normalisation
+   des termes. *)
+
+Inductive term : Set :=
+   Tint : Z -> term
+ | Tplus : term -> term -> term
+ | Tmult : term -> term -> term
+ | Tminus : term -> term -> term
+ | Topp : term -> term
+ | Tvar : nat -> term
+.
+
+(* \subsubsection{Définition des buts réifiés} *)
+(* Définition très restreinte des prédicats manipulés (à enrichir). 
+   La prise en compte des négations et des diséquations demande la
+   prise en compte de la résolution en parallèle de plusieurs buts.
+   Ceci n'est possible qu'en modifiant de manière drastique la définition
+   de normalize qui doit pouvoir générer des listes de buts. Il faut
+   donc aussi modifier la normalisation qui peut elle aussi amener la
+   génération d'une liste de but et donc l'application d'une liste de
+   tactiques de résolution ([execute_omega])  *)
+Inductive proposition : Set :=
+  EqTerm : term -> term -> proposition
+| LeqTerm : term -> term -> proposition
+| TrueTerm : proposition
+| FalseTerm : proposition
+| Tnot : proposition -> proposition
+| GeqTerm : term -> term -> proposition
+| GtTerm : term -> term -> proposition
+| LtTerm : term -> term -> proposition
+| NeqTerm: term -> term -> proposition.
+
+(* Définition des hypothèses *)
+Notation hyps := (list proposition).      
+
+Definition absurd := (cons FalseTerm (nil proposition)).
+
+(* \subsubsection{Traces de fusion d'équations} *)
+
+Inductive t_fusion : Set :=
+    F_equal : t_fusion | F_cancel : t_fusion
+  | F_left : t_fusion  | F_right : t_fusion.
+
+(* \subsection{Egalité décidable efficace} *)
+(* Pour chaque type de donnée réifié, on calcule un test d'égalité efficace.
+   Ce n'est pas le cas de celui rendu par [Decide Equality].
+   
+   Puis on prouve deux théorèmes permettant d'éliminer de telles égalités :
+   \begin{verbatim}
+   (t1,t2: typ) (eq_typ t1 t2) = true -> t1 = t2.
+   (t1,t2: typ) (eq_typ t1 t2) = false -> ~ t1 = t2.
+   \end{verbatim} *)
+
+(* Ces deux tactiques permettent de résoudre pas mal de cas. L'une pour
+   les théorèmes positifs, l'autre pour les théorèmes négatifs *)
+
+Tactic Definition absurd_case := Simpl; Intros; Discriminate.
+Tactic Definition trivial_case := Unfold not; Intros; Discriminate.
+
+(* \subsubsection{Entiers naturels} *)
+
+Fixpoint eq_nat [t1,t2: nat] : bool := 
+  Cases t1 of
+    O => Cases t2 of O => true | _ => false end
+  | (S n1)=> Cases t2 of O => false | (S n2)  => (eq_nat n1 n2) end
+  end.
+
+Theorem eq_nat_true : (t1,t2: nat) (eq_nat t1 t2) = true -> t1 = t2.
+
+Induction t1; [
+  Intro t2; Case t2; [ Trivial | absurd_case ]
+| Intros n H t2; Case t2; 
+    [ absurd_case |  Simpl; Intros; Rewrite (H n0); [ Trivial | Assumption]]].
+
+Save.
+  
+Theorem eq_nat_false : (t1,t2: nat) (eq_nat t1 t2) = false -> ~t1 = t2.
+
+Induction t1; [
+  Intro t2; Case t2;
+   [ Simpl;Intros; Discriminate | trivial_case ]
+| Intros n H t2; Case t2; Simpl; Unfold not; Intros; [
+    Discriminate
+  | Elim (H n0 H0); Simplify_eq H1; Trivial]].
+
+Save.
+                                   
+
+(* \subsubsection{Entiers positifs} *)
+
+Fixpoint eq_pos [p1,p2 : positive] : bool := 
+  Cases p1 of
+    (xI n1) => Cases p2 of (xI n2) => (eq_pos n1 n2) | _ => false end
+  | (xO n1) =>  Cases p2 of (xO n2) => (eq_pos n1 n2) | _ => false end
+  | xH =>  Cases p2 of xH => true | _ => false end
+  end.
+
+Theorem eq_pos_true : (t1,t2: positive) (eq_pos t1 t2) = true -> t1 = t2.
+
+Induction t1; [
+  Intros p H t2; Case t2; [
+    Simpl; Intros; Rewrite (H p0 H0); Trivial | absurd_case | absurd_case ]
+| Intros p H t2; Case t2; [
+    absurd_case | Simpl; Intros; Rewrite (H p0 H0); Trivial | absurd_case ]
+| Intro t2; Case t2; [ absurd_case | absurd_case | Auto ]].
+
+Save.
+  
+Theorem eq_pos_false : (t1,t2: positive) (eq_pos t1 t2) = false -> ~t1 = t2.
+
+Induction t1; [
+  Intros p H t2; Case t2; [
+    Simpl; Unfold not; Intros; Elim (H p0 H0); Simplify_eq H1; Auto
+  | trivial_case | trivial_case ]
+| Intros p H t2; Case t2; [
+    trivial_case 
+  | Simpl; Unfold not; Intros; Elim (H p0 H0); Simplify_eq H1; Auto
+  | trivial_case ]
+| Intros t2; Case t2; [ trivial_case | trivial_case  | absurd_case ]].
+Save.
+
+(* \subsubsection{Entiers relatifs} *)
+
+Definition eq_Z [z1,z2: Z] : bool :=
+  Cases z1 of
+     ZERO     => Cases z2 of ZERO => true | _ => false end
+   | (POS p1) => Cases z2 of (POS p2) => (eq_pos p1 p2) | _ => false end
+   | (NEG p1) => Cases z2 of (NEG p2) => (eq_pos p1 p2) | _ => false end
+  end.
+
+Theorem eq_Z_true : (t1,t2: Z) (eq_Z t1 t2) = true -> t1 = t2.
+
+Induction t1; [
+  Intros t2; Case t2; [ Auto | absurd_case | absurd_case ]
+| Intros p t2; Case t2; [
+    absurd_case | Simpl; Intros; Rewrite (eq_pos_true p p0 H); Trivial 
+  | absurd_case ]
+| Intros p t2; Case t2; [
+    absurd_case | absurd_case
+  | Simpl; Intros; Rewrite (eq_pos_true p p0 H); Trivial ]].
+
+Save.
+
+Theorem eq_Z_false : (t1,t2: Z) (eq_Z t1 t2) = false -> ~(t1 = t2).
+
+Induction t1; [
+  Intros t2; Case t2; [ absurd_case | trivial_case | trivial_case ]
+| Intros p t2; Case t2; [
+    absurd_case
+  | Simpl; Unfold not; Intros; Elim (eq_pos_false p p0 H); Simplify_eq H0; Auto
+  | trivial_case ]
+| Intros p t2; Case t2; [
+    absurd_case | trivial_case 
+  | Simpl; Unfold not; Intros; Elim (eq_pos_false p p0 H); 
+    Simplify_eq H0; Auto]].
+Save.
+
+(* \subsubsection{Termes réifiés} *)
+
+Fixpoint eq_term [t1,t2: term] : bool := 
+   Cases t1 of
+      (Tint st1) =>
+         Cases t2 of (Tint st2) => (eq_Z st1 st2) | _ => false end
+    | (Tplus st11 st12) =>
+         Cases t2 of
+            (Tplus st21 st22) => 
+               (andb (eq_term st11 st21) (eq_term st12 st22))
+         | _ => false 
+         end
+    | (Tmult st11 st12) =>
+         Cases t2 of
+            (Tmult st21 st22) => 
+               (andb (eq_term st11 st21) (eq_term st12 st22))
+         | _ => false 
+         end
+    | (Tminus st11 st12) =>
+         Cases t2 of
+            (Tminus st21 st22) => 
+               (andb (eq_term st11 st21) (eq_term st12 st22))
+         | _ => false 
+         end
+    | (Topp st1) =>
+         Cases t2 of (Topp st2) => (eq_term st1 st2) | _ => false end
+    | (Tvar st1) =>
+         Cases t2 of (Tvar st2) => (eq_nat st1 st2) | _ => false end
+   end.  
+
+Theorem eq_term_true : (t1,t2: term) (eq_term t1 t2) = true -> t1 = t2.
+
+
+Induction t1; Intros until t2; Case t2; Try absurd_case; Simpl; [
+  Intros; Elim eq_Z_true with 1 := H; Trivial
+| Intros t21 t22 H3; Elim andb_prop with 1:= H3; Intros H4 H5; 
+  Elim H with 1 := H4; Elim H0 with 1 := H5; Trivial
+| Intros t21 t22 H3; Elim andb_prop with 1:= H3; Intros H4 H5;
+  Elim H with 1 := H4; Elim H0 with 1 := H5; Trivial
+| Intros t21 t22 H3; Elim andb_prop with 1:= H3; Intros H4 H5; 
+  Elim H with 1 := H4; Elim H0 with 1 := H5; Trivial
+| Intros t21 H3; Elim H with 1 := H3; Trivial
+| Intros; Elim eq_nat_true with 1 := H; Trivial ].
+
+Save.
+
+Theorem eq_term_false : (t1,t2: term) (eq_term t1 t2) = false -> ~(t1 = t2).
+
+Induction t1; [
+  Intros z t2; Case t2; Try trivial_case; Simpl; Unfold not; Intros;
+  Elim eq_Z_false with 1:=H; Simplify_eq H0; Auto
+| Intros t11 H1 t12 H2 t2; Case t2; Try trivial_case; Simpl; Intros t21 t22 H3;
+  Unfold not; Intro H4; Elim andb_false_elim with 1:= H3; Intros H5; 
+  [ Elim H1 with 1 := H5; Simplify_eq H4; Auto |
+    Elim H2 with 1 := H5; Simplify_eq H4; Auto ]
+| Intros t11 H1 t12 H2 t2; Case t2; Try trivial_case; Simpl; Intros t21 t22 H3;
+  Unfold not; Intro H4; Elim andb_false_elim with 1:= H3; Intros H5; 
+  [ Elim H1 with 1 := H5; Simplify_eq H4; Auto |
+    Elim H2 with 1 := H5; Simplify_eq H4; Auto ]
+| Intros t11 H1 t12 H2 t2; Case t2; Try trivial_case; Simpl; Intros t21 t22 H3;
+  Unfold not; Intro H4; Elim andb_false_elim with 1:= H3; Intros H5; 
+  [ Elim H1 with 1 := H5; Simplify_eq H4; Auto |
+    Elim H2 with 1 := H5; Simplify_eq H4; Auto ]
+| Intros t11 H1 t2; Case t2; Try trivial_case; Simpl; Intros t21 H3;
+  Unfold not; Intro H4; Elim H1 with 1 := H3; Simplify_eq H4; Auto 
+| Intros n t2; Case t2; Try trivial_case; Simpl; Unfold not; Intros;
+  Elim eq_nat_false with 1:=H; Simplify_eq H0; Auto ].
+
+Save.
+
+(* \subsubsection{Tactiques pour éliminer ces tests} 
+
+   Si on se contente de faire un [Case (eq_typ t1 t2)] on perd 
+   totalement dans chaque branche le fait que [t1=t2] ou [~t1=t2].
+
+   Initialement, les développements avaient été réalisés avec les
+   tests rendus par [Decide Equality], c'est à dire un test rendant
+   des termes du type [{t1=t2}+{~t1=t2}]. Faire une élimination sur un 
+   tel test préserve bien l'information voulue mais calculatoirement de
+   telles fonctions sont trop lentes. *)
+
+(* Le théorème suivant permet de garder dans les hypothèses la valeur
+   du booléen lors de l'élimination. *)
+
+Theorem bool_ind2 : 
+   (P:(bool->Prop)) (b:bool)
+     (b = true -> (P true))->
+     (b = false -> (P false)) -> (P b).
+
+Induction b; Auto.
+Save.
+
+(* Les tactiques définies si après se comportent exactement comme si on
+   avait utilisé le test précédent et fait une elimination dessus. *)
+
+Tactic Definition Elim_eq_term t1 t2 :=
+  Pattern (eq_term t1 t2); Apply bool_ind2; Intro Aux; [
+    Generalize (eq_term_true t1 t2 Aux); Clear Aux
+  | Generalize (eq_term_false t1 t2 Aux); Clear Aux ].
+
+Tactic Definition Elim_eq_Z t1 t2 :=
+  Pattern (eq_Z t1 t2); Apply bool_ind2; Intro Aux; [
+    Generalize (eq_Z_true t1 t2 Aux); Clear Aux
+  | Generalize (eq_Z_false t1 t2 Aux); Clear Aux ].
+
+Tactic Definition Elim_eq_pos t1 t2 :=
+  Pattern (eq_pos t1 t2); Apply bool_ind2; Intro Aux; [
+    Generalize (eq_pos_true t1 t2 Aux); Clear Aux
+  | Generalize (eq_pos_false t1 t2 Aux); Clear Aux ].
+
+(* \subsubsection{Comparaison sur Z} *)
+
+(* Sujet très lié au précédent : on introduit la tactique d'élimination
+   avec son théorème *)
+
+Theorem relation_ind2 : 
+   (P:(relation->Prop)) (b:relation)
+     (b = EGAL -> (P EGAL))->
+     (b = INFERIEUR -> (P INFERIEUR))->
+     (b = SUPERIEUR -> (P SUPERIEUR)) -> (P b).
+
+Induction b; Auto.
+Save.
+
+Tactic Definition Elim_Zcompare t1 t2 :=
+  Pattern (Zcompare t1 t2); Apply relation_ind2.
+
+(* \subsection{Interprétations}
+   \subsubsection{Interprétation des termes dans Z} *)
+
+Fixpoint interp_term [env:(list Z); t:term] : Z :=
+  Cases t of
+    (Tint x) => x
+  | (Tplus t1 t2) => (Zplus (interp_term env t1) (interp_term env t2))
+  | (Tmult t1 t2) => (Zmult (interp_term env t1) (interp_term env t2))
+  | (Tminus t1 t2) => (Zminus (interp_term env t1) (interp_term env t2))
+  | (Topp t) => (Zopp (interp_term env t))
+  | (Tvar n) => (nth n env ZERO)
+  end.
+
+(* \subsubsection{Interprétation des prédicats} *) 
+Fixpoint interp_proposition [env: (list Z); p:proposition] : Prop := 
+  Cases p of
+    (EqTerm t1 t2) => ((interp_term env t1) = (interp_term env t2))
+  | (LeqTerm t1 t2) => `(interp_term env t1) <= (interp_term env t2)`
+  | TrueTerm => True
+  | FalseTerm => False
+  | (Tnot p') => ~(interp_proposition env p')
+  | (GeqTerm t1 t2) => `(interp_term env t1) >= (interp_term env t2)`
+  | (GtTerm t1 t2) => `(interp_term env t1) > (interp_term env t2)`
+  | (LtTerm t1 t2) => `(interp_term env t1) < (interp_term env t2)`
+  | (NeqTerm t1 t2) => `(Zne (interp_term env t1) (interp_term env t2))`
+  end.
+
+(* \subsubsection{Inteprétation des listes d'hypothèses}
+   \paragraph{Sous forme de conjonction}
+   Interprétation sous forme d'une conjonction d'hypothèses plus faciles
+   à manipuler individuellement *)
+
+Fixpoint interp_hyps [env : (list Z); l: hyps] : Prop :=
+  Cases l of 
+     nil => True
+   | (cons p' l') => (interp_proposition env p') /\ (interp_hyps env l')
+  end.
+
+(* \paragraph{Sous forme de but}
+   C'est cette interpétation que l'on utilise sur le but (car on utilise
+   [Generalize] et qu'une conjonction est forcément lourde (répétition des
+   types dans les conjonctions intermédiaires) *)
+
+Fixpoint interp_goal [env : (list Z); l: hyps] : Prop :=
+  Cases l of 
+     nil => False
+   | (cons p' l') => (interp_proposition env p') -> (interp_goal env l')
+  end.
+
+(* Les théorèmes qui suivent assurent la correspondance entre les deux
+   interprétations. *)
+
+Theorem goal_to_hyps : 
+  (env : (list Z); l: hyps) 
+     ((interp_hyps env l) -> False) -> (interp_goal env l).
+
+Induction l; [
+  Simpl; Auto
+| Simpl; Intros a l1 H1 H2 H3; Apply H1; Intro H4; Apply H2; Auto ].
+Save.
+
+Theorem hyps_to_goal : 
+  (env : (list Z); l: hyps) 
+     (interp_goal env l) -> ((interp_hyps env l) -> False).
+
+Induction l; Simpl; [
+  Auto
+| Intros; Apply H; Elim H1; Auto ].
+Save.
+      
+(* \subsection{Manipulations sur les hypothèses} *)
+
+(* \subsubsection{Définitions de base de stabilité pour la réflexion} *)
+(* Une opération laisse un terme stable si l'égalité est préservée *)
+Definition term_stable [f: term -> term] :=
+ (e: (list Z); t:term) (interp_term e t) = (interp_term e (f t)).
+
+(* Une opération est valide sur une hypothèse, si l'hypothèse implique le
+   résultat de l'opération. \emph{Attention : cela ne concerne que des 
+   opérations sur les hypothèses et non sur les buts (contravariance)}.
+   On définit la validité pour une opération prenant une ou deux propositions
+   en argument (cela suffit pour omega). *)
+
+Definition valid1 [f: proposition -> proposition] :=
+  (e: (list Z)) (p1: proposition) 
+    (interp_proposition e p1) -> (interp_proposition e (f p1)).
+
+Definition valid2 [f: proposition -> proposition -> proposition] :=
+  (e: (list Z)) (p1,p2: proposition) 
+    (interp_proposition e p1) -> (interp_proposition e p2) ->
+      (interp_proposition e (f p1 p2)).
+
+(* Dans cette notion de validité, la fonction prend directement une 
+   liste de propositions et rend une nouvelle liste de propositions. 
+   On reste contravariant *)
+
+Definition valid_hyps [f: hyps -> hyps] :=
+  (e : (list Z)) (lp: hyps) (interp_hyps e lp) -> (interp_hyps e (f lp)).
+
+(* Enfin ce théorème élimine la contravariance et nous ramène à une 
+   opération sur les buts *)
+
+Theorem valid_goal :
+  (env : (list Z); l: hyps; a : hyps -> hyps) 
+    (valid_hyps a) -> (interp_goal env (a l)) -> (interp_goal env l).
+
+Intros; Apply goal_to_hyps; Intro H1; Apply (hyps_to_goal env (a l) H0);
+Apply H; Assumption.
+Save.
+
+(* \subsubsection{Généralisation à des listes de buts (disjonctions)} *)
+
+Notation lhyps := (list hyps).
+
+Fixpoint interp_list_hyps [env: (list Z); l : lhyps] : Prop :=
+   Cases l of
+      nil => False
+    | (cons h l') => (interp_hyps env h) \/ (interp_list_hyps env l')
+   end.
+
+Fixpoint interp_list_goal [env: (list Z);l : lhyps] : Prop :=
+   Cases l of
+      nil => True
+    | (cons h l') => (interp_goal env h) /\ (interp_list_goal env l')
+   end.
+
+Theorem list_goal_to_hyps : 
+  (env: (list Z); l: lhyps)
+    ((interp_list_hyps env l) -> False) -> (interp_list_goal env l).
+
+Induction l; Simpl; [
+  Auto
+| Intros h1 l1 H H1; Split; [
+    Apply goal_to_hyps; Intro H2; Apply H1; Auto
+  | Apply H; Intro H2; Apply H1; Auto ]].
+Save.
+
+Theorem list_hyps_to_goal : 
+  (env: (list Z); l: lhyps)
+    (interp_list_goal env l) -> ((interp_list_hyps env l) -> False).
+
+Induction l; Simpl; [
+  Auto
+|  Intros h1 l1 H (H1,H2) H3; Elim H3; Intro H4; [
+     Apply hyps_to_goal with 1 := H1; Assumption
+   | Auto ]].
+Save.
+
+Definition valid_list_hyps [f: hyps -> lhyps] :=
+  (e : (list Z)) (lp: hyps) (interp_hyps e lp) -> (interp_list_hyps e (f lp)).
+
+Definition valid_list_goal [f: hyps -> lhyps] :=
+  (e : (list Z)) (lp: hyps) 
+     (interp_list_goal e (f lp)) -> (interp_goal e lp) .
+
+Theorem goal_valid : 
+  (f: hyps -> lhyps) (valid_list_hyps f) -> (valid_list_goal f).
+
+Unfold valid_list_goal; Intros f H e lp H1; Apply goal_to_hyps;
+Intro H2; Apply list_hyps_to_goal with 1:=H1; Apply (H e lp); Assumption.
+Save.
+ 
+Theorem append_valid :
+  (e: (list Z)) (l1,l2:lhyps)
+     (interp_list_hyps e l1) \/ (interp_list_hyps e l2) ->
+     (interp_list_hyps e (app l1 l2)).
+
+Intros e; Induction l1; [
+  Simpl; Intros l2 [H | H]; [ Contradiction | Trivial ]
+| Simpl; Intros h1 t1 HR l2 [[H | H] | H] ;[
+    Auto
+  | Right; Apply (HR l2); Left; Trivial
+  | Right; Apply (HR l2); Right; Trivial ]].
+
+Save.
+
+(* \subsubsection{Opérateurs valides sur les hypothèses} *)
+
+(* Extraire une hypothèse de la liste *)
+Definition nth_hyps [n:nat; l: hyps] := (nth n l TrueTerm).
+
+Theorem nth_valid :
+  (e: (list Z); i:nat; l: hyps) 
+     (interp_hyps e l) -> (interp_proposition e (nth_hyps i l)).
+
+Unfold nth_hyps; Induction i; [
+  Induction l; Simpl; [ Auto | Intros; Elim H0; Auto ]
+| Intros n H; Induction l;
+    [ Simpl; Trivial | Intros; Simpl; Apply H; Elim H1; Auto ]].
+Save.
+
+(* Appliquer une opération (valide) sur deux hypothèses extraites de 
+   la liste et ajouter le résultat à la liste. *)
+Definition apply_oper_2 
+  [i,j : nat; f : proposition -> proposition -> proposition ] :=
+  [l: hyps] (cons (f (nth_hyps i l)  (nth_hyps j l)) l).
+
+Theorem apply_oper_2_valid :
+  (i,j : nat; f : proposition -> proposition -> proposition )
+    (valid2 f) -> (valid_hyps (apply_oper_2 i j f)).
+
+Intros i j f Hf; Unfold apply_oper_2 valid_hyps; Simpl; Intros lp Hlp; Split;
+  [ Apply Hf; Apply nth_valid; Assumption | Assumption].
+Save.
+
+(* Modifier une hypothèse par application d'une opération valide *)
+
+Fixpoint apply_oper_1 [i:nat] : (proposition -> proposition) -> hyps -> hyps :=
+  [f : (proposition -> proposition); l : hyps] 
+    Cases l of 
+       nil => (nil proposition)
+    | (cons p l') =>
+	 Cases i of
+           O => (cons (f p) l')
+         | (S j) => (cons p (apply_oper_1 j f l'))
+         end
+    end.
+
+Theorem apply_oper_1_valid :
+  (i : nat; f : proposition -> proposition )
+    (valid1 f) -> (valid_hyps (apply_oper_1 i f)).
+
+Unfold valid_hyps; Intros i f Hf e; Elim i; [
+  Intro lp; Case lp; [
+    Simpl; Trivial
+  | Simpl; Intros p l' (H1, H2); Split; [ Apply Hf with 1:=H1 | Assumption ]]
+| Intros n Hrec lp; Case lp; [
+    Simpl; Auto
+  | Simpl; Intros p l' (H1, H2); 
+    Split; [ Assumption | Apply Hrec; Assumption ]]].
+
+Save.
+
+(* \subsubsection{Manipulations de termes} *)
+(* Les fonctions suivantes permettent d'appliquer une fonction de
+   réécriture sur un sous terme du terme principal. Avec la composition,
+   cela permet de construire des réécritures complexes proches des 
+   tactiques de conversion *)
+
+Definition apply_left [f: term -> term; t : term]:= 
+  Cases t of
+    (Tplus x y) => (Tplus (f x) y)
+  | (Tmult x y) => (Tmult (f x) y)
+  | (Topp x) => (Topp (f x))
+  | x => x
+  end.
+
+Definition apply_right [f: term -> term; t : term]:= 
+  Cases t of
+    (Tplus x y) => (Tplus x (f y))
+  | (Tmult x y) => (Tmult x (f y))
+  | x => x
+  end.
+
+Definition apply_both [f,g: term -> term; t : term]:= 
+  Cases t of
+    (Tplus x y) => (Tplus (f x) (g y))
+  | (Tmult x y) => (Tmult (f x) (g y))
+  | x => x
+  end.
+
+(* Les théorèmes suivants montrent la stabilité (conditionnée) des 
+   fonctions. *)
+
+Theorem apply_left_stable :
+  (f: term -> term) (term_stable f) -> (term_stable (apply_left f)).
+
+Unfold term_stable; Intros f H e t; Case t; Auto; Simpl; 
+Intros;  Elim H; Trivial.
+Save.
+
+Theorem apply_right_stable :
+  (f: term -> term) (term_stable f) -> (term_stable (apply_right f)).
+
+Unfold term_stable; Intros f H e t; Case t; Auto; Simpl; 
+Intros t0 t1; Elim H; Trivial.
+Save.
+
+Theorem apply_both_stable :
+  (f,g: term -> term) (term_stable f) -> (term_stable g) -> 
+     (term_stable (apply_both f g)).
+
+Unfold term_stable; Intros f g H1 H2 e t; Case t; Auto; Simpl; 
+Intros t0 t1; Elim H1; Elim H2; Trivial.
+Save.
+
+Theorem compose_term_stable :
+  (f,g: term -> term) (term_stable f) -> (term_stable g) -> 
+    (term_stable [t: term](f (g t))).
+
+Unfold term_stable; Intros f g Hf Hg e t; Elim Hf; Apply Hg.
+Save.
+
+(* \subsection{Les règles de réécriture} *)
+(* Chacune des règles de réécriture est accompagnée par sa preuve de 
+   stabilité. Toutes ces preuves ont la même forme : il faut analyser 
+   suivant la forme du terme (élimination de chaque Case). On a besoin d'une
+   élimination uniquement dans les cas d'utilisation d'égalité décidable. 
+
+   Cette tactique itère la décomposition des Case. Elle est
+   constituée de deux fonctions s'appelant mutuellement :
+   \begin{itemize} 
+    \item une fonction d'enrobage qui lance la recherche sur le but,
+    \item une fonction récursive qui décompose ce but. Quand elle a trouvé un
+          Case, elle l'élimine. 
+   \end{itemize}  
+   Les motifs sur les cas sont très imparfaits et dans certains cas, il
+   semble que cela ne marche pas. On aimerait plutot un motif de la
+   forme [ Case (?1 :: T) of _ end ] permettant de s'assurer que l'on 
+   utilise le bon type.
+
+   Chaque élimination introduit correctement exactement le nombre d'hypothèses
+   nécessaires et conserve dans le cas d'une égalité la connaissance du
+   résultat du test en faisant la réécriture. Pour un test de comparaison,
+   on conserve simplement le résultat.
+
+   Cette fonction déborde très largement la résolution des réécritures
+   simples et fait une bonne partie des preuves des pas de Omega.
+*)
+
+(* \subsubsection{La tactique pour prouver la stabilité} *)
+Recursive Tactic Definition loop t := (
+  Match t With
+  (* Global *)
+    [(?1 = ?2)] -> (loop ?1) Orelse (loop ?2)
+  | [ ? -> ?1 ] ->  (loop ?1)
+  (* Interprétations *)
+  | [ (interp_hyps ? ?1) ] -> (loop ?1)
+  | [ (interp_list_hyps ? ?1) ] -> (loop ?1)
+  | [ (interp_proposition ? ?1) ] -> (loop ?1)
+  | [ (interp_term ? ?1) ] -> (loop ?1)
+  (* Propositions *)
+  | [(EqTerm ?1 ?2)] -> (loop ?1) Orelse (loop ?2)
+  | [(LeqTerm ?1 ?2)] -> (loop ?1) Orelse (loop ?2)
+  (* Termes *)
+  | [(Tplus ?1 ?2)] -> (loop ?1) Orelse (loop ?2)
+  | [(Tminus ?1 ?2)] -> (loop ?1) Orelse (loop ?2)
+  | [(Tmult ?1 ?2)] -> (loop ?1) Orelse (loop ?2)
+  | [(Topp ?1)] -> (loop ?1)
+  | [(Tint ?1)] -> (loop ?1)
+  (* Eliminations *)
+  | [(Cases ?1 of
+        | (EqTerm _ _) => ?
+        | (LeqTerm _ _) => ?
+        | TrueTerm => ?
+        | FalseTerm => ?
+        | (Tnot _) => ?
+        | (GeqTerm _ _) => ?
+        | (GtTerm _ _) => ?
+        | (LtTerm _ _) => ?
+        | (NeqTerm _ _) => ?
+        end)] -> 
+       (Case ?1; [ Intro; Intro | Intro; Intro | Idtac | Idtac 
+                 | Intro | Intro; Intro | Intro; Intro | Intro; Intro
+                 | Intro; Intro ]);
+        Auto; Simplify
+  | [(Cases ?1 of
+        (Tint _) => ?
+      | (Tplus _ _) => ?
+      | (Tmult _ _) => ?
+      | (Tminus _ _) => ?
+      | (Topp _) => ?
+      | (Tvar _) => ?
+      end)] -> 
+       (Case ?1; [ Intro | Intro; Intro | Intro; Intro | Intro; Intro | 
+                   Intro | Intro ]); Auto; Simplify
+  | [(Cases (Zcompare ?1 ?2) of
+        EGAL => ?
+      | INFERIEUR => ?
+      | SUPERIEUR => ?
+      end)] -> 
+       (Elim_Zcompare ?1 ?2) ; Intro ; Auto; Simplify
+  | [(Cases ?1 of ZERO => ? | (POS _) => ? | (NEG _) => ? end)] -> 
+       (Case ?1; [ Idtac | Intro | Intro ]); Auto; Simplify
+  | [(if (eq_Z ?1 ?2) then ? else ?)] -> 
+       ((Elim_eq_Z ?1 ?2); Intro H; [Rewrite H; Clear H | Clear H]);
+       Simpl; Auto; Simplify
+  | [(if (eq_term ?1 ?2) then ? else ?)] -> 
+       ((Elim_eq_term ?1 ?2); Intro H; [Rewrite H; Clear H | Clear H]); 
+       Simpl; Auto; Simplify
+  | [(if (eq_pos ?1 ?2) then ? else ?)] -> 
+       ((Elim_eq_pos ?1 ?2); Intro H; [Rewrite H; Clear H | Clear H]);
+       Simpl; Auto; Simplify
+  | _ -> Fail)
+And Simplify := (
+  Match Context With [|- ?1 ] -> Try (loop ?1) | _ -> Idtac).
+
+Tactic Definition ProveStable x th :=
+  Unfold term_stable x; Intros; Simplify; Simpl; Apply th.
+
+(* \subsubsection{Les règles elle mêmes} *)
+Definition Tplus_assoc_l [t: term] :=
+  Cases t of
+    (Tplus n (Tplus m p)) => (Tplus (Tplus n m) p)
+  | _ => t
+  end.
+
+Theorem  Tplus_assoc_l_stable : (term_stable  Tplus_assoc_l).
+
+(ProveStable Tplus_assoc_l Zplus_assoc).
+Save.
+
+Definition Tplus_assoc_r [t: term] :=
+  Cases t of
+    (Tplus (Tplus n m) p) => (Tplus n (Tplus m p))
+  | _ => t
+  end.
+
+Theorem  Tplus_assoc_r_stable : (term_stable  Tplus_assoc_r).
+
+(ProveStable Tplus_assoc_r Zplus_assoc_r).
+Save.
+
+Definition Tmult_assoc_r [t: term] :=
+  Cases t of
+    (Tmult (Tmult n m) p) => (Tmult n (Tmult m p))
+  | _ => t
+  end.
+
+Theorem  Tmult_assoc_r_stable : (term_stable  Tmult_assoc_r).
+
+(ProveStable Tmult_assoc_r Zmult_assoc_r).
+Save.
+
+Definition Tplus_permute [t: term] :=
+  Cases t of
+    (Tplus n (Tplus m p)) => (Tplus m (Tplus n p))
+  | _ => t
+  end.
+
+Theorem  Tplus_permute_stable : (term_stable  Tplus_permute).
+
+(ProveStable Tplus_permute Zplus_permute).
+Save.
+
+Definition Tplus_sym [t: term] :=
+  Cases t of
+    (Tplus x y) => (Tplus y x)
+  | _ => t
+  end.
+
+Theorem Tplus_sym_stable : (term_stable Tplus_sym).
+
+(ProveStable Tplus_sym Zplus_sym).
+Save.
+
+Definition Tmult_sym [t: term] :=
+  Cases t of
+    (Tmult x y) => (Tmult y x)
+  | _ => t
+  end.
+
+Theorem Tmult_sym_stable : (term_stable Tmult_sym).
+
+(ProveStable Tmult_sym Zmult_sym).
+Save.
+
+Definition T_OMEGA10 [t: term] :=
+  Cases t of
+    (Tplus (Tmult (Tplus (Tmult v (Tint c1)) l1) (Tint k1))
+           (Tmult (Tplus (Tmult v' (Tint c2)) l2) (Tint k2))) =>
+	Case (eq_term v v') of
+	    (Tplus (Tmult v (Tint (Zplus (Zmult c1 k1) (Zmult c2 k2)))) 
+                   (Tplus (Tmult l1 (Tint k1)) (Tmult l2 (Tint k2))))
+           t
+        end
+  | _ => t
+  end.
+
+Theorem  T_OMEGA10_stable : (term_stable  T_OMEGA10).
+
+(ProveStable T_OMEGA10 OMEGA10).
+Save.
+
+Definition T_OMEGA11 [t: term] :=
+  Cases t of
+    (Tplus (Tmult (Tplus (Tmult v1 (Tint c1)) l1) (Tint k1)) l2) =>
+	(Tplus (Tmult v1 (Tint (Zmult c1 k1))) (Tplus (Tmult l1 (Tint k1)) l2))
+  | _ => t
+  end.
+
+Theorem  T_OMEGA11_stable : (term_stable  T_OMEGA11).
+
+(ProveStable T_OMEGA11 OMEGA11).
+Save.
+
+Definition T_OMEGA12 [t: term] :=
+  Cases t of
+    (Tplus l1 (Tmult (Tplus (Tmult v2 (Tint c2)) l2) (Tint k2))) =>
+        (Tplus (Tmult v2 (Tint (Zmult c2 k2))) (Tplus l1 (Tmult l2 (Tint k2))))
+  | _ => t
+  end.
+
+Theorem  T_OMEGA12_stable : (term_stable  T_OMEGA12).
+
+(ProveStable T_OMEGA12 OMEGA12).
+Save. 
+
+Definition T_OMEGA13 [t: term] :=
+  Cases t of
+    (Tplus (Tplus (Tmult v (Tint (POS x))) l1) 
+	   (Tplus (Tmult v' (Tint (NEG x'))) l2)) =>
+	Case (eq_term v v') of
+	  Case (eq_pos x x') of
+	    (Tplus l1 l2)
+            t
+	  end
+	  t
+	end
+  | (Tplus (Tplus (Tmult v (Tint (NEG x))) l1) 
+	   (Tplus (Tmult v' (Tint (POS x'))) l2)) =>
+	Case (eq_term v v') of
+	  Case (eq_pos x x') of
+	    (Tplus l1 l2)
+             t
+	  end
+	  t
+	end
+
+  | _ => t
+  end.
+
+Theorem  T_OMEGA13_stable : (term_stable  T_OMEGA13).
+
+Unfold term_stable T_OMEGA13; Intros; Simplify; Simpl; 
+  [ Apply OMEGA13 | Apply OMEGA14 ].
+Save.
+
+Definition T_OMEGA15 [t: term] :=
+  Cases t of
+    (Tplus (Tplus (Tmult v (Tint c1)) l1) 
+	   (Tmult (Tplus (Tmult v' (Tint c2)) l2) (Tint k2))) =>
+	Case (eq_term v v') of
+	  (Tplus (Tmult v (Tint (Zplus c1 (Zmult c2 k2))))
+	                  (Tplus l1 (Tmult l2 (Tint k2))))
+	  t
+	end
+  | _ => t
+  end.
+
+Theorem  T_OMEGA15_stable : (term_stable  T_OMEGA15).
+
+(ProveStable T_OMEGA15 OMEGA15).
+Save.
+
+Definition T_OMEGA16 [t: term] :=
+  Cases t of
+    (Tmult (Tplus (Tmult v (Tint c)) l) (Tint k)) =>
+       (Tplus (Tmult v (Tint (Zmult c k))) (Tmult l (Tint k)))
+  | _ => t
+  end.
+
+
+Theorem  T_OMEGA16_stable : (term_stable  T_OMEGA16).
+
+(ProveStable T_OMEGA16 OMEGA16).
+Save.
+
+Definition Tred_factor5 [t: term] := 
+   Cases t of
+      (Tplus (Tmult x (Tint ZERO)) y) => y
+   | _ => t
+   end.
+
+Theorem Tred_factor5_stable : (term_stable  Tred_factor5).
+
+
+(ProveStable Tred_factor5 Zred_factor5).
+Save.
+
+Definition Topp_plus [t: term] :=
+  Cases t of
+    (Topp (Tplus x y)) => (Tplus (Topp x) (Topp y))
+  | _ => t
+  end.
+
+Theorem Topp_plus_stable : (term_stable Topp_plus).
+
+(ProveStable Topp_plus Zopp_Zplus).
+Save.
+
+
+Definition Topp_opp [t: term] :=
+  Cases t of
+    (Topp (Topp x)) => x
+  | _ => t
+  end.
+
+Theorem Topp_opp_stable : (term_stable Topp_opp).
+
+(ProveStable Topp_opp Zopp_Zopp).
+Save.
+
+Definition Topp_mult_r [t: term] :=
+  Cases t of
+    (Topp (Tmult x (Tint k))) => (Tmult x (Tint (Zopp k)))
+  | _ => t
+  end.
+
+Theorem Topp_mult_r_stable : (term_stable Topp_mult_r).
+
+(ProveStable Topp_mult_r Zopp_Zmult_r).
+Save.
+
+Definition Topp_one [t: term] :=
+  Cases t of
+    (Topp x) => (Tmult x (Tint `-1`))
+  | _ => t
+  end.
+
+Theorem Topp_one_stable : (term_stable Topp_one).
+
+(ProveStable Topp_one Zopp_one).
+Save.
+
+Definition Tmult_plus_distr  [t: term] :=
+  Cases t of
+    (Tmult (Tplus n m) p) => (Tplus (Tmult n p) (Tmult m p))
+  | _ => t
+  end.
+
+Theorem Tmult_plus_distr_stable : (term_stable Tmult_plus_distr).
+
+(ProveStable Tmult_plus_distr Zmult_plus_distr_l).
+Save.
+
+Definition Tmult_opp_left [t: term] :=
+  Cases t of
+    (Tmult (Topp x) (Tint y)) => (Tmult x (Tint (Zopp y)))
+  | _ => t
+  end.
+
+Theorem Tmult_opp_left_stable : (term_stable Tmult_opp_left).
+
+(ProveStable Tmult_opp_left Zmult_Zopp_left).
+Save.
+
+Definition Tmult_assoc_reduced [t: term] :=
+  Cases t of
+    (Tmult (Tmult n (Tint m)) (Tint p)) => (Tmult n (Tint (Zmult m p)))
+  | _ => t
+  end.
+
+Theorem  Tmult_assoc_reduced_stable : (term_stable  Tmult_assoc_reduced).
+
+(ProveStable Tmult_assoc_reduced Zmult_assoc_r).
+Save.
+
+Definition Tred_factor0 [t: term] := (Tmult t (Tint `1`)).
+
+Theorem  Tred_factor0_stable : (term_stable  Tred_factor0).
+
+(ProveStable Tred_factor0 Zred_factor0).
+Save.
+
+Definition Tred_factor1 [t: term] :=
+  Cases t of
+    (Tplus x y) => 
+	Case (eq_term x y) of
+	  (Tmult x (Tint `2`))
+	  t
+        end
+  | _ => t
+  end.
+
+Theorem  Tred_factor1_stable : (term_stable  Tred_factor1).
+
+(ProveStable Tred_factor1 Zred_factor1).
+Save.
+
+Definition Tred_factor2 [t: term] :=
+  Cases t of
+    (Tplus x (Tmult y (Tint k))) => 
+	Case (eq_term x y) of
+	  (Tmult x (Tint (Zplus `1` k)))
+	  t
+        end
+  | _ => t
+  end.
+
+(* Attention : il faut rendre opaque [Zplus] pour éviter que la tactique
+   de simplification n'aille trop loin et défasse [Zplus 1 k] *)
+
+Opaque Zplus.
+
+Theorem  Tred_factor2_stable : (term_stable  Tred_factor2).
+(ProveStable Tred_factor2 Zred_factor2).
+Save.
+
+Definition Tred_factor3 [t: term] :=
+  Cases t of
+    (Tplus (Tmult x (Tint k)) y) => 
+	Case (eq_term x y) of
+	  (Tmult x (Tint `1+k`))
+	  t
+        end
+  | _ => t
+  end.
+
+Theorem  Tred_factor3_stable : (term_stable  Tred_factor3).
+
+(ProveStable Tred_factor3 Zred_factor3).
+Save.
+
+
+Definition Tred_factor4 [t: term] :=
+  Cases t of
+    (Tplus (Tmult x (Tint k1)) (Tmult y (Tint k2))) => 
+	Case (eq_term x y) of
+	  (Tmult x (Tint `k1+k2`))
+	  t
+        end
+  | _ => t
+  end.
+
+Theorem  Tred_factor4_stable : (term_stable  Tred_factor4).
+
+(ProveStable Tred_factor4 Zred_factor4).
+Save.
+
+Definition Tred_factor6 [t: term] := (Tplus t (Tint `0`)).
+
+Theorem  Tred_factor6_stable : (term_stable  Tred_factor6).
+
+(ProveStable Tred_factor6 Zred_factor6).
+Save.
+
+Transparent Zplus.
+
+Definition Tminus_def [t:term] :=
+  Cases t of
+    (Tminus x y) => (Tplus x (Topp y))
+  | _ => t
+  end.
+
+Theorem  Tminus_def_stable : (term_stable  Tminus_def).
+
+(* Le théorème ne sert à rien. Le but est prouvé avant. *)
+(ProveStable Tminus_def False).
+Save.
+
+(* \subsection{Fonctions de réécriture complexes} *)
+
+(* \subsubsection{Fonction de réduction} *)
+(* Cette fonction réduit un terme dont la forme normale est un entier. Il
+   suffit pour cela d'échanger le constructeur [Tint] avec les opérateurs
+   réifiés. La réduction est ``gratuite''.  *)
+
+Fixpoint reduce [t:term] : term :=
+  Cases t of
+     (Tplus x y) =>
+	 Cases (reduce x) of
+	   (Tint x') =>
+	      Cases (reduce y) of
+	        (Tint y') => (Tint (Zplus x' y'))
+              | y' => (Tplus (Tint x') y')
+              end
+         | x' => (Tplus x' (reduce y))
+	 end
+  | (Tmult x y) =>
+	 Cases (reduce x) of
+	   (Tint x') =>
+	      Cases (reduce y) of
+	        (Tint y') => (Tint (Zmult x' y'))
+              | y' => (Tmult (Tint x') y')
+              end
+         | x' => (Tmult x' (reduce y))
+	 end
+  | (Tminus x y) =>
+	 Cases (reduce x) of
+	   (Tint x') =>
+	      Cases (reduce y) of
+	        (Tint y') => (Tint (Zminus x' y'))
+              | y' => (Tminus (Tint x') y')
+              end
+         | x' => (Tminus x' (reduce y))
+	 end
+  | (Topp x) =>
+        Cases (reduce x) of
+	  (Tint x') => (Tint (Zopp x'))
+	| x' => (Topp x')
+	end
+  | _ => t
+  end.
+
+Theorem reduce_stable : (term_stable reduce).
+
+Unfold term_stable; Intros e t; Elim t; Auto; 
+Try (Intros t0 H0 t1 H1; Simpl; Rewrite H0; Rewrite H1; (
+ Case (reduce t0); [ 
+   Intro z0; Case (reduce t1); Intros; Auto
+ | Intros; Auto
+ | Intros; Auto
+ | Intros; Auto
+ | Intros; Auto
+ | Intros; Auto ]));
+Intros t0 H0; Simpl; Rewrite H0; Case (reduce t0); Intros; Auto.
+Save.
+
+(* \subsubsection{Fusions}
+    \paragraph{Fusion de deux équations} *)
+(* On donne une somme de deux équations qui sont supposées normalisées. 
+   Cette fonction prend une trace de fusion en argument et transforme
+   le terme en une équation normalisée. C'est une version très simplifiée
+   du moteur de réécriture [rewrite]. *)
+
+Fixpoint fusion [trace : (list t_fusion)] : term -> term := [t: term]
+  Cases trace of
+    nil => (reduce t)
+  | (cons step trace') =>
+	Cases step of
+        | F_equal => 
+	    (apply_right (fusion trace') (T_OMEGA10 t))
+        | F_cancel => 
+	    (fusion trace' (Tred_factor5 (T_OMEGA10 t)))
+        | F_left => 
+	    (apply_right (fusion trace') (T_OMEGA11 t))
+        | F_right =>
+	    (apply_right (fusion trace') (T_OMEGA12 t))
+	end
+  end.
+    
+Theorem fusion_stable : (t : (list t_fusion)) (term_stable (fusion t)).
+
+Induction t; Simpl; [
+  Exact reduce_stable
+| Intros step l H; Case step; [
+    Apply compose_term_stable; 
+      [ Apply apply_right_stable; Assumption | Exact T_OMEGA10_stable ]
+  | Unfold term_stable; Intros e t1; Rewrite T_OMEGA10_stable; 
+    Rewrite Tred_factor5_stable; Apply H
+  | Apply compose_term_stable; 
+      [ Apply apply_right_stable; Assumption | Exact T_OMEGA11_stable ]
+  | Apply compose_term_stable;
+      [ Apply apply_right_stable; Assumption | Exact T_OMEGA12_stable ]]].
+
+Save.
+
+(* \paragraph{Fusion de deux équations dont une sans coefficient} *)
+
+Definition fusion_right [trace : (list t_fusion)] : term -> term := [t: term]
+  Cases trace of
+    nil => (reduce t)  (* Il faut mettre un compute *)
+  | (cons step trace') =>
+	Cases step of
+        | F_equal => 
+	    (apply_right (fusion trace') (T_OMEGA15 t))
+        | F_cancel => 
+	    (fusion trace' (Tred_factor5 (T_OMEGA15 t)))
+        | F_left => 
+	    (apply_right (fusion trace') (Tplus_assoc_r t))
+        | F_right =>
+	    (apply_right (fusion trace') (T_OMEGA12 t))
+	end
+  end.
+
+(* \paragraph{Fusion avec anihilation} *)
+(* Normalement le résultat est une constante *)
+
+Fixpoint fusion_cancel [trace:nat] : term -> term := [t:term]
+  Cases trace of
+    O => (reduce t)
+  | (S trace') => (fusion_cancel trace' (T_OMEGA13 t))
+  end.
+
+Theorem fusion_cancel_stable : (t:nat) (term_stable (fusion_cancel t)).
+
+Unfold term_stable fusion_cancel; Intros trace e; Elim trace; [
+  Exact (reduce_stable e)
+| Intros n H t; Elim H; Exact (T_OMEGA13_stable e t) ].
+Save. 
+
+(* \subsubsection{Opérations afines sur une équation} *)
+(* \paragraph{Multiplication scalaire et somme d'une constante} *)
+
+Fixpoint scalar_norm_add [trace:nat] : term -> term := [t: term]
+  Cases trace of
+    O => (reduce t)
+  | (S trace') => (apply_right (scalar_norm_add trace') (T_OMEGA11 t))
+  end.
+
+Theorem scalar_norm_add_stable : (t:nat) (term_stable (scalar_norm_add t)).
+
+Unfold term_stable scalar_norm_add; Intros trace; Elim trace; [
+  Exact reduce_stable
+| Intros n H e t; Elim apply_right_stable; 
+    [ Exact (T_OMEGA11_stable e t) | Exact H ]].
+Save.
+   
+(* \paragraph{Multiplication scalaire} *)
+Fixpoint scalar_norm [trace:nat] : term -> term := [t: term]
+  Cases trace of
+    O => (reduce t)
+  | (S trace') => (apply_right (scalar_norm trace') (T_OMEGA16 t))
+  end.
+
+Theorem scalar_norm_stable : (t:nat) (term_stable (scalar_norm t)).
+
+Unfold term_stable scalar_norm; Intros trace; Elim trace; [
+  Exact reduce_stable
+| Intros n H e t; Elim apply_right_stable;
+    [ Exact (T_OMEGA16_stable e t) | Exact H ]].
+Save.
+
+(* \paragraph{Somme d'une constante} *)
+Fixpoint add_norm [trace:nat] : term -> term := [t: term]
+  Cases trace of
+    O => (reduce t)
+  | (S trace') => (apply_right (add_norm trace') (Tplus_assoc_r t))
+  end.
+
+Theorem add_norm_stable : (t:nat) (term_stable (add_norm t)).
+
+Unfold term_stable add_norm; Intros trace; Elim trace; [
+  Exact reduce_stable
+| Intros n H e t; Elim apply_right_stable;
+    [ Exact (Tplus_assoc_r_stable e t) | Exact H ]].
+Save.
+
+(* \subsection{La fonction de normalisation des termes (moteur de réécriture)} *)
+
+Inductive step : Set := 
+ | C_DO_BOTH : step -> step -> step
+ | C_LEFT : step -> step
+ | C_RIGHT : step -> step
+ | C_SEQ : step -> step -> step
+ | C_NOP : step
+ | C_OPP_PLUS : step
+ | C_OPP_OPP : step
+ | C_OPP_MULT_R : step
+ | C_OPP_ONE : step
+ | C_REDUCE : step
+ | C_MULT_PLUS_DISTR : step
+ | C_MULT_OPP_LEFT : step
+ | C_MULT_ASSOC_R : step
+ | C_PLUS_ASSOC_R : step
+ | C_PLUS_ASSOC_L : step
+ | C_PLUS_PERMUTE : step
+ | C_PLUS_SYM : step
+ | C_RED0 : step
+ | C_RED1 : step
+ | C_RED2 : step
+ | C_RED3 : step
+ | C_RED4 : step
+ | C_RED5 : step
+ | C_RED6 : step
+ | C_MULT_ASSOC_REDUCED : step
+ | C_MINUS :step
+ | C_MULT_SYM : step
+.
+
+Fixpoint rewrite [s: step] : term -> term :=
+  Cases s of 
+   | (C_DO_BOTH s1 s2) => (apply_both (rewrite s1) (rewrite s2))
+   | (C_LEFT s) => (apply_left (rewrite s))
+   | (C_RIGHT s) => (apply_right (rewrite s))
+   | (C_SEQ s1 s2) => [t: term] (rewrite s2 (rewrite s1 t))
+   | C_NOP => [t:term] t
+   | C_OPP_PLUS => Topp_plus
+   | C_OPP_OPP => Topp_opp
+   | C_OPP_MULT_R => Topp_mult_r
+   | C_OPP_ONE => Topp_one
+   | C_REDUCE => reduce
+   | C_MULT_PLUS_DISTR => Tmult_plus_distr
+   | C_MULT_OPP_LEFT => Tmult_opp_left
+   | C_MULT_ASSOC_R => Tmult_assoc_r
+   | C_PLUS_ASSOC_R => Tplus_assoc_r
+   | C_PLUS_ASSOC_L => Tplus_assoc_l
+   | C_PLUS_PERMUTE => Tplus_permute
+   | C_PLUS_SYM => Tplus_sym
+   | C_RED0 => Tred_factor0
+   | C_RED1 => Tred_factor1
+   | C_RED2 => Tred_factor2
+   | C_RED3 => Tred_factor3
+   | C_RED4 => Tred_factor4
+   | C_RED5 => Tred_factor5
+   | C_RED6 => Tred_factor6
+   | C_MULT_ASSOC_REDUCED => Tmult_assoc_reduced
+   | C_MINUS => Tminus_def
+   | C_MULT_SYM => Tmult_sym
+  end.
+
+Theorem rewrite_stable : (s:step) (term_stable (rewrite s)).
+
+Induction s; Simpl; [
+  Intros; Apply apply_both_stable; Auto
+| Intros; Apply apply_left_stable; Auto
+| Intros; Apply apply_right_stable; Auto
+| Unfold term_stable; Intros; Elim H0; Apply H
+| Unfold term_stable; Auto
+| Exact Topp_plus_stable
+| Exact Topp_opp_stable
+| Exact Topp_mult_r_stable
+| Exact Topp_one_stable
+| Exact reduce_stable
+| Exact Tmult_plus_distr_stable
+| Exact Tmult_opp_left_stable
+| Exact Tmult_assoc_r_stable
+| Exact Tplus_assoc_r_stable
+| Exact Tplus_assoc_l_stable
+| Exact Tplus_permute_stable
+| Exact Tplus_sym_stable
+| Exact Tred_factor0_stable
+| Exact Tred_factor1_stable
+| Exact Tred_factor2_stable
+| Exact Tred_factor3_stable
+| Exact Tred_factor4_stable
+| Exact Tred_factor5_stable
+| Exact Tred_factor6_stable
+| Exact Tmult_assoc_reduced_stable
+| Exact Tminus_def_stable
+| Exact Tmult_sym_stable ].
+Save.
+
+(* \subsection{tactiques de résolution d'un but omega normalisé} 
+   Trace de la procédure 
+\subsubsection{Tactiques générant une contradiction}
+\paragraph{[O_CONSTANT_NOT_NUL]} *)
+
+Definition constant_not_nul [i:nat; h: hyps] :=
+  Cases (nth_hyps i h) of
+     (EqTerm (Tint ZERO) (Tint n)) =>
+	Case (eq_Z n ZERO) of
+	    h
+            absurd
+        end
+   | _ => h
+  end.
+
+Theorem constant_not_nul_valid : 
+  (i:nat) (valid_hyps (constant_not_nul i)).
+
+Unfold valid_hyps constant_not_nul; Intros;
+Generalize (nth_valid e i lp); Simplify; Simpl; (Elim_eq_Z z0 ZERO); Auto;
+Simpl; Intros H1 H2; Elim H1; Symmetry; Auto.
+Save.   
+
+(* \paragraph{[O_CONSTANT_NEG]} *)
+
+Definition constant_neg [i:nat; h: hyps] :=
+   Cases (nth_hyps i h) of
+      (LeqTerm (Tint ZERO) (Tint (NEG n))) => absurd
+   | _ => h
+   end.
+
+Theorem constant_neg_valid : (i:nat) (valid_hyps (constant_neg i)).
+
+Unfold valid_hyps constant_neg; Intros;
+Generalize (nth_valid e i lp); Simplify; Simpl; Unfold Zle; Simpl;
+Intros H1; Elim H1; [ Assumption | Trivial ].
+Save.   
+
+(* \paragraph{[NOT_EXACT_DIVIDE]} *)
+Definition not_exact_divide [k1,k2:Z; body:term; t:nat; i : nat; l:hyps] :=
+  Cases (nth_hyps i l) of
+      (EqTerm (Tint ZERO) b) =>
+         Case (eq_term
+	         (scalar_norm_add t (Tplus (Tmult body (Tint k1)) (Tint k2))) b) of
+	   Cases (Zcompare k2 ZERO) of
+	     SUPERIEUR =>
+	       Cases (Zcompare k1 k2) of
+		 SUPERIEUR => absurd
+	       | _ => l
+	       end
+	   | _ => l
+           end
+	   l
+         end
+   | _ => l
+   end.
+
+Theorem not_exact_divide_valid : (k1,k2:Z; body:term; t:nat; i:nat) 
+	(valid_hyps (not_exact_divide k1 k2 body t i)).
+
+Unfold valid_hyps not_exact_divide; Intros; Generalize (nth_valid e i lp);
+Simplify;
+(Elim_eq_term '(scalar_norm_add t (Tplus (Tmult body (Tint k1)) (Tint k2)))
+	     't1); Auto; 
+Simplify; 
+Intro H2; Elim H2; Simpl; Elim (scalar_norm_add_stable t e); Simpl;
+Intro H4; Absurd `(interp_term e body)*k1+k2 = 0`; [
+   Apply OMEGA4; Assumption | Symmetry; Auto ].
+
+Save.
+
+(* \paragraph{[O_CONTRADICTION]} *)
+
+Definition contradiction [t: nat; i,j:nat;l:hyps] :=
+  Cases (nth_hyps i l) of
+    (LeqTerm  (Tint ZERO) b1) =>
+	Cases (nth_hyps j l) of 
+	  (LeqTerm  (Tint ZERO) b2) => 
+	     Cases (fusion_cancel t (Tplus b1 b2)) of
+	       (Tint k) =>
+		  Cases (Zcompare ZERO k) of
+	            SUPERIEUR => absurd
+	          | _ => l
+                  end
+             | _ => l
+             end
+         | _ => l 
+        end
+  | _ => l 
+  end.
+
+Theorem contradiction_valid : (t,i,j: nat) (valid_hyps (contradiction t i j)).
+
+Unfold valid_hyps contradiction; Intros t i j e l H;
+Generalize (nth_valid ? i ? H); Generalize (nth_valid ? j ? H);
+Case (nth_hyps i l); Auto; Intros t1 t2; Case t1; Auto; Intros z; Case z; Auto;
+Case (nth_hyps j l); Auto; Intros t3 t4; Case t3; Auto; Intros z'; Case z'; 
+Auto; Simpl; Intros H1 H2;
+Generalize (refl_equal Z (interp_term e (fusion_cancel t (Tplus t2 t4))));
+Pattern 2 3 (fusion_cancel t (Tplus t2 t4));
+Case (fusion_cancel t (Tplus t2 t4)); 
+Simpl; Auto; Intro k; Elim (fusion_cancel_stable t);
+Simpl; Intro E; Generalize (OMEGA2 ? ? H2 H1); Rewrite E; Case k; 
+Auto;Unfold Zle; Simpl; Intros p H3; Elim H3; Auto.
+
+Save.
+
+(* \paragraph{[O_NEGATE_CONTRADICT]} *)
+
+Definition negate_contradict [i1,i2:nat; h:hyps]:=
+  Cases (nth_hyps i1 h) of
+    (EqTerm (Tint ZERO) b1) =>
+	Cases (nth_hyps i2 h) of
+           (NeqTerm (Tint ZERO) b2) =>
+	      Cases (eq_term b1 b2) of
+	         true => absurd
+              |  false => h
+	    end
+        | _ => h
+        end
+  | (NeqTerm (Tint ZERO) b1) =>
+	Cases (nth_hyps i2 h) of
+           (EqTerm (Tint ZERO) b2) =>
+	      Cases (eq_term b1 b2) of
+	         true => absurd
+              |  false => h
+	    end
+        | _ => h
+        end
+  | _ => h
+  end.
+
+Definition negate_contradict_inv [t:nat; i1,i2:nat; h:hyps]:=
+  Cases (nth_hyps i1 h) of
+    (EqTerm (Tint ZERO) b1) =>
+	Cases (nth_hyps i2 h) of
+           (NeqTerm (Tint ZERO) b2) =>
+              Cases (eq_term b1 (scalar_norm t (Tmult b2 (Tint `-1`)))) of
+	         true => absurd
+              |  false => h
+	    end
+        | _ => h
+        end
+  | (NeqTerm (Tint ZERO) b1) =>
+	Cases (nth_hyps i2 h) of
+           (EqTerm (Tint ZERO) b2) =>
+              Cases (eq_term b1 (scalar_norm t (Tmult b2 (Tint `-1`)))) of
+	         true => absurd
+              |  false => h
+	    end
+        | _ => h
+        end
+  | _ => h
+  end.
+
+
+Theorem negate_contradict_valid :
+  (i,j:nat) (valid_hyps (negate_contradict i j)).
+
+Unfold valid_hyps negate_contradict; Intros i j e l H;
+Generalize (nth_valid ? i ? H); Generalize (nth_valid ? j ? H);
+Case (nth_hyps i l); Auto; Intros t1 t2; Case t1; Auto; Intros z; Case z; Auto;
+Case (nth_hyps j l); Auto; Intros t3 t4; Case t3; Auto; Intros z'; Case z'; 
+Auto; Simpl; Intros H1 H2; [
+  (Elim_eq_term t2 t4); Intro H3; [ Elim H1; Elim H3; Assumption | Assumption ]
+| (Elim_eq_term t2 t4); Intro H3; 
+    [ Elim H2; Rewrite H3; Assumption | Assumption ]].
+
+Save.
+
+Theorem negate_contradict_inv_valid :
+  (t,i,j:nat) (valid_hyps (negate_contradict_inv t i j)).
+
+
+Unfold valid_hyps negate_contradict_inv; Intros t i j e l H;
+Generalize (nth_valid ? i ? H); Generalize (nth_valid ? j ? H);
+Case (nth_hyps i l); Auto; Intros t1 t2; Case t1; Auto; Intros z; Case z; Auto;
+Case (nth_hyps j l); Auto; Intros t3 t4; Case t3; Auto; Intros z'; Case z'; 
+Auto; Simpl; Intros H1 H2;
+(Pattern (eq_term t2 (scalar_norm t (Tmult t4 (Tint (NEG xH))))); Apply bool_ind2; Intro Aux; [
+  Generalize (eq_term_true t2 (scalar_norm t (Tmult t4 (Tint (NEG xH)))) Aux);
+  Clear Aux
+| Generalize (eq_term_false t2 (scalar_norm t (Tmult t4 (Tint (NEG xH)))) Aux);
+  Clear Aux ]); [
+   Intro H3; Elim H1; Generalize H2; Rewrite H3; 
+   Rewrite <- (scalar_norm_stable t e); Simpl; Elim (interp_term e t4) ; 
+   Simpl; Auto; Intros p H4; Discriminate H4
+ | Auto 
+ | Intro H3; Elim H2; Rewrite H3; Elim (scalar_norm_stable t e); Simpl;
+   Elim H1; Simpl; Trivial
+ | Auto ].
+
+Save.
+
+
+(* \subsubsection{Tactiques générant une nouvelle équation} *)
+(* \paragraph{[O_SUM]}
+ C'est une oper2 valide mais elle traite plusieurs cas à la fois (suivant
+ les opérateurs de comparaison des deux arguments) d'où une
+ preuve un peu compliquée. On utilise quelques lemmes qui sont des 
+ généralisations des théorèmes utilisés par OMEGA. *)
+
+Definition sum [k1,k2: Z; trace: (list t_fusion); prop1,prop2:proposition]:=
+  Cases prop1 of
+    (EqTerm (Tint ZERO) b1) =>
+	Cases prop2 of
+          (EqTerm (Tint ZERO) b2) =>
+	    (EqTerm 
+	       (Tint ZERO) 
+	       (fusion trace 
+	               (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2)))))
+        | (LeqTerm (Tint ZERO) b2) =>
+	    Cases (Zcompare k2 ZERO) of
+	       SUPERIEUR =>
+		 (LeqTerm 
+		    (Tint ZERO) 
+		    (fusion trace 
+			 (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2)))))
+            | _ => TrueTerm
+           end
+       | _ => TrueTerm
+       end
+  | (LeqTerm (Tint ZERO) b1) =>
+      Cases (Zcompare k1 ZERO) of
+        SUPERIEUR =>
+	  Cases prop2 of
+	    (EqTerm (Tint ZERO) b2) =>
+	      (LeqTerm 
+		 (Tint ZERO) 
+		 (fusion trace 
+			 (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2)))))
+	  | (LeqTerm (Tint ZERO) b2) =>
+	       Cases (Zcompare k2 ZERO) of
+		  SUPERIEUR =>
+		    (LeqTerm 
+		       (Tint ZERO) 
+		       (fusion trace 
+			    (Tplus (Tmult b1 (Tint k1)) 
+                                   (Tmult b2 (Tint k2)))))
+	       | _ => TrueTerm
+	      end
+	 | _ => TrueTerm
+	 end
+     | _ => TrueTerm
+     end
+  | (NeqTerm (Tint ZERO) b1) =>
+       Cases prop2 of
+	 (EqTerm (Tint ZERO) b2) =>
+	    Case (eq_Z k1 ZERO) of
+	       TrueTerm
+	       (NeqTerm 
+		  (Tint ZERO) 
+		  (fusion trace 
+			  (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2)))))
+	    end
+      | _ => TrueTerm
+      end
+  | _ => TrueTerm
+  end.
+
+Theorem sum1 :
+  (a,b,c,d:Z) (`0 = a`) -> (`0 = b`) -> (`0 = a*c + b*d`).
+
+Intros; Elim H; Elim H0; Simpl; Auto.
+Save.
+  
+Theorem sum2 :
+  (a,b,c,d:Z)  (`0 <= d`) -> (`0 = a`) -> (`0 <= b`) ->(`0 <= a*c + b*d`).
+
+Intros; Elim H0; Simpl; Generalize H H1; Case b; Case d; 
+Unfold Zle; Simpl; Auto.  
+Save.
+
+Theorem sum3 :
+  (a,b,c,d:Z)  (`0 <= c`) -> (`0 <= d`) -> (`0 <= a`) -> (`0 <= b`) ->(`0 <= a*c + b*d`).
+
+Intros a b c d; Case a; Case b; Case c; Case d; Unfold Zle; Simpl; Auto. 
+Save.
+
+Theorem sum4 : (k:Z) (Zcompare k `0`)=SUPERIEUR -> (`0 <= k`).
+
+Intro; Case k; Unfold Zle; Simpl; Auto; Intros; Discriminate.  
+Save.
+
+Theorem sum5 :
+  (a,b,c,d:Z) (`c <> 0`) -> (`0 <> a`) -> (`0 = b`) -> (`0 <> a*c + b*d`).
+
+Intros a b c d H1 H2 H3; Elim H3; Simpl; Rewrite Zplus_sym;
+Simpl; Generalize H1 H2; Case a; Case c; Simpl; Intros; Try Discriminate;
+Assumption.
+Save.
+
+
+Theorem sum_valid : (k1,k2:Z; t:(list t_fusion)) (valid2 (sum k1 k2 t)).
+
+Unfold valid2; Intros k1 k2 t e p1 p2; Unfold sum; Simplify; Simpl; Auto;
+Try (Elim (fusion_stable t)); Simpl; Intros; [
+  Apply sum1; Assumption
+| Apply sum2; Try Assumption; Apply sum4; Assumption
+| Rewrite Zplus_sym; Apply sum2; Try Assumption; Apply sum4; Assumption
+| Apply sum3; Try Assumption; Apply sum4; Assumption
+| (Elim_eq_Z k1 ZERO); Simpl; Auto; Elim (fusion_stable t); Simpl; Intros;
+  Unfold Zne; Apply sum5; Assumption].
+Save.
+
+(* \paragraph{[O_EXACT_DIVIDE]}
+   c'est une oper1 valide mais on préfère une substitution a ce point la *)
+
+Definition exact_divide [k:Z; body:term; t: nat; prop:proposition] :=
+   Cases prop of
+      (EqTerm (Tint ZERO) b) =>
+         Case (eq_term (scalar_norm t (Tmult body (Tint k))) b) of
+	   Case (eq_Z k ZERO) of
+	      TrueTerm
+	      (EqTerm (Tint ZERO) body)
+           end
+           TrueTerm
+         end
+   | _ => TrueTerm
+   end.
+
+Theorem exact_divide_valid :
+  (k:Z) (t:term) (n:nat) (valid1 (exact_divide k t n)).
+
+
+Unfold valid1 exact_divide; Intros k1 k2 t e p1; Simplify;Simpl; Auto;
+(Elim_eq_term  '(scalar_norm t (Tmult k2 (Tint k1))) 't1); Simpl; Auto;
+(Elim_eq_Z 'k1 '(ZERO)); Simpl; Auto;  Intros H1 H2; Elim H2; 
+Elim scalar_norm_stable; Simpl; Generalize H1; Case (interp_term e k2);
+Try Trivial; (Case k1; Simpl; [
+  Intros; Absurd `0 = 0`; Assumption
+| Intros p2 p3 H3 H4; Discriminate H4
+| Intros p2 p3 H3 H4; Discriminate H4 ]).
+
+Save.
+
+
+
+(* \paragraph{[O_DIV_APPROX]}
+  La preuve reprend le schéma de la précédente mais on
+  est sur une opération de type valid1 et non sur une opération terminale. *)
+
+Definition divide_and_approx [k1,k2:Z; body:term; t:nat; prop:proposition] :=
+  Cases prop of
+      (LeqTerm (Tint ZERO) b) =>
+         Case (eq_term
+                (scalar_norm_add t (Tplus (Tmult body (Tint k1)) (Tint k2))) b) of
+	   Cases (Zcompare k1 ZERO) of
+	     SUPERIEUR =>
+	       Cases (Zcompare k1 k2) of
+		 SUPERIEUR =>(LeqTerm (Tint ZERO) body)
+	       | _ => prop
+	       end
+	   | _ => prop
+           end
+	   prop
+         end
+   | _ => prop
+   end.
+
+Theorem divide_and_approx_valid : (k1,k2:Z; body:term; t:nat) 
+	(valid1 (divide_and_approx k1 k2 body t)).
+
+Unfold valid1 divide_and_approx; Intros k1 k2 body t e p1;Simplify;
+(Elim_eq_term '(scalar_norm_add t (Tplus (Tmult body (Tint k1)) (Tint k2))) 't1); Simplify; Auto;  Intro E; Elim E; Simpl; 
+Elim (scalar_norm_add_stable t e); Simpl; Intro H1; 
+Apply Zmult_le_approx with 3 := H1; Assumption.
+Save.
+
+(* \paragraph{[MERGE_EQ]} *)
+
+Definition merge_eq [t: nat; prop1, prop2: proposition] :=
+  Cases prop1 of
+     (LeqTerm (Tint ZERO) b1) =>
+	Cases prop2 of
+     	  (LeqTerm (Tint ZERO) b2) =>
+             Case (eq_term b1 (scalar_norm t (Tmult b2 (Tint `-1`)))) of
+	        (EqTerm (Tint ZERO) b1)
+ 	       	TrueTerm
+	     end
+        | _ => TrueTerm
+	end
+  | _ => TrueTerm
+  end.
+
+Theorem merge_eq_valid : (n:nat) (valid2 (merge_eq n)).
+
+Unfold valid2 merge_eq; Intros n e p1 p2; Simplify; Simpl; Auto;
+Elim (scalar_norm_stable n e); Simpl; Intros; Symmetry; 
+Apply OMEGA8 with 2 := H0; [ Assumption | Elim Zopp_one; Trivial ].
+Save.
+
+
+
+(* \paragraph{[O_CONSTANT_NUL]} *)
+
+Definition constant_nul [i:nat; h: hyps] :=
+  Cases (nth_hyps i h) of
+     (NeqTerm (Tint ZERO) (Tint ZERO)) => absurd
+   | _ => h
+  end.
+
+Theorem constant_nul_valid : 
+  (i:nat) (valid_hyps (constant_nul i)).
+
+Unfold valid_hyps constant_nul; Intros; Generalize (nth_valid e i lp);
+Simplify; Simpl; Unfold Zne; Intro H1; Absurd `0=0`; Auto.
+Save.
+
+(* \paragraph{[O_STATE]} *)
+
+Definition state [m:Z;s:step; prop1,prop2:proposition] :=
+  Cases prop1 of
+     (EqTerm (Tint ZERO) b1) =>
+	Cases prop2 of
+	   (EqTerm (Tint ZERO) (Tplus b2 (Topp b3))) =>
+	      (EqTerm (Tint ZERO) (rewrite s (Tplus b1 (Tmult (Tplus (Topp b3) b2) (Tint m)))))
+	| _ => TrueTerm
+	end
+  | _ => TrueTerm
+  end.
+
+Theorem state_valid : (m:Z; s:step) (valid2 (state m s)).
+
+Unfold valid2; Intros m s e p1 p2; Unfold state; Simplify; Simpl;Auto;
+Elim (rewrite_stable s e); Simpl; Intros H1 H2; Elim H1;
+Rewrite (Zplus_sym `-(interp_term e t5)` `(interp_term e t3)`);
+Elim H2; Simpl; Reflexivity.
+
+Save.
+
+(* \subsubsection{Tactiques générant plusieurs but}
+   \paragraph{[O_SPLIT_INEQ]} 
+   La seule pour le moment (tant que la normalisation n'est pas réfléchie). *)
+
+Definition split_ineq  [i,t: nat; f1,f2:hyps -> lhyps;  l:hyps] :=
+  Cases (nth_hyps i l) of
+    (NeqTerm  (Tint ZERO) b1) =>
+       (app (f1 (cons (LeqTerm (Tint ZERO) (add_norm t (Tplus b1 (Tint `-1`)))) l))
+            (f2 (cons (LeqTerm (Tint ZERO) 
+                               (scalar_norm_add t 
+	                         (Tplus (Tmult b1 (Tint `-1`)) (Tint `-1`))))
+                      l)))
+  | _ => (cons l (nil ?))
+  end.
+
+Theorem split_ineq_valid : 
+  (i,t: nat; f1,f2: hyps -> lhyps) 
+    (valid_list_hyps f1) ->(valid_list_hyps f2) -> 
+      (valid_list_hyps (split_ineq i t f1 f2)).
+
+Unfold valid_list_hyps split_ineq; Intros i t f1 f2 H1 H2 e lp H; 
+Generalize (nth_valid ? i ? H); 
+Case (nth_hyps i lp); Simpl; Auto; Intros t1 t2; Case t1; Simpl; Auto;
+Intros z; Case z; Simpl; Auto;
+Intro H3; Apply append_valid;Elim (OMEGA19 (interp_term e t2)) ;[
+  Intro H4; Left; Apply H1; Simpl; Elim (add_norm_stable t); Simpl; Auto
+| Intro H4; Right; Apply H2; Simpl; Elim (scalar_norm_add_stable t); 
+  Simpl; Auto
+| Generalize H3; Unfold Zne not; Intros E1 E2; Apply E1; Symmetry; Trivial ].
+Save.
+
+
+(* \subsection{La fonction de rejeu de la trace} *)
+Inductive t_omega : Set :=
+   (* n = 0 n!= 0 *)
+ | O_CONSTANT_NOT_NUL : nat -> t_omega
+ | O_CONSTANT_NEG : nat -> t_omega
+   (* division et approximation d'une équation *)
+ | O_DIV_APPROX : Z -> Z -> term -> nat -> t_omega -> nat -> t_omega
+   (* pas de solution car pas de division exacte (fin) *)
+ | O_NOT_EXACT_DIVIDE :  Z -> Z -> term -> nat -> nat -> t_omega
+   (* division exacte *)
+ | O_EXACT_DIVIDE : Z -> term -> nat -> t_omega -> nat -> t_omega
+ | O_SUM : Z -> nat -> Z -> nat -> (list t_fusion) -> t_omega -> t_omega
+ | O_CONTRADICTION : nat -> nat -> nat -> t_omega
+ | O_MERGE_EQ : nat -> nat -> nat -> t_omega -> t_omega
+ | O_SPLIT_INEQ : nat -> nat -> t_omega -> t_omega -> t_omega
+ | O_CONSTANT_NUL : nat -> t_omega 
+ | O_NEGATE_CONTRADICT : nat -> nat -> t_omega
+ | O_NEGATE_CONTRADICT_INV : nat -> nat -> nat -> t_omega
+ | O_STATE : Z -> step -> nat -> nat -> t_omega -> t_omega.
+
+Notation singleton :=  [a: hyps] (cons a (nil hyps)).
+
+Fixpoint execute_omega [t: t_omega] : hyps -> lhyps := 
+  [l : hyps] Cases t of
+   | (O_CONSTANT_NOT_NUL n) => (singleton (constant_not_nul n l))
+   | (O_CONSTANT_NEG n) => (singleton (constant_neg n l))
+   | (O_DIV_APPROX  k1 k2 body t cont n) =>
+       (execute_omega cont 
+	  (apply_oper_1 n (divide_and_approx k1 k2 body t) l))
+   | (O_NOT_EXACT_DIVIDE  k1 k2 body t i) =>
+       (singleton (not_exact_divide k1 k2 body t i l))
+   | (O_EXACT_DIVIDE k body t cont n) =>
+       (execute_omega cont (apply_oper_1 n (exact_divide k body t) l))
+   | (O_SUM k1 i1 k2 i2 t cont) =>
+       (execute_omega cont (apply_oper_2 i1 i2 (sum k1 k2 t) l))
+   | (O_CONTRADICTION t i j) =>
+       (singleton (contradiction t i j l))
+   | (O_MERGE_EQ t i1 i2 cont) =>
+       (execute_omega cont (apply_oper_2 i1 i2 (merge_eq t) l))
+   | (O_SPLIT_INEQ t i cont1 cont2) =>
+       (split_ineq i t (execute_omega cont1) (execute_omega cont2) l)
+   | (O_CONSTANT_NUL i) => (singleton (constant_nul i l))
+   | (O_NEGATE_CONTRADICT i j) =>  (singleton (negate_contradict i j l))
+   | (O_NEGATE_CONTRADICT_INV t i j) => (singleton (negate_contradict_inv t i j l))
+   | (O_STATE m s i1 i2 cont) =>
+       (execute_omega cont (apply_oper_2 i1 i2 (state m s) l))
+  end.
+
+Theorem omega_valid : (t: t_omega) (valid_list_hyps (execute_omega t)).
+
+Induction t; Simpl; [
+  Unfold valid_list_hyps; Simpl; Intros; Left; 
+  Apply (constant_not_nul_valid n e lp H)
+| Unfold valid_list_hyps; Simpl; Intros; Left; 
+  Apply (constant_neg_valid n e lp H)
+| Unfold valid_list_hyps valid_hyps; Intros k1 k2 body n t' Ht' m e lp H; 
+  Apply Ht';
+  Apply (apply_oper_1_valid m (divide_and_approx k1 k2 body n)
+	  (divide_and_approx_valid k1 k2 body n) e lp H)
+| Unfold valid_list_hyps; Simpl; Intros; Left; 
+  Apply (not_exact_divide_valid z z0 t0 n n0 e lp H)
+| Unfold valid_list_hyps valid_hyps; Intros k body n t' Ht' m e lp H; 
+  Apply Ht';
+  Apply (apply_oper_1_valid m (exact_divide k body n)
+	  (exact_divide_valid k body n) e lp H)
+| Unfold valid_list_hyps valid_hyps; Intros k1 i1 k2 i2 trace t' Ht' e lp H;
+  Apply Ht'; 
+  Apply (apply_oper_2_valid i1 i2 (sum k1 k2 trace) 
+	  (sum_valid k1 k2 trace) e lp H)
+| Unfold valid_list_hyps; Simpl; Intros; Left; 
+  Apply (contradiction_valid n n0 n1 e lp H)
+| Unfold valid_list_hyps valid_hyps; Intros trace i1 i2 t' Ht' e lp H; 
+  Apply Ht';
+  Apply (apply_oper_2_valid i1 i2 (merge_eq trace) 
+          (merge_eq_valid trace) e lp H) 
+| Intros t' i k1 H1 k2 H2; Unfold valid_list_hyps; Simpl; Intros e lp H;
+  Apply (split_ineq_valid i t' (execute_omega k1) (execute_omega k2) 
+	 H1 H2 e lp H)
+| Unfold valid_list_hyps; Simpl; Intros i e lp H; Left; 
+  Apply (constant_nul_valid i e lp H)
+| Unfold valid_list_hyps; Simpl; Intros i j e lp H; Left; 
+  Apply (negate_contradict_valid i j e lp H)
+| Unfold valid_list_hyps; Simpl; Intros n i j e lp H; Left; 
+  Apply (negate_contradict_inv_valid n i j e lp H)
+| Unfold valid_list_hyps valid_hyps; Intros m s i1 i2 t' Ht' e lp H; Apply Ht';
+  Apply (apply_oper_2_valid i1 i2 (state m s) (state_valid m s) e lp H)
+].
+Save.
+
+
+(* \subsection{Les opérations globales sur le but} 
+   \subsubsection{Normalisation} *)
+
+Definition move_right [s: step; p:proposition] :=
+  Cases p of
+     (EqTerm t1 t2) => (EqTerm (Tint ZERO) (rewrite s (Tplus t1 (Topp t2))))
+   | (LeqTerm t1 t2) => (LeqTerm (Tint ZERO) (rewrite s (Tplus t2 (Topp t1))))
+   | (GeqTerm t1 t2) => (LeqTerm (Tint ZERO) (rewrite s (Tplus t1 (Topp t2))))
+   | (LtTerm t1 t2) =>
+        (LeqTerm (Tint ZERO)
+	         (rewrite s (Tplus (Tplus t2 (Tint `-1`)) (Topp t1))))
+   | (GtTerm t1 t2) => 
+        (LeqTerm (Tint ZERO)
+                 (rewrite s (Tplus (Tplus t1 (Tint `-1`)) (Topp t2))))
+   | (NeqTerm t1 t2) => (NeqTerm (Tint ZERO) (rewrite s (Tplus t1 (Topp t2))))
+   | p => p
+  end.
+
+Theorem Zne_left_2 : (x,y:Z)(Zne x y)->(Zne `0` `x+(-y)`).
+Unfold Zne not; Intros x y H1 H2; Apply H1; Apply (Zsimpl_plus_l `-y`);
+Rewrite Zplus_sym; Elim H2; Rewrite Zplus_inverse_l; Trivial.
+Save.
+
+Theorem move_right_valid : (s: step) (valid1 (move_right s)).
+
+Unfold valid1 move_right; Intros s e p; Simplify; Simpl;
+Elim (rewrite_stable s e); Simpl; [
+  Symmetry; Apply Zegal_left; Assumption
+| Intro; Apply Zle_left; Assumption 
+| Intro; Apply Zge_left; Assumption
+| Intro; Apply Zgt_left; Assumption
+| Intro; Apply Zlt_left; Assumption
+| Intro; Apply Zne_left_2; Assumption
+].
+Save.
+
+Definition do_normalize [i:nat; s: step] := (apply_oper_1 i (move_right s)).
+
+Theorem do_normalize_valid : (i:nat; s:step) (valid_hyps (do_normalize i s)).
+
+Intros; Unfold do_normalize; Apply apply_oper_1_valid; Apply move_right_valid.
+Save.
+
+Fixpoint do_normalize_list [l:(list step)] : nat -> hyps -> hyps := 
+  [i:nat; h:hyps] Cases l of
+    (cons s l') => (do_normalize_list l' (S i) (do_normalize i s h))
+  | nil => h
+  end.
+
+Theorem do_normalize_list_valid : 
+  (l:(list step); i:nat) (valid_hyps (do_normalize_list l i)).
+
+Induction l; Simpl; Unfold valid_hyps; [
+  Auto
+| Intros a l' Hl' i e lp H; Unfold valid_hyps in Hl'; Apply Hl';
+  Apply (do_normalize_valid i a e lp); Assumption ].
+Save.
+
+Theorem normalize_goal :
+  (s: (list step); env : (list Z); l: hyps)
+    (interp_goal env (do_normalize_list s O l)) -> 
+      (interp_goal env l).
+
+Intros; Apply valid_goal with 2:=H; Apply do_normalize_list_valid.
+Save.
+
+(* \subsubsection{Exécution de la trace} *)
+
+Theorem execute_goal :
+  (t : t_omega; env : (list Z); l: hyps)
+    (interp_list_goal env (execute_omega t l)) -> (interp_goal env l).
+
+Intros; Apply (goal_valid (execute_omega t) (omega_valid t) env l H).
+Save.
+
+
+Theorem append_goal :
+  (e: (list Z)) (l1,l2:lhyps)
+     (interp_list_goal e l1) /\ (interp_list_goal e l2) ->
+     (interp_list_goal e (app l1 l2)).
+
+Intros e; Induction l1; [
+  Simpl; Intros l2 (H1, H2); Assumption
+| Simpl; Intros h1 t1 HR l2 ((H1 , H2), H3) ; Split; Auto].
+
+
+Save.
+