diff options
Diffstat (limited to 'contrib7')
38 files changed, 0 insertions, 9888 deletions
diff --git a/contrib7/cc/CCSolve.v b/contrib7/cc/CCSolve.v deleted file mode 100644 index 388763ed..00000000 --- a/contrib7/cc/CCSolve.v +++ /dev/null @@ -1,20 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: CCSolve.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *) - -Tactic Definition CCsolve := - Repeat (Match Context With - [ H: ?1 |- ?2] -> - Let Heq = FreshId "Heq" In - (Assert Heq:(?2==?1);[Congruence|(Rewrite Heq;Exact H)]) - |[ H: ?1; G: ?2 -> ?3 |- ?] -> - Let Heq = FreshId "Heq" In - (Assert Heq:(?2==?1) ;[Congruence| - (Rewrite Heq in G;Generalize (G H);Clear G;Intro G)])). - diff --git a/contrib7/correctness/ArrayPermut.v b/contrib7/correctness/ArrayPermut.v deleted file mode 100644 index 4a0025ca..00000000 --- a/contrib7/correctness/ArrayPermut.v +++ /dev/null @@ -1,183 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \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: ArrayPermut.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *) - -(****************************************************************************) -(* 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 deleted file mode 100644 index 3fdc78c1..00000000 --- a/contrib7/correctness/Arrays.v +++ /dev/null @@ -1,75 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \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: Arrays.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *) - -(**********************************************) -(* 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 deleted file mode 100644 index 448b0ab6..00000000 --- a/contrib7/correctness/Arrays_stuff.v +++ /dev/null @@ -1,16 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \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: Arrays_stuff.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *) - -Require Export Exchange. -Require Export ArrayPermut. -Require Export Sorted. - diff --git a/contrib7/correctness/Correctness.v b/contrib7/correctness/Correctness.v deleted file mode 100644 index b0fde165..00000000 --- a/contrib7/correctness/Correctness.v +++ /dev/null @@ -1,25 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \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.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *) - -(* 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 deleted file mode 100644 index 12c8c9de..00000000 --- a/contrib7/correctness/Exchange.v +++ /dev/null @@ -1,94 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \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.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *) - -(****************************************************************************) -(* 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 deleted file mode 100644 index c7a7687d..00000000 --- a/contrib7/correctness/ProgBool.v +++ /dev/null @@ -1,66 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \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: ProgBool.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *) - -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 deleted file mode 100644 index 0ca830c2..00000000 --- a/contrib7/correctness/ProgInt.v +++ /dev/null @@ -1,19 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \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: ProgInt.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *) - -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 deleted file mode 100644 index 20f82ce4..00000000 --- a/contrib7/correctness/ProgramsExtraction.v +++ /dev/null @@ -1,30 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \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: ProgramsExtraction.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *) - -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 deleted file mode 100644 index 00beeaeb..00000000 --- a/contrib7/correctness/Programs_stuff.v +++ /dev/null @@ -1,13 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \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: Programs_stuff.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *) - -Require Export Arrays_stuff. diff --git a/contrib7/correctness/Sorted.v b/contrib7/correctness/Sorted.v deleted file mode 100644 index f476142e..00000000 --- a/contrib7/correctness/Sorted.v +++ /dev/null @@ -1,198 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \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: Sorted.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *) - -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 deleted file mode 100644 index 6e1eb03a..00000000 --- a/contrib7/correctness/Tuples.v +++ /dev/null @@ -1,106 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \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.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *) - -(* 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 deleted file mode 100644 index 33659b43..00000000 --- a/contrib7/correctness/preuves.v +++ /dev/null @@ -1,128 +0,0 @@ - -(* 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/extraction/test_extraction.v b/contrib7/extraction/test_extraction.v deleted file mode 100644 index e76b1c69..00000000 --- a/contrib7/extraction/test_extraction.v +++ /dev/null @@ -1,533 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Arith. -Require PolyList. - -(*** STANDARD EXAMPLES *) - -(** Functions. *) - -Definition idnat := [x:nat]x. -Extraction idnat. -(* let idnat x = x *) - -Definition id := [X:Type][x:X]x. -Extraction id. (* let id x = x *) -Definition id' := (id Set nat). -Extraction id'. (* type id' = nat *) - -Definition test2 := [f:nat->nat][x:nat](f x). -Extraction test2. -(* let test2 f x = f x *) - -Definition test3 := [f:nat->Set->nat][x:nat](f x nat). -Extraction test3. -(* let test3 f x = f x __ *) - -Definition test4 := [f:(nat->nat)->nat][x:nat][g:nat->nat](f g). -Extraction test4. -(* let test4 f x g = f g *) - -Definition test5 := ((1),(0)). -Extraction test5. -(* let test5 = Pair ((S O), O) *) - -Definition cf := [x:nat][_:(le x O)](S x). -Extraction NoInline cf. -Definition test6 := (cf O (le_n O)). -Extraction test6. -(* let test6 = cf O *) - -Definition test7 := ([X:Set][x:X]x nat). -Extraction test7. -(* let test7 x = x *) - -Definition d := [X:Type]X. -Extraction d. (* type 'x d = 'x *) -Definition d2 := (d Set). -Extraction d2. (* type d2 = __ d *) -Definition d3 := [x:(d Set)]O. -Extraction d3. (* let d3 _ = O *) -Definition d4 := (d nat). -Extraction d4. (* type d4 = nat d *) -Definition d5 := ([x:(d Type)]O Type). -Extraction d5. (* let d5 = O *) -Definition d6 := ([x:(d Type)]x). -Extraction d6. (* type 'x d6 = 'x *) - -Definition test8 := ([X:Type][x:X]x Set nat). -Extraction test8. (* type test8 = nat *) - -Definition test9 := let t = nat in (id Set t). -Extraction test9. (* type test9 = nat *) - -Definition test10 := ([X:Type][x:X]O Type Type). -Extraction test10. (* let test10 = O *) - -Definition test11 := let n=O in let p=(S n) in (S p). -Extraction test11. (* let test11 = S (S O) *) - -Definition test12 := (x:(X:Type)X->X)(x Type Type). -Extraction test12. -(* type test12 = (__ -> __ -> __) -> __ *) - - -Definition test13 := Cases (left True True I) of (left x)=>(S O) | (right x)=>O end. -Extraction test13. (* let test13 = S O *) - - -(** example with more arguments that given by the type *) - -Definition test19 := (nat_rec [n:nat]nat->nat [n:nat]O [n:nat][f:nat->nat]f O O). -Extraction test19. -(* let test19 = - let rec f = function - | O -> (fun n0 -> O) - | S n0 -> f n0 - in f O O -*) - - -(** casts *) - -Definition test20 := (True :: Type). -Extraction test20. -(* type test20 = __ *) - - -(** Simple inductive type and recursor. *) - -Extraction nat. -(* -type nat = - | O - | S of nat -*) - -Extraction sumbool_rect. -(* -let sumbool_rect f f0 = function - | Left -> f __ - | Right -> f0 __ -*) - -(** Less simple inductive type. *) - -Inductive c [x:nat] : nat -> Set := - refl : (c x x) - | trans : (y,z:nat)(c x y)->(le y z)->(c x z). -Extraction c. -(* -type c = - | Refl - | Trans of nat * nat * c -*) - -Definition Ensemble := [U:Type]U->Prop. -Definition Empty_set := [U:Type][x:U]False. -Definition Add := [U:Type][A:(Ensemble U)][x:U][y:U](A y) \/ x==y. - -Inductive Finite [U:Type] : (Ensemble U) -> Set := - Empty_is_finite: (Finite U (Empty_set U)) - | Union_is_finite: - (A: (Ensemble U)) (Finite U A) -> - (x: U) ~ (A x) -> (Finite U (Add U A x)). -Extraction Finite. -(* -type 'u finite = - | Empty_is_finite - | Union_is_finite of 'u finite * 'u -*) - - -(** Mutual Inductive *) - -Inductive tree : Set := - Node : nat -> forest -> tree -with forest : Set := - | Leaf : nat -> forest - | Cons : tree -> forest -> forest . - -Extraction tree. -(* -type tree = - | Node of nat * forest -and forest = - | Leaf of nat - | Cons of tree * forest -*) - -Fixpoint tree_size [t:tree] : nat := - Cases t of (Node a f) => (S (forest_size f)) end -with forest_size [f:forest] : nat := - Cases f of - | (Leaf b) => (S O) - | (Cons t f') => (plus (tree_size t) (forest_size f')) - end. - -Extraction tree_size. -(* -let rec tree_size = function - | Node (a, f) -> S (forest_size f) -and forest_size = function - | Leaf b -> S O - | Cons (t, f') -> plus (tree_size t) (forest_size f') -*) - - -(** Eta-expansions of inductive constructor *) - -Inductive titi : Set := tata : nat->nat->nat->nat->titi. -Definition test14 := (tata O). -Extraction test14. -(* let test14 x x0 x1 = Tata (O, x, x0, x1) *) -Definition test15 := (tata O (S O)). -Extraction test15. -(* let test15 x x0 = Tata (O, (S O), x, x0) *) - -Inductive eta : Set := eta_c : nat->Prop->nat->Prop->eta. -Extraction eta_c. -(* -type eta = - | Eta_c of nat * nat -*) -Definition test16 := (eta_c O). -Extraction test16. -(* let test16 x = Eta_c (O, x) *) -Definition test17 := (eta_c O True). -Extraction test17. -(* let test17 x = Eta_c (O, x) *) -Definition test18 := (eta_c O True O). -Extraction test18. -(* let test18 _ = Eta_c (O, O) *) - - -(** Example of singleton inductive type *) - -Inductive bidon [A:Prop;B:Type] : Set := tb : (x:A)(y:B)(bidon A B). -Definition fbidon := [A,B:Type][f:A->B->(bidon True nat)][x:A][y:B](f x y). -Extraction bidon. -(* type 'b bidon = 'b *) -Extraction tb. -(* tb : singleton inductive constructor *) -Extraction fbidon. -(* let fbidon f x y = - f x y -*) - -Definition fbidon2 := (fbidon True nat (tb True nat)). -Extraction fbidon2. (* let fbidon2 y = y *) -Extraction NoInline fbidon. -Extraction fbidon2. -(* let fbidon2 y = fbidon (fun _ x -> x) __ y *) - -(* NB: first argument of fbidon2 has type [True], so it disappears. *) - -(** mutual inductive on many sorts *) - -Inductive - test_0 : Prop := ctest0 : test_0 -with - test_1 : Set := ctest1 : test_0-> test_1. -Extraction test_0. -(* test0 : logical inductive *) -Extraction test_1. -(* -type test1 = - | Ctest1 -*) - -(** logical singleton *) - -Extraction eq. -(* eq : logical inductive *) -Extraction eq_rect. -(* let eq_rect x f y = - f -*) - -(** No more propagation of type parameters. Obj.t instead. *) - -Inductive tp1 : Set := - T : (C:Set)(c:C)tp2 -> tp1 with tp2 : Set := T' : tp1->tp2. -Extraction tp1. -(* -type tp1 = - | T of __ * tp2 -and tp2 = - | T' of tp1 -*) - -Inductive tp1bis : Set := - Tbis : tp2bis -> tp1bis -with tp2bis : Set := T'bis : (C:Set)(c:C)tp1bis->tp2bis. -Extraction tp1bis. -(* -type tp1bis = - | Tbis of tp2bis -and tp2bis = - | T'bis of __ * tp1bis -*) - - -(** Strange inductive type. *) - -Inductive Truc : Set->Set := - chose : (A:Set)(Truc A) - | machin : (A:Set)A->(Truc bool)->(Truc A). -Extraction Truc. -(* -type 'x truc = - | Chose - | Machin of 'x * bool truc -*) - - -(** Dependant type over Type *) - -Definition test24:= (sigT Set [a:Set](option a)). -Extraction test24. -(* type test24 = (__, __ option) sigT *) - - -(** Coq term non strongly-normalizable after extraction *) - -Require Gt. -Definition loop := - [Ax:(Acc nat gt O)] - (Fix F {F [a:nat;b:(Acc nat gt a)] : nat := - (F (S a) (Acc_inv nat gt a b (S a) (gt_Sn_n a)))} - O Ax). -Extraction loop. -(* let loop _ = - let rec f a = - f (S a) - in f O -*) - -(*** EXAMPLES NEEDING OBJ.MAGIC *) - -(** False conversion of type: *) - -Lemma oups : (H:(nat==(list nat)))nat -> nat. -Intros. -Generalize H0;Intros. -Rewrite H in H1. -Case H1. -Exact H0. -Intros. -Exact n. -Qed. -Extraction oups. -(* -let oups h0 = - match Obj.magic h0 with - | Nil -> h0 - | Cons0 (n, l) -> n -*) - - -(** hybrids *) - -Definition horibilis := [b:bool]<[b:bool]if b then Type else nat>if b then Set else O. -Extraction horibilis. -(* -let horibilis = function - | True -> Obj.magic __ - | False -> Obj.magic O -*) - -Definition PropSet := [b:bool]if b then Prop else Set. -Extraction PropSet. (* type propSet = __ *) - -Definition natbool := [b:bool]if b then nat else bool. -Extraction natbool. (* type natbool = __ *) - -Definition zerotrue := [b:bool]<natbool>if b then O else true. -Extraction zerotrue. -(* -let zerotrue = function - | True -> Obj.magic O - | False -> Obj.magic True -*) - -Definition natProp := [b:bool]<[_:bool]Type>if b then nat else Prop. - -Definition natTrue := [b:bool]<[_:bool]Type>if b then nat else True. - -Definition zeroTrue := [b:bool]<natProp>if b then O else True. -Extraction zeroTrue. -(* -let zeroTrue = function - | True -> Obj.magic O - | False -> Obj.magic __ -*) - -Definition natTrue2 := [b:bool]<[_:bool]Type>if b then nat else True. - -Definition zeroprop := [b:bool]<natTrue>if b then O else I. -Extraction zeroprop. -(* -let zeroprop = function - | True -> Obj.magic O - | False -> Obj.magic __ -*) - -(** polymorphic f applied several times *) - -Definition test21 := (id nat O, id bool true). -Extraction test21. -(* let test21 = Pair ((id O), (id True)) *) - -(** ok *) - -Definition test22 := ([f:(X:Type)X->X](f nat O, f bool true) [X:Type][x:X]x). -Extraction test22. -(* let test22 = - let f = fun x -> x in Pair ((f O), (f True)) *) - -(* still ok via optim beta -> let *) - -Definition test23 := [f:(X:Type)X->X](f nat O, f bool true). -Extraction test23. -(* let test23 f = Pair ((Obj.magic f __ O), (Obj.magic f __ True)) *) - -(* problem: fun f -> (f 0, f true) not legal in ocaml *) -(* solution: magic ... *) - - -(** Dummy constant __ can be applied.... *) - -Definition f : (X:Type)(nat->X)->(X->bool)->bool := - [X:Type;x:nat->X;y:X->bool](y (x O)). -Extraction f. -(* let f x y = - y (x O) -*) - -Definition f_prop := (f (O=O) [_](refl_equal ? O) [_]true). -Extraction NoInline f. -Extraction f_prop. -(* let f_prop = - f (Obj.magic __) (fun _ -> True) -*) - -Definition f_arity := (f Set [_:nat]nat [_:Set]true). -Extraction f_arity. -(* let f_arity = - f (Obj.magic __) (fun _ -> True) -*) - -Definition f_normal := (f nat [x]x [x](Cases x of O => true | _ => false end)). -Extraction f_normal. -(* let f_normal = - f (fun x -> x) (fun x -> match x with - | O -> True - | S n -> False) -*) - - -(* inductive with magic needed *) - -Inductive Boite : Set := - boite : (b:bool)(if b then nat else nat*nat)->Boite. -Extraction Boite. -(* -type boite = - | Boite of bool * __ -*) - - -Definition boite1 := (boite true O). -Extraction boite1. -(* let boite1 = Boite (True, (Obj.magic O)) *) - -Definition boite2 := (boite false (O,O)). -Extraction boite2. -(* let boite2 = Boite (False, (Obj.magic (Pair (O, O)))) *) - -Definition test_boite := [B:Boite]<nat>Cases B of - (boite true n) => n -| (boite false n) => (plus (fst ? ? n) (snd ? ? n)) -end. -Extraction test_boite. -(* -let test_boite = function - | Boite (b0, n) -> - (match b0 with - | True -> Obj.magic n - | False -> plus (fst (Obj.magic n)) (snd (Obj.magic n))) -*) - -(* singleton inductive with magic needed *) - -Inductive Box : Set := - box : (A:Set)A -> Box. -Extraction Box. -(* type box = __ *) - -Definition box1 := (box nat O). -Extraction box1. (* let box1 = Obj.magic O *) - -(* applied constant, magic needed *) - -Definition idzarb := [b:bool][x:(if b then nat else bool)]x. -Definition zarb := (idzarb true O). -Extraction NoInline idzarb. -Extraction zarb. -(* let zarb = Obj.magic idzarb True (Obj.magic O) *) - -(** function of variable arity. *) -(** Fun n = nat -> nat -> ... -> nat *) - -Fixpoint Fun [n:nat] : Set := - Cases n of - O => nat - | (S n) => nat -> (Fun n) - end. - -Fixpoint Const [k,n:nat] : (Fun n) := - <Fun>Cases n of - O => k - | (S n) => [p:nat](Const k n) - end. - -Fixpoint proj [k,n:nat] : (Fun n) := - <Fun>Cases n of - O => O (* ou assert false ....*) - | (S n) => Cases k of - O => [x](Const x n) - | (S k) => [x](proj k n) - end - end. - -Definition test_proj := (proj (2) (4) (0) (1) (2) (3)). - -Eval Compute in test_proj. - -Recursive Extraction test_proj. - - - -(*** TO SUM UP: ***) - - -Extraction "test_extraction.ml" - idnat id id' test2 test3 test4 test5 test6 test7 - d d2 d3 d4 d5 d6 test8 id id' test9 test10 test11 - test12 test13 test19 test20 - nat sumbool_rect c Finite tree tree_size - test14 test15 eta_c test16 test17 test18 bidon tb fbidon fbidon2 - fbidon2 test_0 test_1 eq eq_rect tp1 tp1bis Truc oups test24 loop - horibilis PropSet natbool zerotrue zeroTrue zeroprop test21 test22 - test23 f f_prop f_arity f_normal - Boite boite1 boite2 test_boite - Box box1 zarb test_proj. - - diff --git a/contrib7/field/Field.v b/contrib7/field/Field.v deleted file mode 100644 index f282e246..00000000 --- a/contrib7/field/Field.v +++ /dev/null @@ -1,15 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: Field.v,v 1.1.2.1 2004/07/16 19:30:17 herbelin Exp $ *) - -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 deleted file mode 100644 index 2cc01038..00000000 --- a/contrib7/field/Field_Compl.v +++ /dev/null @@ -1,62 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: Field_Compl.v,v 1.2.2.1 2004/07/16 19:30:17 herbelin Exp $ *) - -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 field_rel_option [A:Type] : Type := - | Field_None : (field_rel_option A) - | Field_Some : (A -> A -> A) -> (field_rel_option A). diff --git a/contrib7/field/Field_Tactic.v b/contrib7/field/Field_Tactic.v deleted file mode 100644 index ffd2aad4..00000000 --- a/contrib7/field/Field_Tactic.v +++ /dev/null @@ -1,397 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: Field_Tactic.v,v 1.2.2.1 2004/07/16 19:30:17 herbelin Exp $ *) - -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 - | [(Field_Some ? ?1)] -> Unfold ?1 - | _ -> Idtac); - (Match Eval Cbv Beta Delta [Adiv] Iota in (Adiv FT) With - | [(Field_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 - | [(Field_Some ? ?1)] -> Eval Cbv Beta Delta [?1] in trm - | _ -> trm) In - Match Eval Cbv Beta Delta [Adiv] Iota in (Adiv FT) With - | [(Field_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 deleted file mode 100644 index 3ba2fbc0..00000000 --- a/contrib7/field/Field_Theory.v +++ /dev/null @@ -1,612 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: Field_Theory.v,v 1.2.2.1 2004/07/16 19:30:17 herbelin Exp $ *) - -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 : (field_rel_option A); - Adiv : (field_rel_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/Fourier.v b/contrib7/fourier/Fourier.v deleted file mode 100644 index 740bbef6..00000000 --- a/contrib7/fourier/Fourier.v +++ /dev/null @@ -1,28 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: Fourier.v,v 1.1.2.1 2004/07/16 19:30:17 herbelin Exp $ *) - -(* "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 deleted file mode 100644 index be22e2ff..00000000 --- a/contrib7/fourier/Fourier_util.v +++ /dev/null @@ -1,236 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: Fourier_util.v,v 1.2.2.1 2004/07/16 19:30:17 herbelin Exp $ *) - -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. -Apply Rgt_Ropp. -Red. -Exact H0. -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/interface/AddDad.v b/contrib7/interface/AddDad.v deleted file mode 100644 index d22b7ed1..00000000 --- a/contrib7/interface/AddDad.v +++ /dev/null @@ -1,19 +0,0 @@ -Grammar vernac vernac : ast := - add_dad_rule00 ["AddDadRule" stringarg($name) constrarg($pat) - "first_path" "second_path" tacarg($tac) "."] -> - [(AddDadRule $name $pat (NUMBERLIST) (NUMBERLIST) (TACTIC $tac))]. -Grammar vernac vernac:ast := -| add_dad_rule01 ["AddDadRule" stringarg($name) constrarg($pat) - "first_path" "second_path" ne_numarg_list($l) tacarg($tac) "."] -> - [(AddDadRule $name $pat (NUMBERLIST) (NUMBERLIST ($LIST $l)) (TACTIC $tac))] -| add_dad_rule10 ["AddDadRule" stringarg($name) constrarg($pat) - "first_path" ne_numarg_list($l) "second_path" tacarg($tac) "."] -> - [(AddDadRule $name $pat (NUMBERLIST ($LIST $l))(NUMBERLIST) (TACTIC $tac))] -| add_dad_rule11 ["AddDadRule" stringarg($name) constrarg($pat) - "first_path" ne_numarg_list($l) "second_path" ne_numarg_list($l1) - tacarg($tac) "."] -> - [(AddDadRule $name $pat (NUMBERLIST ($LIST $l))(NUMBERLIST ($LIST $l1)) - (TACTIC $tac))]. - -Grammar vernac vernac : ast := - start_dad [ "StartDad" "."] -> [(StartDad)]. diff --git a/contrib7/interface/Centaur.v b/contrib7/interface/Centaur.v deleted file mode 100644 index d27929f8..00000000 --- a/contrib7/interface/Centaur.v +++ /dev/null @@ -1,88 +0,0 @@ -(* -Declare ML Module "ctast". -Declare ML Module "paths". -Declare ML Module "name_to_ast". -Declare ML Module "xlate". -Declare ML Module "vtp". -Declare ML Module "translate". -Declare ML Module "pbp". -Declare ML Module "blast". -Declare ML Module "dad". -Declare ML Module "showproof_ct". -Declare ML Module "showproof". -Declare ML Module "debug_tac". -Declare ML Module "paths". -Declare ML Module "history". -Declare ML Module "centaur". -(* Require Export Illustrations. *) -(* Require Export AddDad. *) -(* -Grammar vernac vernac : ast := - goal_cmd [ "Goal" "Cmd" numarg($n) "with" tacarg($tac) "." ] -> - [(GOAL_CMD $n (TACTIC $tac))] -| kill_proof_after [ "Kill" "Proof" "after" numarg($n)"." ] -> [(KILL_NODE $n)] -| kill_proof_at [ "Kill" "Proof" "at" numarg($n)"." ] -> [(KILL_NODE $n)] -| kill_sub_proof [ "Kill" "SubProof" numarg($n) "." ] -> [(KILL_SUB_PROOF $n)] - -| print_past_goal [ "Print" "Past" "Goal" numarg($n) "." ] -> - [(PRINT_GOAL_AT $n) ] - -| check_in_goal [ "CHECK_IN_GOAL" numarg($n) constrarg($c) "." ] -> - [(CHECK_IN_GOAL "CHECK" $n $c)] -| eval_in_goal [ "EVAL_IN_GOAL" numarg($n) constrarg($c) "." ] -> - [(CHECK_IN_GOAL "EVAL" $n $c)] -| compute_in_goal [ "COMPUTE_IN_GOAL" numarg($n) constrarg($c) "." ] -> - [(CHECK_IN_GOAL "COMPUTE" $n $c)] -| centaur_reset [ "Centaur" "Reset" identarg($id) "." ] -> [(Centaur_Reset $id)] -(*| show_dad_rules [ "Show" "Dad" "Rules" "." ] -> [(Show_dad_rules)]*) -| start_pcoq [ "Start" "Pcoq" "Mode" "." ] -> [ (START_PCOQ) ] -| start_pcoq [ "Start" "Pcoq" "Debug" "Mode" "." ] -> [ (START_PCOQ_DEBUG) ]. -Grammar vernac ne_id_list : ast list := - id_one [ identarg($id)] -> [$id] - | id_more [identarg($id) ne_id_list($others)] -> [$id ($LIST $others)]. - -Grammar tactic ne_num_list : ast list := - ne_last [ numarg($n) ] -> [ $n ] -| ne_num_ste [ numarg($n) ne_num_list($ns) ] -> [ $n ($LIST $ns)]. - -Grammar tactic two_numarg_list : ast list := - two_single_and_ne [ numarg($n) "to" ne_num_list($ns)] -> - [$n (TACTIC (to)) ($LIST $ns)] -| two_rec [ numarg($n) two_numarg_list($ns)] -> [ $n ($LIST $ns)]. - -Grammar tactic simple_tactic : ast := - pbp0 [ "Pbp" ] -> [(PcoqPbp)] -| pbp1 [ "Pbp" ne_num_list($ns) ] -> - [ (PcoqPbp ($LIST $ns)) ] -| pbp2 [ "Pbp" identarg($id) ] -> [ (PcoqPbp $id) ] -| pbp3 [ "Pbp" identarg($id) ne_num_list($ns)] -> - [ (PcoqPbp $id ($LIST $ns)) ] -| blast1 [ "Blast" ne_num_list($ns) ] -> - [ (PcoqBlast ($LIST $ns)) ] -| dad00 [ "Dad" "to" ] -> [(Dad (TACTIC (to)))] -| dad01 [ "Dad" "to" ne_num_list($ns) ] -> - [(Dad (TACTIC (to)) ($LIST $ns))] -| dadnn [ "Dad" two_numarg_list($ns) ] -> [ (Dad ($LIST $ns)) ] -| debug_tac [ "DebugTac" tactic($tac) ] -> - [(CtDebugTac (TACTIC $tac))] -| on_then_empty [ "OnThen" tactic($tac1) tactic($tac2) ] -> - [(OnThen (TACTIC $tac1) (TACTIC $tac2))] -| on_then_ne [ "OnThen" tactic($tac1) tactic($tac2) ne_num_list($l) ] -> - [(OnThen (TACTIC $tac1) (TACTIC $tac2) ($LIST $l))] -| debug_tac2 [ "DebugTac2" tactic($tac) ] -> - [(CtDebugTac2 (TACTIC $tac))]. - - -(* Maybe we should have syntactic rules to make sur that syntax errors are - displayed with a readable syntax. It is not sure, since the error reporting - procedure changed from V6.1 and does not reprint the command anymore. *) -Grammar vernac vernac : ast := - text_proof_flag_on [ "Text" "Mode" "fr" "." ] -> - [(TEXT_MODE (AST "fr"))] -| text_proof_flag_on [ "Text" "Mode" "en" "." ] -> - [(TEXT_MODE (AST "en"))] -| text_proof_flag_on [ "Text" "Mode" "Off" "." ] -> - [(TEXT_MODE (AST "off"))]. - -*) -*) diff --git a/contrib7/interface/vernacrc b/contrib7/interface/vernacrc deleted file mode 100644 index f95c4212..00000000 --- a/contrib7/interface/vernacrc +++ /dev/null @@ -1,17 +0,0 @@ -# $Id: vernacrc,v 1.1 2003/11/29 20:02:41 herbelin Exp $ - -# This file is loaded initially by ./vernacparser. - -load_syntax_file 17 LogicSyntax -load_syntax_file 36 SpecifSyntax -load_syntax_file 18 Logic_TypeSyntax -load_syntax_file 19 DatatypesSyntax -load_syntax_file 21 Equality -load_syntax_file 22 Inv -load_syntax_file 26 Tauto -load_syntax_file 34 Omega -load_syntax_file 27 Ring -quiet_parse_string -Goal a. -&& END--OF--DATA -print_version diff --git a/contrib7/omega/Omega.v b/contrib7/omega/Omega.v deleted file mode 100644 index 76e37519..00000000 --- a/contrib7/omega/Omega.v +++ /dev/null @@ -1,57 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \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: Omega.v,v 1.1.2.1 2004/07/16 19:30:17 herbelin Exp $ *) - -(* 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 deleted file mode 100644 index 0d05fc3e..00000000 --- a/contrib7/omega/OmegaLemmas.v +++ /dev/null @@ -1,399 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: OmegaLemmas.v,v 1.1.2.1 2004/07/16 19:30:17 herbelin Exp $ 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/ArithRing.v b/contrib7/ring/ArithRing.v deleted file mode 100644 index c2abc4d1..00000000 --- a/contrib7/ring/ArithRing.v +++ /dev/null @@ -1,81 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: ArithRing.v,v 1.1.2.1 2004/07/16 19:30:18 herbelin Exp $ *) - -(* 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 deleted file mode 100644 index f4548bbb..00000000 --- a/contrib7/ring/NArithRing.v +++ /dev/null @@ -1,44 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: NArithRing.v,v 1.1.2.1 2004/07/16 19:30:18 herbelin Exp $ *) - -(* 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 deleted file mode 100644 index 12a51c9f..00000000 --- a/contrib7/ring/Quote.v +++ /dev/null @@ -1,85 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: Quote.v,v 1.1.2.1 2004/07/16 19:30:18 herbelin Exp $ *) - -(*********************************************************************** - 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 deleted file mode 100644 index 860dda13..00000000 --- a/contrib7/ring/Ring.v +++ /dev/null @@ -1,34 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: Ring.v,v 1.1.2.1 2004/07/16 19:30:18 herbelin Exp $ *) - -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 deleted file mode 100644 index 55bb31da..00000000 --- a/contrib7/ring/Ring_abstract.v +++ /dev/null @@ -1,699 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: Ring_abstract.v,v 1.1.2.1 2004/07/16 19:30:18 herbelin Exp $ *) - -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 deleted file mode 100644 index 1dbd9d56..00000000 --- a/contrib7/ring/Ring_normalize.v +++ /dev/null @@ -1,893 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: Ring_normalize.v,v 1.1.2.1 2004/07/16 19:30:18 herbelin Exp $ *) - -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 deleted file mode 100644 index 85fb7f6c..00000000 --- a/contrib7/ring/Ring_theory.v +++ /dev/null @@ -1,384 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: Ring_theory.v,v 1.1.2.1 2004/07/16 19:30:19 herbelin Exp $ *) - -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 deleted file mode 100644 index 222104e5..00000000 --- a/contrib7/ring/Setoid_ring.v +++ /dev/null @@ -1,13 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: Setoid_ring.v,v 1.1.2.1 2004/07/16 19:30:19 herbelin Exp $ *) - -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 deleted file mode 100644 index b6b79dae..00000000 --- a/contrib7/ring/Setoid_ring_normalize.v +++ /dev/null @@ -1,1141 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: Setoid_ring_normalize.v,v 1.1.2.1 2004/07/16 19:30:19 herbelin Exp $ *) - -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 deleted file mode 100644 index 13afc5ee..00000000 --- a/contrib7/ring/Setoid_ring_theory.v +++ /dev/null @@ -1,429 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: Setoid_ring_theory.v,v 1.1.2.1 2004/07/16 19:30:19 herbelin Exp $ *) - -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 deleted file mode 100644 index fc7ef29f..00000000 --- a/contrib7/ring/ZArithRing.v +++ /dev/null @@ -1,35 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: ZArithRing.v,v 1.1.2.1 2004/07/16 19:30:19 herbelin Exp $ *) - -(* 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/ROmega.v b/contrib7/romega/ROmega.v deleted file mode 100644 index 7ee246c7..00000000 --- a/contrib7/romega/ROmega.v +++ /dev/null @@ -1,12 +0,0 @@ -(************************************************************************* - - 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 deleted file mode 100644 index 81baa8d9..00000000 --- a/contrib7/romega/ReflOmegaCore.v +++ /dev/null @@ -1,2602 +0,0 @@ -(************************************************************************* - - PROJET RNRT Calife - 2001 - Author: Pierre Crégut - France Télécom R&D - Licence du projet : LGPL version 2.1 - - *************************************************************************) - -Require Arith. -Require PolyList. -Require Bool. -Require ZArith. -Require Import OmegaLemmas. - -(* \subsection{Definition of basic types} *) - -(* \subsubsection{Environment of propositions (lists) *) -Inductive PropList : Type := - Pnil : PropList | Pcons : Prop -> PropList -> PropList. - -(* Access function for the environment with a default *) -Fixpoint nthProp [n:nat; l:PropList] : Prop -> Prop := - [default]Cases n l of - O (Pcons x l') => x - | O other => default - | (S m) Pnil => default - | (S m) (Pcons x t) => (nthProp m t default) - end. - -(* \subsubsection{Définition of reified integer expressions} - Terms are either: - \begin{itemize} - \item integers [Tint] - \item variables [Tvar] - \item operation over integers (addition, product, opposite, subtraction) - The last two are translated in additions and products. *) - -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{Definition of reified goals} *) -(* Very restricted definition of handled predicates that should be extended - to cover a wider set of operations. - Taking care of negations and disequations require solving more than a - goal in parallel. This is a major improvement over previous versions. *) - -Inductive proposition : Set := - EqTerm : term -> term -> proposition (* egalité entre termes *) -| LeqTerm : term -> term -> proposition (* plus petit ou egal *) -| TrueTerm : proposition (* vrai *) -| FalseTerm : proposition (* faux *) -| Tnot : proposition -> proposition (* négation *) -| GeqTerm : term -> term -> proposition -| GtTerm : term -> term -> proposition -| LtTerm : term -> term -> proposition -| NeqTerm: term -> term -> proposition -| Tor : proposition -> proposition -> proposition -| Tand : proposition -> proposition -> proposition -| Timp : proposition -> proposition -> proposition -| Tprop : nat -> proposition -. - -(* Definition of goals as a list of hypothesis *) -Syntactic Definition hyps := (list proposition). - -(* Definition of lists of subgoals (set of open goals) *) -Syntactic Definition lhyps := (list hyps). - -(* a syngle goal packed in a subgoal list *) -Syntactic Definition singleton := [a: hyps] (cons a (nil hyps)). - -(* an absurd goal *) -Definition absurd := (cons FalseTerm (nil proposition)). - -(* \subsubsection{Traces for merging equations} - This inductive type describes how the monomial of two equations should be - merged when the equations are added. - - For [F_equal], both equations have the same head variable and coefficient - must be added, furthermore if coefficients are opposite, [F_cancel] should - be used to collapse the term. [F_left] and [F_right] indicate which monomial - should be put first in the result *) - -Inductive t_fusion : Set := - F_equal : t_fusion | F_cancel : t_fusion - | F_left : t_fusion | F_right : t_fusion. - -(* \subsubsection{Rewriting steps to normalize terms} *) -Inductive step : Set := - (* apply the rewriting steps to both subterms of an operation *) - | C_DO_BOTH : step -> step -> step - (* apply the rewriting step to the first branch *) - | C_LEFT : step -> step - (* apply the rewriting step to the second branch *) - | C_RIGHT : step -> step - (* apply two steps consecutively to a term *) - | C_SEQ : step -> step -> step - (* empty step *) - | C_NOP : step - (* the following operations correspond to actual rewriting *) - | C_OPP_PLUS : step - | C_OPP_OPP : step - | C_OPP_MULT_R : step - | C_OPP_ONE : step - (* This is a special step that reduces the term (computation) *) - | 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 -. - -(* \subsubsection{Omega steps} *) -(* The following inductive type describes steps as they can be found in - the trace coming from the decision procedure Omega. *) - -Inductive t_omega : Set := - (* n = 0 n!= 0 *) - | O_CONSTANT_NOT_NUL : nat -> t_omega - | O_CONSTANT_NEG : nat -> t_omega - (* division et approximation of an equation *) - | O_DIV_APPROX : Z -> Z -> term -> nat -> t_omega -> nat -> t_omega - (* no solution because no exact division *) - | O_NOT_EXACT_DIVIDE : Z -> Z -> term -> nat -> nat -> t_omega - (* exact division *) - | 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. - -(* \subsubsection{Règles pour normaliser les hypothèses} *) -(* Ces règles indiquent comment normaliser les propositions utiles - de chaque hypothèse utile avant la décomposition des hypothèses et - incluent l'étape d'inversion pour la suppression des négations *) -Inductive p_step : Set := - P_LEFT : p_step -> p_step -| P_RIGHT : p_step -> p_step -| P_INVERT : step -> p_step -| P_STEP : step -> p_step -| P_NOP : p_step -. -(* Liste des normalisations a effectuer : avec un constructeur dans le - type [p_step] permettant - de parcourir à la fois les branches gauches et droit, on pourrait n'avoir - qu'une normalisation par hypothèse. Et comme toutes les hypothèses sont - utiles (sinon on ne les incluerait pas), on pourrait remplacer [h_step] - par une simple liste *) - -Inductive h_step : Set := pair_step : nat -> p_step -> h_step. - -(* \subsubsection{Règles pour décomposer les hypothèses} *) -(* Ce type permet de se diriger dans les constructeurs logiques formant les - prédicats des hypothèses pour aller les décomposer. Ils permettent - en particulier d'extraire une hypothèse d'une conjonction avec - éventuellement le bon niveau de négations. *) - -Inductive direction : Set := - D_left : direction - | D_right : direction - | D_mono : direction. - -(* Ce type permet d'extraire les composants utiles des hypothèses : que ce - soit des hypothèses générées par éclatement d'une disjonction, ou - des équations. Le constructeur terminal indique comment résoudre le système - obtenu en recourrant au type de trace d'Omega [t_omega] *) - -Inductive e_step : Set := - E_SPLIT : nat -> (list direction) -> e_step -> e_step -> e_step - | E_EXTRACT : nat -> (list direction) -> e_step -> e_step - | E_SOLVE : t_omega -> e_step. - -(* \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 - [envp : PropList; 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 envp 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))` - - | (Tor p1 p2) => - (interp_proposition envp env p1) \/ (interp_proposition envp env p2) - | (Tand p1 p2) => - (interp_proposition envp env p1) /\ (interp_proposition envp env p2) - | (Timp p1 p2) => - (interp_proposition envp env p1) -> (interp_proposition envp env p2) - | (Tprop n) => (nthProp n envp True) - 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 [envp: PropList; env : (list Z); l: hyps] : Prop := - Cases l of - nil => True - | (cons p' l') => - (interp_proposition envp env p') /\ (interp_hyps envp 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_concl [envp: PropList;env : (list Z); c: proposition; l: hyps] : Prop := - Cases l of - nil => (interp_proposition envp env c) - | (cons p' l') => - (interp_proposition envp env p') -> (interp_goal_concl envp env c l') - end. - -Syntactic Definition interp_goal := - [envp: PropList;env : (list Z); l: hyps] - (interp_goal_concl envp env FalseTerm l). - -(* Les théorèmes qui suivent assurent la correspondance entre les deux - interprétations. *) - -Theorem goal_to_hyps : - (envp: PropList; env : (list Z); l: hyps) - ((interp_hyps envp env l) -> False) -> (interp_goal envp 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 : - (envp: PropList; env : (list Z); l: hyps) - (interp_goal envp env l) -> ((interp_hyps envp 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] := - (ep : PropList; e: (list Z)) (p1: proposition) - (interp_proposition ep e p1) -> (interp_proposition ep e (f p1)). - -Definition valid2 [f: proposition -> proposition -> proposition] := - (ep : PropList; e: (list Z)) (p1,p2: proposition) - (interp_proposition ep e p1) -> (interp_proposition ep e p2) -> - (interp_proposition ep e (f p1 p2)). - -(* Dans cette notion de validité, la fonction prend directement une - liste de propositions et rend une nouvelle liste de proposition. - On reste contravariant *) - -Definition valid_hyps [f: hyps -> hyps] := - (ep : PropList; e : (list Z)) - (lp: hyps) (interp_hyps ep e lp) -> (interp_hyps ep e (f lp)). - -(* Enfin ce théorème élimine la contravariance et nous ramène à une - opération sur les buts *) - - Theorem valid_goal : - (ep: PropList; env : (list Z); l: hyps; a : hyps -> hyps) - (valid_hyps a) -> (interp_goal ep env (a l)) -> (interp_goal ep env l). - -Intros; Simpl; Apply goal_to_hyps; Intro H1; -Apply (hyps_to_goal ep env (a l) H0); Apply H; Assumption. -Save. - -(* \subsubsection{Généralisation a des listes de buts (disjonctions)} *) - - -Fixpoint interp_list_hyps [envp: PropList; env: (list Z); l : lhyps] : Prop := - Cases l of - nil => False - | (cons h l') => (interp_hyps envp env h) \/ (interp_list_hyps envp env l') - end. - -Fixpoint interp_list_goal [envp: PropList; env: (list Z);l : lhyps] : Prop := - Cases l of - nil => True - | (cons h l') => (interp_goal envp env h) /\ (interp_list_goal envp env l') - end. - -Theorem list_goal_to_hyps : - (envp: PropList; env: (list Z); l: lhyps) - ((interp_list_hyps envp env l) -> False) -> (interp_list_goal envp 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 : - (envp: PropList; env: (list Z); l: lhyps) - (interp_list_goal envp env l) -> ((interp_list_hyps envp 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] := - (ep : PropList; e : (list Z)) (lp: hyps) - (interp_hyps ep e lp) -> (interp_list_hyps ep e (f lp)). - -Definition valid_list_goal [f: hyps -> lhyps] := - (ep : PropList; e : (list Z)) (lp: hyps) - (interp_list_goal ep e (f lp)) -> (interp_goal ep e lp) . - -Theorem goal_valid : - (f: hyps -> lhyps) (valid_list_hyps f) -> (valid_list_goal f). - -Unfold valid_list_goal; Intros f H ep e lp H1; Apply goal_to_hyps; -Intro H2; Apply list_hyps_to_goal with 1:=H1; Apply (H ep e lp); Assumption. -Save. - -Theorem append_valid : - (ep: PropList; e: (list Z)) (l1,l2:lhyps) - (interp_list_hyps ep e l1) \/ (interp_list_hyps ep e l2) -> - (interp_list_hyps ep e (app l1 l2)). - -Intros ep 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 : - (ep: PropList; e: (list Z); i:nat; l: hyps) - (interp_hyps ep e l) -> (interp_proposition ep 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 ep 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) - (* Interpretations *) - | [ (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 _ _) => ? - | (Tor _ _) => ? - | (Tand _ _) => ? - | (Timp _ _) => ? - | (Tprop _) => ? - end)] -> - (Case ?1; [ Intro; Intro | Intro; Intro | Idtac | Idtac - | Intro | Intro; Intro | Intro; Intro | Intro; Intro - | 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 := - (Match x With [?1] -> Unfold term_stable ?1; 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_l). -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). -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 stp l H; Case stp; [ - 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)} *) - - -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 ep 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 ep 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 ep 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 ep 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 ep 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 ep 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 ep 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 ep 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 ep 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 ep 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 ep 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 ep 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 ep 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} *) - -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 ep e lp H) -| Unfold valid_list_hyps; Simpl; Intros; Left; - Apply (constant_neg_valid n ep e lp H) -| Unfold valid_list_hyps valid_hyps; Intros k1 k2 body n t' Ht' m ep 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) ep e lp H) -| Unfold valid_list_hyps; Simpl; Intros; Left; - Apply (not_exact_divide_valid z z0 t0 n n0 ep e lp H) -| Unfold valid_list_hyps valid_hyps; Intros k body n t' Ht' m ep e lp H; - Apply Ht'; - Apply (apply_oper_1_valid m (exact_divide k body n) - (exact_divide_valid k body n) ep e lp H) -| Unfold valid_list_hyps valid_hyps; Intros k1 i1 k2 i2 trace t' Ht' ep e lp H; - Apply Ht'; - Apply (apply_oper_2_valid i1 i2 (sum k1 k2 trace) - (sum_valid k1 k2 trace) ep e lp H) -| Unfold valid_list_hyps; Simpl; Intros; Left; - Apply (contradiction_valid n n0 n1 ep e lp H) -| Unfold valid_list_hyps valid_hyps; Intros trace i1 i2 t' Ht' ep e lp H; - Apply Ht'; - Apply (apply_oper_2_valid i1 i2 (merge_eq trace) - (merge_eq_valid trace) ep e lp H) -| Intros t' i k1 H1 k2 H2; Unfold valid_list_hyps; Simpl; Intros ep e lp H; - Apply (split_ineq_valid i t' (execute_omega k1) (execute_omega k2) - H1 H2 ep e lp H) -| Unfold valid_list_hyps; Simpl; Intros i ep e lp H; Left; - Apply (constant_nul_valid i ep e lp H) -| Unfold valid_list_hyps; Simpl; Intros i j ep e lp H; Left; - Apply (negate_contradict_valid i j ep e lp H) -| Unfold valid_list_hyps; Simpl; Intros n i j ep e lp H; Left; - Apply (negate_contradict_inv_valid n i j ep e lp H) -| Unfold valid_list_hyps valid_hyps; Intros m s i1 i2 t' Ht' ep e lp H; Apply Ht'; - Apply (apply_oper_2_valid i1 i2 (state m s) (state_valid m s) ep 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 ep 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 ep e lp H; Unfold valid_hyps in Hl'; Apply Hl'; - Apply (do_normalize_valid i a ep e lp); Assumption ]. -Save. - -Theorem normalize_goal : - (s: (list step); ep: PropList; env : (list Z); l: hyps) - (interp_goal ep env (do_normalize_list s O l)) -> - (interp_goal ep 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; ep: PropList; env : (list Z); l: hyps) - (interp_list_goal ep env (execute_omega t l)) -> (interp_goal ep env l). - -Intros; Apply (goal_valid (execute_omega t) (omega_valid t) ep env l H). -Save. - - -Theorem append_goal : - (ep: PropList; e: (list Z)) (l1,l2:lhyps) - (interp_list_goal ep e l1) /\ (interp_list_goal ep e l2) -> - (interp_list_goal ep e (app l1 l2)). - -Intros ep e; Induction l1; [ - Simpl; Intros l2 (H1, H2); Assumption -| Simpl; Intros h1 t1 HR l2 ((H1 , H2), H3) ; Split; Auto]. - -Save. - -Require Decidable. - -(* A simple decidability checker : if the proposition belongs to the - simple grammar describe below then it is decidable. Proof is by - induction and uses well known theorem about arithmetic and propositional - calculus *) - -Fixpoint decidability [p:proposition] : bool := - Cases p of - (EqTerm _ _) => true - | (LeqTerm _ _) => true - | (GeqTerm _ _) => true - | (GtTerm _ _) => true - | (LtTerm _ _) => true - | (NeqTerm _ _) => true - | (FalseTerm) => true - | (TrueTerm) => true - | (Tnot t) => (decidability t) - | (Tand t1 t2) => (andb (decidability t1) (decidability t2)) - | (Timp t1 t2) => (andb (decidability t1) (decidability t2)) - | (Tor t1 t2) => (andb (decidability t1) (decidability t2)) - | (Tprop _) => false - end -. - -Theorem decidable_correct : - (ep: PropList) (e: (list Z)) (p:proposition) - (decidability p)=true -> (decidable (interp_proposition ep e p)). - -Induction p; Simpl; Intros; [ - Apply dec_eq -| Apply dec_Zle -| Left;Auto -| Right; Unfold not; Auto -| Apply dec_not; Auto -| Apply dec_Zge -| Apply dec_Zgt -| Apply dec_Zlt -| Apply dec_Zne -| Apply dec_or; Elim andb_prop with 1 := H1; Auto -| Apply dec_and; Elim andb_prop with 1 := H1; Auto -| Apply dec_imp; Elim andb_prop with 1 := H1; Auto -| Discriminate H]. - -Save. - -(* An interpretation function for a complete goal with an explicit - conclusion. We use an intermediate fixpoint. *) - -Fixpoint interp_full_goal - [envp: PropList;env : (list Z); c : proposition; l: hyps] : Prop := - Cases l of - nil => (interp_proposition envp env c) - | (cons p' l') => - (interp_proposition envp env p') -> (interp_full_goal envp env c l') - end. - -Definition interp_full - [ep: PropList;e : (list Z); lc : (hyps * proposition)] : Prop := - Cases lc of (l,c) => (interp_full_goal ep e c l) end. - -(* Relates the interpretation of a complete goal with the interpretation - of its hypothesis and conclusion *) - -Theorem interp_full_false : - (ep: PropList; e : (list Z); l: hyps; c : proposition) - ((interp_hyps ep e l) -> (interp_proposition ep e c)) -> - (interp_full ep e (l,c)). - -Induction l; Unfold interp_full; Simpl; [ - Auto -| Intros a l1 H1 c H2 H3; Apply H1; Auto]. - -Save. - -(* Push the conclusion in the list of hypothesis using a double negation - If the decidability cannot be "proven", then just forget about the - conclusion (equivalent of replacing it with false) *) - -Definition to_contradict [lc : hyps * proposition] := - Cases lc of - (l,c) => (if (decidability c) then (cons (Tnot c) l) else l) - end. - -(* The previous operation is valid in the sense that the new list of - hypothesis implies the original goal *) - -Theorem to_contradict_valid : - (ep: PropList; e : (list Z); lc: hyps * proposition) - (interp_goal ep e (to_contradict lc)) -> (interp_full ep e lc). - -Intros ep e lc; Case lc; Intros l c; Simpl; (Pattern (decidability c)); -Apply bool_ind2; [ - Simpl; Intros H H1; Apply interp_full_false; Intros H2; Apply not_not; [ - Apply decidable_correct; Assumption - | Unfold 1 not; Intro H3; Apply hyps_to_goal with 2:=H2; Auto] -| Intros H1 H2; Apply interp_full_false; Intro H3; Elim hyps_to_goal with 1:= H2; Assumption ]. -Save. - -(* [map_cons x l] adds [x] at the head of each list in [l] (which is a list - of lists *) - -Fixpoint map_cons [A:Set; x:A; l:(list (list A))] : (list (list A)) := - Cases l of - nil => (nil ?) - | (cons l ll) => (cons (cons x l) (map_cons A x ll)) - end. - -(* This function breaks up a list of hypothesis in a list of simpler - list of hypothesis that together implie the original one. The goal - of all this is to transform the goal in a list of solvable problems. - Note that : - - we need a way to drive the analysis as some hypotheis may not - require a split. - - this procedure must be perfectly mimicked by the ML part otherwise - hypothesis will get desynchronised and this will be a mess. - *) - -Fixpoint destructure_hyps [nn: nat] : hyps -> lhyps := - [ll:hyps]Cases nn of - O => (cons ll (nil ?)) - | (S n) => - Cases ll of - nil => (cons (nil ?) (nil ?)) - | (cons (Tor p1 p2) l) => - (app (destructure_hyps n (cons p1 l)) - (destructure_hyps n (cons p2 l))) - | (cons (Tand p1 p2) l) => - (destructure_hyps n (cons p1 (cons p2 l))) - | (cons (Timp p1 p2) l) => - (if (decidability p1) then - (app (destructure_hyps n (cons (Tnot p1) l)) - (destructure_hyps n (cons p2 l))) - else (map_cons ? (Timp p1 p2) (destructure_hyps n l))) - | (cons (Tnot p) l) => - Cases p of - (Tnot p1) => - (if (decidability p1) then (destructure_hyps n (cons p1 l)) - else (map_cons ? (Tnot (Tnot p1)) (destructure_hyps n l))) - | (Tor p1 p2) => - (destructure_hyps n (cons (Tnot p1) (cons (Tnot p2) l))) - | (Tand p1 p2) => - (if (decidability p1) then - (app (destructure_hyps n (cons (Tnot p1) l)) - (destructure_hyps n (cons (Tnot p2) l))) - else (map_cons ? (Tnot p) (destructure_hyps n l))) - | _ => (map_cons ? (Tnot p) (destructure_hyps n l)) - end - | (cons x l) => (map_cons ? x (destructure_hyps n l)) - end - end. - -Theorem map_cons_val : - (ep: PropList; e : (list Z)) - (p:proposition;l:lhyps) - (interp_proposition ep e p) -> - (interp_list_hyps ep e l) -> - (interp_list_hyps ep e (map_cons ? p l) ). - -Induction l; Simpl; [ Auto | Intros; Elim H1; Intro H2; Auto ]. -Save. - -Hints Resolve map_cons_val append_valid decidable_correct. - -Theorem destructure_hyps_valid : - (n:nat) (valid_list_hyps (destructure_hyps n)). - -Induction n; [ - Unfold valid_list_hyps; Simpl; Auto -| Unfold 2 valid_list_hyps; Intros n1 H ep e lp; Case lp; [ - Simpl; Auto - | Intros p l; Case p; - Try (Simpl; Intros; Apply map_cons_val; Simpl; Elim H0; Auto); [ - Intro p'; Case p'; - Try (Simpl; Intros; Apply map_cons_val; Simpl; Elim H0; Auto); [ - Simpl; Intros p1 (H1,H2); Pattern (decidability p1); Apply bool_ind2; - Intro H3; [ - Apply H; Simpl; Split; [ Apply not_not; Auto | Assumption ] - | Auto] - | Simpl; Intros p1 p2 (H1,H2); Apply H; Simpl; - Elim not_or with 1 := H1; Auto - | Simpl; Intros p1 p2 (H1,H2);Pattern (decidability p1); Apply bool_ind2; - Intro H3; [ - Apply append_valid; Elim not_and with 2 := H1; [ - Intro; Left; Apply H; Simpl; Auto - | Intro; Right; Apply H; Simpl; Auto - | Auto ] - | Auto ]] - | Simpl; Intros p1 p2 (H1, H2); Apply append_valid; - (Elim H1; Intro H3; Simpl; [ Left | Right ]); Apply H; Simpl; Auto - | Simpl; Intros; Apply H; Simpl; Tauto - | Simpl; Intros p1 p2 (H1, H2); Pattern (decidability p1); Apply bool_ind2; - Intro H3; [ - Apply append_valid; Elim imp_simp with 2:=H1; [ - Intro H4; Left; Simpl; Apply H; Simpl; Auto - | Intro H4; Right; Simpl; Apply H; Simpl; Auto - | Auto ] - | Auto ]]]]. - -Save. - -Definition prop_stable [f: proposition -> proposition] := - (ep: PropList; e: (list Z); p:proposition) - (interp_proposition ep e p) <-> (interp_proposition ep e (f p)). - -Definition p_apply_left [f: proposition -> proposition; p : proposition]:= - Cases p of - (Timp x y) => (Timp (f x) y) - | (Tor x y) => (Tor (f x) y) - | (Tand x y) => (Tand (f x) y) - | (Tnot x) => (Tnot (f x)) - | x => x - end. - -Theorem p_apply_left_stable : - (f : proposition -> proposition) - (prop_stable f) -> (prop_stable (p_apply_left f)). - -Unfold prop_stable; Intros f H ep e p; Split; -(Case p; Simpl; Auto; Intros p1; Elim (H ep e p1); Tauto). -Save. - -Definition p_apply_right [f: proposition -> proposition; p : proposition]:= - Cases p of - (Timp x y) => (Timp x (f y)) - | (Tor x y) => (Tor x (f y)) - | (Tand x y) => (Tand x (f y)) - | (Tnot x) => (Tnot (f x)) - | x => x - end. - -Theorem p_apply_right_stable : - (f : proposition -> proposition) - (prop_stable f) -> (prop_stable (p_apply_right f)). - -Unfold prop_stable; Intros f H ep e p; Split; -(Case p; Simpl; Auto; [ - Intros p1; Elim (H ep e p1); Tauto - | Intros p1 p2; Elim (H ep e p2); Tauto - | Intros p1 p2; Elim (H ep e p2); Tauto - | Intros p1 p2; Elim (H ep e p2); Tauto - ]). -Save. - -Definition p_invert [f : proposition -> proposition; p : proposition] := -Cases p of - (EqTerm x y) => (Tnot (f (NeqTerm x y))) -| (LeqTerm x y) => (Tnot (f (GtTerm x y))) -| (GeqTerm x y) => (Tnot (f (LtTerm x y))) -| (GtTerm x y) => (Tnot (f (LeqTerm x y))) -| (LtTerm x y) => (Tnot (f (GeqTerm x y))) -| (NeqTerm x y) => (Tnot (f (EqTerm x y))) -| x => x -end. - -Theorem p_invert_stable : - (f : proposition -> proposition) - (prop_stable f) -> (prop_stable (p_invert f)). - -Unfold prop_stable; Intros f H ep e p; Split;(Case p; Simpl; Auto; [ - Intros t1 t2; Elim (H ep e (NeqTerm t1 t2)); Simpl; Unfold Zne; - Generalize (dec_eq (interp_term e t1) (interp_term e t2)); - Unfold decidable; Tauto -| Intros t1 t2; Elim (H ep e (GtTerm t1 t2)); Simpl; Unfold Zgt; - Generalize (dec_Zgt (interp_term e t1) (interp_term e t2)); - Unfold decidable Zgt Zle; Tauto -| Intros t1 t2; Elim (H ep e (LtTerm t1 t2)); Simpl; Unfold Zlt; - Generalize (dec_Zlt (interp_term e t1) (interp_term e t2)); - Unfold decidable Zge; Tauto -| Intros t1 t2; Elim (H ep e (LeqTerm t1 t2)); Simpl; - Generalize (dec_Zgt (interp_term e t1) (interp_term e t2)); Unfold Zle Zgt; - Unfold decidable; Tauto -| Intros t1 t2; Elim (H ep e (GeqTerm t1 t2)); Simpl; - Generalize (dec_Zlt (interp_term e t1) (interp_term e t2)); Unfold Zge Zlt; - Unfold decidable; Tauto -| Intros t1 t2; Elim (H ep e (EqTerm t1 t2)); Simpl; - Generalize (dec_eq (interp_term e t1) (interp_term e t2)); - Unfold decidable Zne; Tauto ]). -Save. - -Theorem Zlt_left_inv : (x,y:Z) `0 <= ((y + (-1)) + (-x))` -> `x<y`. - -Intros; Apply Zlt_S_n; Apply Zle_lt_n_Sm; -Apply (Zsimpl_le_plus_r (Zplus `-1` (Zopp x))); Rewrite Zplus_assoc_l; -Unfold Zs; Rewrite (Zplus_assoc_r x); Rewrite (Zplus_assoc_l y); Simpl; -Rewrite Zero_right; Rewrite Zplus_inverse_r; Assumption. -Save. - -Theorem move_right_stable : (s: step) (prop_stable (move_right s)). - -Unfold move_right prop_stable; Intros s ep e p; Split; [ - 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 ] -| Case p; Simpl; Intros; Auto; Generalize H; Elim (rewrite_stable s); Simpl; - Intro H1; [ - Rewrite (Zplus_n_O (interp_term e t0)); Rewrite H1; Rewrite Zplus_permute; - Rewrite Zplus_inverse_r; Rewrite Zero_right; Trivial - | Apply (Zsimpl_le_plus_r (Zopp (interp_term e t))); Rewrite Zplus_inverse_r; - Assumption - | Apply Zle_ge; Apply (Zsimpl_le_plus_r (Zopp (interp_term e t0))); - Rewrite Zplus_inverse_r; Assumption - | Apply Zlt_gt; Apply Zlt_left_inv; Assumption - | Apply Zlt_left_inv; Assumption - | Unfold Zne not; Unfold Zne in H1; Intro H2; Apply H1; Rewrite H2; - Rewrite Zplus_inverse_r; Trivial ]]. -Save. - - -Fixpoint p_rewrite [s: p_step] : proposition -> proposition := - Cases s of - | (P_LEFT s) => (p_apply_left (p_rewrite s)) - | (P_RIGHT s) => (p_apply_right (p_rewrite s)) - | (P_STEP s) => (move_right s) - | (P_INVERT s) => (p_invert (move_right s)) - | P_NOP => [p:proposition]p - end. - -Theorem p_rewrite_stable : (s : p_step) (prop_stable (p_rewrite s)). - - -Induction s; Simpl; [ - Intros; Apply p_apply_left_stable; Trivial -| Intros; Apply p_apply_right_stable; Trivial -| Intros; Apply p_invert_stable; Apply move_right_stable -| Apply move_right_stable -| Unfold prop_stable; Simpl; Intros; Split; Auto ]. -Save. - -Fixpoint normalize_hyps [l: (list h_step)] : hyps -> hyps := - [lh:hyps] Cases l of - nil => lh - | (cons (pair_step i s) r) => - (normalize_hyps r (apply_oper_1 i (p_rewrite s) lh)) - end. - -Theorem normalize_hyps_valid : - (l: (list h_step)) (valid_hyps (normalize_hyps l)). - -Induction l; Unfold valid_hyps; Simpl; [ - Auto -| Intros n_s r; Case n_s; Intros n s H ep e lp H1; Apply H; - Apply apply_oper_1_valid; [ - Unfold valid1; Intros ep1 e1 p1 H2; Elim (p_rewrite_stable s ep1 e1 p1); - Auto - | Assumption ]]. -Save. - -Theorem normalize_hyps_goal : - (s: (list h_step); ep: PropList; env : (list Z); l: hyps) - (interp_goal ep env (normalize_hyps s l)) -> - (interp_goal ep env l). - -Intros; Apply valid_goal with 2:=H; Apply normalize_hyps_valid. -Save. - -Fixpoint extract_hyp_pos [s: (list direction)] : proposition -> proposition := - [p: proposition] - Cases s of - | (cons D_left l) => - Cases p of - (Tand x y) => (extract_hyp_pos l x) - | _ => p - end - | (cons D_right l) => - Cases p of - (Tand x y) => (extract_hyp_pos l y) - | _ => p - end - | (cons D_mono l) => - Cases p of - (Tnot x ) => (extract_hyp_neg l x) - | _ => p - end - | _ => p - end -with extract_hyp_neg [s: (list direction)] : proposition -> proposition := - [p: proposition] - Cases s of - | (cons D_left l) => - Cases p of - (Tor x y) => (extract_hyp_neg l x) - | (Timp x y) => - (if (decidability x) then (extract_hyp_pos l x) else (Tnot p)) - | _ => (Tnot p) - end - | (cons D_right l) => - Cases p of - (Tor x y) => (extract_hyp_neg l y) - | (Timp x y) => (extract_hyp_neg l y) - | _ => (Tnot p) - end - | (cons D_mono l) => - Cases p of - (Tnot x) => - (if (decidability x) then (extract_hyp_pos l x) else (Tnot p)) - | _ => (Tnot p) - end - | _ => - Cases p of - (Tnot x) => (if (decidability x) then x else (Tnot p)) - | _ => (Tnot p) - end - end. - -Definition co_valid1 [f: proposition -> proposition] := - (ep : PropList; e: (list Z)) (p1: proposition) - (interp_proposition ep e (Tnot p1)) -> (interp_proposition ep e (f p1)). - -Theorem extract_valid : - (s: (list direction)) - ((valid1 (extract_hyp_pos s)) /\ (co_valid1 (extract_hyp_neg s))). - -Unfold valid1 co_valid1; Induction s; [ - Split; [ - Simpl; Auto - | Intros ep e p1; Case p1; Simpl; Auto; Intro p; Pattern (decidability p); - Apply bool_ind2; [ - Intro H; Generalize (decidable_correct ep e p H); Unfold decidable; Tauto - | Simpl; Auto]] -| Intros a s' (H1,H2); Simpl in H2; Split; Intros ep e p; Case a; Auto; - Case p; Auto; Simpl; Intros; - (Apply H1; Tauto) Orelse (Apply H2; Tauto) Orelse - (Pattern (decidability p0); Apply bool_ind2; [ - Intro H3; Generalize (decidable_correct ep e p0 H3);Unfold decidable; - Intro H4; Apply H1; Tauto - | Intro; Tauto ])]. - -Save. - -Fixpoint decompose_solve [s: e_step] : hyps -> lhyps := - [h:hyps] - Cases s of - (E_SPLIT i dl s1 s2) => - (Cases (extract_hyp_pos dl (nth_hyps i h)) of - (Tor x y) => - (app (decompose_solve s1 (cons x h)) - (decompose_solve s2 (cons y h))) - | (Tnot (Tand x y)) => - (if (decidability x) then - (app (decompose_solve s1 (cons (Tnot x) h)) - (decompose_solve s2 (cons (Tnot y) h))) - else (cons h (nil hyps))) - | _ => (cons h (nil hyps)) - end) - | (E_EXTRACT i dl s1) => - (decompose_solve s1 (cons (extract_hyp_pos dl (nth_hyps i h)) h)) - | (E_SOLVE t) => (execute_omega t h) - end. - -Theorem decompose_solve_valid : - (s:e_step)(valid_list_goal (decompose_solve s)). - -Intro s; Apply goal_valid; Unfold valid_list_hyps; Elim s; Simpl; Intros; [ - Cut (interp_proposition ep e1 (extract_hyp_pos l (nth_hyps n lp))); [ - Case (extract_hyp_pos l (nth_hyps n lp)); Simpl; Auto; [ - Intro p; Case p; Simpl;Auto; Intros p1 p2 H2; - Pattern (decidability p1); Apply bool_ind2; [ - Intro H3; Generalize (decidable_correct ep e1 p1 H3); - Intro H4; Apply append_valid; Elim H4; Intro H5; [ - Right; Apply H0; Simpl; Tauto - | Left; Apply H; Simpl; Tauto ] - | Simpl; Auto] - | Intros p1 p2 H2; Apply append_valid; Simpl; Elim H2; [ - Intros H3; Left; Apply H; Simpl; Auto - | Intros H3; Right; Apply H0; Simpl; Auto ]] - | Elim (extract_valid l); Intros H2 H3; Apply H2; Apply nth_valid; Auto] -| Intros; Apply H; Simpl; Split; [ - Elim (extract_valid l); Intros H2 H3; Apply H2; Apply nth_valid; Auto - | Auto ] -| Apply omega_valid with 1:= H]. - -Save. - -(* \subsection{La dernière étape qui élimine tous les séquents inutiles} *) - -Definition valid_lhyps [f: lhyps -> lhyps] := - (ep : PropList; e : (list Z)) (lp: lhyps) - (interp_list_hyps ep e lp) -> (interp_list_hyps ep e (f lp)). - -Fixpoint reduce_lhyps [lp:lhyps] : lhyps := - Cases lp of - (cons (cons FalseTerm nil) lp') => (reduce_lhyps lp') - | (cons x lp') => (cons x (reduce_lhyps lp')) - | nil => (nil hyps) - end. - -Theorem reduce_lhyps_valid : (valid_lhyps reduce_lhyps). - -Unfold valid_lhyps; Intros ep e lp; Elim lp; [ - Simpl; Auto -| Intros a l HR; Elim a; [ - Simpl; Tauto - | Intros a1 l1; Case l1; Case a1; Simpl; Try Tauto]]. -Save. - -Theorem do_reduce_lhyps : - (envp: PropList; env: (list Z); l: lhyps) - (interp_list_goal envp env (reduce_lhyps l)) -> - (interp_list_goal envp env l). - -Intros envp env l H; Apply list_goal_to_hyps; Intro H1; -Apply list_hyps_to_goal with 1 := H; Apply reduce_lhyps_valid; Assumption. -Save. - -Definition concl_to_hyp := [p:proposition] - (if (decidability p) then (Tnot p) else TrueTerm). - -Definition do_concl_to_hyp : - (envp: PropList; env: (list Z); c : proposition; l:hyps) - (interp_goal envp env (cons (concl_to_hyp c) l)) -> - (interp_goal_concl envp env c l). - -Simpl; Intros envp env c l; Induction l; [ - Simpl; Unfold concl_to_hyp; Pattern (decidability c); Apply bool_ind2; [ - Intro H; Generalize (decidable_correct envp env c H); Unfold decidable; - Simpl; Tauto - | Simpl; Intros H1 H2; Elim H2; Trivial] -| Simpl; Tauto ]. -Save. - -Definition omega_tactic := - [t1:e_step ; t2:(list h_step) ; c:proposition; l:hyps] - (reduce_lhyps - (decompose_solve t1 (normalize_hyps t2 (cons (concl_to_hyp c) l)))). - -Theorem do_omega: - (t1: e_step ; t2: (list h_step); - envp: PropList; env: (list Z); c: proposition; l:hyps) - (interp_list_goal envp env (omega_tactic t1 t2 c l)) -> - (interp_goal_concl envp env c l). - -Unfold omega_tactic; Intros; Apply do_concl_to_hyp; -Apply (normalize_hyps_goal t2); Apply (decompose_solve_valid t1); -Apply do_reduce_lhyps; Assumption. -Save. |