summaryrefslogtreecommitdiff
path: root/contrib/micromega
diff options
context:
space:
mode:
authorGravatar Stephane Glondu <steph@glondu.net>2010-07-21 09:46:51 +0200
committerGravatar Stephane Glondu <steph@glondu.net>2010-07-21 09:46:51 +0200
commit5b7eafd0f00a16d78f99a27f5c7d5a0de77dc7e6 (patch)
tree631ad791a7685edafeb1fb2e8faeedc8379318ae /contrib/micromega
parentda178a880e3ace820b41d38b191d3785b82991f5 (diff)
Imported Upstream snapshot 8.3~beta0+13298
Diffstat (limited to 'contrib/micromega')
-rw-r--r--contrib/micromega/CheckerMaker.v129
-rw-r--r--contrib/micromega/Env.v182
-rw-r--r--contrib/micromega/EnvRing.v1403
-rw-r--r--contrib/micromega/LICENSE.sos29
-rw-r--r--contrib/micromega/MExtraction.v23
-rw-r--r--contrib/micromega/OrderedRing.v458
-rw-r--r--contrib/micromega/Psatz.v75
-rw-r--r--contrib/micromega/QMicromega.v199
-rw-r--r--contrib/micromega/RMicromega.v174
-rw-r--r--contrib/micromega/Refl.v129
-rw-r--r--contrib/micromega/RingMicromega.v779
-rw-r--r--contrib/micromega/Tauto.v324
-rw-r--r--contrib/micromega/VarMap.v258
-rw-r--r--contrib/micromega/ZCoeff.v173
-rw-r--r--contrib/micromega/ZMicromega.v705
-rw-r--r--contrib/micromega/certificate.ml740
-rw-r--r--contrib/micromega/coq_micromega.ml1286
-rw-r--r--contrib/micromega/csdpcert.ml197
-rw-r--r--contrib/micromega/g_micromega.ml474
-rw-r--r--contrib/micromega/mfourier.ml667
-rw-r--r--contrib/micromega/micromega.ml1512
-rw-r--r--contrib/micromega/micromega.mli398
-rw-r--r--contrib/micromega/mutils.ml305
-rw-r--r--contrib/micromega/sos.ml1919
-rw-r--r--contrib/micromega/sos.mli66
-rw-r--r--contrib/micromega/vector.ml674
26 files changed, 0 insertions, 12878 deletions
diff --git a/contrib/micromega/CheckerMaker.v b/contrib/micromega/CheckerMaker.v
deleted file mode 100644
index 93b4d213..00000000
--- a/contrib/micromega/CheckerMaker.v
+++ /dev/null
@@ -1,129 +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 *)
-(************************************************************************)
-(* *)
-(* Micromega: A reflexive tactic using the Positivstellensatz *)
-(* *)
-(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
-(* *)
-(************************************************************************)
-
-Require Import Setoid.
-Require Import Decidable.
-Require Import List.
-Require Import Refl.
-
-Set Implicit Arguments.
-
-Section CheckerMaker.
-
-(* 'Formula' is a syntactic representation of a certain kind of propositions. *)
-Variable Formula : Type.
-
-Variable Env : Type.
-
-Variable eval : Env -> Formula -> Prop.
-
-Variable Formula' : Type.
-
-Variable eval' : Env -> Formula' -> Prop.
-
-Variable normalise : Formula -> Formula'.
-
-Variable negate : Formula -> Formula'.
-
-Hypothesis normalise_sound :
- forall (env : Env) (t : Formula), eval env t -> eval' env (normalise t).
-
-Hypothesis negate_correct :
- forall (env : Env) (t : Formula), eval env t <-> ~ (eval' env (negate t)).
-
-Variable Witness : Type.
-
-Variable check_formulas' : list Formula' -> Witness -> bool.
-
-Hypothesis check_formulas'_sound :
- forall (l : list Formula') (w : Witness),
- check_formulas' l w = true ->
- forall env : Env, make_impl (eval' env) l False.
-
-Definition normalise_list : list Formula -> list Formula' := map normalise.
-Definition negate_list : list Formula -> list Formula' := map negate.
-
-Definition check_formulas (l : list Formula) (w : Witness) : bool :=
- check_formulas' (map normalise l) w.
-
-(* Contraposition of normalise_sound for lists *)
-Lemma normalise_sound_contr : forall (env : Env) (l : list Formula),
- make_impl (eval' env) (map normalise l) False -> make_impl (eval env) l False.
-Proof.
-intros env l; induction l as [| t l IH]; simpl in *.
-trivial.
-intros H1 H2. apply IH. apply H1. now apply normalise_sound.
-Qed.
-
-Theorem check_formulas_sound :
- forall (l : list Formula) (w : Witness),
- check_formulas l w = true -> forall env : Env, make_impl (eval env) l False.
-Proof.
-unfold check_formulas; intros l w H env. destruct l as [| t l]; simpl in *.
-pose proof (check_formulas'_sound H env) as H1; now simpl in H1.
-intro H1. apply normalise_sound in H1.
-pose proof (check_formulas'_sound H env) as H2; simpl in H2.
-apply H2 in H1. now apply normalise_sound_contr.
-Qed.
-
-(* In check_conj_formulas', t2 is supposed to be a list of negations of
-formulas. If, for example, t1 = [A1, A2] and t2 = [~ B1, ~ B2], then
-check_conj_formulas' checks that each of [~ B1, A1, A2] and [~ B2, A1, A2] is
-inconsistent. This means that A1 /\ A2 -> B1 and A1 /\ A2 -> B1, i.e., that
-A1 /\ A2 -> B1 /\ B2. *)
-
-Fixpoint check_conj_formulas'
- (t1 : list Formula') (wits : list Witness) (t2 : list Formula') {struct wits} : bool :=
-match t2 with
-| nil => true
-| t':: rt2 =>
- match wits with
- | nil => false
- | w :: rwits =>
- match check_formulas' (t':: t1) w with
- | true => check_conj_formulas' t1 rwits rt2
- | false => false
- end
- end
-end.
-
-(* checks whether the conjunction of t1 implies the conjunction of t2 *)
-
-Definition check_conj_formulas
- (t1 : list Formula) (wits : list Witness) (t2 : list Formula) : bool :=
- check_conj_formulas' (normalise_list t1) wits (negate_list t2).
-
-Theorem check_conj_formulas_sound :
- forall (t1 : list Formula) (t2 : list Formula) (wits : list Witness),
- check_conj_formulas t1 wits t2 = true ->
- forall env : Env, make_impl (eval env) t1 (make_conj (eval env) t2).
-Proof.
-intro t1; induction t2 as [| a2 t2' IH].
-intros; apply make_impl_true.
-intros wits H env.
-unfold check_conj_formulas in H; simpl in H.
-destruct wits as [| w ws]; simpl in H. discriminate.
-case_eq (check_formulas' (negate a2 :: normalise_list t1) w);
-intro H1; rewrite H1 in H; [| discriminate].
-assert (H2 : make_impl (eval' env) (negate a2 :: normalise_list t1) False) by
-now apply check_formulas'_sound with (w := w). clear H1.
-pose proof (IH ws H env) as H1. simpl in H2.
-assert (H3 : eval' env (negate a2) -> make_impl (eval env) t1 False)
-by auto using normalise_sound_contr. clear H2.
-rewrite <- make_conj_impl in *.
-rewrite make_conj_cons. intro H2. split.
-apply <- negate_correct. intro; now elim H3. exact (H1 H2).
-Qed.
-
-End CheckerMaker.
diff --git a/contrib/micromega/Env.v b/contrib/micromega/Env.v
deleted file mode 100644
index 40db9e46..00000000
--- a/contrib/micromega/Env.v
+++ /dev/null
@@ -1,182 +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 *)
-(************************************************************************)
-(* *)
-(* Micromega: A reflexive tactic using the Positivstellensatz *)
-(* *)
-(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
-(* *)
-(************************************************************************)
-
-Require Import ZArith.
-Require Import Coq.Arith.Max.
-Require Import List.
-Set Implicit Arguments.
-
-(* I have addded a Leaf constructor to the varmap data structure (/contrib/ring/Quote.v)
- -- this is harmless and spares a lot of Empty.
- This means smaller proof-terms.
- BTW, by dropping the polymorphism, I get small (yet noticeable) speed-up.
-*)
-
-Section S.
-
- Variable D :Type.
-
- Definition Env := positive -> D.
-
- Definition jump (j:positive) (e:Env) := fun x => e (Pplus x j).
-
- Definition nth (n:positive) (e : Env ) := e n.
-
- Definition hd (x:D) (e: Env) := nth xH e.
-
- Definition tail (e: Env) := jump xH e.
-
- Lemma psucc : forall p, (match p with
- | xI y' => xO (Psucc y')
- | xO y' => xI y'
- | 1%positive => 2%positive
- end) = (p+1)%positive.
- Proof.
- destruct p.
- auto with zarith.
- rewrite xI_succ_xO.
- auto with zarith.
- reflexivity.
- Qed.
-
- Lemma jump_Pplus : forall i j l,
- forall x, jump (i + j) l x = jump i (jump j l) x.
- Proof.
- unfold jump.
- intros.
- rewrite Pplus_assoc.
- reflexivity.
- Qed.
-
- Lemma jump_simpl : forall p l,
- forall x, jump p l x =
- match p with
- | xH => tail l x
- | xO p => jump p (jump p l) x
- | xI p => jump p (jump p (tail l)) x
- end.
- Proof.
- destruct p ; unfold tail ; intros ; repeat rewrite <- jump_Pplus.
- (* xI p = p + p + 1 *)
- rewrite xI_succ_xO.
- rewrite Pplus_diag.
- rewrite <- Pplus_one_succ_r.
- reflexivity.
- (* xO p = p + p *)
- rewrite Pplus_diag.
- reflexivity.
- reflexivity.
- Qed.
-
- Ltac jump_s :=
- repeat
- match goal with
- | |- context [jump xH ?e] => rewrite (jump_simpl xH)
- | |- context [jump (xO ?p) ?e] => rewrite (jump_simpl (xO p))
- | |- context [jump (xI ?p) ?e] => rewrite (jump_simpl (xI p))
- end.
-
- Lemma jump_tl : forall j l, forall x, tail (jump j l) x = jump j (tail l) x.
- Proof.
- unfold tail.
- intros.
- repeat rewrite <- jump_Pplus.
- rewrite Pplus_comm.
- reflexivity.
- Qed.
-
- Lemma jump_Psucc : forall j l,
- forall x, (jump (Psucc j) l x) = (jump 1 (jump j l) x).
- Proof.
- intros.
- rewrite <- jump_Pplus.
- rewrite Pplus_one_succ_r.
- rewrite Pplus_comm.
- reflexivity.
- Qed.
-
- Lemma jump_Pdouble_minus_one : forall i l,
- forall x, (jump (Pdouble_minus_one i) (tail l)) x = (jump i (jump i l)) x.
- Proof.
- unfold tail.
- intros.
- repeat rewrite <- jump_Pplus.
- rewrite <- Pplus_one_succ_r.
- rewrite Psucc_o_double_minus_one_eq_xO.
- rewrite Pplus_diag.
- reflexivity.
- Qed.
-
- Lemma jump_x0_tail : forall p l, forall x, jump (xO p) (tail l) x = jump (xI p) l x.
- Proof.
- intros.
- unfold jump.
- unfold tail.
- unfold jump.
- rewrite <- Pplus_assoc.
- simpl.
- reflexivity.
- Qed.
-
- Lemma nth_spec : forall p l x,
- nth p l =
- match p with
- | xH => hd x l
- | xO p => nth p (jump p l)
- | xI p => nth p (jump p (tail l))
- end.
- Proof.
- unfold nth.
- destruct p.
- intros.
- unfold jump, tail.
- unfold jump.
- rewrite Pplus_diag.
- rewrite xI_succ_xO.
- simpl.
- reflexivity.
- unfold jump.
- rewrite Pplus_diag.
- reflexivity.
- unfold hd.
- unfold nth.
- reflexivity.
- Qed.
-
-
- Lemma nth_jump : forall p l x, nth p (tail l) = hd x (jump p l).
- Proof.
- unfold tail.
- unfold hd.
- unfold jump.
- unfold nth.
- intros.
- rewrite Pplus_comm.
- reflexivity.
- Qed.
-
- Lemma nth_Pdouble_minus_one :
- forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l).
- Proof.
- intros.
- unfold tail.
- unfold nth, jump.
- rewrite Pplus_diag.
- rewrite <- Psucc_o_double_minus_one_eq_xO.
- rewrite Pplus_one_succ_r.
- reflexivity.
- Qed.
-
-End S.
-
diff --git a/contrib/micromega/EnvRing.v b/contrib/micromega/EnvRing.v
deleted file mode 100644
index 04e68272..00000000
--- a/contrib/micromega/EnvRing.v
+++ /dev/null
@@ -1,1403 +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 *)
-(************************************************************************)
-(* F. Besson: to evaluate polynomials, the original code is using a list.
- For big polynomials, this is inefficient -- linear access.
- I have modified the code to use binary trees -- logarithmic access. *)
-
-
-Set Implicit Arguments.
-Require Import Setoid.
-Require Import BinList.
-Require Import Env.
-Require Import BinPos.
-Require Import BinNat.
-Require Import BinInt.
-Require Export Ring_theory.
-
-Open Local Scope positive_scope.
-Import RingSyntax.
-
-Section MakeRingPol.
-
- (* Ring elements *)
- Variable R:Type.
- Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R).
- Variable req : R -> R -> Prop.
-
- (* Ring properties *)
- Variable Rsth : Setoid_Theory R req.
- Variable Reqe : ring_eq_ext radd rmul ropp req.
- Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req.
-
- (* Coefficients *)
- Variable C: Type.
- Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C).
- Variable ceqb : C->C->bool.
- Variable phi : C -> R.
- Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req
- cO cI cadd cmul csub copp ceqb phi.
-
- (* Power coefficients *)
- Variable Cpow : Set.
- Variable Cp_phi : N -> Cpow.
- Variable rpow : R -> Cpow -> R.
- Variable pow_th : power_theory rI rmul req Cp_phi rpow.
-
-
- (* R notations *)
- Notation "0" := rO. Notation "1" := rI.
- Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y).
- Notation "x - y " := (rsub x y). Notation "- x" := (ropp x).
- Notation "x == y" := (req x y).
-
- (* C notations *)
- Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y).
- Notation "x -! y " := (csub x y). Notation "-! x" := (copp x).
- Notation " x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x).
-
- (* Usefull tactics *)
- Add Setoid R req Rsth as R_set1.
- Ltac rrefl := gen_reflexivity Rsth.
- Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed.
- Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed.
- Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed.
- Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed.
- Ltac rsimpl := gen_srewrite Rsth Reqe ARth.
- Ltac add_push := gen_add_push radd Rsth Reqe ARth.
- Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth.
-
- (* Definition of multivariable polynomials with coefficients in C :
- Type [Pol] represents [X1 ... Xn].
- The representation is Horner's where a [n] variable polynomial
- (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients
- are polynomials with [n-1] variables (C[X2..Xn]).
- There are several optimisations to make the repr compacter:
- - [Pc c] is the constant polynomial of value c
- == c*X1^0*..*Xn^0
- - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables.
- variable indices are shifted of j in Q.
- == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn}
- - [PX P i Q] is an optimised Horner form of P*X^i + Q
- with P not the null polynomial
- == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn}
-
- In addition:
- - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden
- since they can be represented by the simpler form (PX P (i+j) Q)
- - (Pinj i (Pinj j P)) is (Pinj (i+j) P)
- - (Pinj i (Pc c)) is (Pc c)
- *)
-
- Inductive Pol : Type :=
- | Pc : C -> Pol
- | Pinj : positive -> Pol -> Pol
- | PX : Pol -> positive -> Pol -> Pol.
-
- Definition P0 := Pc cO.
- Definition P1 := Pc cI.
-
- Fixpoint Peq (P P' : Pol) {struct P'} : bool :=
- match P, P' with
- | Pc c, Pc c' => c ?=! c'
- | Pinj j Q, Pinj j' Q' =>
- match Pcompare j j' Eq with
- | Eq => Peq Q Q'
- | _ => false
- end
- | PX P i Q, PX P' i' Q' =>
- match Pcompare i i' Eq with
- | Eq => if Peq P P' then Peq Q Q' else false
- | _ => false
- end
- | _, _ => false
- end.
-
- Notation " P ?== P' " := (Peq P P').
-
- Definition mkPinj j P :=
- match P with
- | Pc _ => P
- | Pinj j' Q => Pinj ((j + j'):positive) Q
- | _ => Pinj j P
- end.
-
- Definition mkPinj_pred j P:=
- match j with
- | xH => P
- | xO j => Pinj (Pdouble_minus_one j) P
- | xI j => Pinj (xO j) P
- end.
-
- Definition mkPX P i Q :=
- match P with
- | Pc c => if c ?=! cO then mkPinj xH Q else PX P i Q
- | Pinj _ _ => PX P i Q
- | PX P' i' Q' => if Q' ?== P0 then PX P' (i' + i) Q else PX P i Q
- end.
-
- Definition mkXi i := PX P1 i P0.
-
- Definition mkX := mkXi 1.
-
- (** Opposite of addition *)
-
- Fixpoint Popp (P:Pol) : Pol :=
- match P with
- | Pc c => Pc (-! c)
- | Pinj j Q => Pinj j (Popp Q)
- | PX P i Q => PX (Popp P) i (Popp Q)
- end.
-
- Notation "-- P" := (Popp P).
-
- (** Addition et subtraction *)
-
- Fixpoint PaddC (P:Pol) (c:C) {struct P} : Pol :=
- match P with
- | Pc c1 => Pc (c1 +! c)
- | Pinj j Q => Pinj j (PaddC Q c)
- | PX P i Q => PX P i (PaddC Q c)
- end.
-
- Fixpoint PsubC (P:Pol) (c:C) {struct P} : Pol :=
- match P with
- | Pc c1 => Pc (c1 -! c)
- | Pinj j Q => Pinj j (PsubC Q c)
- | PX P i Q => PX P i (PsubC Q c)
- end.
-
- Section PopI.
-
- Variable Pop : Pol -> Pol -> Pol.
- Variable Q : Pol.
-
- Fixpoint PaddI (j:positive) (P:Pol){struct P} : Pol :=
- match P with
- | Pc c => mkPinj j (PaddC Q c)
- | Pinj j' Q' =>
- match ZPminus j' j with
- | Zpos k => mkPinj j (Pop (Pinj k Q') Q)
- | Z0 => mkPinj j (Pop Q' Q)
- | Zneg k => mkPinj j' (PaddI k Q')
- end
- | PX P i Q' =>
- match j with
- | xH => PX P i (Pop Q' Q)
- | xO j => PX P i (PaddI (Pdouble_minus_one j) Q')
- | xI j => PX P i (PaddI (xO j) Q')
- end
- end.
-
- Fixpoint PsubI (j:positive) (P:Pol){struct P} : Pol :=
- match P with
- | Pc c => mkPinj j (PaddC (--Q) c)
- | Pinj j' Q' =>
- match ZPminus j' j with
- | Zpos k => mkPinj j (Pop (Pinj k Q') Q)
- | Z0 => mkPinj j (Pop Q' Q)
- | Zneg k => mkPinj j' (PsubI k Q')
- end
- | PX P i Q' =>
- match j with
- | xH => PX P i (Pop Q' Q)
- | xO j => PX P i (PsubI (Pdouble_minus_one j) Q')
- | xI j => PX P i (PsubI (xO j) Q')
- end
- end.
-
- Variable P' : Pol.
-
- Fixpoint PaddX (i':positive) (P:Pol) {struct P} : Pol :=
- match P with
- | Pc c => PX P' i' P
- | Pinj j Q' =>
- match j with
- | xH => PX P' i' Q'
- | xO j => PX P' i' (Pinj (Pdouble_minus_one j) Q')
- | xI j => PX P' i' (Pinj (xO j) Q')
- end
- | PX P i Q' =>
- match ZPminus i i' with
- | Zpos k => mkPX (Pop (PX P k P0) P') i' Q'
- | Z0 => mkPX (Pop P P') i Q'
- | Zneg k => mkPX (PaddX k P) i Q'
- end
- end.
-
- Fixpoint PsubX (i':positive) (P:Pol) {struct P} : Pol :=
- match P with
- | Pc c => PX (--P') i' P
- | Pinj j Q' =>
- match j with
- | xH => PX (--P') i' Q'
- | xO j => PX (--P') i' (Pinj (Pdouble_minus_one j) Q')
- | xI j => PX (--P') i' (Pinj (xO j) Q')
- end
- | PX P i Q' =>
- match ZPminus i i' with
- | Zpos k => mkPX (Pop (PX P k P0) P') i' Q'
- | Z0 => mkPX (Pop P P') i Q'
- | Zneg k => mkPX (PsubX k P) i Q'
- end
- end.
-
-
- End PopI.
-
- Fixpoint Padd (P P': Pol) {struct P'} : Pol :=
- match P' with
- | Pc c' => PaddC P c'
- | Pinj j' Q' => PaddI Padd Q' j' P
- | PX P' i' Q' =>
- match P with
- | Pc c => PX P' i' (PaddC Q' c)
- | Pinj j Q =>
- match j with
- | xH => PX P' i' (Padd Q Q')
- | xO j => PX P' i' (Padd (Pinj (Pdouble_minus_one j) Q) Q')
- | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q')
- end
- | PX P i Q =>
- match ZPminus i i' with
- | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q')
- | Z0 => mkPX (Padd P P') i (Padd Q Q')
- | Zneg k => mkPX (PaddX Padd P' k P) i (Padd Q Q')
- end
- end
- end.
- Notation "P ++ P'" := (Padd P P').
-
- Fixpoint Psub (P P': Pol) {struct P'} : Pol :=
- match P' with
- | Pc c' => PsubC P c'
- | Pinj j' Q' => PsubI Psub Q' j' P
- | PX P' i' Q' =>
- match P with
- | Pc c => PX (--P') i' (*(--(PsubC Q' c))*) (PaddC (--Q') c)
- | Pinj j Q =>
- match j with
- | xH => PX (--P') i' (Psub Q Q')
- | xO j => PX (--P') i' (Psub (Pinj (Pdouble_minus_one j) Q) Q')
- | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q')
- end
- | PX P i Q =>
- match ZPminus i i' with
- | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q')
- | Z0 => mkPX (Psub P P') i (Psub Q Q')
- | Zneg k => mkPX (PsubX Psub P' k P) i (Psub Q Q')
- end
- end
- end.
- Notation "P -- P'" := (Psub P P').
-
- (** Multiplication *)
-
- Fixpoint PmulC_aux (P:Pol) (c:C) {struct P} : Pol :=
- match P with
- | Pc c' => Pc (c' *! c)
- | Pinj j Q => mkPinj j (PmulC_aux Q c)
- | PX P i Q => mkPX (PmulC_aux P c) i (PmulC_aux Q c)
- end.
-
- Definition PmulC P c :=
- if c ?=! cO then P0 else
- if c ?=! cI then P else PmulC_aux P c.
-
- Section PmulI.
- Variable Pmul : Pol -> Pol -> Pol.
- Variable Q : Pol.
- Fixpoint PmulI (j:positive) (P:Pol) {struct P} : Pol :=
- match P with
- | Pc c => mkPinj j (PmulC Q c)
- | Pinj j' Q' =>
- match ZPminus j' j with
- | Zpos k => mkPinj j (Pmul (Pinj k Q') Q)
- | Z0 => mkPinj j (Pmul Q' Q)
- | Zneg k => mkPinj j' (PmulI k Q')
- end
- | PX P' i' Q' =>
- match j with
- | xH => mkPX (PmulI xH P') i' (Pmul Q' Q)
- | xO j' => mkPX (PmulI j P') i' (PmulI (Pdouble_minus_one j') Q')
- | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q')
- end
- end.
-
- End PmulI.
-(* A symmetric version of the multiplication *)
-
- Fixpoint Pmul (P P'' : Pol) {struct P''} : Pol :=
- match P'' with
- | Pc c => PmulC P c
- | Pinj j' Q' => PmulI Pmul Q' j' P
- | PX P' i' Q' =>
- match P with
- | Pc c => PmulC P'' c
- | Pinj j Q =>
- let QQ' :=
- match j with
- | xH => Pmul Q Q'
- | xO j => Pmul (Pinj (Pdouble_minus_one j) Q) Q'
- | xI j => Pmul (Pinj (xO j) Q) Q'
- end in
- mkPX (Pmul P P') i' QQ'
- | PX P i Q=>
- let QQ' := Pmul Q Q' in
- let PQ' := PmulI Pmul Q' xH P in
- let QP' := Pmul (mkPinj xH Q) P' in
- let PP' := Pmul P P' in
- (mkPX (mkPX PP' i P0 ++ QP') i' P0) ++ mkPX PQ' i QQ'
- end
- end.
-
-(* Non symmetric *)
-(*
- Fixpoint Pmul_aux (P P' : Pol) {struct P'} : Pol :=
- match P' with
- | Pc c' => PmulC P c'
- | Pinj j' Q' => PmulI Pmul_aux Q' j' P
- | PX P' i' Q' =>
- (mkPX (Pmul_aux P P') i' P0) ++ (PmulI Pmul_aux Q' xH P)
- end.
-
- Definition Pmul P P' :=
- match P with
- | Pc c => PmulC P' c
- | Pinj j Q => PmulI Pmul_aux Q j P'
- | PX P i Q =>
- (mkPX (Pmul_aux P P') i P0) ++ (PmulI Pmul_aux Q xH P')
- end.
-*)
- Notation "P ** P'" := (Pmul P P').
-
- Fixpoint Psquare (P:Pol) : Pol :=
- match P with
- | Pc c => Pc (c *! c)
- | Pinj j Q => Pinj j (Psquare Q)
- | PX P i Q =>
- let twoPQ := Pmul P (mkPinj xH (PmulC Q (cI +! cI))) in
- let Q2 := Psquare Q in
- let P2 := Psquare P in
- mkPX (mkPX P2 i P0 ++ twoPQ) i Q2
- end.
-
- (** Monomial **)
-
- Inductive Mon: Set :=
- mon0: Mon
- | zmon: positive -> Mon -> Mon
- | vmon: positive -> Mon -> Mon.
-
- Fixpoint Mphi(l:Env R) (M: Mon) {struct M} : R :=
- match M with
- mon0 => rI
- | zmon j M1 => Mphi (jump j l) M1
- | vmon i M1 =>
- let x := hd 0 l in
- let xi := pow_pos rmul x i in
- (Mphi (tail l) M1) * xi
- end.
-
- Definition mkZmon j M :=
- match M with mon0 => mon0 | _ => zmon j M end.
-
- Definition zmon_pred j M :=
- match j with xH => M | _ => mkZmon (Ppred j) M end.
-
- Definition mkVmon i M :=
- match M with
- | mon0 => vmon i mon0
- | zmon j m => vmon i (zmon_pred j m)
- | vmon i' m => vmon (i+i') m
- end.
-
- Fixpoint MFactor (P: Pol) (M: Mon) {struct P}: Pol * Pol :=
- match P, M with
- _, mon0 => (Pc cO, P)
- | Pc _, _ => (P, Pc cO)
- | Pinj j1 P1, zmon j2 M1 =>
- match (j1 ?= j2) Eq with
- Eq => let (R,S) := MFactor P1 M1 in
- (mkPinj j1 R, mkPinj j1 S)
- | Lt => let (R,S) := MFactor P1 (zmon (j2 - j1) M1) in
- (mkPinj j1 R, mkPinj j1 S)
- | Gt => (P, Pc cO)
- end
- | Pinj _ _, vmon _ _ => (P, Pc cO)
- | PX P1 i Q1, zmon j M1 =>
- let M2 := zmon_pred j M1 in
- let (R1, S1) := MFactor P1 M in
- let (R2, S2) := MFactor Q1 M2 in
- (mkPX R1 i R2, mkPX S1 i S2)
- | PX P1 i Q1, vmon j M1 =>
- match (i ?= j) Eq with
- Eq => let (R1,S1) := MFactor P1 (mkZmon xH M1) in
- (mkPX R1 i Q1, S1)
- | Lt => let (R1,S1) := MFactor P1 (vmon (j - i) M1) in
- (mkPX R1 i Q1, S1)
- | Gt => let (R1,S1) := MFactor P1 (mkZmon xH M1) in
- (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO))
- end
- end.
-
- Definition POneSubst (P1: Pol) (M1: Mon) (P2: Pol): option Pol :=
- let (Q1,R1) := MFactor P1 M1 in
- match R1 with
- (Pc c) => if c ?=! cO then None
- else Some (Padd Q1 (Pmul P2 R1))
- | _ => Some (Padd Q1 (Pmul P2 R1))
- end.
-
- Fixpoint PNSubst1 (P1: Pol) (M1: Mon) (P2: Pol) (n: nat) {struct n}: Pol :=
- match POneSubst P1 M1 P2 with
- Some P3 => match n with S n1 => PNSubst1 P3 M1 P2 n1 | _ => P3 end
- | _ => P1
- end.
-
- Definition PNSubst (P1: Pol) (M1: Mon) (P2: Pol) (n: nat): option Pol :=
- match POneSubst P1 M1 P2 with
- Some P3 => match n with S n1 => Some (PNSubst1 P3 M1 P2 n1) | _ => None end
- | _ => None
- end.
-
- Fixpoint PSubstL1 (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}:
- Pol :=
- match LM1 with
- cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n
- | _ => P1
- end.
-
- Fixpoint PSubstL (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}: option Pol :=
- match LM1 with
- cons (M1,P2) LM2 =>
- match PNSubst P1 M1 P2 n with
- Some P3 => Some (PSubstL1 P3 LM2 n)
- | None => PSubstL P1 LM2 n
- end
- | _ => None
- end.
-
- Fixpoint PNSubstL (P1: Pol) (LM1: list (Mon * Pol)) (m n: nat) {struct m}: Pol :=
- match PSubstL P1 LM1 n with
- Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end
- | _ => P1
- end.
-
- (** Evaluation of a polynomial towards R *)
-
- Fixpoint Pphi(l:Env R) (P:Pol) {struct P} : R :=
- match P with
- | Pc c => [c]
- | Pinj j Q => Pphi (jump j l) Q
- | PX P i Q =>
- let x := hd 0 l in
- let xi := pow_pos rmul x i in
- (Pphi l P) * xi + (Pphi (tail l) Q)
- end.
-
- Reserved Notation "P @ l " (at level 10, no associativity).
- Notation "P @ l " := (Pphi l P).
- (** Proofs *)
- Lemma ZPminus_spec : forall x y,
- match ZPminus x y with
- | Z0 => x = y
- | Zpos k => x = (y + k)%positive
- | Zneg k => y = (x + k)%positive
- end.
- Proof.
- induction x;destruct y.
- replace (ZPminus (xI x) (xI y)) with (Zdouble (ZPminus x y));trivial.
- assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial.
- replace (ZPminus (xI x) (xO y)) with (Zdouble_plus_one (ZPminus x y));trivial.
- assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_plus_one;rewrite H;trivial.
- apply Pplus_xI_double_minus_one.
- simpl;trivial.
- replace (ZPminus (xO x) (xI y)) with (Zdouble_minus_one (ZPminus x y));trivial.
- assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_minus_one;rewrite H;trivial.
- apply Pplus_xI_double_minus_one.
- replace (ZPminus (xO x) (xO y)) with (Zdouble (ZPminus x y));trivial.
- assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial.
- replace (ZPminus (xO x) xH) with (Zpos (Pdouble_minus_one x));trivial.
- rewrite <- Pplus_one_succ_l.
- rewrite Psucc_o_double_minus_one_eq_xO;trivial.
- replace (ZPminus xH (xI y)) with (Zneg (xO y));trivial.
- replace (ZPminus xH (xO y)) with (Zneg (Pdouble_minus_one y));trivial.
- rewrite <- Pplus_one_succ_l.
- rewrite Psucc_o_double_minus_one_eq_xO;trivial.
- simpl;trivial.
- Qed.
-
- Lemma Peq_ok : forall P P',
- (P ?== P') = true -> forall l, P@l == P'@ l.
- Proof.
- induction P;destruct P';simpl;intros;try discriminate;trivial.
- apply (morph_eq CRmorph);trivial.
- assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq);
- try discriminate H.
- rewrite (IHP P' H); rewrite H1;trivial;rrefl.
- assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq);
- try discriminate H.
- rewrite H1;trivial. clear H1.
- assert (H1 := IHP1 P'1);assert (H2 := IHP2 P'2);
- destruct (P2 ?== P'1);[destruct (P3 ?== P'2); [idtac|discriminate H]
- |discriminate H].
- rewrite (H1 H);rewrite (H2 H);rrefl.
- Qed.
-
- Lemma Pphi0 : forall l, P0@l == 0.
- Proof.
- intros;simpl;apply (morph0 CRmorph).
- Qed.
-
-Lemma env_morph : forall p e1 e2, (forall x, e1 x = e2 x) ->
- p @ e1 = p @ e2.
-Proof.
- induction p ; simpl.
- reflexivity.
- intros.
- apply IHp.
- intros.
- unfold jump.
- apply H.
- intros.
- rewrite (IHp1 e1 e2) ; auto.
- rewrite (IHp2 (tail e1) (tail e2)) ; auto.
- unfold hd. unfold nth. rewrite H. reflexivity.
- unfold tail. unfold jump. intros ; apply H.
-Qed.
-
-Lemma Pjump_Pplus : forall P i j l, P @ (jump (i + j) l ) = P @ (jump j (jump i l)).
-Proof.
- intros. apply env_morph. intros. rewrite <- jump_Pplus.
- rewrite Pplus_comm.
- reflexivity.
-Qed.
-
-Lemma Pjump_xO_tail : forall P p l,
- P @ (jump (xO p) (tail l)) = P @ (jump (xI p) l).
-Proof.
- intros.
- apply env_morph.
- intros.
- rewrite (@jump_simpl R (xI p)).
- rewrite (@jump_simpl R (xO p)).
- reflexivity.
-Qed.
-
-Lemma Pjump_Pdouble_minus_one : forall P p l,
- P @ (jump (Pdouble_minus_one p) (tail l)) = P @ (jump (xO p) l).
-Proof.
- intros.
- apply env_morph.
- intros.
- rewrite jump_Pdouble_minus_one.
- rewrite (@jump_simpl R (xO p)).
- reflexivity.
-Qed.
-
-
-
- Lemma Pphi1 : forall l, P1@l == 1.
- Proof.
- intros;simpl;apply (morph1 CRmorph).
- Qed.
-
- Lemma mkPinj_ok : forall j l P, (mkPinj j P)@l == P@(jump j l).
- Proof.
- intros j l p;destruct p;simpl;rsimpl.
- rewrite Pjump_Pplus.
- reflexivity.
- Qed.
-
- Let pow_pos_Pplus :=
- pow_pos_Pplus rmul Rsth Reqe.(Rmul_ext) ARth.(ARmul_comm) ARth.(ARmul_assoc).
-
- Lemma mkPX_ok : forall l P i Q,
- (mkPX P i Q)@l == P@l*(pow_pos rmul (hd 0 l) i) + Q@(tail l).
- Proof.
- intros l P i Q;unfold mkPX.
- destruct P;try (simpl;rrefl).
- assert (H := morph_eq CRmorph c cO);destruct (c ?=! cO);simpl;try rrefl.
- rewrite (H (refl_equal true));rewrite (morph0 CRmorph).
- rewrite mkPinj_ok;rsimpl;simpl;rrefl.
- assert (H := @Peq_ok P3 P0);destruct (P3 ?== P0);simpl;try rrefl.
- rewrite (H (refl_equal true));trivial.
- rewrite Pphi0. rewrite pow_pos_Pplus;rsimpl.
- Qed.
-
-
- Ltac Esimpl :=
- repeat (progress (
- match goal with
- | |- context [P0@?l] => rewrite (Pphi0 l)
- | |- context [P1@?l] => rewrite (Pphi1 l)
- | |- context [(mkPinj ?j ?P)@?l] => rewrite (mkPinj_ok j l P)
- | |- context [(mkPX ?P ?i ?Q)@?l] => rewrite (mkPX_ok l P i Q)
- | |- context [[cO]] => rewrite (morph0 CRmorph)
- | |- context [[cI]] => rewrite (morph1 CRmorph)
- | |- context [[?x +! ?y]] => rewrite ((morph_add CRmorph) x y)
- | |- context [[?x *! ?y]] => rewrite ((morph_mul CRmorph) x y)
- | |- context [[?x -! ?y]] => rewrite ((morph_sub CRmorph) x y)
- | |- context [[-! ?x]] => rewrite ((morph_opp CRmorph) x)
- end));
- rsimpl; simpl.
-
- Lemma PaddC_ok : forall c P l, (PaddC P c)@l == P@l + [c].
- Proof.
- induction P;simpl;intros;Esimpl;trivial.
- rewrite IHP2;rsimpl.
- Qed.
-
- Lemma PsubC_ok : forall c P l, (PsubC P c)@l == P@l - [c].
- Proof.
- induction P;simpl;intros.
- Esimpl.
- rewrite IHP;rsimpl.
- rewrite IHP2;rsimpl.
- Qed.
-
- Lemma PmulC_aux_ok : forall c P l, (PmulC_aux P c)@l == P@l * [c].
- Proof.
- induction P;simpl;intros;Esimpl;trivial.
- rewrite IHP1;rewrite IHP2;rsimpl.
- mul_push ([c]);rrefl.
- Qed.
-
- Lemma PmulC_ok : forall c P l, (PmulC P c)@l == P@l * [c].
- Proof.
- intros c P l; unfold PmulC.
- assert (H:= morph_eq CRmorph c cO);destruct (c ?=! cO).
- rewrite (H (refl_equal true));Esimpl.
- assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI).
- rewrite (H1 (refl_equal true));Esimpl.
- apply PmulC_aux_ok.
- Qed.
-
- Lemma Popp_ok : forall P l, (--P)@l == - P@l.
- Proof.
- induction P;simpl;intros.
- Esimpl.
- apply IHP.
- rewrite IHP1;rewrite IHP2;rsimpl.
- Qed.
-
- Ltac Esimpl2 :=
- Esimpl;
- repeat (progress (
- match goal with
- | |- context [(PaddC ?P ?c)@?l] => rewrite (PaddC_ok c P l)
- | |- context [(PsubC ?P ?c)@?l] => rewrite (PsubC_ok c P l)
- | |- context [(PmulC ?P ?c)@?l] => rewrite (PmulC_ok c P l)
- | |- context [(--?P)@?l] => rewrite (Popp_ok P l)
- end)); Esimpl.
-
-
-
-
- Lemma Padd_ok : forall P' P l, (P ++ P')@l == P@l + P'@l.
- Proof.
- induction P';simpl;intros;Esimpl2.
- generalize P p l;clear P p l.
- induction P;simpl;intros.
- Esimpl2;apply (ARadd_comm ARth).
- assert (H := ZPminus_spec p p0);destruct (ZPminus p p0).
- rewrite H;Esimpl. rewrite IHP';rrefl.
- rewrite H;Esimpl. rewrite IHP';Esimpl.
- rewrite Pjump_Pplus. rrefl.
- rewrite H;Esimpl. rewrite IHP.
- rewrite Pjump_Pplus. rrefl.
- destruct p0;simpl.
- rewrite IHP2;simpl. rsimpl.
- rewrite Pjump_xO_tail. Esimpl.
- rewrite IHP2;simpl.
- rewrite Pjump_Pdouble_minus_one.
- rsimpl.
- rewrite IHP'.
- rsimpl.
- destruct P;simpl.
- Esimpl2;add_push [c];rrefl.
- destruct p0;simpl;Esimpl2.
- rewrite IHP'2;simpl.
- rewrite Pjump_xO_tail.
- rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl.
- rewrite IHP'2;simpl.
- rewrite Pjump_Pdouble_minus_one. rsimpl.
- add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl.
- rewrite IHP'2;rsimpl.
- unfold tail.
- add_push (P @ (jump 1 l));rrefl.
- assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2.
- rewrite IHP'1;rewrite IHP'2;rsimpl.
- add_push (P3 @ (tail l));rewrite H;rrefl.
- rewrite IHP'1;rewrite IHP'2;simpl;Esimpl.
- rewrite H;rewrite Pplus_comm.
- rewrite pow_pos_Pplus;rsimpl.
- add_push (P3 @ (tail l));rrefl.
- assert (forall P k l,
- (PaddX Padd P'1 k P) @ l == P@l + P'1@l * pow_pos rmul (hd 0 l) k).
- induction P;simpl;intros;try apply (ARadd_comm ARth).
- destruct p2; simpl; try apply (ARadd_comm ARth).
- rewrite Pjump_xO_tail.
- apply (ARadd_comm ARth).
- rewrite Pjump_Pdouble_minus_one.
- apply (ARadd_comm ARth).
- assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2.
- rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (tail l0));rrefl.
- rewrite IHP'1;simpl;Esimpl.
- rewrite H1;rewrite Pplus_comm.
- rewrite pow_pos_Pplus;simpl;Esimpl.
- add_push (P5 @ (tail l0));rrefl.
- rewrite IHP1;rewrite H1;rewrite Pplus_comm.
- rewrite pow_pos_Pplus;simpl;rsimpl.
- add_push (P5 @ (tail l0));rrefl.
- rewrite H0;rsimpl.
- add_push (P3 @ (tail l)).
- rewrite H;rewrite Pplus_comm.
- rewrite IHP'2;rewrite pow_pos_Pplus;rsimpl.
- add_push (P3 @ (tail l));rrefl.
- Qed.
-
- Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l.
- Proof.
- induction P';simpl;intros;Esimpl2;trivial.
- generalize P p l;clear P p l.
- induction P;simpl;intros.
- Esimpl2;apply (ARadd_comm ARth).
- assert (H := ZPminus_spec p p0);destruct (ZPminus p p0).
- rewrite H;Esimpl. rewrite IHP';rsimpl.
- rewrite H;Esimpl. rewrite IHP';Esimpl.
- rewrite <- Pjump_Pplus;rewrite Pplus_comm;rrefl.
- rewrite H;Esimpl. rewrite IHP.
- rewrite <- Pjump_Pplus;rewrite Pplus_comm;rrefl.
- destruct p0;simpl.
- rewrite IHP2;simpl; try rewrite Pjump_xO_tail ; rsimpl.
- rewrite IHP2;simpl.
- rewrite Pjump_Pdouble_minus_one;rsimpl.
- unfold tail ; rsimpl.
- rewrite IHP';rsimpl.
- destruct P;simpl.
- repeat rewrite Popp_ok;Esimpl2;rsimpl;add_push [c];try rrefl.
- destruct p0;simpl;Esimpl2.
- rewrite IHP'2;simpl;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));trivial.
- rewrite Pjump_xO_tail.
- add_push (P @ ((jump (xI p0) l)));rrefl.
- rewrite IHP'2;simpl;rewrite Pjump_Pdouble_minus_one;rsimpl.
- add_push (- (P'1 @ l * pow_pos rmul (hd 0 l) p));rrefl.
- unfold tail.
- rewrite IHP'2;rsimpl;add_push (P @ (jump 1 l));rrefl.
- assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2.
- rewrite IHP'1; rewrite IHP'2;rsimpl.
- add_push (P3 @ (tail l));rewrite H;rrefl.
- rewrite IHP'1; rewrite IHP'2;rsimpl;simpl;Esimpl.
- rewrite H;rewrite Pplus_comm.
- rewrite pow_pos_Pplus;rsimpl.
- add_push (P3 @ (tail l));rrefl.
- assert (forall P k l,
- (PsubX Psub P'1 k P) @ l == P@l + - P'1@l * pow_pos rmul (hd 0 l) k).
- induction P;simpl;intros.
- rewrite Popp_ok;rsimpl;apply (ARadd_comm ARth);trivial.
- destruct p2;simpl; rewrite Popp_ok;rsimpl.
- rewrite Pjump_xO_tail.
- apply (ARadd_comm ARth);trivial.
- rewrite Pjump_Pdouble_minus_one.
- apply (ARadd_comm ARth);trivial.
- apply (ARadd_comm ARth);trivial.
- assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2;rsimpl.
- rewrite IHP'1;rsimpl;add_push (P5 @ (tail l0));rewrite H1;rrefl.
- rewrite IHP'1;rewrite H1;rewrite Pplus_comm.
- rewrite pow_pos_Pplus;simpl;Esimpl.
- add_push (P5 @ (tail l0));rrefl.
- rewrite IHP1;rewrite H1;rewrite Pplus_comm.
- rewrite pow_pos_Pplus;simpl;rsimpl.
- add_push (P5 @ (tail l0));rrefl.
- rewrite H0;rsimpl.
- rewrite IHP'2;rsimpl;add_push (P3 @ (tail l)).
- rewrite H;rewrite Pplus_comm.
- rewrite pow_pos_Pplus;rsimpl.
- Qed.
-(* Proof for the symmetric version *)
-
- Lemma PmulI_ok :
- forall P',
- (forall (P : Pol) (l : Env R), (Pmul P P') @ l == P @ l * P' @ l) ->
- forall (P : Pol) (p : positive) (l : Env R),
- (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l).
- Proof.
- induction P;simpl;intros.
- Esimpl2;apply (ARmul_comm ARth).
- assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2.
- rewrite H1; rewrite H;rrefl.
- rewrite H1; rewrite H.
- rewrite Pjump_Pplus;simpl;rrefl.
- rewrite H1.
- rewrite Pjump_Pplus;rewrite IHP;rrefl.
- destruct p0;Esimpl2.
- rewrite IHP1;rewrite IHP2;rsimpl.
- rewrite Pjump_xO_tail.
- mul_push (pow_pos rmul (hd 0 l) p);rrefl.
- rewrite IHP1;rewrite IHP2;simpl;rsimpl.
- mul_push (pow_pos rmul (hd 0 l) p); rewrite Pjump_Pdouble_minus_one.
- rrefl.
- rewrite IHP1;simpl;rsimpl.
- mul_push (pow_pos rmul (hd 0 l) p).
- rewrite H;rrefl.
- Qed.
-
-(*
- Lemma PmulI_ok :
- forall P',
- (forall (P : Pol) (l : list R), (Pmul_aux P P') @ l == P @ l * P' @ l) ->
- forall (P : Pol) (p : positive) (l : list R),
- (PmulI Pmul_aux P' p P) @ l == P @ l * P' @ (jump p l).
- Proof.
- induction P;simpl;intros.
- Esimpl2;apply (ARmul_comm ARth).
- assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2.
- rewrite H1; rewrite H;rrefl.
- rewrite H1; rewrite H.
- rewrite Pplus_comm.
- rewrite jump_Pplus;simpl;rrefl.
- rewrite H1;rewrite Pplus_comm.
- rewrite jump_Pplus;rewrite IHP;rrefl.
- destruct p0;Esimpl2.
- rewrite IHP1;rewrite IHP2;simpl;rsimpl.
- mul_push (pow_pos rmul (hd 0 l) p);rrefl.
- rewrite IHP1;rewrite IHP2;simpl;rsimpl.
- mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl.
- rewrite IHP1;simpl;rsimpl.
- mul_push (pow_pos rmul (hd 0 l) p).
- rewrite H;rrefl.
- Qed.
-
- Lemma Pmul_aux_ok : forall P' P l,(Pmul_aux P P')@l == P@l * P'@l.
- Proof.
- induction P';simpl;intros.
- Esimpl2;trivial.
- apply PmulI_ok;trivial.
- rewrite Padd_ok;Esimpl2.
- rewrite (PmulI_ok P'2 IHP'2). rewrite IHP'1. rrefl.
- Qed.
-*)
-
-(* Proof for the symmetric version *)
- Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
- Proof.
- intros P P';generalize P;clear P;induction P';simpl;intros.
- apply PmulC_ok. apply PmulI_ok;trivial.
- destruct P.
- rewrite (ARmul_comm ARth);Esimpl2;Esimpl2.
- Esimpl2. rewrite IHP'1;Esimpl2.
- assert (match p0 with
- | xI j => Pinj (xO j) P ** P'2
- | xO j => Pinj (Pdouble_minus_one j) P ** P'2
- | 1 => P ** P'2
- end @ (tail l) == P @ (jump p0 l) * P'2 @ (tail l)).
- destruct p0;rewrite IHP'2;Esimpl.
- rewrite Pjump_xO_tail. reflexivity.
- rewrite Pjump_Pdouble_minus_one;Esimpl.
- rewrite H;Esimpl.
- rewrite Padd_ok; Esimpl2. rewrite Padd_ok; Esimpl2.
- repeat (rewrite IHP'1 || rewrite IHP'2);simpl.
- rewrite PmulI_ok;trivial.
- unfold tail.
- mul_push (P'1@l). simpl. mul_push (P'2 @ (jump 1 l)). Esimpl.
- Qed.
-
-(*
-Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
- Proof.
- destruct P;simpl;intros.
- Esimpl2;apply (ARmul_comm ARth).
- rewrite (PmulI_ok P (Pmul_aux_ok P)).
- apply (ARmul_comm ARth).
- rewrite Padd_ok; Esimpl2.
- rewrite (PmulI_ok P3 (Pmul_aux_ok P3));trivial.
- rewrite Pmul_aux_ok;mul_push (P' @ l).
- rewrite (ARmul_comm ARth (P' @ l));rrefl.
- Qed.
-*)
-
- Lemma Psquare_ok : forall P l, (Psquare P)@l == P@l * P@l.
- Proof.
- induction P;simpl;intros;Esimpl2.
- apply IHP. rewrite Padd_ok. rewrite Pmul_ok;Esimpl2.
- rewrite IHP1;rewrite IHP2.
- mul_push (pow_pos rmul (hd 0 l) p). mul_push (P2@l).
- rrefl.
- Qed.
-
- Lemma Mphi_morph : forall P env env', (forall x, env x = env' x ) ->
- Mphi env P = Mphi env' P.
- Proof.
- induction P ; simpl.
- reflexivity.
- intros.
- apply IHP.
- intros.
- unfold jump.
- apply H.
- (**)
- intros.
- replace (Mphi (tail env) P) with (Mphi (tail env') P).
- unfold hd. unfold nth.
- rewrite H.
- reflexivity.
- apply IHP.
- unfold tail,jump.
- intros. symmetry. apply H.
- Qed.
-
-Lemma Mjump_xO_tail : forall M p l,
- Mphi (jump (xO p) (tail l)) M = Mphi (jump (xI p) l) M.
-Proof.
- intros.
- apply Mphi_morph.
- intros.
- rewrite (@jump_simpl R (xI p)).
- rewrite (@jump_simpl R (xO p)).
- reflexivity.
-Qed.
-
-Lemma Mjump_Pdouble_minus_one : forall M p l,
- Mphi (jump (Pdouble_minus_one p) (tail l)) M = Mphi (jump (xO p) l) M.
-Proof.
- intros.
- apply Mphi_morph.
- intros.
- rewrite jump_Pdouble_minus_one.
- rewrite (@jump_simpl R (xO p)).
- reflexivity.
-Qed.
-
-Lemma Mjump_Pplus : forall M i j l, Mphi (jump (i + j) l ) M = Mphi (jump j (jump i l)) M.
-Proof.
- intros. apply Mphi_morph. intros. rewrite <- jump_Pplus.
- rewrite Pplus_comm.
- reflexivity.
-Qed.
-
-
-
- Lemma mkZmon_ok: forall M j l,
- Mphi l (mkZmon j M) == Mphi l (zmon j M).
- intros M j l; case M; simpl; intros; rsimpl.
- Qed.
-
- Lemma zmon_pred_ok : forall M j l,
- Mphi (tail l) (zmon_pred j M) == Mphi l (zmon j M).
- Proof.
- destruct j; simpl;intros l; rsimpl.
- rewrite mkZmon_ok;rsimpl.
- simpl.
- rewrite Mjump_xO_tail.
- reflexivity.
- rewrite mkZmon_ok;simpl.
- rewrite Mjump_Pdouble_minus_one; rsimpl.
- Qed.
-
- Lemma mkVmon_ok : forall M i l, Mphi l (mkVmon i M) == Mphi l M*pow_pos rmul (hd 0 l) i.
- Proof.
- destruct M;simpl;intros;rsimpl.
- rewrite zmon_pred_ok;simpl;rsimpl.
- rewrite Pplus_comm;rewrite pow_pos_Pplus;rsimpl.
- Qed.
-
-
- Lemma Mphi_ok: forall P M l,
- let (Q,R) := MFactor P M in
- P@l == Q@l + (Mphi l M) * (R@l).
- Proof.
- intros P; elim P; simpl; auto; clear P.
- intros c M l; case M; simpl; auto; try intro p; try intro m;
- try rewrite (morph0 CRmorph); rsimpl.
-
- intros i P Hrec M l; case M; simpl; clear M.
- rewrite (morph0 CRmorph); rsimpl.
- intros j M.
- case_eq ((i ?= j) Eq); intros He; simpl.
- rewrite (Pcompare_Eq_eq _ _ He).
- generalize (Hrec M (jump j l)); case (MFactor P M);
- simpl; intros P2 Q2 H; repeat rewrite mkPinj_ok; auto.
- generalize (Hrec (zmon (j -i) M) (jump i l));
- case (MFactor P (zmon (j -i) M)); simpl.
- intros P2 Q2 H; repeat rewrite mkPinj_ok; auto.
- rewrite <- (Pplus_minus _ _ (ZC2 _ _ He)).
- rewrite Mjump_Pplus; auto.
- rewrite (morph0 CRmorph); rsimpl.
- intros P2 m; rewrite (morph0 CRmorph); rsimpl.
-
- intros P2 Hrec1 i Q2 Hrec2 M l; case M; simpl; auto.
- rewrite (morph0 CRmorph); rsimpl.
- intros j M1.
- generalize (Hrec1 (zmon j M1) l);
- case (MFactor P2 (zmon j M1)).
- intros R1 S1 H1.
- generalize (Hrec2 (zmon_pred j M1) (tail l));
- case (MFactor Q2 (zmon_pred j M1)); simpl.
- intros R2 S2 H2; rewrite H1; rewrite H2.
- repeat rewrite mkPX_ok; simpl.
- rsimpl.
- apply radd_ext; rsimpl.
- rewrite (ARadd_comm ARth); rsimpl.
- apply radd_ext; rsimpl.
- rewrite (ARadd_comm ARth); rsimpl.
- rewrite zmon_pred_ok;rsimpl.
- intros j M1.
- case_eq ((i ?= j) Eq); intros He; simpl.
- rewrite (Pcompare_Eq_eq _ _ He).
- generalize (Hrec1 (mkZmon xH M1) l); case (MFactor P2 (mkZmon xH M1));
- simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
- rewrite H; rewrite mkPX_ok; rsimpl.
- repeat (rewrite <-(ARadd_assoc ARth)).
- apply radd_ext; rsimpl.
- rewrite (ARadd_comm ARth); rsimpl.
- apply radd_ext; rsimpl.
- repeat (rewrite <-(ARmul_assoc ARth)).
- rewrite mkZmon_ok.
- apply rmul_ext; rsimpl.
- rewrite (ARmul_comm ARth); rsimpl.
- generalize (Hrec1 (vmon (j - i) M1) l);
- case (MFactor P2 (vmon (j - i) M1));
- simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
- rewrite H; rsimpl; repeat rewrite mkPinj_ok; auto.
- rewrite mkPX_ok; rsimpl.
- repeat (rewrite <-(ARadd_assoc ARth)).
- apply radd_ext; rsimpl.
- rewrite (ARadd_comm ARth); rsimpl.
- apply radd_ext; rsimpl.
- repeat (rewrite <-(ARmul_assoc ARth)).
- apply rmul_ext; rsimpl.
- rewrite (ARmul_comm ARth); rsimpl.
- apply rmul_ext; rsimpl.
- rewrite <- pow_pos_Pplus.
- rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl.
- generalize (Hrec1 (mkZmon 1 M1) l);
- case (MFactor P2 (mkZmon 1 M1));
- simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
- rewrite H; rsimpl.
- rewrite mkPX_ok; rsimpl.
- repeat (rewrite <-(ARadd_assoc ARth)).
- apply radd_ext; rsimpl.
- rewrite (ARadd_comm ARth); rsimpl.
- apply radd_ext; rsimpl.
- rewrite mkZmon_ok.
- repeat (rewrite <-(ARmul_assoc ARth)).
- apply rmul_ext; rsimpl.
- rewrite (ARmul_comm ARth); rsimpl.
- rewrite mkPX_ok; simpl; rsimpl.
- rewrite (morph0 CRmorph); rsimpl.
- repeat (rewrite <-(ARmul_assoc ARth)).
- rewrite (ARmul_comm ARth (Q3@l)); rsimpl.
- apply rmul_ext; rsimpl.
- rewrite <- pow_pos_Pplus.
- rewrite (Pplus_minus _ _ He); rsimpl.
- Qed.
-
-(* Proof for the symmetric version *)
-
- Lemma POneSubst_ok: forall P1 M1 P2 P3 l,
- POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l.
- Proof.
- intros P2 M1 P3 P4 l; unfold POneSubst.
- generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto.
- intros Q1 R1; case R1.
- intros c H; rewrite H.
- generalize (morph_eq CRmorph c cO);
- case (c ?=! cO); simpl; auto.
- intros H1 H2; rewrite H1; auto; rsimpl.
- discriminate.
- intros _ H1 H2; injection H1; intros; subst.
- rewrite H2; rsimpl.
- (* new version *)
- rewrite Padd_ok; rewrite PmulC_ok; rsimpl.
- intros i P5 H; rewrite H.
- intros HH H1; injection HH; intros; subst; rsimpl.
- rewrite Padd_ok; rewrite PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl.
- intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3.
- assert (P4 = Q1 ++ P3 ** PX i P5 P6).
- injection H2; intros; subst;trivial.
- rewrite H;rewrite Padd_ok;rewrite Pmul_ok;rsimpl.
-Qed.
-(*
- Lemma POneSubst_ok: forall P1 M1 P2 P3 l,
- POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l.
-Proof.
- intros P2 M1 P3 P4 l; unfold POneSubst.
- generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto.
- intros Q1 R1; case R1.
- intros c H; rewrite H.
- generalize (morph_eq CRmorph c cO);
- case (c ?=! cO); simpl; auto.
- intros H1 H2; rewrite H1; auto; rsimpl.
- discriminate.
- intros _ H1 H2; injection H1; intros; subst.
- rewrite H2; rsimpl.
- rewrite Padd_ok; rewrite Pmul_ok; rsimpl.
- intros i P5 H; rewrite H.
- intros HH H1; injection HH; intros; subst; rsimpl.
- rewrite Padd_ok; rewrite Pmul_ok. rewrite H1; rsimpl.
- intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3.
- injection H2; intros; subst; rsimpl.
- rewrite Padd_ok.
- rewrite Pmul_ok; rsimpl.
- Qed.
-*)
- Lemma PNSubst1_ok: forall n P1 M1 P2 l,
- Mphi l M1 == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l.
- Proof.
- intros n; elim n; simpl; auto.
- intros P2 M1 P3 l H.
- generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l);
- case (POneSubst P2 M1 P3); [idtac | intros; rsimpl].
- intros P4 Hrec; rewrite (Hrec P4); auto; rsimpl.
- intros n1 Hrec P2 M1 P3 l H.
- generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l);
- case (POneSubst P2 M1 P3); [idtac | intros; rsimpl].
- intros P4 Hrec1; rewrite (Hrec1 P4); auto; rsimpl.
- Qed.
-
- Lemma PNSubst_ok: forall n P1 M1 P2 l P3,
- PNSubst P1 M1 P2 n = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l.
- Proof.
- intros n P2 M1 P3 l P4; unfold PNSubst.
- generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l);
- case (POneSubst P2 M1 P3); [idtac | intros; discriminate].
- intros P5 H1; case n; try (intros; discriminate).
- intros n1 H2; injection H2; intros; subst.
- rewrite <- PNSubst1_ok; auto.
- Qed.
-
- Fixpoint MPcond (LM1: list (Mon * Pol)) (l: Env R) {struct LM1} : Prop :=
- match LM1 with
- cons (M1,P2) LM2 => (Mphi l M1 == P2@l) /\ (MPcond LM2 l)
- | _ => True
- end.
-
- Lemma PSubstL1_ok: forall n LM1 P1 l,
- MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l.
- Proof.
- intros n LM1; elim LM1; simpl; auto.
- intros; rsimpl.
- intros (M2,P2) LM2 Hrec P3 l [H H1].
- rewrite <- Hrec; auto.
- apply PNSubst1_ok; auto.
- Qed.
-
- Lemma PSubstL_ok: forall n LM1 P1 P2 l,
- PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l.
- Proof.
- intros n LM1; elim LM1; simpl; auto.
- intros; discriminate.
- intros (M2,P2) LM2 Hrec P3 P4 l.
- generalize (PNSubst_ok n P3 M2 P2); case (PNSubst P3 M2 P2 n).
- intros P5 H0 H1 [H2 H3]; injection H1; intros; subst.
- rewrite <- PSubstL1_ok; auto.
- intros l1 H [H1 H2]; auto.
- Qed.
-
- Lemma PNSubstL_ok: forall m n LM1 P1 l,
- MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l.
- Proof.
- intros m; elim m; simpl; auto.
- intros n LM1 P2 l H; generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l);
- case (PSubstL P2 LM1 n); intros; rsimpl; auto.
- intros m1 Hrec n LM1 P2 l H.
- generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l);
- case (PSubstL P2 LM1 n); intros; rsimpl; auto.
- rewrite <- Hrec; auto.
- Qed.
-
- (** Definition of polynomial expressions *)
-
- Inductive PExpr : Type :=
- | PEc : C -> PExpr
- | PEX : positive -> PExpr
- | PEadd : PExpr -> PExpr -> PExpr
- | PEsub : PExpr -> PExpr -> PExpr
- | PEmul : PExpr -> PExpr -> PExpr
- | PEopp : PExpr -> PExpr
- | PEpow : PExpr -> N -> PExpr.
-
- (** evaluation of polynomial expressions towards R *)
- Definition mk_X j := mkPinj_pred j mkX.
-
- (** evaluation of polynomial expressions towards R *)
-
- Fixpoint PEeval (l:Env R) (pe:PExpr) {struct pe} : R :=
- match pe with
- | PEc c => phi c
- | PEX j => nth j l
- | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2)
- | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2)
- | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2)
- | PEopp pe1 => - (PEeval l pe1)
- | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n)
- end.
-
- (** Correctness proofs *)
-
- Lemma mkX_ok : forall p l, nth p l == (mk_X p) @ l.
- Proof.
- destruct p;simpl;intros;Esimpl;trivial.
- rewrite nth_spec ; auto.
- unfold hd.
- rewrite <- nth_Pdouble_minus_one.
- rewrite (nth_jump (Pdouble_minus_one p) l 1).
- reflexivity.
- Qed.
-
- Ltac Esimpl3 :=
- repeat match goal with
- | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P2 P1 l)
- | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P2 P1 l)
- end;Esimpl2;try rrefl;try apply (ARadd_comm ARth).
-
-(* Power using the chinise algorithm *)
-(*Section POWER.
- Variable subst_l : Pol -> Pol.
- Fixpoint Ppow_pos (P:Pol) (p:positive){struct p} : Pol :=
- match p with
- | xH => P
- | xO p => subst_l (Psquare (Ppow_pos P p))
- | xI p => subst_l (Pmul P (Psquare (Ppow_pos P p)))
- end.
-
- Definition Ppow_N P n :=
- match n with
- | N0 => P1
- | Npos p => Ppow_pos P p
- end.
-
- Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) ->
- forall P p, (Ppow_pos P p)@l == (pow_pos Pmul P p)@l.
- Proof.
- intros l subst_l_ok P.
- induction p;simpl;intros;try rrefl;try rewrite subst_l_ok.
- repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl.
- repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl.
- Qed.
-
- Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) ->
- forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l.
- Proof. destruct n;simpl. rrefl. apply Ppow_pos_ok. trivial. Qed.
-
- End POWER. *)
-
-Section POWER.
- Variable subst_l : Pol -> Pol.
- Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol :=
- match p with
- | xH => subst_l (Pmul res P)
- | xO p => Ppow_pos (Ppow_pos res P p) P p
- | xI p => subst_l (Pmul (Ppow_pos (Ppow_pos res P p) P p) P)
- end.
-
- Definition Ppow_N P n :=
- match n with
- | N0 => P1
- | Npos p => Ppow_pos P1 P p
- end.
-
- Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) ->
- forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l.
- Proof.
- intros l subst_l_ok res P p. generalize res;clear res.
- induction p;simpl;intros;try rewrite subst_l_ok; repeat rewrite Pmul_ok;repeat rewrite IHp.
- rsimpl. mul_push (P@l);rsimpl. rsimpl. rrefl.
- Qed.
-
- Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) ->
- forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l.
- Proof. destruct n;simpl. rrefl. rewrite Ppow_pos_ok. trivial. Esimpl. auto. Qed.
-
- End POWER.
-
- (** Normalization and rewriting *)
-
- Section NORM_SUBST_REC.
- Variable n : nat.
- Variable lmp:list (Mon*Pol).
- Let subst_l P := PNSubstL P lmp n n.
- Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2).
- Let Ppow_subst := Ppow_N subst_l.
-
- Fixpoint norm_aux (pe:PExpr) : Pol :=
- match pe with
- | PEc c => Pc c
- | PEX j => mk_X j
- | PEadd (PEopp pe1) pe2 => Psub (norm_aux pe2) (norm_aux pe1)
- | PEadd pe1 (PEopp pe2) =>
- Psub (norm_aux pe1) (norm_aux pe2)
- | PEadd pe1 pe2 => Padd (norm_aux pe1) (norm_aux pe2)
- | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2)
- | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2)
- | PEopp pe1 => Popp (norm_aux pe1)
- | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n
- end.
-
- Definition norm_subst pe := subst_l (norm_aux pe).
-
- (*
- Fixpoint norm_subst (pe:PExpr) : Pol :=
- match pe with
- | PEc c => Pc c
- | PEX j => subst_l (mk_X j)
- | PEadd (PEopp pe1) pe2 => Psub (norm_subst pe2) (norm_subst pe1)
- | PEadd pe1 (PEopp pe2) =>
- Psub (norm_subst pe1) (norm_subst pe2)
- | PEadd pe1 pe2 => Padd (norm_subst pe1) (norm_subst pe2)
- | PEsub pe1 pe2 => Psub (norm_subst pe1) (norm_subst pe2)
- | PEmul pe1 pe2 => Pmul_subst (norm_subst pe1) (norm_subst pe2)
- | PEopp pe1 => Popp (norm_subst pe1)
- | PEpow pe1 n => Ppow_subst (norm_subst pe1) n
- end.
-
- Lemma norm_subst_spec :
- forall l pe, MPcond lmp l ->
- PEeval l pe == (norm_subst pe)@l.
- Proof.
- intros;assert (subst_l_ok:forall P, (subst_l P)@l == P@l).
- unfold subst_l;intros.
- rewrite <- PNSubstL_ok;trivial. rrefl.
- assert (Pms_ok:forall P1 P2, (Pmul_subst P1 P2)@l == P1@l*P2@l).
- intros;unfold Pmul_subst;rewrite subst_l_ok;rewrite Pmul_ok;rrefl.
- induction pe;simpl;Esimpl3.
- rewrite subst_l_ok;apply mkX_ok.
- rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3.
- rewrite IHpe1;rewrite IHpe2;rrefl.
- rewrite Pms_ok;rewrite IHpe1;rewrite IHpe2;rrefl.
- rewrite IHpe;rrefl.
- unfold Ppow_subst. rewrite Ppow_N_ok. trivial.
- rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3.
- induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok;
- repeat rewrite Pmul_ok;rrefl.
- Qed.
-*)
- Lemma norm_aux_spec :
- forall l pe, (*MPcond lmp l ->*)
- PEeval l pe == (norm_aux pe)@l.
- Proof.
- intros.
- induction pe;simpl;Esimpl3.
- apply mkX_ok.
- rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3.
- rewrite IHpe1;rewrite IHpe2;rrefl.
- rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. rrefl.
- rewrite IHpe;rrefl.
- rewrite Ppow_N_ok by reflexivity.
- rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3.
- induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok;
- repeat rewrite Pmul_ok;rrefl.
- Qed.
-
-
- End NORM_SUBST_REC.
-
-
-End MakeRingPol.
-
diff --git a/contrib/micromega/LICENSE.sos b/contrib/micromega/LICENSE.sos
deleted file mode 100644
index 5aadfa2a..00000000
--- a/contrib/micromega/LICENSE.sos
+++ /dev/null
@@ -1,29 +0,0 @@
- HOL Light copyright notice, licence and disclaimer
-
- (c) University of Cambridge 1998
- (c) Copyright, John Harrison 1998-2006
-
-HOL Light version 2.20, hereinafter referred to as "the software", is a
-computer theorem proving system written by John Harrison. Much of the
-software was developed at the University of Cambridge Computer Laboratory,
-New Museums Site, Pembroke Street, Cambridge, CB2 3QG, England. The
-software is copyright, University of Cambridge 1998 and John Harrison
-1998-2006.
-
-Permission to use, copy, modify, and distribute the software and its
-documentation for any purpose and without fee is hereby granted. In the
-case of further distribution of the software the present text, including
-copyright notice, licence and disclaimer of warranty, must be included in
-full and unmodified form in any release. Distribution of derivative
-software obtained by modifying the software, or incorporating it into
-other software, is permitted, provided the inclusion of the software is
-acknowledged and that any changes made to the software are clearly
-documented.
-
-John Harrison and the University of Cambridge disclaim all warranties
-with regard to the software, including all implied warranties of
-merchantability and fitness. In no event shall John Harrison or the
-University of Cambridge be liable for any special, indirect,
-incidental or consequential damages or any damages whatsoever,
-including, but not limited to, those arising from computer failure or
-malfunction, work stoppage, loss of profit or loss of contracts.
diff --git a/contrib/micromega/MExtraction.v b/contrib/micromega/MExtraction.v
deleted file mode 100644
index a5ac92db..00000000
--- a/contrib/micromega/MExtraction.v
+++ /dev/null
@@ -1,23 +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 *)
-(************************************************************************)
-(* *)
-(* Micromega: A reflexive tactic using the Positivstellensatz *)
-(* *)
-(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
-(* *)
-(************************************************************************)
-
-(* Used to generate micromega.ml *)
-
-Require Import ZMicromega.
-Require Import QMicromega.
-Require Import VarMap.
-Require Import RingMicromega.
-Require Import NArith.
-
-Extraction "micromega.ml" List.map simpl_cone map_cone indexes n_of_Z Nnat.N_of_nat ZTautoChecker QTautoChecker find.
diff --git a/contrib/micromega/OrderedRing.v b/contrib/micromega/OrderedRing.v
deleted file mode 100644
index 149b7731..00000000
--- a/contrib/micromega/OrderedRing.v
+++ /dev/null
@@ -1,458 +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 *)
-(************************************************************************)
-(* Evgeny Makarov, INRIA, 2007 *)
-(************************************************************************)
-
-Require Import Setoid.
-Require Import Ring.
-
-(** Generic properties of ordered rings on a setoid equality *)
-
-Set Implicit Arguments.
-
-Module Import OrderedRingSyntax.
-Export RingSyntax.
-
-Reserved Notation "x ~= y" (at level 70, no associativity).
-Reserved Notation "x [=] y" (at level 70, no associativity).
-Reserved Notation "x [~=] y" (at level 70, no associativity).
-Reserved Notation "x [<] y" (at level 70, no associativity).
-Reserved Notation "x [<=] y" (at level 70, no associativity).
-End OrderedRingSyntax.
-
-Section DEFINITIONS.
-
-Variable R : Type.
-Variable (rO rI : R) (rplus rtimes rminus: R -> R -> R) (ropp : R -> R).
-Variable req rle rlt : R -> R -> Prop.
-Notation "0" := rO.
-Notation "1" := rI.
-Notation "x + y" := (rplus x y).
-Notation "x * y " := (rtimes x y).
-Notation "x - y " := (rminus x y).
-Notation "- x" := (ropp x).
-Notation "x == y" := (req x y).
-Notation "x ~= y" := (~ req x y).
-Notation "x <= y" := (rle x y).
-Notation "x < y" := (rlt x y).
-
-Record SOR : Type := mk_SOR_theory {
- SORsetoid : Setoid_Theory R req;
- SORplus_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2;
- SORtimes_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2;
- SORopp_wd : forall x1 x2, x1 == x2 -> -x1 == -x2;
- SORle_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 <= y1 <-> x2 <= y2);
- SORlt_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 < y1 <-> x2 < y2);
- SORrt : ring_theory rO rI rplus rtimes rminus ropp req;
- SORle_refl : forall n : R, n <= n;
- SORle_antisymm : forall n m : R, n <= m -> m <= n -> n == m;
- SORle_trans : forall n m p : R, n <= m -> m <= p -> n <= p;
- SORlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m;
- SORlt_trichotomy : forall n m : R, n < m \/ n == m \/ m < n;
- SORplus_le_mono_l : forall n m p : R, n <= m -> p + n <= p + m;
- SORtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m;
- SORneq_0_1 : 0 ~= 1
-}.
-
-(* We cannot use Relation_Definitions.order.ord_antisym and
-Relations_1.Antisymmetric because they refer to Leibniz equality *)
-
-End DEFINITIONS.
-
-Section STRICT_ORDERED_RING.
-
-Variable R : Type.
-Variable (rO rI : R) (rplus rtimes rminus: R -> R -> R) (ropp : R -> R).
-Variable req rle rlt : R -> R -> Prop.
-
-Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt.
-
-Notation "0" := rO.
-Notation "1" := rI.
-Notation "x + y" := (rplus x y).
-Notation "x * y " := (rtimes x y).
-Notation "x - y " := (rminus x y).
-Notation "- x" := (ropp x).
-Notation "x == y" := (req x y).
-Notation "x ~= y" := (~ req x y).
-Notation "x <= y" := (rle x y).
-Notation "x < y" := (rlt x y).
-
-
-Add Relation R req
- reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ )
- symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ )
- transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ )
-as sor_setoid.
-
-
-Add Morphism rplus with signature req ==> req ==> req as rplus_morph.
-Proof.
-exact sor.(SORplus_wd).
-Qed.
-Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph.
-Proof.
-exact sor.(SORtimes_wd).
-Qed.
-Add Morphism ropp with signature req ==> req as ropp_morph.
-Proof.
-exact sor.(SORopp_wd).
-Qed.
-Add Morphism rle with signature req ==> req ==> iff as rle_morph.
-Proof.
-exact sor.(SORle_wd).
-Qed.
-Add Morphism rlt with signature req ==> req ==> iff as rlt_morph.
-Proof.
-exact sor.(SORlt_wd).
-Qed.
-
-Add Ring SOR : sor.(SORrt).
-
-Add Morphism rminus with signature req ==> req ==> req as rminus_morph.
-Proof.
-intros x1 x2 H1 y1 y2 H2.
-rewrite (sor.(SORrt).(Rsub_def) x1 y1).
-rewrite (sor.(SORrt).(Rsub_def) x2 y2).
-rewrite H1; now rewrite H2.
-Qed.
-
-Theorem Rneq_symm : forall n m : R, n ~= m -> m ~= n.
-Proof.
-intros n m H1 H2; rewrite H2 in H1; now apply H1.
-Qed.
-
-(* Propeties of plus, minus and opp *)
-
-Theorem Rplus_0_l : forall n : R, 0 + n == n.
-Proof.
-intro; ring.
-Qed.
-
-Theorem Rplus_0_r : forall n : R, n + 0 == n.
-Proof.
-intro; ring.
-Qed.
-
-Theorem Rtimes_0_r : forall n : R, n * 0 == 0.
-Proof.
-intro; ring.
-Qed.
-
-Theorem Rplus_comm : forall n m : R, n + m == m + n.
-Proof.
-intros; ring.
-Qed.
-
-Theorem Rtimes_0_l : forall n : R, 0 * n == 0.
-Proof.
-intro; ring.
-Qed.
-
-Theorem Rtimes_comm : forall n m : R, n * m == m * n.
-Proof.
-intros; ring.
-Qed.
-
-Theorem Rminus_eq_0 : forall n m : R, n - m == 0 <-> n == m.
-Proof.
-intros n m.
-split; intro H. setoid_replace n with ((n - m) + m) by ring. rewrite H.
-now rewrite Rplus_0_l.
-rewrite H; ring.
-Qed.
-
-Theorem Rplus_cancel_l : forall n m p : R, p + n == p + m <-> n == m.
-Proof.
-intros n m p; split; intro H.
-setoid_replace n with (- p + (p + n)) by ring.
-setoid_replace m with (- p + (p + m)) by ring. now rewrite H.
-now rewrite H.
-Qed.
-
-(* Relations *)
-
-Theorem Rle_refl : forall n : R, n <= n.
-Proof sor.(SORle_refl).
-
-Theorem Rle_antisymm : forall n m : R, n <= m -> m <= n -> n == m.
-Proof sor.(SORle_antisymm).
-
-Theorem Rle_trans : forall n m p : R, n <= m -> m <= p -> n <= p.
-Proof sor.(SORle_trans).
-
-Theorem Rlt_trichotomy : forall n m : R, n < m \/ n == m \/ m < n.
-Proof sor.(SORlt_trichotomy).
-
-Theorem Rlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m.
-Proof sor.(SORlt_le_neq).
-
-Theorem Rneq_0_1 : 0 ~= 1.
-Proof sor.(SORneq_0_1).
-
-Theorem Req_em : forall n m : R, n == m \/ n ~= m.
-Proof.
-intros n m. destruct (Rlt_trichotomy n m) as [H | [H | H]]; try rewrite Rlt_le_neq in H.
-right; now destruct H.
-now left.
-right; apply Rneq_symm; now destruct H.
-Qed.
-
-Theorem Req_dne : forall n m : R, ~ ~ n == m <-> n == m.
-Proof.
-intros n m; destruct (Req_em n m) as [H | H].
-split; auto.
-split. intro H1; false_hyp H H1. auto.
-Qed.
-
-Theorem Rle_lt_eq : forall n m : R, n <= m <-> n < m \/ n == m.
-Proof.
-intros n m; rewrite Rlt_le_neq.
-split; [intro H | intros [[H1 H2] | H]].
-destruct (Req_em n m) as [H1 | H1]. now right. left; now split.
-assumption.
-rewrite H; apply Rle_refl.
-Qed.
-
-Ltac le_less := rewrite Rle_lt_eq; left; try assumption.
-Ltac le_equal := rewrite Rle_lt_eq; right; try reflexivity; try assumption.
-Ltac le_elim H := rewrite Rle_lt_eq in H; destruct H as [H | H].
-
-Theorem Rlt_trans : forall n m p : R, n < m -> m < p -> n < p.
-Proof.
-intros n m p; repeat rewrite Rlt_le_neq; intros [H1 H2] [H3 H4]; split.
-now apply Rle_trans with m.
-intro H. rewrite H in H1. pose proof (Rle_antisymm H3 H1). now apply H4.
-Qed.
-
-Theorem Rle_lt_trans : forall n m p : R, n <= m -> m < p -> n < p.
-Proof.
-intros n m p H1 H2; le_elim H1.
-now apply Rlt_trans with (m := m). now rewrite H1.
-Qed.
-
-Theorem Rlt_le_trans : forall n m p : R, n < m -> m <= p -> n < p.
-Proof.
-intros n m p H1 H2; le_elim H2.
-now apply Rlt_trans with (m := m). now rewrite <- H2.
-Qed.
-
-Theorem Rle_gt_cases : forall n m : R, n <= m \/ m < n.
-Proof.
-intros n m; destruct (Rlt_trichotomy n m) as [H | [H | H]].
-left; now le_less. left; now le_equal. now right.
-Qed.
-
-Theorem Rlt_neq : forall n m : R, n < m -> n ~= m.
-Proof.
-intros n m; rewrite Rlt_le_neq; now intros [_ H].
-Qed.
-
-Theorem Rle_ngt : forall n m : R, n <= m <-> ~ m < n.
-Proof.
-intros n m; split.
-intros H H1; assert (H2 : n < n) by now apply Rle_lt_trans with m. now apply (Rlt_neq H2).
-intro H. destruct (Rle_gt_cases n m) as [H1 | H1]. assumption. false_hyp H1 H.
-Qed.
-
-Theorem Rlt_nge : forall n m : R, n < m <-> ~ m <= n.
-Proof.
-intros n m; split.
-intros H H1; assert (H2 : n < n) by now apply Rlt_le_trans with m. now apply (Rlt_neq H2).
-intro H. destruct (Rle_gt_cases m n) as [H1 | H1]. false_hyp H1 H. assumption.
-Qed.
-
-(* Plus, minus and order *)
-
-Theorem Rplus_le_mono_l : forall n m p : R, n <= m <-> p + n <= p + m.
-Proof.
-intros n m p; split.
-apply sor.(SORplus_le_mono_l).
-intro H. apply (sor.(SORplus_le_mono_l) (p + n) (p + m) (- p)) in H.
-setoid_replace (- p + (p + n)) with n in H by ring.
-setoid_replace (- p + (p + m)) with m in H by ring. assumption.
-Qed.
-
-Theorem Rplus_le_mono_r : forall n m p : R, n <= m <-> n + p <= m + p.
-Proof.
-intros n m p; rewrite (Rplus_comm n p); rewrite (Rplus_comm m p).
-apply Rplus_le_mono_l.
-Qed.
-
-Theorem Rplus_lt_mono_l : forall n m p : R, n < m <-> p + n < p + m.
-Proof.
-intros n m p; do 2 rewrite Rlt_le_neq. rewrite Rplus_cancel_l.
-now rewrite <- Rplus_le_mono_l.
-Qed.
-
-Theorem Rplus_lt_mono_r : forall n m p : R, n < m <-> n + p < m + p.
-Proof.
-intros n m p.
-rewrite (Rplus_comm n p); rewrite (Rplus_comm m p); apply Rplus_lt_mono_l.
-Qed.
-
-Theorem Rplus_lt_mono : forall n m p q : R, n < m -> p < q -> n + p < m + q.
-Proof.
-intros n m p q H1 H2.
-apply Rlt_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_lt_mono_l].
-Qed.
-
-Theorem Rplus_le_mono : forall n m p q : R, n <= m -> p <= q -> n + p <= m + q.
-Proof.
-intros n m p q H1 H2.
-apply Rle_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_le_mono_l].
-Qed.
-
-Theorem Rplus_lt_le_mono : forall n m p q : R, n < m -> p <= q -> n + p < m + q.
-Proof.
-intros n m p q H1 H2.
-apply Rlt_le_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_le_mono_l].
-Qed.
-
-Theorem Rplus_le_lt_mono : forall n m p q : R, n <= m -> p < q -> n + p < m + q.
-Proof.
-intros n m p q H1 H2.
-apply Rle_lt_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_lt_mono_l].
-Qed.
-
-Theorem Rplus_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n + m.
-Proof.
-intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_mono.
-Qed.
-
-Theorem Rplus_pos_nonneg : forall n m : R, 0 < n -> 0 <= m -> 0 < n + m.
-Proof.
-intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_le_mono.
-Qed.
-
-Theorem Rplus_nonneg_pos : forall n m : R, 0 <= n -> 0 < m -> 0 < n + m.
-Proof.
-intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_lt_mono.
-Qed.
-
-Theorem Rplus_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n + m.
-Proof.
-intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_mono.
-Qed.
-
-Theorem Rle_le_minus : forall n m : R, n <= m <-> 0 <= m - n.
-Proof.
-intros n m. rewrite (@Rplus_le_mono_r n m (- n)).
-setoid_replace (n + - n) with 0 by ring.
-now setoid_replace (m + - n) with (m - n) by ring.
-Qed.
-
-Theorem Rlt_lt_minus : forall n m : R, n < m <-> 0 < m - n.
-Proof.
-intros n m. rewrite (@Rplus_lt_mono_r n m (- n)).
-setoid_replace (n + - n) with 0 by ring.
-now setoid_replace (m + - n) with (m - n) by ring.
-Qed.
-
-Theorem Ropp_lt_mono : forall n m : R, n < m <-> - m < - n.
-Proof.
-intros n m. split; intro H.
-apply -> (@Rplus_lt_mono_l n m (- n - m)) in H.
-setoid_replace (- n - m + n) with (- m) in H by ring.
-now setoid_replace (- n - m + m) with (- n) in H by ring.
-apply -> (@Rplus_lt_mono_l (- m) (- n) (n + m)) in H.
-setoid_replace (n + m + - m) with n in H by ring.
-now setoid_replace (n + m + - n) with m in H by ring.
-Qed.
-
-Theorem Ropp_pos_neg : forall n : R, 0 < - n <-> n < 0.
-Proof.
-intro n; rewrite (Ropp_lt_mono n 0). now setoid_replace (- 0) with 0 by ring.
-Qed.
-
-(* Times and order *)
-
-Theorem Rtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m.
-Proof sor.(SORtimes_pos_pos).
-
-Theorem Rtimes_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n * m.
-Proof.
-intros n m H1 H2.
-le_elim H1. le_elim H2.
-le_less; now apply Rtimes_pos_pos.
-rewrite <- H2; rewrite Rtimes_0_r; le_equal.
-rewrite <- H1; rewrite Rtimes_0_l; le_equal.
-Qed.
-
-Theorem Rtimes_pos_neg : forall n m : R, 0 < n -> m < 0 -> n * m < 0.
-Proof.
-intros n m H1 H2. apply -> Ropp_pos_neg.
-setoid_replace (- (n * m)) with (n * (- m)) by ring.
-apply Rtimes_pos_pos. assumption. now apply <- Ropp_pos_neg.
-Qed.
-
-Theorem Rtimes_neg_neg : forall n m : R, n < 0 -> m < 0 -> 0 < n * m.
-Proof.
-intros n m H1 H2.
-setoid_replace (n * m) with ((- n) * (- m)) by ring.
-apply Rtimes_pos_pos; now apply <- Ropp_pos_neg.
-Qed.
-
-Theorem Rtimes_square_nonneg : forall n : R, 0 <= n * n.
-Proof.
-intro n; destruct (Rlt_trichotomy 0 n) as [H | [H | H]].
-le_less; now apply Rtimes_pos_pos.
-rewrite <- H, Rtimes_0_l; le_equal.
-le_less; now apply Rtimes_neg_neg.
-Qed.
-
-Theorem Rtimes_neq_0 : forall n m : R, n ~= 0 /\ m ~= 0 -> n * m ~= 0.
-Proof.
-intros n m [H1 H2].
-destruct (Rlt_trichotomy n 0) as [H3 | [H3 | H3]];
-destruct (Rlt_trichotomy m 0) as [H4 | [H4 | H4]];
-try (false_hyp H3 H1); try (false_hyp H4 H2).
-apply Rneq_symm. apply Rlt_neq. now apply Rtimes_neg_neg.
-apply Rlt_neq. rewrite Rtimes_comm. now apply Rtimes_pos_neg.
-apply Rlt_neq. now apply Rtimes_pos_neg.
-apply Rneq_symm. apply Rlt_neq. now apply Rtimes_pos_pos.
-Qed.
-
-(* The following theorems are used to build a morphism from Z to R and
-prove its properties in ZCoeff.v. They are not used in RingMicromega.v. *)
-
-(* Surprisingly, multilication is needed to prove the following theorem *)
-
-Theorem Ropp_neg_pos : forall n : R, - n < 0 <-> 0 < n.
-Proof.
-intro n; setoid_replace n with (- - n) by ring. rewrite Ropp_pos_neg.
-now setoid_replace (- - n) with n by ring.
-Qed.
-
-Theorem Rlt_0_1 : 0 < 1.
-Proof.
-apply <- Rlt_le_neq. split.
-setoid_replace 1 with (1 * 1) by ring. apply Rtimes_square_nonneg.
-apply Rneq_0_1.
-Qed.
-
-Theorem Rlt_succ_r : forall n : R, n < 1 + n.
-Proof.
-intro n. rewrite <- (Rplus_0_l n); setoid_replace (1 + (0 + n)) with (1 + n) by ring.
-apply -> Rplus_lt_mono_r. apply Rlt_0_1.
-Qed.
-
-Theorem Rlt_lt_succ : forall n m : R, n < m -> n < 1 + m.
-Proof.
-intros n m H; apply Rlt_trans with m. assumption. apply Rlt_succ_r.
-Qed.
-
-(*Theorem Rtimes_lt_mono_pos_l : forall n m p : R, 0 < p -> n < m -> p * n < p * m.
-Proof.
-intros n m p H1 H2. apply <- Rlt_lt_minus.
-setoid_replace (p * m - p * n) with (p * (m - n)) by ring.
-apply Rtimes_pos_pos. assumption. now apply -> Rlt_lt_minus.
-Qed.*)
-
-End STRICT_ORDERED_RING.
-
diff --git a/contrib/micromega/Psatz.v b/contrib/micromega/Psatz.v
deleted file mode 100644
index b2dd9910..00000000
--- a/contrib/micromega/Psatz.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 *)
-(************************************************************************)
-(* *)
-(* Micromega: A reflexive tactic using the Positivstellensatz *)
-(* *)
-(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
-(* *)
-(************************************************************************)
-
-Require Import ZMicromega.
-Require Import QMicromega.
-Require Import RMicromega.
-Require Import QArith.
-Require Export Ring_normalize.
-Require Import ZArith.
-Require Import Raxioms.
-Require Export RingMicromega.
-Require Import VarMap.
-Require Tauto.
-
-Ltac xpsatz dom d :=
- let tac := lazymatch dom with
- | Z =>
- (sos_Z || psatz_Z d) ;
- intros __wit __varmap __ff ;
- change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
- apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity
- | R =>
- (sos_R || psatz_R d) ;
- intros __wit __varmap __ff ;
- change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ;
- apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity
- | Q =>
- (sos_Q || psatz_Q d) ;
- intros __wit __varmap __ff ;
- change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ;
- apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity
- | _ => fail "Unsupported domain"
- end in tac.
-
-Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n.
-Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:-1.
-
-Ltac psatzl dom :=
- let tac := lazymatch dom with
- | Z =>
- psatzl_Z ;
- intros __wit __varmap __ff ;
- change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
- apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity
- | Q =>
- psatzl_Q ;
- intros __wit __varmap __ff ;
- change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ;
- apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity
- | R =>
- psatzl_R ;
- intros __wit __varmap __ff ;
- change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ;
- apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity
- | _ => fail "Unsupported domain"
- end in tac.
-
-
-
-Ltac lia :=
- xlia ;
- intros __wit __varmap __ff ;
- change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
- apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity.
diff --git a/contrib/micromega/QMicromega.v b/contrib/micromega/QMicromega.v
deleted file mode 100644
index c054f218..00000000
--- a/contrib/micromega/QMicromega.v
+++ /dev/null
@@ -1,199 +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 *)
-(************************************************************************)
-(* *)
-(* Micromega: A reflexive tactic using the Positivstellensatz *)
-(* *)
-(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
-(* *)
-(************************************************************************)
-
-Require Import OrderedRing.
-Require Import RingMicromega.
-Require Import Refl.
-Require Import QArith.
-Require Import Qfield.
-
-Lemma Qsor : SOR 0 1 Qplus Qmult Qminus Qopp Qeq Qle Qlt.
-Proof.
- constructor; intros ; subst ; try (intuition (subst; auto with qarith)).
- apply Q_Setoid.
- rewrite H ; rewrite H0 ; reflexivity.
- rewrite H ; rewrite H0 ; reflexivity.
- rewrite H ; auto ; reflexivity.
- rewrite <- H ; rewrite <- H0 ; auto.
- rewrite H ; rewrite H0 ; auto.
- rewrite <- H ; rewrite <- H0 ; auto.
- rewrite H ; rewrite H0 ; auto.
- apply Qsrt.
- apply Qle_refl.
- apply Qle_antisym ; auto.
- eapply Qle_trans ; eauto.
- apply Qlt_le_weak ; auto.
- apply (Qlt_not_eq n m H H0) ; auto.
- destruct (Qle_lt_or_eq _ _ H0) ; auto.
- tauto.
- destruct(Q_dec n m) as [[H1 |H1] | H1 ] ; tauto.
- apply (Qplus_le_compat p p n m (Qle_refl p) H).
- generalize (Qmult_lt_compat_r 0 n m H0 H).
- rewrite Qmult_0_l.
- auto.
- compute in H.
- discriminate.
-Qed.
-
-
-Lemma QSORaddon :
- SORaddon 0 1 Qplus Qmult Qminus Qopp Qeq Qle (* ring elements *)
- 0 1 Qplus Qmult Qminus Qopp (* coefficients *)
- Qeq_bool Qle_bool
- (fun x => x) (fun x => x) (pow_N 1 Qmult).
-Proof.
- constructor.
- constructor ; intros ; try reflexivity.
- apply Qeq_bool_eq; auto.
- constructor.
- reflexivity.
- intros x y.
- apply Qeq_bool_neq ; auto.
- apply Qle_bool_imp_le.
-Qed.
-
-
-(*Definition Zeval_expr := eval_pexpr 0 Zplus Zmult Zminus Zopp (fun x => x) (fun x => Z_of_N x) (Zpower).*)
-Require Import EnvRing.
-
-Fixpoint Qeval_expr (env: PolEnv Q) (e: PExpr Q) : Q :=
- match e with
- | PEc c => c
- | PEX j => env j
- | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2)
- | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2)
- | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2)
- | PEopp pe1 => - (Qeval_expr env pe1)
- | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z_of_N n)
- end.
-
-Lemma Qeval_expr_simpl : forall env e,
- Qeval_expr env e =
- match e with
- | PEc c => c
- | PEX j => env j
- | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2)
- | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2)
- | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2)
- | PEopp pe1 => - (Qeval_expr env pe1)
- | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z_of_N n)
- end.
-Proof.
- destruct e ; reflexivity.
-Qed.
-
-Definition Qeval_expr' := eval_pexpr Qplus Qmult Qminus Qopp (fun x => x) (fun x => x) (pow_N 1 Qmult).
-
-Lemma QNpower : forall r n, r ^ Z_of_N n = pow_N 1 Qmult r n.
-Proof.
- destruct n ; reflexivity.
-Qed.
-
-
-Lemma Qeval_expr_compat : forall env e, Qeval_expr env e = Qeval_expr' env e.
-Proof.
- induction e ; simpl ; subst ; try congruence.
- rewrite IHe.
- apply QNpower.
-Qed.
-
-Definition Qeval_op2 (o : Op2) : Q -> Q -> Prop :=
-match o with
-| OpEq => Qeq
-| OpNEq => fun x y => ~ x == y
-| OpLe => Qle
-| OpGe => fun x y => Qle y x
-| OpLt => Qlt
-| OpGt => fun x y => Qlt y x
-end.
-
-Definition Qeval_formula (e:PolEnv Q) (ff : Formula Q) :=
- let (lhs,o,rhs) := ff in Qeval_op2 o (Qeval_expr e lhs) (Qeval_expr e rhs).
-
-Definition Qeval_formula' :=
- eval_formula Qplus Qmult Qminus Qopp Qeq Qle Qlt (fun x => x) (fun x => x) (pow_N 1 Qmult).
-
-Lemma Qeval_formula_compat : forall env f, Qeval_formula env f <-> Qeval_formula' env f.
-Proof.
- intros.
- unfold Qeval_formula.
- destruct f.
- repeat rewrite Qeval_expr_compat.
- unfold Qeval_formula'.
- unfold Qeval_expr'.
- split ; destruct Fop ; simpl; auto.
-Qed.
-
-
-
-Definition Qeval_nformula :=
- eval_nformula 0 Qplus Qmult Qminus Qopp Qeq Qle Qlt (fun x => x) (fun x => x) (pow_N 1 Qmult).
-
-Definition Qeval_op1 (o : Op1) : Q -> Prop :=
-match o with
-| Equal => fun x : Q => x == 0
-| NonEqual => fun x : Q => ~ x == 0
-| Strict => fun x : Q => 0 < x
-| NonStrict => fun x : Q => 0 <= x
-end.
-
-Lemma Qeval_nformula_simpl : forall env f, Qeval_nformula env f = (let (p, op) := f in Qeval_op1 op (Qeval_expr env p)).
-Proof.
- intros.
- destruct f.
- rewrite Qeval_expr_compat.
- reflexivity.
-Qed.
-
-Lemma Qeval_nformula_dec : forall env d, (Qeval_nformula env d) \/ ~ (Qeval_nformula env d).
-Proof.
- exact (fun env d =>eval_nformula_dec Qsor (fun x => x) (fun x => x) (pow_N 1 Qmult) env d).
-Qed.
-
-Definition QWitness := ConeMember Q.
-
-Definition QWeakChecker := check_normalised_formulas 0 1 Qplus Qmult Qminus Qopp Qeq_bool Qle_bool.
-
-Require Import List.
-
-Lemma QWeakChecker_sound : forall (l : list (NFormula Q)) (cm : QWitness),
- QWeakChecker l cm = true ->
- forall env, make_impl (Qeval_nformula env) l False.
-Proof.
- intros l cm H.
- intro.
- unfold Qeval_nformula.
- apply (checker_nf_sound Qsor QSORaddon l cm).
- unfold QWeakChecker in H.
- exact H.
-Qed.
-
-Require Import Tauto.
-
-Definition QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness) : bool :=
- @tauto_checker (Formula Q) (NFormula Q) (@cnf_normalise Q) (@cnf_negate Q) QWitness QWeakChecker f w.
-
-Lemma QTautoChecker_sound : forall f w, QTautoChecker f w = true -> forall env, eval_f (Qeval_formula env) f.
-Proof.
- intros f w.
- unfold QTautoChecker.
- apply (tauto_checker_sound Qeval_formula Qeval_nformula).
- apply Qeval_nformula_dec.
- intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_normalise_correct Qsor).
- intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_negate_correct Qsor).
- intros t w0.
- apply QWeakChecker_sound.
-Qed.
-
-
diff --git a/contrib/micromega/RMicromega.v b/contrib/micromega/RMicromega.v
deleted file mode 100644
index 7c6969c2..00000000
--- a/contrib/micromega/RMicromega.v
+++ /dev/null
@@ -1,174 +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 *)
-(************************************************************************)
-(* *)
-(* Micromega: A reflexive tactic using the Positivstellensatz *)
-(* *)
-(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
-(* *)
-(************************************************************************)
-
-Require Import OrderedRing.
-Require Import RingMicromega.
-Require Import Refl.
-Require Import Raxioms RIneq Rpow_def DiscrR.
-Require Setoid.
-
-Definition Rsrt : ring_theory R0 R1 Rplus Rmult Rminus Ropp (@eq R).
-Proof.
- constructor.
- exact Rplus_0_l.
- exact Rplus_comm.
- intros. rewrite Rplus_assoc. auto.
- exact Rmult_1_l.
- exact Rmult_comm.
- intros ; rewrite Rmult_assoc ; auto.
- intros. rewrite Rmult_comm. rewrite Rmult_plus_distr_l.
- rewrite (Rmult_comm z). rewrite (Rmult_comm z). auto.
- reflexivity.
- exact Rplus_opp_r.
-Qed.
-
-Add Ring Rring : Rsrt.
-Open Scope R_scope.
-
-Lemma Rmult_neutral : forall x:R , 0 * x = 0.
-Proof.
- intro ; ring.
-Qed.
-
-
-Lemma Rsor : SOR R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle Rlt.
-Proof.
- constructor; intros ; subst ; try (intuition (subst; try ring ; auto with real)).
- constructor.
- constructor.
- unfold RelationClasses.Symmetric. auto.
- unfold RelationClasses.Transitive. intros. subst. reflexivity.
- apply Rsrt.
- eapply Rle_trans ; eauto.
- apply (Rlt_irrefl m) ; auto.
- apply Rnot_le_lt. auto with real.
- destruct (total_order_T n m) as [ [H1 | H1] | H1] ; auto.
- intros.
- rewrite <- (Rmult_neutral m).
- apply (Rmult_lt_compat_r) ; auto.
-Qed.
-
-Require ZMicromega.
-
-(* R with coeffs in Z *)
-
-Lemma RZSORaddon :
- SORaddon R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle (* ring elements *)
- 0%Z 1%Z Zplus Zmult Zminus Zopp (* coefficients *)
- Zeq_bool Zle_bool
- IZR Nnat.nat_of_N pow.
-Proof.
- constructor.
- constructor ; intros ; try reflexivity.
- apply plus_IZR.
- symmetry. apply Z_R_minus.
- apply mult_IZR.
- apply Ropp_Ropp_IZR.
- apply IZR_eq.
- apply Zeq_bool_eq ; auto.
- apply R_power_theory.
- intros x y.
- intro.
- apply IZR_neq.
- apply Zeq_bool_neq ; auto.
- intros. apply IZR_le. apply Zle_bool_imp_le. auto.
-Qed.
-
-
-Require Import EnvRing.
-
-Definition INZ (n:N) : R :=
- match n with
- | N0 => IZR 0%Z
- | Npos p => IZR (Zpos p)
- end.
-
-Definition Reval_expr := eval_pexpr Rplus Rmult Rminus Ropp IZR Nnat.nat_of_N pow.
-
-
-Definition Reval_op2 (o:Op2) : R -> R -> Prop :=
- match o with
- | OpEq => @eq R
- | OpNEq => fun x y => ~ x = y
- | OpLe => Rle
- | OpGe => Rge
- | OpLt => Rlt
- | OpGt => Rgt
- end.
-
-
-Definition Reval_formula (e: PolEnv R) (ff : Formula Z) :=
- let (lhs,o,rhs) := ff in Reval_op2 o (Reval_expr e lhs) (Reval_expr e rhs).
-
-Definition Reval_formula' :=
- eval_formula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IZR Nnat.nat_of_N pow.
-
-Lemma Reval_formula_compat : forall env f, Reval_formula env f <-> Reval_formula' env f.
-Proof.
- intros.
- unfold Reval_formula.
- destruct f.
- unfold Reval_formula'.
- unfold Reval_expr.
- split ; destruct Fop ; simpl ; auto.
- apply Rge_le.
- apply Rle_ge.
-Qed.
-
-Definition Reval_nformula :=
- eval_nformula 0 Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IZR Nnat.nat_of_N pow.
-
-
-Lemma Reval_nformula_dec : forall env d, (Reval_nformula env d) \/ ~ (Reval_nformula env d).
-Proof.
- exact (fun env d =>eval_nformula_dec Rsor IZR Nnat.nat_of_N pow env d).
-Qed.
-
-Definition RWitness := ConeMember Z.
-
-Definition RWeakChecker := check_normalised_formulas 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool Zle_bool.
-
-Require Import List.
-
-Lemma RWeakChecker_sound : forall (l : list (NFormula Z)) (cm : RWitness),
- RWeakChecker l cm = true ->
- forall env, make_impl (Reval_nformula env) l False.
-Proof.
- intros l cm H.
- intro.
- unfold Reval_nformula.
- apply (checker_nf_sound Rsor RZSORaddon l cm).
- unfold RWeakChecker in H.
- exact H.
-Qed.
-
-Require Import Tauto.
-
-Definition RTautoChecker (f : BFormula (Formula Z)) (w: list RWitness) : bool :=
- @tauto_checker (Formula Z) (NFormula Z) (@cnf_normalise Z) (@cnf_negate Z) RWitness RWeakChecker f w.
-
-Lemma RTautoChecker_sound : forall f w, RTautoChecker f w = true -> forall env, eval_f (Reval_formula env) f.
-Proof.
- intros f w.
- unfold RTautoChecker.
- apply (tauto_checker_sound Reval_formula Reval_nformula).
- apply Reval_nformula_dec.
- intros. rewrite Reval_formula_compat.
- unfold Reval_formula'. now apply (cnf_normalise_correct Rsor).
- intros. rewrite Reval_formula_compat. unfold Reval_formula. now apply (cnf_negate_correct Rsor).
- intros t w0.
- apply RWeakChecker_sound.
-Qed.
-
-
diff --git a/contrib/micromega/Refl.v b/contrib/micromega/Refl.v
deleted file mode 100644
index 801d8b21..00000000
--- a/contrib/micromega/Refl.v
+++ /dev/null
@@ -1,129 +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 *)
-(************************************************************************)
-(* *)
-(* Micromega: A reflexive tactic using the Positivstellensatz *)
-(* *)
-(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
-(* *)
-(************************************************************************)
-
-Require Import List.
-Require Setoid.
-
-Set Implicit Arguments.
-
-(* Refl of '->' '/\': basic properties *)
-
-Fixpoint make_impl (A : Type) (eval : A -> Prop) (l : list A) (goal : Prop) {struct l} : Prop :=
- match l with
- | nil => goal
- | cons e l => (eval e) -> (make_impl eval l goal)
- end.
-
-Theorem make_impl_true :
- forall (A : Type) (eval : A -> Prop) (l : list A), make_impl eval l True.
-Proof.
-induction l as [| a l IH]; simpl.
-trivial.
-intro; apply IH.
-Qed.
-
-Fixpoint make_conj (A : Type) (eval : A -> Prop) (l : list A) {struct l} : Prop :=
- match l with
- | nil => True
- | cons e nil => (eval e)
- | cons e l2 => ((eval e) /\ (make_conj eval l2))
- end.
-
-Theorem make_conj_cons : forall (A : Type) (eval : A -> Prop) (a : A) (l : list A),
- make_conj eval (a :: l) <-> eval a /\ make_conj eval l.
-Proof.
-intros; destruct l; simpl; tauto.
-Qed.
-
-
-Lemma make_conj_impl : forall (A : Type) (eval : A -> Prop) (l : list A) (g : Prop),
- (make_conj eval l -> g) <-> make_impl eval l g.
-Proof.
- induction l.
- simpl.
- tauto.
- simpl.
- intros.
- destruct l.
- simpl.
- tauto.
- generalize (IHl g).
- tauto.
-Qed.
-
-Lemma make_conj_in : forall (A : Type) (eval : A -> Prop) (l : list A),
- make_conj eval l -> (forall p, In p l -> eval p).
-Proof.
- induction l.
- simpl.
- tauto.
- simpl.
- intros.
- destruct l.
- simpl in H0.
- destruct H0.
- subst; auto.
- tauto.
- destruct H.
- destruct H0.
- subst;auto.
- apply IHl; auto.
-Qed.
-
-
-
-Lemma make_conj_app : forall A eval l1 l2, @make_conj A eval (l1 ++ l2) <-> @make_conj A eval l1 /\ @make_conj A eval l2.
-Proof.
- induction l1.
- simpl.
- tauto.
- intros.
- change ((a::l1) ++ l2) with (a :: (l1 ++ l2)).
- rewrite make_conj_cons.
- rewrite IHl1.
- rewrite make_conj_cons.
- tauto.
-Qed.
-
-Lemma not_make_conj_cons : forall (A:Type) (t:A) a eval (no_middle_eval : (eval t) \/ ~ (eval t)),
- ~ make_conj eval (t ::a) -> ~ (eval t) \/ (~ make_conj eval a).
-Proof.
- intros.
- simpl in H.
- destruct a.
- tauto.
- tauto.
-Qed.
-
-Lemma not_make_conj_app : forall (A:Type) (t:list A) a eval
- (no_middle_eval : forall d, eval d \/ ~ eval d) ,
- ~ make_conj eval (t ++ a) -> (~ make_conj eval t) \/ (~ make_conj eval a).
-Proof.
- induction t.
- simpl.
- tauto.
- intros.
- simpl ((a::t)++a0)in H.
- destruct (@not_make_conj_cons _ _ _ _ (no_middle_eval a) H).
- left ; red ; intros.
- apply H0.
- rewrite make_conj_cons in H1.
- tauto.
- destruct (IHt _ _ no_middle_eval H0).
- left ; red ; intros.
- apply H1.
- rewrite make_conj_cons in H2.
- tauto.
- right ; auto.
-Qed.
diff --git a/contrib/micromega/RingMicromega.v b/contrib/micromega/RingMicromega.v
deleted file mode 100644
index 6885b82c..00000000
--- a/contrib/micromega/RingMicromega.v
+++ /dev/null
@@ -1,779 +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 *)
-(************************************************************************)
-(* Evgeny Makarov, INRIA, 2007 *)
-(************************************************************************)
-
-Require Import NArith.
-Require Import Relation_Definitions.
-Require Import Setoid.
-(*****)
-Require Import Env.
-Require Import EnvRing.
-(*****)
-Require Import List.
-Require Import Bool.
-Require Import OrderedRing.
-Require Import Refl.
-
-
-Set Implicit Arguments.
-
-Import OrderedRingSyntax.
-
-Section Micromega.
-
-(* Assume we have a strict(ly?) ordered ring *)
-
-Variable R : Type.
-Variables rO rI : R.
-Variables rplus rtimes rminus: R -> R -> R.
-Variable ropp : R -> R.
-Variables req rle rlt : R -> R -> Prop.
-
-Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt.
-
-Notation "0" := rO.
-Notation "1" := rI.
-Notation "x + y" := (rplus x y).
-Notation "x * y " := (rtimes x y).
-Notation "x - y " := (rminus x y).
-Notation "- x" := (ropp x).
-Notation "x == y" := (req x y).
-Notation "x ~= y" := (~ req x y).
-Notation "x <= y" := (rle x y).
-Notation "x < y" := (rlt x y).
-
-(* Assume we have a type of coefficients C and a morphism from C to R *)
-
-Variable C : Type.
-Variables cO cI : C.
-Variables cplus ctimes cminus: C -> C -> C.
-Variable copp : C -> C.
-Variables ceqb cleb : C -> C -> bool.
-Variable phi : C -> R.
-
-(* Power coefficients *)
-Variable E : Set. (* the type of exponents *)
-Variable pow_phi : N -> E.
-Variable rpow : R -> E -> R.
-
-Notation "[ x ]" := (phi x).
-Notation "x [=] y" := (ceqb x y).
-Notation "x [<=] y" := (cleb x y).
-
-(* Let's collect all hypotheses in addition to the ordered ring axioms into
-one structure *)
-
-Record SORaddon := mk_SOR_addon {
- SORrm : ring_morph 0 1 rplus rtimes rminus ropp req cO cI cplus ctimes cminus copp ceqb phi;
- SORpower : power_theory rI rtimes req pow_phi rpow;
- SORcneqb_morph : forall x y : C, x [=] y = false -> [x] ~= [y];
- SORcleb_morph : forall x y : C, x [<=] y = true -> [x] <= [y]
-}.
-
-Variable addon : SORaddon.
-
-Add Relation R req
- reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ )
- symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ )
- transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ )
-as micomega_sor_setoid.
-
-Add Morphism rplus with signature req ==> req ==> req as rplus_morph.
-Proof.
-exact sor.(SORplus_wd).
-Qed.
-Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph.
-Proof.
-exact sor.(SORtimes_wd).
-Qed.
-Add Morphism ropp with signature req ==> req as ropp_morph.
-Proof.
-exact sor.(SORopp_wd).
-Qed.
-Add Morphism rle with signature req ==> req ==> iff as rle_morph.
-Proof.
- exact sor.(SORle_wd).
-Qed.
-Add Morphism rlt with signature req ==> req ==> iff as rlt_morph.
-Proof.
- exact sor.(SORlt_wd).
-Qed.
-
-Add Morphism rminus with signature req ==> req ==> req as rminus_morph.
-Proof.
- exact (rminus_morph sor). (* We already proved that minus is a morphism in OrderedRing.v *)
-Qed.
-
-Definition cneqb (x y : C) := negb (ceqb x y).
-Definition cltb (x y : C) := (cleb x y) && (cneqb x y).
-
-Notation "x [~=] y" := (cneqb x y).
-Notation "x [<] y" := (cltb x y).
-
-Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption.
-Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption.
-Ltac le_elim H := rewrite (Rle_lt_eq sor) in H; destruct H as [H | H].
-
-Lemma cleb_sound : forall x y : C, x [<=] y = true -> [x] <= [y].
-Proof.
- exact addon.(SORcleb_morph).
-Qed.
-
-Lemma cneqb_sound : forall x y : C, x [~=] y = true -> [x] ~= [y].
-Proof.
-intros x y H1. apply addon.(SORcneqb_morph). unfold cneqb, negb in H1.
-destruct (ceqb x y); now try discriminate.
-Qed.
-
-Lemma cltb_sound : forall x y : C, x [<] y = true -> [x] < [y].
-Proof.
-intros x y H. unfold cltb in H. apply andb_prop in H. destruct H as [H1 H2].
-apply cleb_sound in H1. apply cneqb_sound in H2. apply <- (Rlt_le_neq sor). now split.
-Qed.
-
-(* Begin Micromega *)
-
-Definition PExprC := PExpr C. (* arbitrary expressions built from +, *, - *)
-Definition PolC := Pol C. (* polynomials in generalized Horner form, defined in Ring_polynom or EnvRing *)
-(*****)
-(*Definition Env := Env R. (* For interpreting PExprC *)*)
-Definition PolEnv := Env R. (* For interpreting PolC *)
-(*****)
-(*Definition Env := list R.
-Definition PolEnv := list R.*)
-(*****)
-
-(* What benefit do we get, in the case of EnvRing, from defining eval_pexpr
-explicitely below and not through PEeval, as the following lemma says? The
-function eval_pexpr seems to be a straightforward special case of PEeval
-when the environment (i.e., the second last argument of PEeval) of type
-off_map (which is (option positive * t)) is (None, env). *)
-
-(*****)
-Fixpoint eval_pexpr (l : PolEnv) (pe : PExprC) {struct pe} : R :=
-match pe with
-| PEc c => phi c
-| PEX j => l j
-| PEadd pe1 pe2 => (eval_pexpr l pe1) + (eval_pexpr l pe2)
-| PEsub pe1 pe2 => (eval_pexpr l pe1) - (eval_pexpr l pe2)
-| PEmul pe1 pe2 => (eval_pexpr l pe1) * (eval_pexpr l pe2)
-| PEopp pe1 => - (eval_pexpr l pe1)
-| PEpow pe1 n => rpow (eval_pexpr l pe1) (pow_phi n)
-end.
-
-
-Lemma eval_pexpr_simpl : forall (l : PolEnv) (pe : PExprC),
- eval_pexpr l pe =
- match pe with
- | PEc c => phi c
- | PEX j => l j
- | PEadd pe1 pe2 => (eval_pexpr l pe1) + (eval_pexpr l pe2)
- | PEsub pe1 pe2 => (eval_pexpr l pe1) - (eval_pexpr l pe2)
- | PEmul pe1 pe2 => (eval_pexpr l pe1) * (eval_pexpr l pe2)
- | PEopp pe1 => - (eval_pexpr l pe1)
- | PEpow pe1 n => rpow (eval_pexpr l pe1) (pow_phi n)
- end.
-Proof.
- intros ; destruct pe ; reflexivity.
-Qed.
-
-
-
-Lemma eval_pexpr_PEeval : forall (env : PolEnv) (pe : PExprC),
- eval_pexpr env pe =
- PEeval rplus rtimes rminus ropp phi pow_phi rpow env pe.
-Proof.
-induction pe; simpl; intros.
-reflexivity.
-reflexivity.
-rewrite <- IHpe1; rewrite <- IHpe2; reflexivity.
-rewrite <- IHpe1; rewrite <- IHpe2; reflexivity.
-rewrite <- IHpe1; rewrite <- IHpe2; reflexivity.
-rewrite <- IHpe; reflexivity.
-rewrite <- IHpe; reflexivity.
-Qed.
-(*****)
-(*Definition eval_pexpr : Env -> PExprC -> R :=
- PEeval 0 rplus rtimes rminus ropp phi pow_phi rpow.*)
-(*****)
-
-Inductive Op1 : Set := (* relations with 0 *)
-| Equal (* == 0 *)
-| NonEqual (* ~= 0 *)
-| Strict (* > 0 *)
-| NonStrict (* >= 0 *).
-
-Definition NFormula := (PExprC * Op1)%type. (* normalized formula *)
-
-Definition eval_op1 (o : Op1) : R -> Prop :=
-match o with
-| Equal => fun x => x == 0
-| NonEqual => fun x : R => x ~= 0
-| Strict => fun x : R => 0 < x
-| NonStrict => fun x : R => 0 <= x
-end.
-
-Definition eval_nformula (env : PolEnv) (f : NFormula) : Prop :=
-let (p, op) := f in eval_op1 op (eval_pexpr env p).
-
-
-Definition OpMult (o o' : Op1) : Op1 :=
-match o with
-| Equal => Equal
-| NonStrict => NonStrict (* (OpMult NonStrict Equal) could be defined as Equal *)
-| Strict => o'
-| NonEqual => NonEqual (* does not matter what we return here; see the following lemmas *)
-end.
-
-Definition OpAdd (o o': Op1) : Op1 :=
-match o with
-| Equal => o'
-| NonStrict =>
- match o' with
- | Strict => Strict
- | _ => NonStrict
- end
-| Strict => Strict
-| NonEqual => NonEqual (* does not matter what we return here *)
-end.
-
-Lemma OpMultNonEqual :
- forall o o' : Op1, o <> NonEqual -> o' <> NonEqual -> OpMult o o' <> NonEqual.
-Proof.
-intros o o' H1 H2; destruct o; destruct o'; simpl; try discriminate;
-try (intro H; apply H1; reflexivity);
-try (intro H; apply H2; reflexivity).
-Qed.
-
-Lemma OpAdd_NonEqual :
- forall o o' : Op1, o <> NonEqual -> o' <> NonEqual -> OpAdd o o' <> NonEqual.
-Proof.
-intros o o' H1 H2; destruct o; destruct o'; simpl; try discriminate;
-try (intro H; apply H1; reflexivity);
-try (intro H; apply H2; reflexivity).
-Qed.
-
-Lemma OpMult_sound :
- forall (o o' : Op1) (x y : R), o <> NonEqual -> o' <> NonEqual ->
- eval_op1 o x -> eval_op1 o' y -> eval_op1 (OpMult o o') (x * y).
-Proof.
-unfold eval_op1; destruct o; simpl; intros o' x y H1 H2 H3 H4.
-rewrite H3; now rewrite (Rtimes_0_l sor).
-elimtype False; now apply H1.
-destruct o'.
-rewrite H4; now rewrite (Rtimes_0_r sor).
-elimtype False; now apply H2.
-now apply (Rtimes_pos_pos sor).
-apply (Rtimes_nonneg_nonneg sor); [le_less | assumption].
-destruct o'.
-rewrite H4, (Rtimes_0_r sor); le_equal.
-elimtype False; now apply H2.
-apply (Rtimes_nonneg_nonneg sor); [assumption | le_less].
-now apply (Rtimes_nonneg_nonneg sor).
-Qed.
-
-Lemma OpAdd_sound :
- forall (o o' : Op1) (e e' : R), o <> NonEqual -> o' <> NonEqual ->
- eval_op1 o e -> eval_op1 o' e' -> eval_op1 (OpAdd o o') (e + e').
-Proof.
-unfold eval_op1; destruct o; simpl; intros o' e e' H1 H2 H3 H4.
-destruct o'.
-now rewrite H3, H4, (Rplus_0_l sor).
-elimtype False; now apply H2.
-now rewrite H3, (Rplus_0_l sor).
-now rewrite H3, (Rplus_0_l sor).
-elimtype False; now apply H1.
-destruct o'.
-now rewrite H4, (Rplus_0_r sor).
-elimtype False; now apply H2.
-now apply (Rplus_pos_pos sor).
-now apply (Rplus_pos_nonneg sor).
-destruct o'.
-now rewrite H4, (Rplus_0_r sor).
-elimtype False; now apply H2.
-now apply (Rplus_nonneg_pos sor).
-now apply (Rplus_nonneg_nonneg sor).
-Qed.
-
-(* We consider a monoid whose generators are polynomials from the
-hypotheses of the form (p ~= 0). Thus it follows from the hypotheses that
-every element of the monoid (i.e., arbitrary product of generators) is ~=
-0. Therefore, the square of every element is > 0. *)
-
-Inductive Monoid (l : list NFormula) : PExprC -> Prop :=
-| M_One : Monoid l (PEc cI)
-| M_In : forall p : PExprC, In (p, NonEqual) l -> Monoid l p
-| M_Mult : forall (e1 e2 : PExprC), Monoid l e1 -> Monoid l e2 -> Monoid l (PEmul e1 e2).
-
-(* Do we really need to rely on the intermediate definition of monoid ?
- InC why the restriction NonEqual ?
- Could not we consider the IsIdeal as a IsMult ?
- The same for IsSquare ?
-*)
-
-Inductive Cone (l : list (NFormula)) : PExprC -> Op1 -> Prop :=
-| InC : forall p op, In (p, op) l -> op <> NonEqual -> Cone l p op
-| IsIdeal : forall p, Cone l p Equal -> forall p', Cone l (PEmul p p') Equal
-| IsSquare : forall p, Cone l (PEmul p p) NonStrict
-| IsMonoid : forall p, Monoid l p -> Cone l (PEmul p p) Strict
-| IsMult : forall p op q oq, Cone l p op -> Cone l q oq -> Cone l (PEmul p q) (OpMult op oq)
-| IsAdd : forall p op q oq, Cone l p op -> Cone l q oq -> Cone l (PEadd p q) (OpAdd op oq)
-| IsPos : forall c : C, cltb cO c = true -> Cone l (PEc c) Strict
-| IsZ : Cone l (PEc cO) Equal.
-
-(* As promised, if all hypotheses are true in some environment, then every
-member of the monoid is nonzero in this environment *)
-
-Lemma monoid_nonzero : forall (l : list NFormula) (env : PolEnv),
- (forall f : NFormula, In f l -> eval_nformula env f) ->
- forall p : PExprC, Monoid l p -> eval_pexpr env p ~= 0.
-Proof.
-intros l env H1 p H2. induction H2 as [| f H | e1 e2 H3 IH1 H4 IH2]; simpl.
-rewrite addon.(SORrm).(morph1). apply (Rneq_symm sor). apply (Rneq_0_1 sor).
-apply H1 in H. now simpl in H.
-simpl in IH1, IH2. apply (Rtimes_neq_0 sor). now split.
-Qed.
-
-(* If all members of a cone base are true in some environment, then every
-member of the cone is true as well *)
-
-Lemma cone_true :
- forall (l : list NFormula) (env : PolEnv),
- (forall (f : NFormula), In f l -> eval_nformula env f) ->
- forall (p : PExprC) (op : Op1), Cone l p op ->
- op <> NonEqual /\ eval_nformula env (p, op).
-Proof.
-intros l env H1 p op H2. induction H2; simpl in *.
-split. assumption. apply H1 in H. now unfold eval_nformula in H.
-split. discriminate. destruct IHCone as [_ H3]. rewrite H3. now rewrite (Rtimes_0_l sor).
-split. discriminate. apply (Rtimes_square_nonneg sor).
-split. discriminate. apply <- (Rlt_le_neq sor). split. apply (Rtimes_square_nonneg sor).
-apply (Rneq_symm sor). apply (Rtimes_neq_0 sor). split; now apply monoid_nonzero with l.
-destruct IHCone1 as [IH1 IH2]; destruct IHCone2 as [IH3 IH4].
-split. now apply OpMultNonEqual. now apply OpMult_sound.
-destruct IHCone1 as [IH1 IH2]; destruct IHCone2 as [IH3 IH4].
-split. now apply OpAdd_NonEqual. now apply OpAdd_sound.
-split. discriminate. rewrite <- addon.(SORrm).(morph0). now apply cltb_sound.
-split. discriminate. apply addon.(SORrm).(morph0).
-Qed.
-
-(* Every element of a monoid is a product of some generators; therefore,
-to determine an element we can give a list of generators' indices *)
-
-Definition MonoidMember : Set := list nat.
-
-Inductive ConeMember : Type :=
-| S_In : nat -> ConeMember
-| S_Ideal : PExprC -> ConeMember -> ConeMember
-| S_Square : PExprC -> ConeMember
-| S_Monoid : MonoidMember -> ConeMember
-| S_Mult : ConeMember -> ConeMember -> ConeMember
-| S_Add : ConeMember -> ConeMember -> ConeMember
-| S_Pos : C -> ConeMember
-| S_Z : ConeMember.
-
-Definition nformula_times (f f' : NFormula) : NFormula :=
-let (p, op) := f in
- let (p', op') := f' in
- (PEmul p p', OpMult op op').
-
-Definition nformula_plus (f f' : NFormula) : NFormula :=
-let (p, op) := f in
- let (p', op') := f' in
- (PEadd p p', OpAdd op op').
-
-Definition nformula_times_0 (p : PExprC) (f : NFormula) : NFormula :=
-let (q, op) := f in
- match op with
- | Equal => (PEmul q p, Equal)
- | _ => f
- end.
-
-Fixpoint eval_monoid (l : list NFormula) (ns : MonoidMember) {struct ns} : PExprC :=
-match ns with
-| nil => PEc cI
-| n :: ns =>
- let p := match nth n l (PEc cI, NonEqual) with
- | (q, NonEqual) => q
- | _ => PEc cI
- end in
- PEmul p (eval_monoid l ns)
-end.
-
-Theorem eval_monoid_in_monoid :
- forall (l : list NFormula) (ns : MonoidMember), Monoid l (eval_monoid l ns).
-Proof.
-intro l; induction ns; simpl in *.
-constructor.
-apply M_Mult; [| assumption].
-destruct (nth_in_or_default a l (PEc cI, NonEqual)).
-destruct (nth a l (PEc cI, NonEqual)). destruct o; try constructor. assumption.
-rewrite e; simpl. constructor.
-Qed.
-
-(* Provides the cone member from the witness, i.e., ConeMember *)
-Fixpoint eval_cone (l : list NFormula) (cm : ConeMember) {struct cm} : NFormula :=
-match cm with
-| S_In n => match nth n l (PEc cO, Equal) with
- | (_, NonEqual) => (PEc cO, Equal)
- | f => f
- end
-| S_Ideal p cm' => nformula_times_0 p (eval_cone l cm')
-| S_Square p => (PEmul p p, NonStrict)
-| S_Monoid m => let p := eval_monoid l m in (PEmul p p, Strict)
-| S_Mult p q => nformula_times (eval_cone l p) (eval_cone l q)
-| S_Add p q => nformula_plus (eval_cone l p) (eval_cone l q)
-| S_Pos c => if cltb cO c then (PEc c, Strict) else (PEc cO, Equal)
-| S_Z => (PEc cO, Equal)
-end.
-
-Theorem eval_cone_in_cone :
- forall (l : list NFormula) (cm : ConeMember),
- let (p, op) := eval_cone l cm in Cone l p op.
-Proof.
-intros l cm; induction cm; simpl.
-destruct (nth_in_or_default n l (PEc cO, Equal)).
-destruct (nth n l (PEc cO, Equal)). destruct o; try (now apply InC). apply IsZ.
-rewrite e. apply IsZ.
-destruct (eval_cone l cm). destruct o; simpl; try assumption. now apply IsIdeal.
-apply IsSquare.
-apply IsMonoid. apply eval_monoid_in_monoid.
-destruct (eval_cone l cm1). destruct (eval_cone l cm2). unfold nformula_times. now apply IsMult.
-destruct (eval_cone l cm1). destruct (eval_cone l cm2). unfold nformula_plus. now apply IsAdd.
-case_eq (cO [<] c) ; intros ; [apply IsPos ; auto| apply IsZ].
-apply IsZ.
-Qed.
-
-(* (inconsistent_cone_member l p) means (p, op) is in the cone for some op
-(> 0, >= 0, == 0, or ~= 0) and this formula is inconsistent. This fact
-implies that l is inconsistent, as shown by the next lemma. Inconsistency
-of a formula (p, op) can be established by normalizing p and showing that
-it is a constant c for which (c, op) is false. (This is only a sufficient,
-not necessary, condition, of course.) Membership in the cone can be
-verified if we have a certificate. *)
-
-Definition inconsistent_cone_member (l : list NFormula) (p : PExprC) :=
- exists op : Op1, Cone l p op /\
- forall env : PolEnv, ~ eval_op1 op (eval_pexpr env p).
-
-(* If some element of a cone is inconsistent, then the base of the cone
-is also inconsistent *)
-
-Lemma prove_inconsistent :
- forall (l : list NFormula) (p : PExprC),
- inconsistent_cone_member l p -> forall env, make_impl (eval_nformula env) l False.
-Proof.
-intros l p H env.
-destruct H as [o [wit H]].
-apply -> make_conj_impl.
-intro H1. apply H with env.
-pose proof (@cone_true l env) as H2.
-cut (forall f : NFormula, In f l -> eval_nformula env f). intro H3.
-apply (proj2 (H2 H3 p o wit)). intro. now apply make_conj_in.
-Qed.
-
-Definition normalise_pexpr : PExprC -> PolC :=
- norm_aux cO cI cplus ctimes cminus copp ceqb.
-
-(* The following definition we don't really need, hence it is commented *)
-(*Definition eval_pol : PolEnv -> PolC -> R := Pphi 0 rplus rtimes phi.*)
-
-(* roughly speaking, normalise_pexpr_correct is a proof of
- forall env p, eval_pexpr env p == eval_pol env (normalise_pexpr p) *)
-
-(*****)
-Definition normalise_pexpr_correct :=
-let Rops_wd := mk_reqe rplus rtimes ropp req
- sor.(SORplus_wd)
- sor.(SORtimes_wd)
- sor.(SORopp_wd) in
- norm_aux_spec sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))
- addon.(SORrm) addon.(SORpower).
-(*****)
-(*Definition normalise_pexpr_correct :=
-let Rops_wd := mk_reqe rplus rtimes ropp req
- sor.(SORplus_wd)
- sor.(SORtimes_wd)
- sor.(SORopp_wd) in
- norm_aux_spec sor.(SORsetoid) Rops_wd (Rth_ARth sor.(SORsetoid) Rops_wd sor.(SORrt))
- addon.(SORrm) addon.(SORpower) nil.*)
-(*****)
-
-(* Check that a formula f is inconsistent by normalizing and comparing the
-resulting constant with 0 *)
-
-Definition check_inconsistent (f : NFormula) : bool :=
-let (e, op) := f in
- match normalise_pexpr e with
- | Pc c =>
- match op with
- | Equal => cneqb c cO
- | NonStrict => c [<] cO
- | Strict => c [<=] cO
- | NonEqual => false (* eval_cone never returns (p, NonEqual) *)
- end
- | _ => false (* not a constant *)
- end.
-
-Lemma check_inconsistent_sound :
- forall (p : PExprC) (op : Op1),
- check_inconsistent (p, op) = true -> forall env, ~ eval_op1 op (eval_pexpr env p).
-Proof.
-intros p op H1 env. unfold check_inconsistent, normalise_pexpr in H1.
-destruct op; simpl;
-(*****)
-rewrite eval_pexpr_PEeval;
-(*****)
-(*unfold eval_pexpr;*)
-(*****)
-rewrite normalise_pexpr_correct;
-destruct (norm_aux cO cI cplus ctimes cminus copp ceqb p); simpl; try discriminate H1;
-try rewrite <- addon.(SORrm).(morph0); trivial.
-now apply cneqb_sound.
-apply cleb_sound in H1. now apply -> (Rle_ngt sor).
-apply cltb_sound in H1. now apply -> (Rlt_nge sor).
-Qed.
-
-Definition check_normalised_formulas : list NFormula -> ConeMember -> bool :=
- fun l cm => check_inconsistent (eval_cone l cm).
-
-Lemma checker_nf_sound :
- forall (l : list NFormula) (cm : ConeMember),
- check_normalised_formulas l cm = true ->
- forall env : PolEnv, make_impl (eval_nformula env) l False.
-Proof.
-intros l cm H env.
-unfold check_normalised_formulas in H.
-case_eq (eval_cone l cm). intros p op H1.
-apply prove_inconsistent with p. unfold inconsistent_cone_member. exists op. split.
-pose proof (eval_cone_in_cone l cm) as H2. now rewrite H1 in H2.
-apply check_inconsistent_sound. now rewrite <- H1.
-Qed.
-
-(** Normalisation of formulae **)
-
-Inductive Op2 : Set := (* binary relations *)
-| OpEq
-| OpNEq
-| OpLe
-| OpGe
-| OpLt
-| OpGt.
-
-Definition eval_op2 (o : Op2) : R -> R -> Prop :=
-match o with
-| OpEq => req
-| OpNEq => fun x y : R => x ~= y
-| OpLe => rle
-| OpGe => fun x y : R => y <= x
-| OpLt => fun x y : R => x < y
-| OpGt => fun x y : R => y < x
-end.
-
-Record Formula : Type := {
- Flhs : PExprC;
- Fop : Op2;
- Frhs : PExprC
-}.
-
-Definition eval_formula (env : PolEnv) (f : Formula) : Prop :=
- let (lhs, op, rhs) := f in
- (eval_op2 op) (eval_pexpr env lhs) (eval_pexpr env rhs).
-
-(* We normalize Formulas by moving terms to one side *)
-
-Definition normalise (f : Formula) : NFormula :=
-let (lhs, op, rhs) := f in
- match op with
- | OpEq => (PEsub lhs rhs, Equal)
- | OpNEq => (PEsub lhs rhs, NonEqual)
- | OpLe => (PEsub rhs lhs, NonStrict)
- | OpGe => (PEsub lhs rhs, NonStrict)
- | OpGt => (PEsub lhs rhs, Strict)
- | OpLt => (PEsub rhs lhs, Strict)
- end.
-
-Definition negate (f : Formula) : NFormula :=
-let (lhs, op, rhs) := f in
- match op with
- | OpEq => (PEsub rhs lhs, NonEqual)
- | OpNEq => (PEsub rhs lhs, Equal)
- | OpLe => (PEsub lhs rhs, Strict) (* e <= e' == ~ e > e' *)
- | OpGe => (PEsub rhs lhs, Strict)
- | OpGt => (PEsub rhs lhs, NonStrict)
- | OpLt => (PEsub lhs rhs, NonStrict)
-end.
-
-Theorem normalise_sound :
- forall (env : PolEnv) (f : Formula),
- eval_formula env f -> eval_nformula env (normalise f).
-Proof.
-intros env f H; destruct f as [lhs op rhs]; simpl in *.
-destruct op; simpl in *.
-now apply <- (Rminus_eq_0 sor).
-intros H1. apply -> (Rminus_eq_0 sor) in H1. now apply H.
-now apply -> (Rle_le_minus sor).
-now apply -> (Rle_le_minus sor).
-now apply -> (Rlt_lt_minus sor).
-now apply -> (Rlt_lt_minus sor).
-Qed.
-
-Theorem negate_correct :
- forall (env : PolEnv) (f : Formula),
- eval_formula env f <-> ~ (eval_nformula env (negate f)).
-Proof.
-intros env f; destruct f as [lhs op rhs]; simpl.
-destruct op; simpl.
-symmetry. rewrite (Rminus_eq_0 sor).
-split; intro H; [symmetry; now apply -> (Req_dne sor) | symmetry in H; now apply <- (Req_dne sor)].
-rewrite (Rminus_eq_0 sor). split; intro; now apply (Rneq_symm sor).
-rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor).
-rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor).
-rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor).
-rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor).
-Qed.
-
-(** Another normalistion - this is used for cnf conversion **)
-
-Definition xnormalise (t:Formula) : list (NFormula) :=
- let (lhs,o,rhs) := t in
- match o with
- | OpEq =>
- (PEsub lhs rhs, Strict)::(PEsub rhs lhs , Strict)::nil
- | OpNEq => (PEsub lhs rhs,Equal) :: nil
- | OpGt => (PEsub rhs lhs,NonStrict) :: nil
- | OpLt => (PEsub lhs rhs,NonStrict) :: nil
- | OpGe => (PEsub rhs lhs , Strict) :: nil
- | OpLe => (PEsub lhs rhs ,Strict) :: nil
- end.
-
-Require Import Tauto.
-
-Definition cnf_normalise (t:Formula) : cnf (NFormula) :=
- List.map (fun x => x::nil) (xnormalise t).
-
-
-Add Ring SORRing : sor.(SORrt).
-
-Lemma cnf_normalise_correct : forall env t, eval_cnf (eval_nformula env) (cnf_normalise t) -> eval_formula env t.
-Proof.
- unfold cnf_normalise, xnormalise ; simpl ; intros env t.
- unfold eval_cnf.
- destruct t as [lhs o rhs]; case_eq o ; simpl;
- generalize (eval_pexpr env lhs);
- generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros.
- (**)
- apply sor.(SORle_antisymm).
- rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
- rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
- now rewrite <- (Rminus_eq_0 sor).
- rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto.
- rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto.
- rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto.
- rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto.
-Qed.
-
-Definition xnegate (t:Formula) : list (NFormula) :=
- let (lhs,o,rhs) := t in
- match o with
- | OpEq => (PEsub lhs rhs,Equal) :: nil
- | OpNEq => (PEsub lhs rhs ,Strict)::(PEsub rhs lhs,Strict)::nil
- | OpGt => (PEsub lhs rhs,Strict) :: nil
- | OpLt => (PEsub rhs lhs,Strict) :: nil
- | OpGe => (PEsub lhs rhs,NonStrict) :: nil
- | OpLe => (PEsub rhs lhs,NonStrict) :: nil
- end.
-
-Definition cnf_negate (t:Formula) : cnf (NFormula) :=
- List.map (fun x => x::nil) (xnegate t).
-
-Lemma cnf_negate_correct : forall env t, eval_cnf (eval_nformula env) (cnf_negate t) -> ~ eval_formula env t.
-Proof.
- unfold cnf_negate, xnegate ; simpl ; intros env t.
- unfold eval_cnf.
- destruct t as [lhs o rhs]; case_eq o ; simpl ;
- generalize (eval_pexpr env lhs);
- generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros ;
- intuition.
- (**)
- apply H0.
- rewrite H1 ; ring.
- (**)
- apply H1.
- apply sor.(SORle_antisymm).
- rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
- rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
- (**)
- apply H0. now rewrite (Rle_le_minus sor) in H1.
- apply H0. now rewrite (Rle_le_minus sor) in H1.
- apply H0. now rewrite (Rlt_lt_minus sor) in H1.
- apply H0. now rewrite (Rlt_lt_minus sor) in H1.
-Qed.
-
-
-Lemma eval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d).
-Proof.
- intros.
- destruct d ; simpl.
- generalize (eval_pexpr env p); intros.
- destruct o ; simpl.
- apply (Req_em sor r 0).
- destruct (Req_em sor r 0) ; tauto.
- rewrite <- (Rle_ngt sor r 0). generalize (Rle_gt_cases sor r 0). tauto.
- rewrite <- (Rlt_nge sor r 0). generalize (Rle_gt_cases sor 0 r). tauto.
-Qed.
-
-(** Some syntactic simplifications of expressions and cone elements *)
-
-
-Fixpoint simpl_expr (e:PExprC) : PExprC :=
- match e with
- | PEmul y z => let y' := simpl_expr y in let z' := simpl_expr z in
- match y' , z' with
- | PEc c , z' => if ceqb c cI then z' else PEmul y' z'
- | _ , _ => PEmul y' z'
- end
- | PEadd x y => PEadd (simpl_expr x) (simpl_expr y)
- | _ => e
- end.
-
-
-Definition simpl_cone (e:ConeMember) : ConeMember :=
- match e with
- | S_Square t => match simpl_expr t with
- | PEc c => if ceqb cO c then S_Z else S_Pos (ctimes c c)
- | x => S_Square x
- end
- | S_Mult t1 t2 =>
- match t1 , t2 with
- | S_Z , x => S_Z
- | x , S_Z => S_Z
- | S_Pos c , S_Pos c' => S_Pos (ctimes c c')
- | S_Pos p1 , S_Mult (S_Pos p2) x => S_Mult (S_Pos (ctimes p1 p2)) x
- | S_Pos p1 , S_Mult x (S_Pos p2) => S_Mult (S_Pos (ctimes p1 p2)) x
- | S_Mult (S_Pos p2) x , S_Pos p1 => S_Mult (S_Pos (ctimes p1 p2)) x
- | S_Mult x (S_Pos p2) , S_Pos p1 => S_Mult (S_Pos (ctimes p1 p2)) x
- | S_Pos x , S_Add y z => S_Add (S_Mult (S_Pos x) y) (S_Mult (S_Pos x) z)
- | S_Pos c , _ => if ceqb cI c then t2 else S_Mult t1 t2
- | _ , S_Pos c => if ceqb cI c then t1 else S_Mult t1 t2
- | _ , _ => e
- end
- | S_Add t1 t2 =>
- match t1 , t2 with
- | S_Z , x => x
- | x , S_Z => x
- | x , y => S_Add x y
- end
- | _ => e
- end.
-
-
-
-End Micromega.
-
diff --git a/contrib/micromega/Tauto.v b/contrib/micromega/Tauto.v
deleted file mode 100644
index ef48efa6..00000000
--- a/contrib/micromega/Tauto.v
+++ /dev/null
@@ -1,324 +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 *)
-(************************************************************************)
-(* *)
-(* Micromega: A reflexive tactic using the Positivstellensatz *)
-(* *)
-(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
-(* *)
-(************************************************************************)
-
-Require Import List.
-Require Import Refl.
-Require Import Bool.
-
-Set Implicit Arguments.
-
-
- Inductive BFormula (A:Type) : Type :=
- | TT : BFormula A
- | FF : BFormula A
- | X : Prop -> BFormula A
- | A : A -> BFormula A
- | Cj : BFormula A -> BFormula A -> BFormula A
- | D : BFormula A-> BFormula A -> BFormula A
- | N : BFormula A -> BFormula A
- | I : BFormula A-> BFormula A-> BFormula A.
-
- Fixpoint eval_f (A:Type) (ev:A -> Prop ) (f:BFormula A) {struct f}: Prop :=
- match f with
- | TT => True
- | FF => False
- | A a => ev a
- | X p => p
- | Cj e1 e2 => (eval_f ev e1) /\ (eval_f ev e2)
- | D e1 e2 => (eval_f ev e1) \/ (eval_f ev e2)
- | N e => ~ (eval_f ev e)
- | I f1 f2 => (eval_f ev f1) -> (eval_f ev f2)
- end.
-
-
- Lemma map_simpl : forall A B f l, @map A B f l = match l with
- | nil => nil
- | a :: l=> (f a) :: (@map A B f l)
- end.
- Proof.
- destruct l ; reflexivity.
- Qed.
-
-
-
- Section S.
-
- Variable Env : Type.
- Variable Term : Type.
- Variable eval : Env -> Term -> Prop.
- Variable Term' : Type.
- Variable eval' : Env -> Term' -> Prop.
-
-
-
- Variable no_middle_eval' : forall env d, (eval' env d) \/ ~ (eval' env d).
-
-
- Definition clause := list Term'.
- Definition cnf := list clause.
-
- Variable normalise : Term -> cnf.
- Variable negate : Term -> cnf.
-
-
- Definition tt : cnf := @nil clause.
- Definition ff : cnf := cons (@nil Term') nil.
-
-
- Definition or_clause_cnf (t:clause) (f:cnf) : cnf :=
- List.map (fun x => (t++x)) f.
-
- Fixpoint or_cnf (f : cnf) (f' : cnf) {struct f}: cnf :=
- match f with
- | nil => tt
- | e :: rst => (or_cnf rst f') ++ (or_clause_cnf e f')
- end.
-
-
- Definition and_cnf (f1 : cnf) (f2 : cnf) : cnf :=
- f1 ++ f2.
-
- Fixpoint xcnf (pol : bool) (f : BFormula Term) {struct f}: cnf :=
- match f with
- | TT => if pol then tt else ff
- | FF => if pol then ff else tt
- | X p => if pol then ff else ff (* This is not complete - cannot negate any proposition *)
- | A x => if pol then normalise x else negate x
- | N e => xcnf (negb pol) e
- | Cj e1 e2 =>
- (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2)
- | D e1 e2 => (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2)
- | I e1 e2 => (if pol then or_cnf else and_cnf) (xcnf (negb pol) e1) (xcnf pol e2)
- end.
-
- Definition eval_cnf (env : Term' -> Prop) (f:cnf) := make_conj (fun cl => ~ make_conj env cl) f.
-
-
- Lemma eval_cnf_app : forall env x y, eval_cnf (eval' env) (x++y) -> eval_cnf (eval' env) x /\ eval_cnf (eval' env) y.
- Proof.
- unfold eval_cnf.
- intros.
- rewrite make_conj_app in H ; auto.
- Qed.
-
-
- Lemma or_clause_correct : forall env t f, eval_cnf (eval' env) (or_clause_cnf t f) -> (~ make_conj (eval' env) t) \/ (eval_cnf (eval' env) f).
- Proof.
- unfold eval_cnf.
- unfold or_clause_cnf.
- induction f.
- simpl.
- intros ; right;auto.
- (**)
- rewrite map_simpl.
- intros.
- rewrite make_conj_cons in H.
- destruct H as [HH1 HH2].
- generalize (IHf HH2) ; clear IHf ; intro.
- destruct H.
- left ; auto.
- rewrite make_conj_cons.
- destruct (not_make_conj_app _ _ _ (no_middle_eval' env) HH1).
- tauto.
- tauto.
- Qed.
-
- Lemma eval_cnf_cons : forall env a f, (~ make_conj (eval' env) a) -> eval_cnf (eval' env) f -> eval_cnf (eval' env) (a::f).
- Proof.
- intros.
- unfold eval_cnf in *.
- rewrite make_conj_cons ; eauto.
- Qed.
-
- Lemma or_cnf_correct : forall env f f', eval_cnf (eval' env) (or_cnf f f') -> (eval_cnf (eval' env) f) \/ (eval_cnf (eval' env) f').
- Proof.
- induction f.
- unfold eval_cnf.
- simpl.
- tauto.
- (**)
- intros.
- simpl in H.
- destruct (eval_cnf_app _ _ _ H).
- clear H.
- destruct (IHf _ H0).
- destruct (or_clause_correct _ _ _ H1).
- left.
- apply eval_cnf_cons ; auto.
- right ; auto.
- right ; auto.
- Qed.
-
- Variable normalise_correct : forall env t, eval_cnf (eval' env) (normalise t) -> eval env t.
-
- Variable negate_correct : forall env t, eval_cnf (eval' env) (negate t) -> ~ eval env t.
-
-
- Lemma xcnf_correct : forall f pol env, eval_cnf (eval' env) (xcnf pol f) -> eval_f (eval env) (if pol then f else N f).
- Proof.
- induction f.
- (* TT *)
- unfold eval_cnf.
- simpl.
- destruct pol ; simpl ; auto.
- (* FF *)
- unfold eval_cnf.
- destruct pol; simpl ; auto.
- (* P *)
- simpl.
- destruct pol ; intros ;simpl.
- unfold eval_cnf in H.
- (* Here I have to drop the proposition *)
- simpl in H.
- tauto.
- (* Here, I could store P in the clause *)
- unfold eval_cnf in H;simpl in H.
- tauto.
- (* A *)
- simpl.
- destruct pol ; simpl.
- intros.
- apply normalise_correct ; auto.
- (* A 2 *)
- intros.
- apply negate_correct ; auto.
- auto.
- (* Cj *)
- destruct pol ; simpl.
- (* pol = true *)
- intros.
- unfold and_cnf in H.
- destruct (eval_cnf_app _ _ _ H).
- clear H.
- split.
- apply (IHf1 _ _ H0).
- apply (IHf2 _ _ H1).
- (* pol = false *)
- intros.
- destruct (or_cnf_correct _ _ _ H).
- generalize (IHf1 false env H0).
- simpl.
- tauto.
- generalize (IHf2 false env H0).
- simpl.
- tauto.
- (* D *)
- simpl.
- destruct pol.
- (* pol = true *)
- intros.
- destruct (or_cnf_correct _ _ _ H).
- generalize (IHf1 _ env H0).
- simpl.
- tauto.
- generalize (IHf2 _ env H0).
- simpl.
- tauto.
- (* pol = true *)
- unfold and_cnf.
- intros.
- destruct (eval_cnf_app _ _ _ H).
- clear H.
- simpl.
- generalize (IHf1 _ _ H0).
- generalize (IHf2 _ _ H1).
- simpl.
- tauto.
- (**)
- simpl.
- destruct pol ; simpl.
- intros.
- apply (IHf false) ; auto.
- intros.
- generalize (IHf _ _ H).
- tauto.
- (* I *)
- simpl; intros.
- destruct pol.
- simpl.
- intro.
- destruct (or_cnf_correct _ _ _ H).
- generalize (IHf1 _ _ H1).
- simpl in *.
- tauto.
- generalize (IHf2 _ _ H1).
- auto.
- (* pol = false *)
- unfold and_cnf in H.
- simpl in H.
- destruct (eval_cnf_app _ _ _ H).
- generalize (IHf1 _ _ H0).
- generalize (IHf2 _ _ H1).
- simpl.
- tauto.
- Qed.
-
-
- Variable Witness : Type.
- Variable checker : list Term' -> Witness -> bool.
-
- Variable checker_sound : forall t w, checker t w = true -> forall env, make_impl (eval' env) t False.
-
- Fixpoint cnf_checker (f : cnf) (l : list Witness) {struct f}: bool :=
- match f with
- | nil => true
- | e::f => match l with
- | nil => false
- | c::l => match checker e c with
- | true => cnf_checker f l
- | _ => false
- end
- end
- end.
-
- Lemma cnf_checker_sound : forall t w, cnf_checker t w = true -> forall env, eval_cnf (eval' env) t.
- Proof.
- unfold eval_cnf.
- induction t.
- (* bc *)
- simpl.
- auto.
- (* ic *)
- simpl.
- destruct w.
- intros ; discriminate.
- case_eq (checker a w) ; intros ; try discriminate.
- generalize (@checker_sound _ _ H env).
- generalize (IHt _ H0 env) ; intros.
- destruct t.
- red ; intro.
- rewrite <- make_conj_impl in H2.
- tauto.
- rewrite <- make_conj_impl in H2.
- tauto.
- Qed.
-
-
- Definition tauto_checker (f:BFormula Term) (w:list Witness) : bool :=
- cnf_checker (xcnf true f) w.
-
- Lemma tauto_checker_sound : forall t w, tauto_checker t w = true -> forall env, eval_f (eval env) t.
- Proof.
- unfold tauto_checker.
- intros.
- change (eval_f (eval env) t) with (eval_f (eval env) (if true then t else TT Term)).
- apply (xcnf_correct t true).
- eapply cnf_checker_sound ; eauto.
- Qed.
-
-
-
-
-End S.
-
diff --git a/contrib/micromega/VarMap.v b/contrib/micromega/VarMap.v
deleted file mode 100644
index 240c0fb7..00000000
--- a/contrib/micromega/VarMap.v
+++ /dev/null
@@ -1,258 +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 *)
-(************************************************************************)
-(* *)
-(* Micromega: A reflexive tactic using the Positivstellensatz *)
-(* *)
-(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
-(* *)
-(************************************************************************)
-
-Require Import ZArith.
-Require Import Coq.Arith.Max.
-Require Import List.
-Set Implicit Arguments.
-
-(* I have addded a Leaf constructor to the varmap data structure (/contrib/ring/Quote.v)
- -- this is harmless and spares a lot of Empty.
- This means smaller proof-terms.
- BTW, by dropping the polymorphism, I get small (yet noticeable) speed-up.
-*)
-
-Section MakeVarMap.
- Variable A : Type.
- Variable default : A.
-
- Inductive t : Type :=
- | Empty : t
- | Leaf : A -> t
- | Node : t -> A -> t -> t .
-
- Fixpoint find (vm : t ) (p:positive) {struct vm} : A :=
- match vm with
- | Empty => default
- | Leaf i => i
- | Node l e r => match p with
- | xH => e
- | xO p => find l p
- | xI p => find r p
- end
- end.
-
- (* an off_map (a map with offset) offers the same functionalites as /contrib/setoid_ring/BinList.v - it is used in EnvRing.v *)
-(*
- Definition off_map := (option positive *t )%type.
-
-
-
- Definition jump (j:positive) (l:off_map ) :=
- let (o,m) := l in
- match o with
- | None => (Some j,m)
- | Some j0 => (Some (j+j0)%positive,m)
- end.
-
- Definition nth (n:positive) (l: off_map ) :=
- let (o,m) := l in
- let idx := match o with
- | None => n
- | Some i => i + n
- end%positive in
- find idx m.
-
-
- Definition hd (l:off_map) := nth xH l.
-
-
- Definition tail (l:off_map ) := jump xH l.
-
-
- Lemma psucc : forall p, (match p with
- | xI y' => xO (Psucc y')
- | xO y' => xI y'
- | 1%positive => 2%positive
- end) = (p+1)%positive.
- Proof.
- destruct p.
- auto with zarith.
- rewrite xI_succ_xO.
- auto with zarith.
- reflexivity.
- Qed.
-
- Lemma jump_Pplus : forall i j l,
- (jump (i + j) l) = (jump i (jump j l)).
- Proof.
- unfold jump.
- destruct l.
- destruct o.
- rewrite Pplus_assoc.
- reflexivity.
- reflexivity.
- Qed.
-
- Lemma jump_simpl : forall p l,
- jump p l =
- match p with
- | xH => tail l
- | xO p => jump p (jump p l)
- | xI p => jump p (jump p (tail l))
- end.
- Proof.
- destruct p ; unfold tail ; intros ; repeat rewrite <- jump_Pplus.
- (* xI p = p + p + 1 *)
- rewrite xI_succ_xO.
- rewrite Pplus_diag.
- rewrite <- Pplus_one_succ_r.
- reflexivity.
- (* xO p = p + p *)
- rewrite Pplus_diag.
- reflexivity.
- reflexivity.
- Qed.
-
- Ltac jump_s :=
- repeat
- match goal with
- | |- context [jump xH ?e] => rewrite (jump_simpl xH)
- | |- context [jump (xO ?p) ?e] => rewrite (jump_simpl (xO p))
- | |- context [jump (xI ?p) ?e] => rewrite (jump_simpl (xI p))
- end.
-
- Lemma jump_tl : forall j l, tail (jump j l) = jump j (tail l).
- Proof.
- unfold tail.
- intros.
- repeat rewrite <- jump_Pplus.
- rewrite Pplus_comm.
- reflexivity.
- Qed.
-
- Lemma jump_Psucc : forall j l,
- (jump (Psucc j) l) = (jump 1 (jump j l)).
- Proof.
- intros.
- rewrite <- jump_Pplus.
- rewrite Pplus_one_succ_r.
- rewrite Pplus_comm.
- reflexivity.
- Qed.
-
- Lemma jump_Pdouble_minus_one : forall i l,
- (jump (Pdouble_minus_one i) (tail l)) = (jump i (jump i l)).
- Proof.
- unfold tail.
- intros.
- repeat rewrite <- jump_Pplus.
- rewrite <- Pplus_one_succ_r.
- rewrite Psucc_o_double_minus_one_eq_xO.
- rewrite Pplus_diag.
- reflexivity.
- Qed.
-
- Lemma jump_x0_tail : forall p l, jump (xO p) (tail l) = jump (xI p) l.
- Proof.
- intros.
- jump_s.
- repeat rewrite <- jump_Pplus.
- reflexivity.
- Qed.
-
-
- Lemma nth_spec : forall p l,
- nth p l =
- match p with
- | xH => hd l
- | xO p => nth p (jump p l)
- | xI p => nth p (jump p (tail l))
- end.
- Proof.
- unfold nth.
- destruct l.
- destruct o.
- simpl.
- rewrite psucc.
- destruct p.
- replace (p0 + xI p)%positive with ((p + (p0 + 1) + p))%positive.
- reflexivity.
- rewrite xI_succ_xO.
- rewrite Pplus_one_succ_r.
- rewrite <- Pplus_diag.
- rewrite Pplus_comm.
- symmetry.
- rewrite (Pplus_comm p0).
- rewrite <- Pplus_assoc.
- rewrite (Pplus_comm 1)%positive.
- rewrite <- Pplus_assoc.
- reflexivity.
- (**)
- replace ((p0 + xO p))%positive with (p + p0 + p)%positive.
- reflexivity.
- rewrite <- Pplus_diag.
- rewrite <- Pplus_assoc.
- rewrite Pplus_comm.
- rewrite Pplus_assoc.
- reflexivity.
- reflexivity.
- simpl.
- destruct p.
- rewrite xI_succ_xO.
- rewrite Pplus_one_succ_r.
- rewrite <- Pplus_diag.
- symmetry.
- rewrite Pplus_comm.
- rewrite Pplus_assoc.
- reflexivity.
- rewrite Pplus_diag.
- reflexivity.
- reflexivity.
- Qed.
-
-
- Lemma nth_jump : forall p l, nth p (tail l) = hd (jump p l).
- Proof.
- destruct l.
- unfold tail.
- unfold hd.
- unfold jump.
- unfold nth.
- destruct o.
- symmetry.
- rewrite Pplus_comm.
- rewrite <- Pplus_assoc.
- rewrite (Pplus_comm p0).
- reflexivity.
- rewrite Pplus_comm.
- reflexivity.
- Qed.
-
- Lemma nth_Pdouble_minus_one :
- forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l).
- Proof.
- destruct l.
- unfold tail.
- unfold nth, jump.
- destruct o.
- rewrite ((Pplus_comm p)).
- rewrite <- (Pplus_assoc p0).
- rewrite Pplus_diag.
- rewrite <- Psucc_o_double_minus_one_eq_xO.
- rewrite Pplus_one_succ_r.
- rewrite (Pplus_comm (Pdouble_minus_one p)).
- rewrite Pplus_assoc.
- rewrite (Pplus_comm p0).
- reflexivity.
- rewrite <- Pplus_one_succ_l.
- rewrite Psucc_o_double_minus_one_eq_xO.
- rewrite Pplus_diag.
- reflexivity.
- Qed.
-
-*)
-
-End MakeVarMap.
-
diff --git a/contrib/micromega/ZCoeff.v b/contrib/micromega/ZCoeff.v
deleted file mode 100644
index ced67e39..00000000
--- a/contrib/micromega/ZCoeff.v
+++ /dev/null
@@ -1,173 +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 *)
-(************************************************************************)
-(* Evgeny Makarov, INRIA, 2007 *)
-(************************************************************************)
-
-Require Import OrderedRing.
-Require Import RingMicromega.
-Require Import ZArith.
-Require Import InitialRing.
-Require Import Setoid.
-
-Import OrderedRingSyntax.
-
-Set Implicit Arguments.
-
-Section InitialMorphism.
-
-Variable R : Type.
-Variables rO rI : R.
-Variables rplus rtimes rminus: R -> R -> R.
-Variable ropp : R -> R.
-Variables req rle rlt : R -> R -> Prop.
-
-Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt.
-
-Notation "0" := rO.
-Notation "1" := rI.
-Notation "x + y" := (rplus x y).
-Notation "x * y " := (rtimes x y).
-Notation "x - y " := (rminus x y).
-Notation "- x" := (ropp x).
-Notation "x == y" := (req x y).
-Notation "x ~= y" := (~ req x y).
-Notation "x <= y" := (rle x y).
-Notation "x < y" := (rlt x y).
-
-Lemma req_refl : forall x, req x x.
-Proof.
- destruct sor.(SORsetoid).
- apply Equivalence_Reflexive.
-Qed.
-
-Lemma req_sym : forall x y, req x y -> req y x.
-Proof.
- destruct sor.(SORsetoid).
- apply Equivalence_Symmetric.
-Qed.
-
-Lemma req_trans : forall x y z, req x y -> req y z -> req x z.
-Proof.
- destruct sor.(SORsetoid).
- apply Equivalence_Transitive.
-Qed.
-
-
-Add Relation R req
- reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _)
- symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _)
- transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _)
-as sor_setoid.
-
-Add Morphism rplus with signature req ==> req ==> req as rplus_morph.
-Proof.
-exact sor.(SORplus_wd).
-Qed.
-Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph.
-Proof.
-exact sor.(SORtimes_wd).
-Qed.
-Add Morphism ropp with signature req ==> req as ropp_morph.
-Proof.
-exact sor.(SORopp_wd).
-Qed.
-Add Morphism rle with signature req ==> req ==> iff as rle_morph.
-Proof.
-exact sor.(SORle_wd).
-Qed.
-Add Morphism rlt with signature req ==> req ==> iff as rlt_morph.
-Proof.
-exact sor.(SORlt_wd).
-Qed.
-Add Morphism rminus with signature req ==> req ==> req as rminus_morph.
-Proof.
- exact (rminus_morph sor).
-Qed.
-
-Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption.
-Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption.
-
-Definition gen_order_phi_Z : Z -> R := gen_phiZ 0 1 rplus rtimes ropp.
-
-Notation phi_pos := (gen_phiPOS 1 rplus rtimes).
-Notation phi_pos1 := (gen_phiPOS1 1 rplus rtimes).
-
-Notation "[ x ]" := (gen_order_phi_Z x).
-
-Lemma ring_ops_wd : ring_eq_ext rplus rtimes ropp req.
-Proof.
-constructor.
-exact rplus_morph.
-exact rtimes_morph.
-exact ropp_morph.
-Qed.
-
-Lemma Zring_morph :
- ring_morph 0 1 rplus rtimes rminus ropp req
- 0%Z 1%Z Zplus Zmult Zminus Zopp
- Zeq_bool gen_order_phi_Z.
-Proof.
-exact (gen_phiZ_morph sor.(SORsetoid) ring_ops_wd sor.(SORrt)).
-Qed.
-
-Lemma phi_pos1_pos : forall x : positive, 0 < phi_pos1 x.
-Proof.
-induction x as [x IH | x IH |]; simpl;
-try apply (Rplus_pos_pos sor); try apply (Rtimes_pos_pos sor); try apply (Rplus_pos_pos sor);
-try apply (Rlt_0_1 sor); assumption.
-Qed.
-
-Lemma phi_pos1_succ : forall x : positive, phi_pos1 (Psucc x) == 1 + phi_pos1 x.
-Proof.
-exact (ARgen_phiPOS_Psucc sor.(SORsetoid) ring_ops_wd
- (Rth_ARth sor.(SORsetoid) ring_ops_wd sor.(SORrt))).
-Qed.
-
-Lemma clt_pos_morph : forall x y : positive, (x < y)%positive -> phi_pos1 x < phi_pos1 y.
-Proof.
-intros x y H. pattern y; apply Plt_ind with x.
-rewrite phi_pos1_succ; apply (Rlt_succ_r sor).
-clear y H; intros y _ H. rewrite phi_pos1_succ. now apply (Rlt_lt_succ sor).
-assumption.
-Qed.
-
-Lemma clt_morph : forall x y : Z, (x < y)%Z -> [x] < [y].
-Proof.
-unfold Zlt; intros x y H;
-do 2 rewrite (same_genZ sor.(SORsetoid) ring_ops_wd sor.(SORrt));
-destruct x; destruct y; simpl in *; try discriminate.
-apply phi_pos1_pos.
-now apply clt_pos_morph.
-apply <- (Ropp_neg_pos sor); apply phi_pos1_pos.
-apply (Rlt_trans sor) with 0. apply <- (Ropp_neg_pos sor); apply phi_pos1_pos.
-apply phi_pos1_pos.
-rewrite Pcompare_antisym in H; simpl in H. apply -> (Ropp_lt_mono sor).
-now apply clt_pos_morph.
-Qed.
-
-Lemma Zcleb_morph : forall x y : Z, Zle_bool x y = true -> [x] <= [y].
-Proof.
-unfold Zle_bool; intros x y H.
-case_eq (x ?= y)%Z; intro H1; rewrite H1 in H.
-le_equal. apply Zring_morph.(morph_eq). unfold Zeq_bool; now rewrite H1.
-le_less. now apply clt_morph.
-discriminate.
-Qed.
-
-Lemma Zcneqb_morph : forall x y : Z, Zeq_bool x y = false -> [x] ~= [y].
-Proof.
-intros x y H. unfold Zeq_bool in H.
-case_eq (Zcompare x y); intro H1; rewrite H1 in *; (discriminate || clear H).
-apply (Rlt_neq sor). now apply clt_morph.
-fold (x > y)%Z in H1. rewrite Zgt_iff_lt in H1.
-apply (Rneq_symm sor). apply (Rlt_neq sor). now apply clt_morph.
-Qed.
-
-End InitialMorphism.
-
-
diff --git a/contrib/micromega/ZMicromega.v b/contrib/micromega/ZMicromega.v
deleted file mode 100644
index 0855925a..00000000
--- a/contrib/micromega/ZMicromega.v
+++ /dev/null
@@ -1,705 +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 *)
-(************************************************************************)
-(* *)
-(* Micromega: A reflexive tactic using the Positivstellensatz *)
-(* *)
-(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
-(* *)
-(************************************************************************)
-
-Require Import OrderedRing.
-Require Import RingMicromega.
-Require Import ZCoeff.
-Require Import Refl.
-Require Import ZArith.
-Require Import List.
-Require Import Bool.
-
-Ltac flatten_bool :=
- repeat match goal with
- [ id : (_ && _)%bool = true |- _ ] => destruct (andb_prop _ _ id); clear id
- | [ id : (_ || _)%bool = true |- _ ] => destruct (orb_prop _ _ id); clear id
- end.
-
-Require Import EnvRing.
-
-Open Scope Z_scope.
-
-Lemma Zsor : SOR 0 1 Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt.
-Proof.
- constructor ; intros ; subst ; try (intuition (auto with zarith)).
- apply Zsth.
- apply Zth.
- destruct (Ztrichotomy n m) ; intuition (auto with zarith).
- apply Zmult_lt_0_compat ; auto.
-Qed.
-
-Lemma ZSORaddon :
- SORaddon 0 1 Zplus Zmult Zminus Zopp (@eq Z) Zle (* ring elements *)
- 0%Z 1%Z Zplus Zmult Zminus Zopp (* coefficients *)
- Zeq_bool Zle_bool
- (fun x => x) (fun x => x) (pow_N 1 Zmult).
-Proof.
- constructor.
- constructor ; intros ; try reflexivity.
- apply Zeq_bool_eq ; auto.
- constructor.
- reflexivity.
- intros x y.
- apply Zeq_bool_neq ; auto.
- apply Zle_bool_imp_le.
-Qed.
-
-
-(*Definition Zeval_expr := eval_pexpr 0 Zplus Zmult Zminus Zopp (fun x => x) (fun x => Z_of_N x) (Zpower).*)
-
-Fixpoint Zeval_expr (env: PolEnv Z) (e: PExpr Z) : Z :=
- match e with
- | PEc c => c
- | PEX j => env j
- | PEadd pe1 pe2 => (Zeval_expr env pe1) + (Zeval_expr env pe2)
- | PEsub pe1 pe2 => (Zeval_expr env pe1) - (Zeval_expr env pe2)
- | PEmul pe1 pe2 => (Zeval_expr env pe1) * (Zeval_expr env pe2)
- | PEopp pe1 => - (Zeval_expr env pe1)
- | PEpow pe1 n => Zpower (Zeval_expr env pe1) (Z_of_N n)
- end.
-
-Lemma Zeval_expr_simpl : forall env e,
- Zeval_expr env e =
- match e with
- | PEc c => c
- | PEX j => env j
- | PEadd pe1 pe2 => (Zeval_expr env pe1) + (Zeval_expr env pe2)
- | PEsub pe1 pe2 => (Zeval_expr env pe1) - (Zeval_expr env pe2)
- | PEmul pe1 pe2 => (Zeval_expr env pe1) * (Zeval_expr env pe2)
- | PEopp pe1 => - (Zeval_expr env pe1)
- | PEpow pe1 n => Zpower (Zeval_expr env pe1) (Z_of_N n)
- end.
-Proof.
- destruct e ; reflexivity.
-Qed.
-
-
-Definition Zeval_expr' := eval_pexpr Zplus Zmult Zminus Zopp (fun x => x) (fun x => x) (pow_N 1 Zmult).
-
-Lemma ZNpower : forall r n, r ^ Z_of_N n = pow_N 1 Zmult r n.
-Proof.
- destruct n.
- reflexivity.
- simpl.
- unfold Zpower_pos.
- replace (pow_pos Zmult r p) with (1 * (pow_pos Zmult r p)) by ring.
- generalize 1.
- induction p; simpl ; intros ; repeat rewrite IHp ; ring.
-Qed.
-
-
-
-Lemma Zeval_expr_compat : forall env e, Zeval_expr env e = Zeval_expr' env e.
-Proof.
- induction e ; simpl ; subst ; try congruence.
- rewrite IHe.
- apply ZNpower.
-Qed.
-
-Definition Zeval_op2 (o : Op2) : Z -> Z -> Prop :=
-match o with
-| OpEq => @eq Z
-| OpNEq => fun x y => ~ x = y
-| OpLe => Zle
-| OpGe => Zge
-| OpLt => Zlt
-| OpGt => Zgt
-end.
-
-Definition Zeval_formula (e: PolEnv Z) (ff : Formula Z) :=
- let (lhs,o,rhs) := ff in Zeval_op2 o (Zeval_expr e lhs) (Zeval_expr e rhs).
-
-Definition Zeval_formula' :=
- eval_formula Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt (fun x => x) (fun x => x) (pow_N 1 Zmult).
-
-Lemma Zeval_formula_compat : forall env f, Zeval_formula env f <-> Zeval_formula' env f.
-Proof.
- intros.
- unfold Zeval_formula.
- destruct f.
- repeat rewrite Zeval_expr_compat.
- unfold Zeval_formula'.
- unfold Zeval_expr'.
- split ; destruct Fop ; simpl; auto with zarith.
-Qed.
-
-
-
-Definition Zeval_nformula :=
- eval_nformula 0 Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt (fun x => x) (fun x => x) (pow_N 1 Zmult).
-
-Definition Zeval_op1 (o : Op1) : Z -> Prop :=
-match o with
-| Equal => fun x : Z => x = 0
-| NonEqual => fun x : Z => x <> 0
-| Strict => fun x : Z => 0 < x
-| NonStrict => fun x : Z => 0 <= x
-end.
-
-Lemma Zeval_nformula_simpl : forall env f, Zeval_nformula env f = (let (p, op) := f in Zeval_op1 op (Zeval_expr env p)).
-Proof.
- intros.
- destruct f.
- rewrite Zeval_expr_compat.
- reflexivity.
-Qed.
-
-Lemma Zeval_nformula_dec : forall env d, (Zeval_nformula env d) \/ ~ (Zeval_nformula env d).
-Proof.
- exact (fun env d =>eval_nformula_dec Zsor (fun x => x) (fun x => x) (pow_N 1%Z Zmult) env d).
-Qed.
-
-Definition ZWitness := ConeMember Z.
-
-Definition ZWeakChecker := check_normalised_formulas 0 1 Zplus Zmult Zminus Zopp Zeq_bool Zle_bool.
-
-Lemma ZWeakChecker_sound : forall (l : list (NFormula Z)) (cm : ZWitness),
- ZWeakChecker l cm = true ->
- forall env, make_impl (Zeval_nformula env) l False.
-Proof.
- intros l cm H.
- intro.
- unfold Zeval_nformula.
- apply (checker_nf_sound Zsor ZSORaddon l cm).
- unfold ZWeakChecker in H.
- exact H.
-Qed.
-
-Definition xnormalise (t:Formula Z) : list (NFormula Z) :=
- let (lhs,o,rhs) := t in
- match o with
- | OpEq =>
- ((PEsub lhs (PEadd rhs (PEc 1))),NonStrict)::((PEsub rhs (PEadd lhs (PEc 1))),NonStrict)::nil
- | OpNEq => (PEsub lhs rhs,Equal) :: nil
- | OpGt => (PEsub rhs lhs,NonStrict) :: nil
- | OpLt => (PEsub lhs rhs,NonStrict) :: nil
- | OpGe => (PEsub rhs (PEadd lhs (PEc 1)),NonStrict) :: nil
- | OpLe => (PEsub lhs (PEadd rhs (PEc 1)),NonStrict) :: nil
- end.
-
-Require Import Tauto.
-
-Definition normalise (t:Formula Z) : cnf (NFormula Z) :=
- List.map (fun x => x::nil) (xnormalise t).
-
-
-Lemma normalise_correct : forall env t, eval_cnf (Zeval_nformula env) (normalise t) <-> Zeval_formula env t.
-Proof.
- unfold normalise, xnormalise ; simpl ; intros env t.
- rewrite Zeval_formula_compat.
- unfold eval_cnf.
- destruct t as [lhs o rhs]; case_eq o ; simpl;
- generalize ( eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x)
- (fun x : BinNat.N => x) (pow_N 1 Zmult) env lhs);
- generalize (eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x)
- (fun x : BinNat.N => x) (pow_N 1 Zmult) env rhs) ; intros z1 z2 ; intros ; subst;
- intuition (auto with zarith).
-Qed.
-
-Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z) :=
- let (lhs,o,rhs) := t in
- match o with
- | OpEq => (PEsub lhs rhs,Equal) :: nil
- | OpNEq => ((PEsub lhs (PEadd rhs (PEc 1))),NonStrict)::((PEsub rhs (PEadd lhs (PEc 1))),NonStrict)::nil
- | OpGt => (PEsub lhs (PEadd rhs (PEc 1)),NonStrict) :: nil
- | OpLt => (PEsub rhs (PEadd lhs (PEc 1)),NonStrict) :: nil
- | OpGe => (PEsub lhs rhs,NonStrict) :: nil
- | OpLe => (PEsub rhs lhs,NonStrict) :: nil
- end.
-
-Definition negate (t:RingMicromega.Formula Z) : cnf (NFormula Z) :=
- List.map (fun x => x::nil) (xnegate t).
-
-Lemma negate_correct : forall env t, eval_cnf (Zeval_nformula env) (negate t) <-> ~ Zeval_formula env t.
-Proof.
- unfold negate, xnegate ; simpl ; intros env t.
- rewrite Zeval_formula_compat.
- unfold eval_cnf.
- destruct t as [lhs o rhs]; case_eq o ; simpl ;
- generalize ( eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x)
- (fun x : BinNat.N => x) (pow_N 1 Zmult) env lhs);
- generalize (eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x)
- (fun x : BinNat.N => x) (pow_N 1 Zmult) env rhs) ; intros z1 z2 ; intros ;
- intuition (auto with zarith).
-Qed.
-
-
-Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z)) : bool :=
- @tauto_checker (Formula Z) (NFormula Z) normalise negate ZWitness ZWeakChecker f w.
-
-(* To get a complete checker, the proof format has to be enriched *)
-
-Require Import Zdiv.
-Open Scope Z_scope.
-
-Definition ceiling (a b:Z) : Z :=
- let (q,r) := Zdiv_eucl a b in
- match r with
- | Z0 => q
- | _ => q + 1
- end.
-
-Lemma narrow_interval_lower_bound : forall a b x, a > 0 -> a * x >= b -> x >= ceiling b a.
-Proof.
- unfold ceiling.
- intros.
- generalize (Z_div_mod b a H).
- destruct (Zdiv_eucl b a).
- intros.
- destruct H1.
- destruct H2.
- subst.
- destruct (Ztrichotomy z0 0) as [ HH1 | [HH2 | HH3]]; destruct z0 ; try auto with zarith ; try discriminate.
- assert (HH :x >= z \/ x < z) by (destruct (Ztrichotomy x z) ; auto with zarith).
- destruct HH ;auto.
- generalize (Zmult_lt_compat_l _ _ _ H3 H1).
- auto with zarith.
- clear H2.
- assert (HH :x >= z +1 \/ x <= z) by (destruct (Ztrichotomy x z) ; intuition (auto with zarith)).
- destruct HH ;auto.
- assert (0 < a) by auto with zarith.
- generalize (Zmult_lt_0_le_compat_r _ _ _ H2 H1).
- intros.
- rewrite Zmult_comm in H4.
- rewrite (Zmult_comm z) in H4.
- auto with zarith.
-Qed.
-
-Lemma narrow_interval_upper_bound : forall a b x, a > 0 -> a * x <= b -> x <= Zdiv b a.
-Proof.
- unfold Zdiv.
- intros.
- generalize (Z_div_mod b a H).
- destruct (Zdiv_eucl b a).
- intros.
- destruct H1.
- destruct H2.
- subst.
- assert (HH :x <= z \/ z <= x -1) by (destruct (Ztrichotomy x z) ; intuition (auto with zarith)).
- destruct HH ;auto.
- assert (0 < a) by auto with zarith.
- generalize (Zmult_lt_0_le_compat_r _ _ _ H4 H1).
- intros.
- ring_simplify in H5.
- rewrite Zmult_comm in H5.
- auto with zarith.
-Qed.
-
-
-(* In this case, a certificate is made of a pair of inequations, in 1 variable,
- that do not have an integer solution.
- => modify the fourier elimination
- *)
-Require Import QArith.
-
-
-Inductive ProofTerm : Type :=
-| RatProof : ZWitness -> ProofTerm
-| CutProof : PExprC Z -> Q -> ZWitness -> ProofTerm -> ProofTerm
-| EnumProof : Q -> PExprC Z -> Q -> ZWitness -> ZWitness -> list ProofTerm -> ProofTerm.
-
-(* n/d <= x -> d*x - n >= 0 *)
-
-Definition makeLb (v:PExpr Z) (q:Q) : NFormula Z :=
- let (n,d) := q in (PEsub (PEmul (PEc (Zpos d)) v) (PEc n),NonStrict).
-
-(* x <= n/d -> d * x <= d *)
-Definition makeUb (v:PExpr Z) (q:Q) : NFormula Z :=
- let (n,d) := q in
- (PEsub (PEc n) (PEmul (PEc (Zpos d)) v), NonStrict).
-
-Definition qceiling (q:Q) : Z :=
- let (n,d) := q in ceiling n (Zpos d).
-
-Definition qfloor (q:Q) : Z :=
- let (n,d) := q in Zdiv n (Zpos d).
-
-Definition makeLbCut (v:PExprC Z) (q:Q) : NFormula Z :=
- (PEsub v (PEc (qceiling q)), NonStrict).
-
-Definition neg_nformula (f : NFormula Z) :=
- let (e,o) := f in
- (PEopp (PEadd e (PEc 1%Z)), o).
-
-Lemma neg_nformula_sound : forall env f, snd f = NonStrict ->( ~ (Zeval_nformula env (neg_nformula f)) <-> Zeval_nformula env f).
-Proof.
- unfold neg_nformula.
- destruct f.
- simpl.
- intros ; subst ; simpl in *.
- split; auto with zarith.
-Qed.
-
-
-Definition cutChecker (l:list (NFormula Z)) (e: PExpr Z) (lb:Q) (pf : ZWitness) : option (NFormula Z) :=
- let (lb,lc) := (makeLb e lb,makeLbCut e lb) in
- if ZWeakChecker (neg_nformula lb::l) pf then Some lc else None.
-
-
-Fixpoint ZChecker (l:list (NFormula Z)) (pf : ProofTerm) {struct pf} : bool :=
- match pf with
- | RatProof pf => ZWeakChecker l pf
- | CutProof e q pf rst =>
- match cutChecker l e q pf with
- | None => false
- | Some c => ZChecker (c::l) rst
- end
- | EnumProof lb e ub pf1 pf2 rst =>
- match cutChecker l e lb pf1 , cutChecker l (PEopp e) (Qopp ub) pf2 with
- | None , _ | _ , None => false
- | Some _ , Some _ => let (lb',ub') := (qceiling lb, Zopp (qceiling (- ub))) in
- (fix label (pfs:list ProofTerm) :=
- fun lb ub =>
- match pfs with
- | nil => if Z_gt_dec lb ub then true else false
- | pf::rsr => andb (ZChecker ((PEsub e (PEc lb), Equal) :: l) pf) (label rsr (Zplus lb 1%Z) ub)
- end)
- rst lb' ub'
- end
- end.
-
-
-Lemma ZChecker_simpl : forall (pf : ProofTerm) (l:list (NFormula Z)),
- ZChecker l pf =
- match pf with
- | RatProof pf => ZWeakChecker l pf
- | CutProof e q pf rst =>
- match cutChecker l e q pf with
- | None => false
- | Some c => ZChecker (c::l) rst
- end
- | EnumProof lb e ub pf1 pf2 rst =>
- match cutChecker l e lb pf1 , cutChecker l (PEopp e) (Qopp ub) pf2 with
- | None , _ | _ , None => false
- | Some _ , Some _ => let (lb',ub') := (qceiling lb, Zopp (qceiling (- ub))) in
- (fix label (pfs:list ProofTerm) :=
- fun lb ub =>
- match pfs with
- | nil => if Z_gt_dec lb ub then true else false
- | pf::rsr => andb (ZChecker ((PEsub e (PEc lb), Equal) :: l) pf) (label rsr (Zplus lb 1%Z) ub)
- end)
- rst lb' ub'
- end
- end.
-Proof.
- destruct pf ; reflexivity.
-Qed.
-
-(*
-Fixpoint depth (n:nat) : ProofTerm -> option nat :=
- match n with
- | O => fun pf => None
- | S n =>
- fun pf =>
- match pf with
- | RatProof _ => Some O
- | CutProof _ _ _ p => option_map S (depth n p)
- | EnumProof _ _ _ _ _ l =>
- let f := fun pf x =>
- match x , depth n pf with
- | None , _ | _ , None => None
- | Some n1 , Some n2 => Some (Max.max n1 n2)
- end in
- List.fold_right f (Some O) l
- end
- end.
-*)
-Fixpoint bdepth (pf : ProofTerm) : nat :=
- match pf with
- | RatProof _ => O
- | CutProof _ _ _ p => S (bdepth p)
- | EnumProof _ _ _ _ _ l => S (List.fold_right (fun pf x => Max.max (bdepth pf) x) O l)
- end.
-
-Require Import Wf_nat.
-
-Lemma in_bdepth : forall l a b p c c0 y, In y l -> ltof ProofTerm bdepth y (EnumProof a b p c c0 l).
-Proof.
- induction l.
- simpl.
- tauto.
- simpl.
- intros.
- destruct H.
- subst.
- unfold ltof.
- simpl.
- generalize ( (fold_right
- (fun (pf : ProofTerm) (x : nat) => Max.max (bdepth pf) x) 0%nat l)).
- intros.
- generalize (bdepth y) ; intros.
- generalize (Max.max_l n0 n) (Max.max_r n0 n).
- omega.
- generalize (IHl a0 b p c c0 y H).
- unfold ltof.
- simpl.
- generalize ( (fold_right (fun (pf : ProofTerm) (x : nat) => Max.max (bdepth pf) x) 0%nat
- l)).
- intros.
- generalize (Max.max_l (bdepth a) n) (Max.max_r (bdepth a) n).
- omega.
-Qed.
-
-Lemma lb_lbcut : forall env e q, Zeval_nformula env (makeLb e q) -> Zeval_nformula env (makeLbCut e q).
-Proof.
- unfold makeLb, makeLbCut.
- destruct q.
- rewrite Zeval_nformula_simpl.
- rewrite Zeval_nformula_simpl.
- unfold Zeval_op1.
- rewrite Zeval_expr_simpl.
- rewrite Zeval_expr_simpl.
- rewrite Zeval_expr_simpl.
- intro.
- rewrite Zeval_expr_simpl.
- revert H.
- generalize (Zeval_expr env e).
- rewrite Zeval_expr_simpl.
- rewrite Zeval_expr_simpl.
- unfold qceiling.
- intros.
- assert ( z >= ceiling Qnum (' Qden))%Z.
- apply narrow_interval_lower_bound.
- compute.
- reflexivity.
- destruct z ; auto with zarith.
- auto with zarith.
-Qed.
-
-Lemma cutChecker_sound : forall e lb pf l res, cutChecker l e lb pf = Some res ->
- forall env, make_impl (Zeval_nformula env) l (Zeval_nformula env res).
-Proof.
- unfold cutChecker.
- intros.
- revert H.
- case_eq (ZWeakChecker (neg_nformula (makeLb e lb) :: l) pf); intros ; [idtac | discriminate].
- generalize (ZWeakChecker_sound _ _ H env).
- intros.
- inversion H0 ; subst ; clear H0.
- apply -> make_conj_impl.
- simpl in H1.
- rewrite <- make_conj_impl in H1.
- intros.
- apply -> neg_nformula_sound ; auto.
- red ; intros.
- apply H1 ; auto.
- clear H H1 H0.
- generalize (lb_lbcut env e lb).
- intros.
- destruct (Zeval_nformula_dec env ((neg_nformula (makeLb e lb)))).
- auto.
- rewrite -> neg_nformula_sound in H0.
- assert (HH := H H0).
- rewrite <- neg_nformula_sound in HH.
- tauto.
- reflexivity.
- unfold makeLb.
- destruct lb.
- reflexivity.
-Qed.
-
-
-Lemma cutChecker_sound_bound : forall e lb pf l res, cutChecker l e lb pf = Some res ->
- forall env, make_conj (Zeval_nformula env) l -> (Zeval_expr env e >= qceiling lb)%Z.
-Proof.
- intros.
- generalize (cutChecker_sound _ _ _ _ _ H env).
- intros.
- rewrite <- (make_conj_impl) in H1.
- generalize (H1 H0).
- unfold cutChecker in H.
- destruct (ZWeakChecker (neg_nformula (makeLb e lb) :: l) pf).
- unfold makeLbCut in H.
- inversion H ; subst.
- clear H.
- simpl.
- rewrite Zeval_expr_compat.
- unfold Zeval_expr'.
- auto with zarith.
- discriminate.
-Qed.
-
-
-Lemma ZChecker_sound : forall w l, ZChecker l w = true -> forall env, make_impl (Zeval_nformula env) l False.
-Proof.
- induction w using (well_founded_ind (well_founded_ltof _ bdepth)).
- destruct w.
- (* RatProof *)
- simpl.
- intros.
- eapply ZWeakChecker_sound.
- apply H0.
- (* CutProof *)
- simpl.
- intro.
- case_eq (cutChecker l p q z) ; intros.
- generalize (cutChecker_sound _ _ _ _ _ H0 env).
- intro.
- assert (make_impl (Zeval_nformula env) (n::l) False).
- eapply (H w) ; auto.
- unfold ltof.
- simpl.
- auto with arith.
- simpl in H3.
- rewrite <- make_conj_impl in H2.
- rewrite <- make_conj_impl in H3.
- rewrite <- make_conj_impl.
- tauto.
- discriminate.
- (* EnumProof *)
- intro.
- rewrite ZChecker_simpl.
- case_eq (cutChecker l0 p q z).
- rename q into llb.
- case_eq (cutChecker l0 (PEopp p) (- q0) z0).
- intros.
- rename q0 into uub.
- (* get the bounds of the enum *)
- rewrite <- make_conj_impl.
- intro.
- assert (qceiling llb <= Zeval_expr env p <= - qceiling ( - uub))%Z.
- generalize (cutChecker_sound_bound _ _ _ _ _ H0 env H3).
- generalize (cutChecker_sound_bound _ _ _ _ _ H1 env H3).
- intros.
- rewrite Zeval_expr_simpl in H5.
- auto with zarith.
- clear H0 H1.
- revert H2 H3 H4.
- generalize (qceiling llb) (- qceiling (- uub))%Z.
- set (FF := (fix label (pfs : list ProofTerm) (lb ub : Z) {struct pfs} : bool :=
- match pfs with
- | nil => if Z_gt_dec lb ub then true else false
- | pf :: rsr =>
- (ZChecker ((PEsub p (PEc lb), Equal) :: l0) pf &&
- label rsr (lb + 1)%Z ub)%bool
- end)).
- intros z1 z2.
- intros.
- assert (forall x, z1 <= x <= z2 -> exists pr,
- (In pr l /\
- ZChecker ((PEsub p (PEc x),Equal) :: l0) pr = true))%Z.
- clear H.
- revert H2.
- clear H4.
- revert z1 z2.
- induction l;simpl ;intros.
- destruct (Z_gt_dec z1 z2).
- intros.
- apply False_ind ; omega.
- discriminate.
- intros.
- simpl in H2.
- flatten_bool.
- assert (HH:(x = z1 \/ z1 +1 <=x)%Z) by omega.
- destruct HH.
- subst.
- exists a ; auto.
- assert (z1 + 1 <= x <= z2)%Z by omega.
- destruct (IHl _ _ H1 _ H4).
- destruct H5.
- exists x0 ; split;auto.
- (*/asser *)
- destruct (H0 _ H4) as [pr [Hin Hcheker]].
- assert (make_impl (Zeval_nformula env) ((PEsub p (PEc (Zeval_expr env p)),Equal) :: l0) False).
- apply (H pr);auto.
- apply in_bdepth ; auto.
- rewrite <- make_conj_impl in H1.
- apply H1.
- rewrite make_conj_cons.
- split ;auto.
- rewrite Zeval_nformula_simpl;
- unfold Zeval_op1;
- rewrite Zeval_expr_simpl.
- generalize (Zeval_expr env p).
- intros.
- rewrite Zeval_expr_simpl.
- auto with zarith.
- intros ; discriminate.
- intros ; discriminate.
-Qed.
-
-Definition ZTautoChecker (f : BFormula (Formula Z)) (w: list ProofTerm): bool :=
- @tauto_checker (Formula Z) (NFormula Z) normalise negate ProofTerm ZChecker f w.
-
-Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_f (Zeval_formula env) f.
-Proof.
- intros f w.
- unfold ZTautoChecker.
- apply (tauto_checker_sound Zeval_formula Zeval_nformula).
- apply Zeval_nformula_dec.
- intros env t.
- rewrite normalise_correct ; auto.
- intros env t.
- rewrite negate_correct ; auto.
- intros t w0.
- apply ZChecker_sound.
-Qed.
-
-
-Open Scope Z_scope.
-
-
-Fixpoint map_cone (f: nat -> nat) (e:ZWitness) : ZWitness :=
- match e with
- | S_In n => S_In _ (f n)
- | S_Ideal e cm => S_Ideal e (map_cone f cm)
- | S_Square _ => e
- | S_Monoid l => S_Monoid _ (List.map f l)
- | S_Mult cm1 cm2 => S_Mult (map_cone f cm1) (map_cone f cm2)
- | S_Add cm1 cm2 => S_Add (map_cone f cm1) (map_cone f cm2)
- | _ => e
- end.
-
-Fixpoint indexes (e:ZWitness) : list nat :=
- match e with
- | S_In n => n::nil
- | S_Ideal e cm => indexes cm
- | S_Square e => nil
- | S_Monoid l => l
- | S_Mult cm1 cm2 => (indexes cm1)++ (indexes cm2)
- | S_Add cm1 cm2 => (indexes cm1)++ (indexes cm2)
- | _ => nil
- end.
-
-(** To ease bindings from ml code **)
-(*Definition varmap := Quote.varmap.*)
-Definition make_impl := Refl.make_impl.
-Definition make_conj := Refl.make_conj.
-
-Require VarMap.
-
-(*Definition varmap_type := VarMap.t Z. *)
-Definition env := PolEnv Z.
-Definition node := @VarMap.Node Z.
-Definition empty := @VarMap.Empty Z.
-Definition leaf := @VarMap.Leaf Z.
-
-Definition coneMember := ZWitness.
-
-Definition eval := Zeval_formula.
-
-Definition prod_pos_nat := prod positive nat.
-
-Require Import Int.
-
-
-Definition n_of_Z (z:Z) : BinNat.N :=
- match z with
- | Z0 => N0
- | Zpos p => Npos p
- | Zneg p => N0
- end.
-
-
-
diff --git a/contrib/micromega/certificate.ml b/contrib/micromega/certificate.ml
deleted file mode 100644
index f4efcd08..00000000
--- a/contrib/micromega/certificate.ml
+++ /dev/null
@@ -1,740 +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 *)
-(************************************************************************)
-(* *)
-(* Micromega: A reflexive tactic using the Positivstellensatz *)
-(* *)
-(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
-(* *)
-(************************************************************************)
-
-(* We take as input a list of polynomials [p1...pn] and return an unfeasibility
- certificate polynomial. *)
-
-(*open Micromega.Polynomial*)
-open Big_int
-open Num
-
-module Mc = Micromega
-module Ml2C = Mutils.CamlToCoq
-module C2Ml = Mutils.CoqToCaml
-
-let (<+>) = add_num
-let (<->) = minus_num
-let (<*>) = mult_num
-
-type var = Mc.positive
-
-module Monomial :
-sig
- type t
- val const : t
- val var : var -> t
- val find : var -> t -> int
- val mult : var -> t -> t
- val prod : t -> t -> t
- val compare : t -> t -> int
- val pp : out_channel -> t -> unit
- val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a
-end
- =
-struct
- (* A monomial is represented by a multiset of variables *)
- module Map = Map.Make(struct type t = var let compare = Pervasives.compare end)
- open Map
-
- type t = int Map.t
-
- (* The monomial that corresponds to a constant *)
- let const = Map.empty
-
- (* The monomial 'x' *)
- let var x = Map.add x 1 Map.empty
-
- (* Get the degre of a variable in a monomial *)
- let find x m = try find x m with Not_found -> 0
-
- (* Multiply a monomial by a variable *)
- let mult x m = add x ( (find x m) + 1) m
-
- (* Product of monomials *)
- let prod m1 m2 = Map.fold (fun k d m -> add k ((find k m) + d) m) m1 m2
-
- (* Total ordering of monomials *)
- let compare m1 m2 = Map.compare Pervasives.compare m1 m2
-
- let pp o m = Map.iter (fun k v ->
- if v = 1 then Printf.fprintf o "x%i." (C2Ml.index k)
- else Printf.fprintf o "x%i^%i." (C2Ml.index k) v) m
-
- let fold = fold
-
-end
-
-
-module Poly :
- (* A polynomial is a map of monomials *)
- (*
- This is probably a naive implementation
- (expected to be fast enough - Coq is probably the bottleneck)
- *The new ring contribution is using a sparse Horner representation.
- *)
-sig
- type t
- val get : Monomial.t -> t -> num
- val variable : var -> t
- val add : Monomial.t -> num -> t -> t
- val constant : num -> t
- val mult : Monomial.t -> num -> t -> t
- val product : t -> t -> t
- val addition : t -> t -> t
- val uminus : t -> t
- val fold : (Monomial.t -> num -> 'a -> 'a) -> t -> 'a -> 'a
- val pp : out_channel -> t -> unit
- val compare : t -> t -> int
-end =
-struct
- (*normalisation bug : 0*x ... *)
- module P = Map.Make(Monomial)
- open P
-
- type t = num P.t
-
- let pp o p = P.iter (fun k v ->
- if compare_num v (Int 0) <> 0
- then
- if Monomial.compare Monomial.const k = 0
- then Printf.fprintf o "%s " (string_of_num v)
- else Printf.fprintf o "%s*%a " (string_of_num v) Monomial.pp k) p
-
- (* Get the coefficient of monomial mn *)
- let get : Monomial.t -> t -> num =
- fun mn p -> try find mn p with Not_found -> (Int 0)
-
-
- (* The polynomial 1.x *)
- let variable : var -> t =
- fun x -> add (Monomial.var x) (Int 1) empty
-
- (*The constant polynomial *)
- let constant : num -> t =
- fun c -> add (Monomial.const) c empty
-
- (* The addition of a monomial *)
-
- let add : Monomial.t -> num -> t -> t =
- fun mn v p ->
- let vl = (get mn p) <+> v in
- add mn vl p
-
-
- (** Design choice: empty is not a polynomial
- I do not remember why ....
- **)
-
- (* The product by a monomial *)
- let mult : Monomial.t -> num -> t -> t =
- fun mn v p ->
- fold (fun mn' v' res -> P.add (Monomial.prod mn mn') (v<*>v') res) p empty
-
-
- let addition : t -> t -> t =
- fun p1 p2 -> fold (fun mn v p -> add mn v p) p1 p2
-
-
- let product : t -> t -> t =
- fun p1 p2 ->
- fold (fun mn v res -> addition (mult mn v p2) res ) p1 empty
-
-
- let uminus : t -> t =
- fun p -> map (fun v -> minus_num v) p
-
- let fold = P.fold
-
- let compare = compare compare_num
-end
-
-open Mutils
-type 'a number_spec = {
- bigint_to_number : big_int -> 'a;
- number_to_num : 'a -> num;
- zero : 'a;
- unit : 'a;
- mult : 'a -> 'a -> 'a;
- eqb : 'a -> 'a -> Mc.bool
-}
-
-let z_spec = {
- bigint_to_number = Ml2C.bigint ;
- number_to_num = (fun x -> Big_int (C2Ml.z_big_int x));
- zero = Mc.Z0;
- unit = Mc.Zpos Mc.XH;
- mult = Mc.zmult;
- eqb = Mc.zeq_bool
-}
-
-
-let q_spec = {
- bigint_to_number = (fun x -> {Mc.qnum = Ml2C.bigint x; Mc.qden = Mc.XH});
- number_to_num = C2Ml.q_to_num;
- zero = {Mc.qnum = Mc.Z0;Mc.qden = Mc.XH};
- unit = {Mc.qnum = (Mc.Zpos Mc.XH) ; Mc.qden = Mc.XH};
- mult = Mc.qmult;
- eqb = Mc.qeq_bool
-}
-
-let r_spec = z_spec
-
-
-
-
-let dev_form n_spec p =
- let rec dev_form p =
- match p with
- | Mc.PEc z -> Poly.constant (n_spec.number_to_num z)
- | Mc.PEX v -> Poly.variable v
- | Mc.PEmul(p1,p2) ->
- let p1 = dev_form p1 in
- let p2 = dev_form p2 in
- Poly.product p1 p2
- | Mc.PEadd(p1,p2) -> Poly.addition (dev_form p1) (dev_form p2)
- | Mc.PEopp p -> Poly.uminus (dev_form p)
- | Mc.PEsub(p1,p2) -> Poly.addition (dev_form p1) (Poly.uminus (dev_form p2))
- | Mc.PEpow(p,n) ->
- let p = dev_form p in
- let n = C2Ml.n n in
- let rec pow n =
- if n = 0
- then Poly.constant (n_spec.number_to_num n_spec.unit)
- else Poly.product p (pow (n-1)) in
- pow n in
- dev_form p
-
-
-let monomial_to_polynomial mn =
- Monomial.fold
- (fun v i acc ->
- let mn = if i = 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in
- if acc = Mc.PEc (Mc.Zpos Mc.XH)
- then mn
- else Mc.PEmul(mn,acc))
- mn
- (Mc.PEc (Mc.Zpos Mc.XH))
-
-let list_to_polynomial vars l =
- assert (List.for_all (fun x -> ceiling_num x =/ x) l);
- let var x = monomial_to_polynomial (List.nth vars x) in
- let rec xtopoly p i = function
- | [] -> p
- | c::l -> if c =/ (Int 0) then xtopoly p (i+1) l
- else let c = Mc.PEc (Ml2C.bigint (numerator c)) in
- let mn =
- if c = Mc.PEc (Mc.Zpos Mc.XH)
- then var i
- else Mc.PEmul (c,var i) in
- let p' = if p = Mc.PEc Mc.Z0 then mn else
- Mc.PEadd (mn, p) in
- xtopoly p' (i+1) l in
-
- xtopoly (Mc.PEc Mc.Z0) 0 l
-
-let rec fixpoint f x =
- let y' = f x in
- if y' = x then y'
- else fixpoint f y'
-
-
-
-
-
-
-
-
-let rec_simpl_cone n_spec e =
- let simpl_cone =
- Mc.simpl_cone n_spec.zero n_spec.unit n_spec.mult n_spec.eqb in
-
- let rec rec_simpl_cone = function
- | Mc.S_Mult(t1, t2) ->
- simpl_cone (Mc.S_Mult (rec_simpl_cone t1, rec_simpl_cone t2))
- | Mc.S_Add(t1,t2) ->
- simpl_cone (Mc.S_Add (rec_simpl_cone t1, rec_simpl_cone t2))
- | x -> simpl_cone x in
- rec_simpl_cone e
-
-
-let simplify_cone n_spec c = fixpoint (rec_simpl_cone n_spec) c
-
-type cone_prod =
- Const of cone
- | Ideal of cone *cone
- | Mult of cone * cone
- | Other of cone
-and cone = Mc.zWitness
-
-
-
-let factorise_linear_cone c =
-
- let rec cone_list c l =
- match c with
- | Mc.S_Add (x,r) -> cone_list r (x::l)
- | _ -> c :: l in
-
- let factorise c1 c2 =
- match c1 , c2 with
- | Mc.S_Ideal(x,y) , Mc.S_Ideal(x',y') ->
- if x = x' then Some (Mc.S_Ideal(x, Mc.S_Add(y,y'))) else None
- | Mc.S_Mult(x,y) , Mc.S_Mult(x',y') ->
- if x = x' then Some (Mc.S_Mult(x, Mc.S_Add(y,y'))) else None
- | _ -> None in
-
- let rec rebuild_cone l pending =
- match l with
- | [] -> (match pending with
- | None -> Mc.S_Z
- | Some p -> p
- )
- | e::l ->
- (match pending with
- | None -> rebuild_cone l (Some e)
- | Some p -> (match factorise p e with
- | None -> Mc.S_Add(p, rebuild_cone l (Some e))
- | Some f -> rebuild_cone l (Some f) )
- ) in
-
- (rebuild_cone (List.sort Pervasives.compare (cone_list c [])) None)
-
-
-
-(* The binding with Fourier might be a bit obsolete
- -- how does it handle equalities ? *)
-
-(* Certificates are elements of the cone such that P = 0 *)
-
-(* To begin with, we search for certificates of the form:
- a1.p1 + ... an.pn + b1.q1 +... + bn.qn + c = 0
- where pi >= 0 qi > 0
- ai >= 0
- bi >= 0
- Sum bi + c >= 1
- This is a linear problem: each monomial is considered as a variable.
- Hence, we can use fourier.
-
- The variable c is at index 0
-*)
-
-open Mfourier
- (*module Fourier = Fourier(Vector.VList)(SysSet(Vector.VList))*)
- (*module Fourier = Fourier(Vector.VSparse)(SysSetAlt(Vector.VSparse))*)
-module Fourier = Mfourier.Fourier(Vector.VSparse)(*(SysSetAlt(Vector.VMap))*)
-
-module Vect = Fourier.Vect
-open Fourier.Cstr
-
-(* fold_left followed by a rev ! *)
-
-let constrain_monomial mn l =
- let coeffs = List.fold_left (fun acc p -> (Poly.get mn p)::acc) [] l in
- if mn = Monomial.const
- then
- { coeffs = Vect.from_list ((Big_int unit_big_int):: (List.rev coeffs)) ;
- op = Eq ;
- cst = Big_int zero_big_int }
- else
- { coeffs = Vect.from_list ((Big_int zero_big_int):: (List.rev coeffs)) ;
- op = Eq ;
- cst = Big_int zero_big_int }
-
-
-let positivity l =
- let rec xpositivity i l =
- match l with
- | [] -> []
- | (_,Mc.Equal)::l -> xpositivity (i+1) l
- | (_,_)::l ->
- {coeffs = Vect.update (i+1) (fun _ -> Int 1) Vect.null ;
- op = Ge ;
- cst = Int 0 } :: (xpositivity (i+1) l)
- in
- xpositivity 0 l
-
-
-let string_of_op = function
- | Mc.Strict -> "> 0"
- | Mc.NonStrict -> ">= 0"
- | Mc.Equal -> "= 0"
- | Mc.NonEqual -> "<> 0"
-
-
-
-(* If the certificate includes at least one strict inequality,
- the obtained polynomial can also be 0 *)
-let build_linear_system l =
-
- (* Gather the monomials: HINT add up of the polynomials *)
- let l' = List.map fst l in
- let monomials =
- List.fold_left (fun acc p -> Poly.addition p acc) (Poly.constant (Int 0)) l'
- in (* For each monomial, compute a constraint *)
- let s0 =
- Poly.fold (fun mn _ res -> (constrain_monomial mn l')::res) monomials [] in
- (* I need at least something strictly positive *)
- let strict = {
- coeffs = Vect.from_list ((Big_int unit_big_int)::
- (List.map (fun (x,y) ->
- match y with Mc.Strict ->
- Big_int unit_big_int
- | _ -> Big_int zero_big_int) l));
- op = Ge ; cst = Big_int unit_big_int } in
- (* Add the positivity constraint *)
- {coeffs = Vect.from_list ([Big_int unit_big_int]) ;
- op = Ge ;
- cst = Big_int zero_big_int}::(strict::(positivity l)@s0)
-
-
-let big_int_to_z = Ml2C.bigint
-
-(* For Q, this is a pity that the certificate has been scaled
- -- at a lower layer, certificates are using nums... *)
-let make_certificate n_spec cert li =
- let bint_to_cst = n_spec.bigint_to_number in
- match cert with
- | [] -> None
- | e::cert' ->
- let cst = match compare_big_int e zero_big_int with
- | 0 -> Mc.S_Z
- | 1 -> Mc.S_Pos (bint_to_cst e)
- | _ -> failwith "positivity error"
- in
- let rec scalar_product cert l =
- match cert with
- | [] -> Mc.S_Z
- | c::cert -> match l with
- | [] -> failwith "make_certificate(1)"
- | i::l ->
- let r = scalar_product cert l in
- match compare_big_int c zero_big_int with
- | -1 -> Mc.S_Add (
- Mc.S_Ideal (Mc.PEc ( bint_to_cst c), Mc.S_In (Ml2C.nat i)),
- r)
- | 0 -> r
- | _ -> Mc.S_Add (
- Mc.S_Mult (Mc.S_Pos (bint_to_cst c), Mc.S_In (Ml2C.nat i)),
- r) in
-
- Some ((factorise_linear_cone
- (simplify_cone n_spec (Mc.S_Add (cst, scalar_product cert' li)))))
-
-
-exception Found of Monomial.t
-
-let raw_certificate l =
- let sys = build_linear_system l in
- try
- match Fourier.find_point sys with
- | None -> None
- | Some cert -> Some (rats_to_ints (Vect.to_list cert))
- (* should not use rats_to_ints *)
- with x ->
- if debug
- then (Printf.printf "raw certificate %s" (Printexc.to_string x);
- flush stdout) ;
- None
-
-
-let simple_linear_prover to_constant l =
- let (lc,li) = List.split l in
- match raw_certificate lc with
- | None -> None (* No certificate *)
- | Some cert -> make_certificate to_constant cert li
-
-
-
-let linear_prover n_spec l =
- let li = List.combine l (interval 0 (List.length l -1)) in
- let (l1,l') = List.partition
- (fun (x,_) -> if snd' x = Mc.NonEqual then true else false) li in
- let l' = List.map
- (fun (c,i) -> let (Mc.Pair(x,y)) = c in
- match y with
- Mc.NonEqual -> failwith "cannot happen"
- | y -> ((dev_form n_spec x, y),i)) l' in
-
- simple_linear_prover n_spec l'
-
-
-let linear_prover n_spec l =
- try linear_prover n_spec l with
- x -> (print_string (Printexc.to_string x); None)
-
-(* zprover.... *)
-
-(* I need to gather the set of variables --->
- Then go for fold
- Once I have an interval, I need a certificate : 2 other fourier elims.
- (I could probably get the certificate directly
- as it is done in the fourier contrib.)
-*)
-
-let make_linear_system l =
- let l' = List.map fst l in
- let monomials = List.fold_left (fun acc p -> Poly.addition p acc)
- (Poly.constant (Int 0)) l' in
- let monomials = Poly.fold
- (fun mn _ l -> if mn = Monomial.const then l else mn::l) monomials [] in
- (List.map (fun (c,op) ->
- {coeffs = Vect.from_list (List.map (fun mn -> (Poly.get mn c)) monomials) ;
- op = op ;
- cst = minus_num ( (Poly.get Monomial.const c))}) l
- ,monomials)
-
-
-open Interval
-let pplus x y = Mc.PEadd(x,y)
-let pmult x y = Mc.PEmul(x,y)
-let pconst x = Mc.PEc x
-let popp x = Mc.PEopp x
-
-let debug = false
-
-(* keep track of enumerated vectors *)
-let rec mem p x l =
- match l with [] -> false | e::l -> if p x e then true else mem p x l
-
-let rec remove_assoc p x l =
- match l with [] -> [] | e::l -> if p x (fst e) then
- remove_assoc p x l else e::(remove_assoc p x l)
-
-let eq x y = Vect.compare x y = 0
-
-let remove e l = List.fold_left (fun l x -> if eq x e then l else x::l) [] l
-
-
-(* The prover is (probably) incomplete --
- only searching for naive cutting planes *)
-
-let candidates sys =
- let ll = List.fold_right (
- fun (Mc.Pair(e,k)) r ->
- match k with
- | Mc.NonStrict -> (dev_form z_spec e , Ge)::r
- | Mc.Equal -> (dev_form z_spec e , Eq)::r
- (* we already know the bound -- don't compute it again *)
- | _ -> failwith "Cannot happen candidates") sys [] in
-
- let (sys,var_mn) = make_linear_system ll in
- let vars = mapi (fun _ i -> Vect.set i (Int 1) Vect.null) var_mn in
- (List.fold_left (fun l cstr ->
- let gcd = Big_int (Vect.gcd cstr.coeffs) in
- if gcd =/ (Int 1) && cstr.op = Eq
- then l
- else (Vect.mul (Int 1 // gcd) cstr.coeffs)::l) [] sys) @ vars
-
-
-let rec xzlinear_prover planes sys =
- match linear_prover z_spec sys with
- | Some prf -> Some (Mc.RatProof prf)
- | None -> (* find the candidate with the smallest range *)
- (* Grrr - linear_prover is also calling 'make_linear_system' *)
- let ll = List.fold_right (fun (Mc.Pair(e,k)) r -> match k with
- Mc.NonEqual -> r
- | k -> (dev_form z_spec e ,
- match k with
- Mc.NonStrict -> Ge
- | Mc.Equal -> Eq
- | Mc.Strict | Mc.NonEqual -> failwith "Cannot happen") :: r) sys [] in
- let (ll,var) = make_linear_system ll in
- let candidates = List.fold_left (fun acc vect ->
- match Fourier.optimise vect ll with
- | None -> acc
- | Some i ->
-(* Printf.printf "%s in %s\n" (Vect.string vect) (string_of_intrvl i) ; *)
- flush stdout ;
- (vect,i) ::acc) [] planes in
-
- let smallest_interval =
- match List.fold_left (fun (x1,i1) (x2,i2) ->
- if smaller_itv i1 i2
- then (x1,i1) else (x2,i2)) (Vect.null,Itv(None,None)) candidates
- with
- | (x,Itv(Some i, Some j)) -> Some(i,x,j)
- | (x,Point n) -> Some(n,x,n)
- | x -> None (* This might be a cutting plane *)
- in
- match smallest_interval with
- | Some (lb,e,ub) ->
- let (lbn,lbd) =
- (Ml2C.bigint (sub_big_int (numerator lb) unit_big_int),
- Ml2C.bigint (denominator lb)) in
- let (ubn,ubd) =
- (Ml2C.bigint (add_big_int unit_big_int (numerator ub)) ,
- Ml2C.bigint (denominator ub)) in
- let expr = list_to_polynomial var (Vect.to_list e) in
- (match
- (*x <= ub -> x > ub *)
- linear_prover z_spec
- (Mc.Pair(pplus (pmult (pconst ubd) expr) (popp (pconst ubn)),
- Mc.NonStrict) :: sys),
- (* lb <= x -> lb > x *)
- linear_prover z_spec
- (Mc.Pair( pplus (popp (pmult (pconst lbd) expr)) (pconst lbn) ,
- Mc.NonStrict)::sys)
- with
- | Some cub , Some clb ->
- (match zlinear_enum (remove e planes) expr
- (ceiling_num lb) (floor_num ub) sys
- with
- | None -> None
- | Some prf ->
- Some (Mc.EnumProof(Ml2C.q lb,expr,Ml2C.q ub,clb,cub,prf)))
- | _ -> None
- )
- | _ -> None
-and zlinear_enum planes expr clb cub l =
- if clb >/ cub
- then Some Mc.Nil
- else
- let pexpr = pplus (popp (pconst (Ml2C.bigint (numerator clb)))) expr in
- let sys' = (Mc.Pair(pexpr, Mc.Equal))::l in
- (*let enum = *)
- match xzlinear_prover planes sys' with
- | None -> if debug then print_string "zlp?"; None
- | Some prf -> if debug then print_string "zlp!";
- match zlinear_enum planes expr (clb +/ (Int 1)) cub l with
- | None -> None
- | Some prfl -> Some (Mc.Cons(prf,prfl))
-
-let zlinear_prover sys =
- let candidates = candidates sys in
- (* Printf.printf "candidates %d" (List.length candidates) ; *)
- xzlinear_prover candidates sys
-
-open Sos
-
-let rec scale_term t =
- match t with
- | Zero -> unit_big_int , Zero
- | Const n -> (denominator n) , Const (Big_int (numerator n))
- | Var n -> unit_big_int , Var n
- | Inv _ -> failwith "scale_term : not implemented"
- | Opp t -> let s, t = scale_term t in s, Opp t
- | Add(t1,t2) -> let s1,y1 = scale_term t1 and s2,y2 = scale_term t2 in
- let g = gcd_big_int s1 s2 in
- let s1' = div_big_int s1 g in
- let s2' = div_big_int s2 g in
- let e = mult_big_int g (mult_big_int s1' s2') in
- if (compare_big_int e unit_big_int) = 0
- then (unit_big_int, Add (y1,y2))
- else e, Add (Mul(Const (Big_int s2'), y1),
- Mul (Const (Big_int s1'), y2))
- | Sub _ -> failwith "scale term: not implemented"
- | Mul(y,z) -> let s1,y1 = scale_term y and s2,y2 = scale_term z in
- mult_big_int s1 s2 , Mul (y1, y2)
- | Pow(t,n) -> let s,t = scale_term t in
- power_big_int_positive_int s n , Pow(t,n)
- | _ -> failwith "scale_term : not implemented"
-
-let scale_term t =
- let (s,t') = scale_term t in
- s,t'
-
-
-let get_index_of_ith_match f i l =
- let rec get j res l =
- match l with
- | [] -> failwith "bad index"
- | e::l -> if f e
- then
- (if j = i then res else get (j+1) (res+1) l )
- else get j (res+1) l in
- get 0 0 l
-
-
-let rec scale_certificate pos = match pos with
- | Axiom_eq i -> unit_big_int , Axiom_eq i
- | Axiom_le i -> unit_big_int , Axiom_le i
- | Axiom_lt i -> unit_big_int , Axiom_lt i
- | Monoid l -> unit_big_int , Monoid l
- | Rational_eq n -> (denominator n) , Rational_eq (Big_int (numerator n))
- | Rational_le n -> (denominator n) , Rational_le (Big_int (numerator n))
- | Rational_lt n -> (denominator n) , Rational_lt (Big_int (numerator n))
- | Square t -> let s,t' = scale_term t in
- mult_big_int s s , Square t'
- | Eqmul (t, y) -> let s1,y1 = scale_term t and s2,y2 = scale_certificate y in
- mult_big_int s1 s2 , Eqmul (y1,y2)
- | Sum (y, z) -> let s1,y1 = scale_certificate y
- and s2,y2 = scale_certificate z in
- let g = gcd_big_int s1 s2 in
- let s1' = div_big_int s1 g in
- let s2' = div_big_int s2 g in
- mult_big_int g (mult_big_int s1' s2'),
- Sum (Product(Rational_le (Big_int s2'), y1),
- Product (Rational_le (Big_int s1'), y2))
- | Product (y, z) ->
- let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in
- mult_big_int s1 s2 , Product (y1,y2)
-
-
-open Micromega
- let rec term_to_q_expr = function
- | Const n -> PEc (Ml2C.q n)
- | Zero -> PEc ( Ml2C.q (Int 0))
- | Var s -> PEX (Ml2C.index
- (int_of_string (String.sub s 1 (String.length s - 1))))
- | Mul(p1,p2) -> PEmul(term_to_q_expr p1, term_to_q_expr p2)
- | Add(p1,p2) -> PEadd(term_to_q_expr p1, term_to_q_expr p2)
- | Opp p -> PEopp (term_to_q_expr p)
- | Pow(t,n) -> PEpow (term_to_q_expr t,Ml2C.n n)
- | Sub(t1,t2) -> PEsub (term_to_q_expr t1, term_to_q_expr t2)
- | _ -> failwith "term_to_q_expr: not implemented"
-
-let q_cert_of_pos pos =
- let rec _cert_of_pos = function
- Axiom_eq i -> Mc.S_In (Ml2C.nat i)
- | Axiom_le i -> Mc.S_In (Ml2C.nat i)
- | Axiom_lt i -> Mc.S_In (Ml2C.nat i)
- | Monoid l -> Mc.S_Monoid (Ml2C.list Ml2C.nat l)
- | Rational_eq n | Rational_le n | Rational_lt n ->
- if compare_num n (Int 0) = 0 then Mc.S_Z else
- Mc.S_Pos (Ml2C.q n)
- | Square t -> Mc.S_Square (term_to_q_expr t)
- | Eqmul (t, y) -> Mc.S_Ideal(term_to_q_expr t, _cert_of_pos y)
- | Sum (y, z) -> Mc.S_Add (_cert_of_pos y, _cert_of_pos z)
- | Product (y, z) -> Mc.S_Mult (_cert_of_pos y, _cert_of_pos z) in
- simplify_cone q_spec (_cert_of_pos pos)
-
-
- let rec term_to_z_expr = function
- | Const n -> PEc (Ml2C.bigint (big_int_of_num n))
- | Zero -> PEc ( Z0)
- | Var s -> PEX (Ml2C.index
- (int_of_string (String.sub s 1 (String.length s - 1))))
- | Mul(p1,p2) -> PEmul(term_to_z_expr p1, term_to_z_expr p2)
- | Add(p1,p2) -> PEadd(term_to_z_expr p1, term_to_z_expr p2)
- | Opp p -> PEopp (term_to_z_expr p)
- | Pow(t,n) -> PEpow (term_to_z_expr t,Ml2C.n n)
- | Sub(t1,t2) -> PEsub (term_to_z_expr t1, term_to_z_expr t2)
- | _ -> failwith "term_to_z_expr: not implemented"
-
-let z_cert_of_pos pos =
- let s,pos = (scale_certificate pos) in
- let rec _cert_of_pos = function
- Axiom_eq i -> Mc.S_In (Ml2C.nat i)
- | Axiom_le i -> Mc.S_In (Ml2C.nat i)
- | Axiom_lt i -> Mc.S_In (Ml2C.nat i)
- | Monoid l -> Mc.S_Monoid (Ml2C.list Ml2C.nat l)
- | Rational_eq n | Rational_le n | Rational_lt n ->
- if compare_num n (Int 0) = 0 then Mc.S_Z else
- Mc.S_Pos (Ml2C.bigint (big_int_of_num n))
- | Square t -> Mc.S_Square (term_to_z_expr t)
- | Eqmul (t, y) -> Mc.S_Ideal(term_to_z_expr t, _cert_of_pos y)
- | Sum (y, z) -> Mc.S_Add (_cert_of_pos y, _cert_of_pos z)
- | Product (y, z) -> Mc.S_Mult (_cert_of_pos y, _cert_of_pos z) in
- simplify_cone z_spec (_cert_of_pos pos)
-
diff --git a/contrib/micromega/coq_micromega.ml b/contrib/micromega/coq_micromega.ml
deleted file mode 100644
index b4863ffc..00000000
--- a/contrib/micromega/coq_micromega.ml
+++ /dev/null
@@ -1,1286 +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 *)
-(************************************************************************)
-(* *)
-(* Micromega: A reflexive tactic using the Positivstellensatz *)
-(* *)
-(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
-(* *)
-(************************************************************************)
-
-open Mutils
-let debug = false
-
-let time str f x =
- let t0 = (Unix.times()).Unix.tms_utime in
- let res = f x in
- let t1 = (Unix.times()).Unix.tms_utime in
- (*if debug then*) (Printf.printf "time %s %f\n" str (t1 -. t0) ;
- flush stdout);
- res
-
-type ('a,'b) formula =
- | TT
- | FF
- | X of 'b
- | A of 'a * Names.name
- | C of ('a,'b) formula * ('a,'b) formula * Names.name
- | D of ('a,'b) formula * ('a,'b) formula * Names.name
- | N of ('a,'b) formula * Names.name
- | I of ('a,'b) formula * ('a,'b) formula * Names.name
-
-let none = Names.Anonymous
-
-let tag_formula t f =
- match f with
- | A(x,_) -> A(x,t)
- | C(x,y,_) -> C(x,y,t)
- | D(x,y,_) -> D(x,y,t)
- | N(x,_) -> N(x,t)
- | I(x,y,_) -> I(x,y,t)
- | _ -> f
-
-let tt = []
-let ff = [ [] ]
-
-
-type ('constant,'contr) sentence =
- ('constant Micromega.formula, 'contr) formula
-
-let cnf negate normalise f =
- let negate a =
- CoqToCaml.list (fun cl -> CoqToCaml.list (fun x -> x) cl) (negate a) in
-
- let normalise a =
- CoqToCaml.list (fun cl -> CoqToCaml.list (fun x -> x) cl) (normalise a) in
-
- let and_cnf x y = x @ y in
- let or_clause_cnf t f = List.map (fun x -> t@x ) f in
-
- let rec or_cnf f f' =
- match f with
- | [] -> tt
- | e :: rst -> (or_cnf rst f') @ (or_clause_cnf e f') in
-
- let rec xcnf (pol : bool) f =
- match f with
- | TT -> if pol then tt else ff (* ?? *)
- | FF -> if pol then ff else tt (* ?? *)
- | X p -> if pol then ff else ff (* ?? *)
- | A(x,t) -> if pol then normalise x else negate x
- | N(e,t) -> xcnf (not pol) e
- | C(e1,e2,t) ->
- (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2)
- | D(e1,e2,t) ->
- (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2)
- | I(e1,e2,t) ->
- (if pol then or_cnf else and_cnf) (xcnf (not pol) e1) (xcnf pol e2) in
-
- xcnf true f
-
-
-
-module M =
-struct
- open Coqlib
- open Term
- (* let constant = gen_constant_in_modules "Omicron" coq_modules*)
-
-
- let logic_dir = ["Coq";"Logic";"Decidable"]
- let coq_modules =
- init_modules @
- [logic_dir] @ arith_modules @ zarith_base_modules @
- [ ["Coq";"Lists";"List"];
- ["ZMicromega"];
- ["Tauto"];
- ["RingMicromega"];
- ["EnvRing"];
- ["Coq"; "micromega"; "ZMicromega"];
- ["Coq" ; "micromega" ; "Tauto"];
- ["Coq" ; "micromega" ; "RingMicromega"];
- ["Coq" ; "micromega" ; "EnvRing"];
- ["Coq";"QArith"; "QArith_base"];
- ["Coq";"Reals" ; "Rdefinitions"];
- ["Coq";"Reals" ; "Rpow_def"];
- ["LRing_normalise"]]
-
- let constant = gen_constant_in_modules "ZMicromega" coq_modules
-
- let coq_and = lazy (constant "and")
- let coq_or = lazy (constant "or")
- let coq_not = lazy (constant "not")
- let coq_iff = lazy (constant "iff")
- let coq_True = lazy (constant "True")
- let coq_False = lazy (constant "False")
-
- let coq_cons = lazy (constant "cons")
- let coq_nil = lazy (constant "nil")
- let coq_list = lazy (constant "list")
-
- let coq_O = lazy (constant "O")
- let coq_S = lazy (constant "S")
- let coq_nat = lazy (constant "nat")
-
- let coq_NO = lazy
- (gen_constant_in_modules "N" [ ["Coq";"NArith";"BinNat" ]] "N0")
- let coq_Npos = lazy
- (gen_constant_in_modules "N" [ ["Coq";"NArith"; "BinNat"]] "Npos")
- (* let coq_n = lazy (constant "N")*)
-
- let coq_pair = lazy (constant "pair")
- let coq_None = lazy (constant "None")
- let coq_option = lazy (constant "option")
- let coq_positive = lazy (constant "positive")
- let coq_xH = lazy (constant "xH")
- let coq_xO = lazy (constant "xO")
- let coq_xI = lazy (constant "xI")
-
- let coq_N0 = lazy (constant "N0")
- let coq_N0 = lazy (constant "Npos")
-
-
- let coq_Z = lazy (constant "Z")
- let coq_Q = lazy (constant "Q")
- let coq_R = lazy (constant "R")
-
- let coq_ZERO = lazy (constant "Z0")
- let coq_POS = lazy (constant "Zpos")
- let coq_NEG = lazy (constant "Zneg")
-
- let coq_QWitness = lazy
- (gen_constant_in_modules "QMicromega"
- [["Coq"; "micromega"; "QMicromega"]] "QWitness")
- let coq_ZWitness = lazy
- (gen_constant_in_modules "QMicromega"
- [["Coq"; "micromega"; "ZMicromega"]] "ZWitness")
-
-
- let coq_Build_Witness = lazy (constant "Build_Witness")
-
-
- let coq_Qmake = lazy (constant "Qmake")
- let coq_R0 = lazy (constant "R0")
- let coq_R1 = lazy (constant "R1")
-
-
- let coq_proofTerm = lazy (constant "ProofTerm")
- let coq_ratProof = lazy (constant "RatProof")
- let coq_cutProof = lazy (constant "CutProof")
- let coq_enumProof = lazy (constant "EnumProof")
-
- let coq_Zgt = lazy (constant "Zgt")
- let coq_Zge = lazy (constant "Zge")
- let coq_Zle = lazy (constant "Zle")
- let coq_Zlt = lazy (constant "Zlt")
- let coq_Eq = lazy (constant "eq")
-
- let coq_Zplus = lazy (constant "Zplus")
- let coq_Zminus = lazy (constant "Zminus")
- let coq_Zopp = lazy (constant "Zopp")
- let coq_Zmult = lazy (constant "Zmult")
- let coq_Zpower = lazy (constant "Zpower")
- let coq_N_of_Z = lazy
- (gen_constant_in_modules "ZArithRing"
- [["Coq";"setoid_ring";"ZArithRing"]] "N_of_Z")
-
- let coq_Qgt = lazy (constant "Qgt")
- let coq_Qge = lazy (constant "Qge")
- let coq_Qle = lazy (constant "Qle")
- let coq_Qlt = lazy (constant "Qlt")
- let coq_Qeq = lazy (constant "Qeq")
-
-
- let coq_Qplus = lazy (constant "Qplus")
- let coq_Qminus = lazy (constant "Qminus")
- let coq_Qopp = lazy (constant "Qopp")
- let coq_Qmult = lazy (constant "Qmult")
- let coq_Qpower = lazy (constant "Qpower")
-
-
- let coq_Rgt = lazy (constant "Rgt")
- let coq_Rge = lazy (constant "Rge")
- let coq_Rle = lazy (constant "Rle")
- let coq_Rlt = lazy (constant "Rlt")
-
- let coq_Rplus = lazy (constant "Rplus")
- let coq_Rminus = lazy (constant "Rminus")
- let coq_Ropp = lazy (constant "Ropp")
- let coq_Rmult = lazy (constant "Rmult")
- let coq_Rpower = lazy (constant "pow")
-
-
- let coq_PEX = lazy (constant "PEX" )
- let coq_PEc = lazy (constant"PEc")
- let coq_PEadd = lazy (constant "PEadd")
- let coq_PEopp = lazy (constant "PEopp")
- let coq_PEmul = lazy (constant "PEmul")
- let coq_PEsub = lazy (constant "PEsub")
- let coq_PEpow = lazy (constant "PEpow")
-
-
- let coq_OpEq = lazy (constant "OpEq")
- let coq_OpNEq = lazy (constant "OpNEq")
- let coq_OpLe = lazy (constant "OpLe")
- let coq_OpLt = lazy (constant "OpLt")
- let coq_OpGe = lazy (constant "OpGe")
- let coq_OpGt = lazy (constant "OpGt")
-
-
- let coq_S_In = lazy (constant "S_In")
- let coq_S_Square = lazy (constant "S_Square")
- let coq_S_Monoid = lazy (constant "S_Monoid")
- let coq_S_Ideal = lazy (constant "S_Ideal")
- let coq_S_Mult = lazy (constant "S_Mult")
- let coq_S_Add = lazy (constant "S_Add")
- let coq_S_Pos = lazy (constant "S_Pos")
- let coq_S_Z = lazy (constant "S_Z")
- let coq_coneMember = lazy (constant "coneMember")
-
-
- let coq_make_impl = lazy
- (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_impl")
- let coq_make_conj = lazy
- (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_conj")
-
- let coq_Build = lazy
- (gen_constant_in_modules "RingMicromega"
- [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ]
- "Build_Formula")
- let coq_Cstr = lazy
- (gen_constant_in_modules "RingMicromega"
- [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] "Formula")
-
-
- type parse_error =
- | Ukn
- | BadStr of string
- | BadNum of int
- | BadTerm of Term.constr
- | Msg of string
- | Goal of (Term.constr list ) * Term.constr * parse_error
-
- let string_of_error = function
- | Ukn -> "ukn"
- | BadStr s -> s
- | BadNum i -> string_of_int i
- | BadTerm _ -> "BadTerm"
- | Msg s -> s
- | Goal _ -> "Goal"
-
-
- exception ParseError
-
-
-
-
- let get_left_construct term =
- match Term.kind_of_term term with
- | Term.Construct(_,i) -> (i,[| |])
- | Term.App(l,rst) ->
- (match Term.kind_of_term l with
- | Term.Construct(_,i) -> (i,rst)
- | _ -> raise ParseError
- )
- | _ -> raise ParseError
-
- module Mc = Micromega
-
- let rec parse_nat term =
- let (i,c) = get_left_construct term in
- match i with
- | 1 -> Mc.O
- | 2 -> Mc.S (parse_nat (c.(0)))
- | i -> raise ParseError
-
-
- let pp_nat o n = Printf.fprintf o "%i" (CoqToCaml.nat n)
-
-
- let rec dump_nat x =
- match x with
- | Mc.O -> Lazy.force coq_O
- | Mc.S p -> Term.mkApp(Lazy.force coq_S,[| dump_nat p |])
-
-
- let rec parse_positive term =
- let (i,c) = get_left_construct term in
- match i with
- | 1 -> Mc.XI (parse_positive c.(0))
- | 2 -> Mc.XO (parse_positive c.(0))
- | 3 -> Mc.XH
- | i -> raise ParseError
-
-
- let rec dump_positive x =
- match x with
- | Mc.XH -> Lazy.force coq_xH
- | Mc.XO p -> Term.mkApp(Lazy.force coq_xO,[| dump_positive p |])
- | Mc.XI p -> Term.mkApp(Lazy.force coq_xI,[| dump_positive p |])
-
- let pp_positive o x = Printf.fprintf o "%i" (CoqToCaml.positive x)
-
-
- let rec dump_n x =
- match x with
- | Mc.N0 -> Lazy.force coq_N0
- | Mc.Npos p -> Term.mkApp(Lazy.force coq_Npos,[| dump_positive p|])
-
- let rec dump_index x =
- match x with
- | Mc.XH -> Lazy.force coq_xH
- | Mc.XO p -> Term.mkApp(Lazy.force coq_xO,[| dump_index p |])
- | Mc.XI p -> Term.mkApp(Lazy.force coq_xI,[| dump_index p |])
-
-
- let pp_index o x = Printf.fprintf o "%i" (CoqToCaml.index x)
-
- let rec dump_n x =
- match x with
- | Mc.N0 -> Lazy.force coq_NO
- | Mc.Npos p -> Term.mkApp(Lazy.force coq_Npos,[| dump_positive p |])
-
- let rec pp_n o x = output_string o (string_of_int (CoqToCaml.n x))
-
- let dump_pair t1 t2 dump_t1 dump_t2 (Mc.Pair (x,y)) =
- Term.mkApp(Lazy.force coq_pair,[| t1 ; t2 ; dump_t1 x ; dump_t2 y|])
-
-
- let rec parse_z term =
- let (i,c) = get_left_construct term in
- match i with
- | 1 -> Mc.Z0
- | 2 -> Mc.Zpos (parse_positive c.(0))
- | 3 -> Mc.Zneg (parse_positive c.(0))
- | i -> raise ParseError
-
- let dump_z x =
- match x with
- | Mc.Z0 ->Lazy.force coq_ZERO
- | Mc.Zpos p -> Term.mkApp(Lazy.force coq_POS,[| dump_positive p|])
- | Mc.Zneg p -> Term.mkApp(Lazy.force coq_NEG,[| dump_positive p|])
-
- let pp_z o x = Printf.fprintf o "%i" (CoqToCaml.z x)
-
-let dump_num bd1 =
- Term.mkApp(Lazy.force coq_Qmake,
- [|dump_z (CamlToCoq.bigint (numerator bd1)) ;
- dump_positive (CamlToCoq.positive_big_int (denominator bd1)) |])
-
-
-let dump_q q =
- Term.mkApp(Lazy.force coq_Qmake,
- [| dump_z q.Micromega.qnum ; dump_positive q.Micromega.qden|])
-
-let parse_q term =
- match Term.kind_of_term term with
- | Term.App(c, args) -> if c = Lazy.force coq_Qmake then
- {Mc.qnum = parse_z args.(0) ; Mc.qden = parse_positive args.(1) }
- else raise ParseError
- | _ -> raise ParseError
-
-
- let rec parse_list parse_elt term =
- let (i,c) = get_left_construct term in
- match i with
- | 1 -> Mc.Nil
- | 2 -> Mc.Cons(parse_elt c.(1), parse_list parse_elt c.(2))
- | i -> raise ParseError
-
-
- let rec dump_list typ dump_elt l =
- match l with
- | Mc.Nil -> Term.mkApp(Lazy.force coq_nil,[| typ |])
- | Mc.Cons(e,l) -> Term.mkApp(Lazy.force coq_cons,
- [| typ; dump_elt e;dump_list typ dump_elt l|])
-
- let rec dump_ml_list typ dump_elt l =
- match l with
- | [] -> Term.mkApp(Lazy.force coq_nil,[| typ |])
- | e::l -> Term.mkApp(Lazy.force coq_cons,
- [| typ; dump_elt e;dump_ml_list typ dump_elt l|])
-
-
-
- let pp_list op cl elt o l =
- let rec _pp o l =
- match l with
- | Mc.Nil -> ()
- | Mc.Cons(e,Mc.Nil) -> Printf.fprintf o "%a" elt e
- | Mc.Cons(e,l) -> Printf.fprintf o "%a ,%a" elt e _pp l in
- Printf.fprintf o "%s%a%s" op _pp l cl
-
-
-
- let pp_var = pp_positive
- let dump_var = dump_positive
-
- let rec pp_expr o e =
- match e with
- | Mc.PEX n -> Printf.fprintf o "V %a" pp_var n
- | Mc.PEc z -> pp_z o z
- | Mc.PEadd(e1,e2) -> Printf.fprintf o "(%a)+(%a)" pp_expr e1 pp_expr e2
- | Mc.PEmul(e1,e2) -> Printf.fprintf o "%a*(%a)" pp_expr e1 pp_expr e2
- | Mc.PEopp e -> Printf.fprintf o "-(%a)" pp_expr e
- | Mc.PEsub(e1,e2) -> Printf.fprintf o "(%a)-(%a)" pp_expr e1 pp_expr e2
- | Mc.PEpow(e,n) -> Printf.fprintf o "(%a)^(%a)" pp_expr e pp_n n
-
-
- let dump_expr typ dump_z e =
- let rec dump_expr e =
- match e with
- | Mc.PEX n -> mkApp(Lazy.force coq_PEX,[| typ; dump_var n |])
- | Mc.PEc z -> mkApp(Lazy.force coq_PEc,[| typ ; dump_z z |])
- | Mc.PEadd(e1,e2) -> mkApp(Lazy.force coq_PEadd,
- [| typ; dump_expr e1;dump_expr e2|])
- | Mc.PEsub(e1,e2) -> mkApp(Lazy.force coq_PEsub,
- [| typ; dump_expr e1;dump_expr e2|])
- | Mc.PEopp e -> mkApp(Lazy.force coq_PEopp,
- [| typ; dump_expr e|])
- | Mc.PEmul(e1,e2) -> mkApp(Lazy.force coq_PEmul,
- [| typ; dump_expr e1;dump_expr e2|])
- | Mc.PEpow(e,n) -> mkApp(Lazy.force coq_PEpow,
- [| typ; dump_expr e; dump_n n|])
- in
- dump_expr e
-
- let rec dump_monoid l = dump_list (Lazy.force coq_nat) dump_nat l
-
- let rec dump_cone typ dump_z e =
- let z = Lazy.force typ in
- let rec dump_cone e =
- match e with
- | Mc.S_In n -> mkApp(Lazy.force coq_S_In,[| z; dump_nat n |])
- | Mc.S_Ideal(e,c) -> mkApp(Lazy.force coq_S_Ideal,
- [| z; dump_expr z dump_z e ; dump_cone c |])
- | Mc.S_Square e -> mkApp(Lazy.force coq_S_Square,
- [| z;dump_expr z dump_z e|])
- | Mc.S_Monoid l -> mkApp (Lazy.force coq_S_Monoid,
- [|z; dump_monoid l|])
- | Mc.S_Add(e1,e2) -> mkApp(Lazy.force coq_S_Add,
- [| z; dump_cone e1; dump_cone e2|])
- | Mc.S_Mult(e1,e2) -> mkApp(Lazy.force coq_S_Mult,
- [| z; dump_cone e1; dump_cone e2|])
- | Mc.S_Pos p -> mkApp(Lazy.force coq_S_Pos,[| z; dump_z p|])
- | Mc.S_Z -> mkApp( Lazy.force coq_S_Z,[| z|]) in
- dump_cone e
-
-
- let pp_cone pp_z o e =
- let rec pp_cone o e =
- match e with
- | Mc.S_In n ->
- Printf.fprintf o "(S_In %a)%%nat" pp_nat n
- | Mc.S_Ideal(e,c) ->
- Printf.fprintf o "(S_Ideal %a %a)" pp_expr e pp_cone c
- | Mc.S_Square e ->
- Printf.fprintf o "(S_Square %a)" pp_expr e
- | Mc.S_Monoid l ->
- Printf.fprintf o "(S_Monoid %a)" (pp_list "[" "]" pp_nat) l
- | Mc.S_Add(e1,e2) ->
- Printf.fprintf o "(S_Add %a %a)" pp_cone e1 pp_cone e2
- | Mc.S_Mult(e1,e2) ->
- Printf.fprintf o "(S_Mult %a %a)" pp_cone e1 pp_cone e2
- | Mc.S_Pos p ->
- Printf.fprintf o "(S_Pos %a)%%positive" pp_z p
- | Mc.S_Z ->
- Printf.fprintf o "S_Z" in
- pp_cone o e
-
-
- let rec dump_op = function
- | Mc.OpEq-> Lazy.force coq_OpEq
- | Mc.OpNEq-> Lazy.force coq_OpNEq
- | Mc.OpLe -> Lazy.force coq_OpLe
- | Mc.OpGe -> Lazy.force coq_OpGe
- | Mc.OpGt-> Lazy.force coq_OpGt
- | Mc.OpLt-> Lazy.force coq_OpLt
-
-
-
- let pp_op o e=
- match e with
- | Mc.OpEq-> Printf.fprintf o "="
- | Mc.OpNEq-> Printf.fprintf o "<>"
- | Mc.OpLe -> Printf.fprintf o "=<"
- | Mc.OpGe -> Printf.fprintf o ">="
- | Mc.OpGt-> Printf.fprintf o ">"
- | Mc.OpLt-> Printf.fprintf o "<"
-
-
-
-
- let pp_cstr o {Mc.flhs = l ; Mc.fop = op ; Mc.frhs = r } =
- Printf.fprintf o"(%a %a %a)" pp_expr l pp_op op pp_expr r
-
- let dump_cstr typ dump_constant {Mc.flhs = e1 ; Mc.fop = o ; Mc.frhs = e2} =
- Term.mkApp(Lazy.force coq_Build,
- [| typ; dump_expr typ dump_constant e1 ;
- dump_op o ;
- dump_expr typ dump_constant e2|])
-
- let assoc_const x l =
- try
- snd (List.find (fun (x',y) -> x = Lazy.force x') l)
- with
- Not_found -> raise ParseError
-
- let zop_table = [
- coq_Zgt, Mc.OpGt ;
- coq_Zge, Mc.OpGe ;
- coq_Zlt, Mc.OpLt ;
- coq_Zle, Mc.OpLe ]
-
- let rop_table = [
- coq_Rgt, Mc.OpGt ;
- coq_Rge, Mc.OpGe ;
- coq_Rlt, Mc.OpLt ;
- coq_Rle, Mc.OpLe ]
-
- let qop_table = [
- coq_Qlt, Mc.OpLt ;
- coq_Qle, Mc.OpLe ;
- coq_Qeq, Mc.OpEq
- ]
-
-
- let parse_zop (op,args) =
- match kind_of_term op with
- | Const x -> (assoc_const op zop_table, args.(0) , args.(1))
- | Ind(n,0) ->
- if op = Lazy.force coq_Eq && args.(0) = Lazy.force coq_Z
- then (Mc.OpEq, args.(1), args.(2))
- else raise ParseError
- | _ -> failwith "parse_zop"
-
-
- let parse_rop (op,args) =
- match kind_of_term op with
- | Const x -> (assoc_const op rop_table, args.(0) , args.(1))
- | Ind(n,0) ->
- if op = Lazy.force coq_Eq && args.(0) = Lazy.force coq_R
- then (Mc.OpEq, args.(1), args.(2))
- else raise ParseError
- | _ -> failwith "parse_zop"
-
- let parse_qop (op,args) =
- (assoc_const op qop_table, args.(0) , args.(1))
-
-
- module Env =
- struct
- type t = constr list
-
- let compute_rank_add env v =
- let rec _add env n v =
- match env with
- | [] -> ([v],n)
- | e::l ->
- if eq_constr e v
- then (env,n)
- else
- let (env,n) = _add l ( n+1) v in
- (e::env,n) in
- let (env, n) = _add env 1 v in
- (env, CamlToCoq.idx n)
-
-
- let empty = []
-
- let elements env = env
-
- end
-
-
- let is_constant t = (* This is an approx *)
- match kind_of_term t with
- | Construct(i,_) -> true
- | _ -> false
-
-
- type 'a op =
- | Binop of ('a Mc.pExpr -> 'a Mc.pExpr -> 'a Mc.pExpr)
- | Opp
- | Power
- | Ukn of string
-
-
- let assoc_ops x l =
- try
- snd (List.find (fun (x',y) -> x = Lazy.force x') l)
- with
- Not_found -> Ukn "Oups"
-
-
-
- let parse_expr parse_constant parse_exp ops_spec env term =
- if debug
- then (Pp.pp (Pp.str "parse_expr: ");
- Pp.pp_flush ();Pp.pp (Printer.prterm term); Pp.pp_flush ());
-
- let constant_or_variable env term =
- try
- ( Mc.PEc (parse_constant term) , env)
- with ParseError ->
- let (env,n) = Env.compute_rank_add env term in
- (Mc.PEX n , env) in
-
- let rec parse_expr env term =
- let combine env op (t1,t2) =
- let (expr1,env) = parse_expr env t1 in
- let (expr2,env) = parse_expr env t2 in
- (op expr1 expr2,env) in
- match kind_of_term term with
- | App(t,args) ->
- (
- match kind_of_term t with
- | Const c ->
- ( match assoc_ops t ops_spec with
- | Binop f -> combine env f (args.(0),args.(1))
- | Opp -> let (expr,env) = parse_expr env args.(0) in
- (Mc.PEopp expr, env)
- | Power ->
- let (expr,env) = parse_expr env args.(0) in
- let exp = (parse_exp args.(1)) in
- (Mc.PEpow(expr, exp) , env)
- | Ukn s ->
- if debug
- then (Printf.printf "unknown op: %s\n" s; flush stdout;);
- let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env)
- )
- | _ -> constant_or_variable env term
- )
- | _ -> constant_or_variable env term in
- parse_expr env term
-
-
- let zop_spec =
- [
- coq_Zplus , Binop (fun x y -> Mc.PEadd(x,y)) ;
- coq_Zminus , Binop (fun x y -> Mc.PEsub(x,y)) ;
- coq_Zmult , Binop (fun x y -> Mc.PEmul (x,y)) ;
- coq_Zopp , Opp ;
- coq_Zpower , Power]
-
-let qop_spec =
- [
- coq_Qplus , Binop (fun x y -> Mc.PEadd(x,y)) ;
- coq_Qminus , Binop (fun x y -> Mc.PEsub(x,y)) ;
- coq_Qmult , Binop (fun x y -> Mc.PEmul (x,y)) ;
- coq_Qopp , Opp ;
- coq_Qpower , Power]
-
-let rop_spec =
- [
- coq_Rplus , Binop (fun x y -> Mc.PEadd(x,y)) ;
- coq_Rminus , Binop (fun x y -> Mc.PEsub(x,y)) ;
- coq_Rmult , Binop (fun x y -> Mc.PEmul (x,y)) ;
- coq_Ropp , Opp ;
- coq_Rpower , Power]
-
-
-
-
-
-let zconstant = parse_z
-let qconstant = parse_q
-
-
-let rconstant term =
- if debug
- then (Pp.pp_flush ();
- Pp.pp (Pp.str "rconstant: ");
- Pp.pp (Printer.prterm term); Pp.pp_flush ());
- match Term.kind_of_term term with
- | Const x ->
- if term = Lazy.force coq_R0
- then Mc.Z0
- else if term = Lazy.force coq_R1
- then Mc.Zpos Mc.XH
- else raise ParseError
- | _ -> raise ParseError
-
-
-let parse_zexpr =
- parse_expr zconstant (fun x -> Mc.n_of_Z (parse_z x)) zop_spec
-let parse_qexpr =
- parse_expr qconstant (fun x -> Mc.n_of_Z (parse_z x)) qop_spec
-let parse_rexpr =
- parse_expr rconstant (fun x -> Mc.n_of_nat (parse_nat x)) rop_spec
-
-
- let parse_arith parse_op parse_expr env cstr =
- if debug
- then (Pp.pp_flush ();
- Pp.pp (Pp.str "parse_arith: ");
- Pp.pp (Printer.prterm cstr);
- Pp.pp_flush ());
- match kind_of_term cstr with
- | App(op,args) ->
- let (op,lhs,rhs) = parse_op (op,args) in
- let (e1,env) = parse_expr env lhs in
- let (e2,env) = parse_expr env rhs in
- ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env)
- | _ -> failwith "error : parse_arith(2)"
-
- let parse_zarith = parse_arith parse_zop parse_zexpr
-
- let parse_qarith = parse_arith parse_qop parse_qexpr
-
- let parse_rarith = parse_arith parse_rop parse_rexpr
-
-
- (* generic parsing of arithmetic expressions *)
-
-
-
-
- let rec f2f = function
- | TT -> Mc.TT
- | FF -> Mc.FF
- | X _ -> Mc.X
- | A (x,_) -> Mc.A x
- | C (a,b,_) -> Mc.Cj(f2f a,f2f b)
- | D (a,b,_) -> Mc.D(f2f a,f2f b)
- | N (a,_) -> Mc.N(f2f a)
- | I(a,b,_) -> Mc.I(f2f a,f2f b)
-
- let is_prop t =
- match t with
- | Names.Anonymous -> true (* Not quite right *)
- | Names.Name x -> false
-
- let mkC f1 f2 = C(f1,f2,none)
- let mkD f1 f2 = D(f1,f2,none)
- let mkIff f1 f2 = C(I(f1,f2,none),I(f2,f2,none),none)
- let mkI f1 f2 = I(f1,f2,none)
-
- let mkformula_binary g term f1 f2 =
- match f1 , f2 with
- | X _ , X _ -> X(term)
- | _ -> g f1 f2
-
- let parse_formula parse_atom env term =
- let parse_atom env t = try let (at,env) = parse_atom env t in (A(at,none), env) with _ -> (X(t),env) in
-
- let rec xparse_formula env term =
- match kind_of_term term with
- | App(l,rst) ->
- (match rst with
- | [|a;b|] when l = Lazy.force coq_and ->
- let f,env = xparse_formula env a in
- let g,env = xparse_formula env b in
- mkformula_binary mkC term f g,env
- | [|a;b|] when l = Lazy.force coq_or ->
- let f,env = xparse_formula env a in
- let g,env = xparse_formula env b in
- mkformula_binary mkD term f g,env
- | [|a|] when l = Lazy.force coq_not ->
- let (f,env) = xparse_formula env a in (N(f,none), env)
- | [|a;b|] when l = Lazy.force coq_iff ->
- let f,env = xparse_formula env a in
- let g,env = xparse_formula env b in
- mkformula_binary mkIff term f g,env
- | _ -> parse_atom env term)
- | Prod(typ,a,b) when not (Termops.dependent (mkRel 1) b) ->
- let f,env = xparse_formula env a in
- let g,env = xparse_formula env b in
- mkformula_binary mkI term f g,env
- | _ when term = Lazy.force coq_True -> (TT,env)
- | _ when term = Lazy.force coq_False -> (FF,env)
- | _ -> X(term),env in
- xparse_formula env term
-
- let coq_TT = lazy
- (gen_constant_in_modules "ZMicromega"
- [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "TT")
- let coq_FF = lazy
- (gen_constant_in_modules "ZMicromega"
- [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "FF")
- let coq_And = lazy
- (gen_constant_in_modules "ZMicromega"
- [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "Cj")
- let coq_Or = lazy
- (gen_constant_in_modules "ZMicromega"
- [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "D")
- let coq_Neg = lazy
- (gen_constant_in_modules "ZMicromega"
- [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "N")
- let coq_Atom = lazy
- (gen_constant_in_modules "ZMicromega"
- [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "A")
- let coq_X = lazy
- (gen_constant_in_modules "ZMicromega"
- [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "X")
- let coq_Impl = lazy
- (gen_constant_in_modules "ZMicromega"
- [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "I")
- let coq_Formula = lazy
- (gen_constant_in_modules "ZMicromega"
- [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "BFormula")
-
- let dump_formula typ dump_atom f =
- let rec xdump f =
- match f with
- | TT -> mkApp(Lazy.force coq_TT,[| typ|])
- | FF -> mkApp(Lazy.force coq_FF,[| typ|])
- | C(x,y,_) -> mkApp(Lazy.force coq_And,[| typ ; xdump x ; xdump y|])
- | D(x,y,_) -> mkApp(Lazy.force coq_Or,[| typ ; xdump x ; xdump y|])
- | I(x,y,_) -> mkApp(Lazy.force coq_Impl,[| typ ; xdump x ; xdump y|])
- | N(x,_) -> mkApp(Lazy.force coq_Neg,[| typ ; xdump x|])
- | A(x,_) -> mkApp(Lazy.force coq_Atom,[| typ ; dump_atom x|])
- | X(t) -> mkApp(Lazy.force coq_X,[| typ ; t|]) in
-
- xdump f
-
-
-
-
- (* ! reverse the list of bindings *)
- let set l concl =
- let rec _set acc = function
- | [] -> acc
- | (e::l) ->
- let (name,expr,typ) = e in
- _set (Term.mkNamedLetIn
- (Names.id_of_string name)
- expr typ acc) l in
- _set concl l
-
-
-end
-
-open M
-
-
-let rec sig_of_cone = function
- | Mc.S_In n -> [CoqToCaml.nat n]
- | Mc.S_Ideal(e,w) -> sig_of_cone w
- | Mc.S_Mult(w1,w2) ->
- (sig_of_cone w1)@(sig_of_cone w2)
- | Mc.S_Add(w1,w2) -> (sig_of_cone w1)@(sig_of_cone w2)
- | _ -> []
-
-let same_proof sg cl1 cl2 =
- let cl1 = CoqToCaml.list (fun x -> x) cl1 in
- let cl2 = CoqToCaml.list (fun x -> x) cl2 in
- let rec xsame_proof sg =
- match sg with
- | [] -> true
- | n::sg -> (try List.nth cl1 n = List.nth cl2 n with _ -> false)
- && (xsame_proof sg ) in
- xsame_proof sg
-
-
-
-
-let tags_of_clause tgs wit clause =
- let rec xtags tgs = function
- | Mc.S_In n -> Names.Idset.union tgs
- (snd (List.nth clause (CoqToCaml.nat n) ))
- | Mc.S_Ideal(e,w) -> xtags tgs w
- | Mc.S_Mult (w1,w2) | Mc.S_Add(w1,w2) -> xtags (xtags tgs w1) w2
- | _ -> tgs in
- xtags tgs wit
-
-let tags_of_cnf wits cnf =
- List.fold_left2 (fun acc w cl -> tags_of_clause acc w cl)
- Names.Idset.empty wits cnf
-
-
-let find_witness prover polys1 =
- let l = CoqToCaml.list (fun x -> x) polys1 in
- try_any prover l
-
-let rec witness prover l1 l2 =
- match l2 with
- | Micromega.Nil -> Some (Micromega.Nil)
- | Micromega.Cons(e,l2) ->
- match find_witness prover (Micromega.Cons( e,l1)) with
- | None -> None
- | Some w ->
- (match witness prover l1 l2 with
- | None -> None
- | Some l -> Some (Micromega.Cons (w,l))
- )
-
-
-let rec apply_ids t ids =
- match ids with
- | [] -> t
- | i::ids -> apply_ids (Term.mkApp(t,[| Term.mkVar i |])) ids
-
-
-let coq_Node = lazy
- (Coqlib.gen_constant_in_modules "VarMap"
- [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node")
-let coq_Leaf = lazy
- (Coqlib.gen_constant_in_modules "VarMap"
- [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Leaf")
-let coq_Empty = lazy
- (Coqlib.gen_constant_in_modules "VarMap"
- [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty")
-
-
-let btree_of_array typ a =
- let size_of_a = Array.length a in
- let semi_size_of_a = size_of_a lsr 1 in
- let node = Lazy.force coq_Node
- and leaf = Lazy.force coq_Leaf
- and empty = Term.mkApp (Lazy.force coq_Empty, [| typ |]) in
- let rec aux n =
- if n > size_of_a
- then empty
- else if n > semi_size_of_a
- then Term.mkApp (leaf, [| typ; a.(n-1) |])
- else Term.mkApp (node, [| typ; aux (2*n); a.(n-1); aux (2*n+1) |])
- in
- aux 1
-
-let btree_of_array typ a =
- try
- btree_of_array typ a
- with x ->
- failwith (Printf.sprintf "btree of array : %s" (Printexc.to_string x))
-
-let dump_varmap typ env =
- btree_of_array typ (Array.of_list env)
-
-
-let rec pp_varmap o vm =
- match vm with
- | Mc.Empty -> output_string o "[]"
- | Mc.Leaf z -> Printf.fprintf o "[%a]" pp_z z
- | Mc.Node(l,z,r) -> Printf.fprintf o "[%a, %a, %a]" pp_varmap l pp_z z pp_varmap r
-
-
-
-let rec dump_proof_term = function
- | Micromega.RatProof cone ->
- Term.mkApp(Lazy.force coq_ratProof, [|dump_cone coq_Z dump_z cone|])
- | Micromega.CutProof(e,q,cone,prf) ->
- Term.mkApp(Lazy.force coq_cutProof,
- [| dump_expr (Lazy.force coq_Z) dump_z e ;
- dump_q q ;
- dump_cone coq_Z dump_z cone ;
- dump_proof_term prf|])
- | Micromega.EnumProof( q1,e1,q2,c1,c2,prfs) ->
- Term.mkApp (Lazy.force coq_enumProof,
- [| dump_q q1 ; dump_expr (Lazy.force coq_Z) dump_z e1 ; dump_q q2;
- dump_cone coq_Z dump_z c1 ; dump_cone coq_Z dump_z c2 ;
- dump_list (Lazy.force coq_proofTerm) dump_proof_term prfs |])
-
-let pp_q o q = Printf.fprintf o "%a/%a" pp_z q.Micromega.qnum pp_positive q.Micromega.qden
-
-
-let rec pp_proof_term o = function
- | Micromega.RatProof cone -> Printf.fprintf o "R[%a]" (pp_cone pp_z) cone
- | Micromega.CutProof(e,q,_,p) -> failwith "not implemented"
- | Micromega.EnumProof(q1,e1,q2,c1,c2,rst) ->
- Printf.fprintf o "EP[%a,%a,%a,%a,%a,%a]"
- pp_q q1 pp_expr e1 pp_q q2 (pp_cone pp_z) c1 (pp_cone pp_z) c2
- (pp_list "[" "]" pp_proof_term) rst
-
-let rec parse_hyps parse_arith env hyps =
- match hyps with
- | [] -> ([],env)
- | (i,t)::l ->
- let (lhyps,env) = parse_hyps parse_arith env l in
- try
- let (c,env) = parse_formula parse_arith env t in
- ((i,c)::lhyps, env)
- with _ -> (lhyps,env)
- (*(if debug then Printf.printf "parse_arith : %s\n" x);*)
-
-
-exception ParseError
-
-let parse_goal parse_arith env hyps term =
- (* try*)
- let (f,env) = parse_formula parse_arith env term in
- let (lhyps,env) = parse_hyps parse_arith env hyps in
- (lhyps,f,env)
- (* with Failure x -> raise ParseError*)
-
-
-type ('a, 'b) domain_spec = {
- typ : Term.constr; (* Z, Q , R *)
- coeff : Term.constr ; (* Z, Q *)
- dump_coeff : 'a -> Term.constr ;
- proof_typ : Term.constr ;
- dump_proof : 'b -> Term.constr
-}
-
-let zz_domain_spec = lazy {
- typ = Lazy.force coq_Z;
- coeff = Lazy.force coq_Z;
- dump_coeff = dump_z ;
- proof_typ = Lazy.force coq_proofTerm ;
- dump_proof = dump_proof_term
-}
-
-let qq_domain_spec = lazy {
- typ = Lazy.force coq_Q;
- coeff = Lazy.force coq_Q;
- dump_coeff = dump_q ;
- proof_typ = Lazy.force coq_QWitness ;
- dump_proof = dump_cone coq_Q dump_q
-}
-
-let rz_domain_spec = lazy {
- typ = Lazy.force coq_R;
- coeff = Lazy.force coq_Z;
- dump_coeff = dump_z;
- proof_typ = Lazy.force coq_ZWitness ;
- dump_proof = dump_cone coq_Z dump_z
-}
-
-
-
-
-let micromega_order_change spec cert cert_typ env ff gl =
- let formula_typ = (Term.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in
-
- let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in
- let vm = dump_varmap ( spec.typ) env in
- Tactics.change_in_concl None
- (set
- [
- ("__ff", ff, Term.mkApp(Lazy.force coq_Formula ,[| formula_typ |]));
- ("__varmap", vm , Term.mkApp
- (Coqlib.gen_constant_in_modules "VarMap"
- [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "t", [| spec.typ|]));
- ("__wit", cert,cert_typ)
- ]
- (Tacmach.pf_concl gl )
-
- )
- gl
-
-
-let detect_duplicates cnf wit =
- let cnf = CoqToCaml.list (fun x -> x) cnf in
- let wit = CoqToCaml.list (fun x -> x) wit in
-
- let rec xdup cnf wit =
- match wit with
- | [] -> []
- | w :: wit ->
- let sg = sig_of_cone w in
- match cnf with
- | [] -> []
- | e::cnf ->
- let (dups,cnf) = (List.partition (fun x -> same_proof sg e x) cnf) in
- dups@(xdup cnf wit) in
- xdup cnf wit
-
-let find_witness prover polys1 =
- try_any prover polys1
-
-
-let witness_list_with_tags prover l =
-
- let rec xwitness_list l =
- match l with
- | [] -> Some([])
- | e::l ->
- match find_witness prover (List.map fst e) with
- | None -> None
- | Some w ->
- (match xwitness_list l with
- | None -> None
- | Some l -> Some (w::l)
- ) in
- xwitness_list l
-
-let witness_list_without_tags prover l =
-
- let rec xwitness_list l =
- match l with
- | [] -> Some([])
- | e::l ->
- match find_witness prover e with
- | None -> None
- | Some w ->
- (match xwitness_list l with
- | None -> None
- | Some l -> Some (w::l)
- ) in
- xwitness_list l
-
-let witness_list prover l =
- let rec xwitness_list l =
- match l with
- | Micromega.Nil -> Some(Micromega.Nil)
- | Micromega.Cons(e,l) ->
- match find_witness prover e with
- | None -> None
- | Some w ->
- (match xwitness_list l with
- | None -> None
- | Some l -> Some (Micromega.Cons(w,l))
- ) in
- xwitness_list l
-
-
-
-
-let is_singleton = function [] -> true | [e] -> true | _ -> false
-
-
-let micromega_tauto negate normalise spec prover env polys1 polys2 gl =
- let spec = Lazy.force spec in
- let (ff,ids) =
- List.fold_right
- (fun (id,f) (cc,ids) ->
- match f with
- X _ -> (cc,ids)
- | _ -> (I(tag_formula (Names.Name id) f,cc,none), id::ids))
- polys1 (polys2,[]) in
-
- let cnf_ff = cnf negate normalise ff in
-
- if debug then
- (Pp.pp (Pp.str "Formula....\n") ;
- let formula_typ = (Term.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in
- let ff = dump_formula formula_typ
- (dump_cstr spec.typ spec.dump_coeff) ff in
- Pp.pp (Printer.prterm ff) ; Pp.pp_flush ()) ;
-
- match witness_list_without_tags prover cnf_ff with
- | None -> Tacticals.tclFAIL 0 (Pp.str "Cannot find witness") gl
- | Some res -> (*Printf.printf "\nList %i" (List.length res); *)
- let (ff,res,ids) = (ff,res,List.map Term.mkVar ids) in
- let res' = dump_ml_list (spec.proof_typ) spec.dump_proof res in
- (Tacticals.tclTHENSEQ
- [
- Tactics.generalize ids;
- micromega_order_change spec res'
- (Term.mkApp(Lazy.force coq_list,[| spec.proof_typ|])) env ff ;
- ]) gl
-
-
-let micromega_gen parse_arith negate normalise spec prover gl =
- let concl = Tacmach.pf_concl gl in
- let hyps = Tacmach.pf_hyps_types gl in
- try
- let (hyps,concl,env) = parse_goal parse_arith Env.empty hyps concl in
- let env = Env.elements env in
- micromega_tauto negate normalise spec prover env hyps concl gl
- with
- | Failure x -> flush stdout ; Pp.pp_flush () ;
- Tacticals.tclFAIL 0 (Pp.str x) gl
- | ParseError -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl
-
-
-let lift_ratproof prover l =
- match prover l with
- | None -> None
- | Some c -> Some (Mc.RatProof c)
-
-
-type csdpcert = Sos.positivstellensatz option
-type micromega_polys = (Micromega.q Mc.pExpr, Mc.op1) Micromega.prod list
-type provername = string * int option
-
-let call_csdpcert provername poly =
- let tmp_to,ch_to = Filename.open_temp_file "csdpcert" ".in" in
- let tmp_from = Filename.temp_file "csdpcert" ".out" in
- output_value ch_to (provername,poly : provername * micromega_polys);
- close_out ch_to;
- let cmdname =
- List.fold_left Filename.concat (Envars.coqlib ())
- ["contrib"; "micromega"; "csdpcert" ^ Coq_config.exec_extension] in
- let c = Sys.command (cmdname ^" "^ tmp_to ^" "^ tmp_from) in
- (try Sys.remove tmp_to with _ -> ());
- if c <> 0 then Util.error ("Failed to call csdp certificate generator");
- let ch_from = open_in tmp_from in
- let cert = (input_value ch_from : csdpcert) in
- close_in ch_from; Sys.remove tmp_from;
- cert
-
-let rec z_to_q_expr e =
- match e with
- | Mc.PEc z -> Mc.PEc {Mc.qnum = z ; Mc.qden = Mc.XH}
- | Mc.PEX x -> Mc.PEX x
- | Mc.PEadd(e1,e2) -> Mc.PEadd(z_to_q_expr e1, z_to_q_expr e2)
- | Mc.PEsub(e1,e2) -> Mc.PEsub(z_to_q_expr e1, z_to_q_expr e2)
- | Mc.PEmul(e1,e2) -> Mc.PEmul(z_to_q_expr e1, z_to_q_expr e2)
- | Mc.PEopp(e) -> Mc.PEopp(z_to_q_expr e)
- | Mc.PEpow(e,n) -> Mc.PEpow(z_to_q_expr e,n)
-
-
-let call_csdpcert_q provername poly =
- match call_csdpcert provername poly with
- | None -> None
- | Some cert ->
- let cert = Certificate.q_cert_of_pos cert in
- match Mc.qWeakChecker (CamlToCoq.list (fun x -> x) poly) cert with
- | Mc.True -> Some cert
- | Mc.False -> (print_string "buggy certificate" ; flush stdout) ;None
-
-
-let call_csdpcert_z provername poly =
- let l = List.map (fun (Mc.Pair(e,o)) -> (Mc.Pair(z_to_q_expr e,o))) poly in
- match call_csdpcert provername l with
- | None -> None
- | Some cert ->
- let cert = Certificate.z_cert_of_pos cert in
- match Mc.zWeakChecker (CamlToCoq.list (fun x -> x) poly) cert with
- | Mc.True -> Some cert
- | Mc.False -> (print_string "buggy certificate" ; flush stdout) ;None
-
-
-
-
-let psatzl_Z gl =
- micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec
- [lift_ratproof
- (Certificate.linear_prover Certificate.z_spec), "fourier refutation" ] gl
-
-
-let psatzl_Q gl =
- micromega_gen parse_qarith Mc.cnf_negate Mc.cnf_normalise qq_domain_spec
- [ Certificate.linear_prover Certificate.q_spec, "fourier refutation" ] gl
-
-let psatz_Q i gl =
- micromega_gen parse_qarith Mc.cnf_negate Mc.cnf_normalise qq_domain_spec
- [ call_csdpcert_q ("real_nonlinear_prover", Some i), "fourier refutation" ] gl
-
-let psatzl_R gl =
- micromega_gen parse_rarith Mc.cnf_negate Mc.cnf_normalise rz_domain_spec
- [ Certificate.linear_prover Certificate.z_spec, "fourier refutation" ] gl
-
-
-let psatz_R i gl =
- micromega_gen parse_rarith Mc.cnf_negate Mc.cnf_normalise rz_domain_spec
- [ call_csdpcert_z ("real_nonlinear_prover", Some i), "fourier refutation" ] gl
-
-
-let psatz_Z i gl =
- micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec
- [lift_ratproof (call_csdpcert_z ("real_nonlinear_prover",Some i)),
- "fourier refutation" ] gl
-
-
-let sos_Z gl =
- micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec
- [lift_ratproof (call_csdpcert_z ("pure_sos", None)), "pure sos refutation"] gl
-
-let sos_Q gl =
- micromega_gen parse_qarith Mc.cnf_negate Mc.cnf_normalise qq_domain_spec
- [call_csdpcert_q ("pure_sos", None), "pure sos refutation"] gl
-
-let sos_R gl =
- micromega_gen parse_rarith Mc.cnf_negate Mc.cnf_normalise rz_domain_spec
- [call_csdpcert_z ("pure_sos", None), "pure sos refutation"] gl
-
-
-
-let xlia gl =
- micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec
- [Certificate.zlinear_prover, "zprover"] gl
diff --git a/contrib/micromega/csdpcert.ml b/contrib/micromega/csdpcert.ml
deleted file mode 100644
index e451a38f..00000000
--- a/contrib/micromega/csdpcert.ml
+++ /dev/null
@@ -1,197 +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 *)
-(************************************************************************)
-(* *)
-(* Micromega: A reflexive tactic using the Positivstellensatz *)
-(* *)
-(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
-(* *)
-(************************************************************************)
-
-open Big_int
-open Num
-open Sos
-
-module Mc = Micromega
-module Ml2C = Mutils.CamlToCoq
-module C2Ml = Mutils.CoqToCaml
-
-let debug = false
-
-module M =
-struct
- open Mc
-
- let rec expr_to_term = function
- | PEc z -> Const (C2Ml.q_to_num z)
- | PEX v -> Var ("x"^(string_of_int (C2Ml.index v)))
- | PEmul(p1,p2) ->
- let p1 = expr_to_term p1 in
- let p2 = expr_to_term p2 in
- let res = Mul(p1,p2) in res
-
- | PEadd(p1,p2) -> Add(expr_to_term p1, expr_to_term p2)
- | PEsub(p1,p2) -> Sub(expr_to_term p1, expr_to_term p2)
- | PEpow(p,n) -> Pow(expr_to_term p , C2Ml.n n)
- | PEopp p -> Opp (expr_to_term p)
-
-
-
-
-(* let term_to_expr e =
- let e' = term_to_expr e in
- if debug
- then Printf.printf "term_to_expr : %s - %s\n"
- (string_of_poly (poly_of_term e))
- (string_of_poly (poly_of_term (expr_to_term e')));
- e' *)
-
-end
-open M
-
-open List
-open Mutils
-
-
-
-
-let rec canonical_sum_to_string = function s -> failwith "not implemented"
-
-let print_canonical_sum m = Format.print_string (canonical_sum_to_string m)
-
-let print_list_term l =
- print_string "print_list_term\n";
- List.iter (fun (Mc.Pair(e,k)) -> Printf.printf "q: %s %s ;"
- (string_of_poly (poly_of_term (expr_to_term e)))
- (match k with
- Mc.Equal -> "= "
- | Mc.Strict -> "> "
- | Mc.NonStrict -> ">= "
- | _ -> failwith "not_implemented")) l ;
- print_string "\n"
-
-
-let partition_expr l =
- let rec f i = function
- | [] -> ([],[],[])
- | Mc.Pair(e,k)::l ->
- let (eq,ge,neq) = f (i+1) l in
- match k with
- | Mc.Equal -> ((e,i)::eq,ge,neq)
- | Mc.NonStrict -> (eq,(e,Axiom_le i)::ge,neq)
- | Mc.Strict -> (* e > 0 == e >= 0 /\ e <> 0 *)
- (eq, (e,Axiom_lt i)::ge,(e,Axiom_lt i)::neq)
- | Mc.NonEqual -> (eq,ge,(e,Axiom_eq i)::neq)
- (* Not quite sure -- Coq interface has changed *)
- in f 0 l
-
-
-let rec sets_of_list l =
- match l with
- | [] -> [[]]
- | e::l -> let s = sets_of_list l in
- s@(List.map (fun s0 -> e::s0) s)
-
-(* The exploration is probably not complete - for simple cases, it works... *)
-let real_nonlinear_prover d l =
- try
- let (eq,ge,neq) = partition_expr l in
-
- let rec elim_const = function
- [] -> []
- | (x,y)::l -> let p = poly_of_term (expr_to_term x) in
- if poly_isconst p
- then elim_const l
- else (p,y)::(elim_const l) in
-
- let eq = elim_const eq in
- let peq = List.map fst eq in
-
- let pge = List.map
- (fun (e,psatz) -> poly_of_term (expr_to_term e),psatz) ge in
-
- let monoids = List.map (fun m -> (List.fold_right (fun (p,kd) y ->
- let p = poly_of_term (expr_to_term p) in
- match kd with
- | Axiom_lt i -> poly_mul p y
- | Axiom_eq i -> poly_mul (poly_pow p 2) y
- | _ -> failwith "monoids") m (poly_const (Int 1)) , map snd m))
- (sets_of_list neq) in
-
- let (cert_ideal, cert_cone,monoid) = deepen_until d (fun d ->
- list_try_find (fun m -> let (ci,cc) =
- real_positivnullstellensatz_general false d peq pge (poly_neg (fst m) ) in
- (ci,cc,snd m)) monoids) 0 in
-
- let proofs_ideal = map2 (fun q i -> Eqmul(term_of_poly q,Axiom_eq i))
- cert_ideal (List.map snd eq) in
-
- let proofs_cone = map term_of_sos cert_cone in
-
- let proof_ne =
- let (neq , lt) = List.partition
- (function Axiom_eq _ -> true | _ -> false ) monoid in
- let sq = match
- (List.map (function Axiom_eq i -> i | _ -> failwith "error") neq)
- with
- | [] -> Rational_lt (Int 1)
- | l -> Monoid l in
- List.fold_right (fun x y -> Product(x,y)) lt sq in
-
- let proof = list_fold_right_elements
- (fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in
- Some proof
- with
- | Sos.TooDeep -> None
-
-
-(* This is somewhat buggy, over Z, strict inequality vanish... *)
-let pure_sos l =
- (* If there is no strict inequality,
- I should nonetheless be able to try something - over Z > is equivalent to -1 >= *)
- try
- let l = List.combine l (interval 0 (length l -1)) in
- let (lt,i) = try (List.find (fun (x,_) -> snd' x = Mc.Strict) l)
- with Not_found -> List.hd l in
- let plt = poly_neg (poly_of_term (expr_to_term (fst' lt))) in
- let (n,polys) = sumofsquares plt in (* n * (ci * pi^2) *)
- let pos = Product (Rational_lt n,
- List.fold_right (fun (c,p) rst -> Sum (Product (Rational_lt c, Square
- (term_of_poly p)), rst))
- polys (Rational_lt (Int 0))) in
- let proof = Sum(Axiom_lt i, pos) in
-(* let s,proof' = scale_certificate proof in
- let cert = snd (cert_of_pos proof') in *)
- Some proof
- with
- | Not_found -> (* This is no strict inequality *) None
- | x -> None
-
-
-type micromega_polys = (Micromega.q Mc.pExpr, Mc.op1) Micromega.prod list
-type csdp_certificate = Sos.positivstellensatz option
-type provername = string * int option
-
-let main () =
- if Array.length Sys.argv <> 3 then
- (Printf.printf "Usage: csdpcert inputfile outputfile\n"; exit 1);
- let input_file = Sys.argv.(1) in
- let output_file = Sys.argv.(2) in
- let inch = open_in input_file in
- let (prover,poly) = (input_value inch : provername * micromega_polys) in
- close_in inch;
- let cert =
- match prover with
- | "real_nonlinear_prover", Some d -> real_nonlinear_prover d poly
- | "pure_sos", None -> pure_sos poly
- | prover, _ -> (Printf.printf "unknown prover: %s\n" prover; exit 1) in
- let outch = open_out output_file in
- output_value outch (cert:csdp_certificate);
- close_out outch;
- exit 0;;
-
-let _ = main () in ()
diff --git a/contrib/micromega/g_micromega.ml4 b/contrib/micromega/g_micromega.ml4
deleted file mode 100644
index 50024e78..00000000
--- a/contrib/micromega/g_micromega.ml4
+++ /dev/null
@@ -1,74 +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 *)
-(************************************************************************)
-(* *)
-(* Micromega: A reflexive tactic using the Positivstellensatz *)
-(* *)
-(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
-(* *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-(* $Id: g_micromega.ml4 11306 2008-08-05 16:51:08Z notin $ *)
-
-open Quote
-open Ring
-open Mutils
-open Rawterm
-open Util
-
-let out_arg = function
- | ArgVar _ -> anomaly "Unevaluated or_var variable"
- | ArgArg x -> x
-
-TACTIC EXTEND PsatzZ
-| [ "psatz_Z" int_or_var(i) ] -> [ Coq_micromega.psatz_Z (out_arg i) ]
-| [ "psatz_Z" ] -> [ Coq_micromega.psatz_Z (-1) ]
-END
-
-TACTIC EXTEND Sos_Z
-| [ "sos_Z" ] -> [ Coq_micromega.sos_Z]
- END
-
-TACTIC EXTEND Sos_Q
-| [ "sos_Q" ] -> [ Coq_micromega.sos_Q]
- END
-
-TACTIC EXTEND Sos_R
-| [ "sos_R" ] -> [ Coq_micromega.sos_R]
-END
-
-
-TACTIC EXTEND Omicron
-[ "psatzl_Z" ] -> [ Coq_micromega.psatzl_Z]
-END
-
-TACTIC EXTEND QOmicron
-[ "psatzl_Q" ] -> [ Coq_micromega.psatzl_Q]
-END
-
-
-TACTIC EXTEND ZOmicron
-[ "xlia" ] -> [ Coq_micromega.xlia]
-END
-
-TACTIC EXTEND ROmicron
-[ "psatzl_R" ] -> [ Coq_micromega.psatzl_R]
-END
-
-TACTIC EXTEND RMicromega
-| [ "psatz_R" int_or_var(i) ] -> [ Coq_micromega.psatz_R (out_arg i) ]
-| [ "psatz_R" ] -> [ Coq_micromega.psatz_R (-1) ]
-END
-
-
-TACTIC EXTEND QMicromega
-| [ "psatz_Q" int_or_var(i) ] -> [ Coq_micromega.psatz_Q (out_arg i) ]
-| [ "psatz_Q" ] -> [ Coq_micromega.psatz_Q (-1) ]
-END
-
diff --git a/contrib/micromega/mfourier.ml b/contrib/micromega/mfourier.ml
deleted file mode 100644
index 415d3a3e..00000000
--- a/contrib/micromega/mfourier.ml
+++ /dev/null
@@ -1,667 +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 *)
-(************************************************************************)
-(* *)
-(* Micromega: A reflexive tactic using the Positivstellensatz *)
-(* *)
-(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
-(* *)
-(************************************************************************)
-
-(* Yet another implementation of Fourier *)
-open Num
-
-module Cmp =
- (* How to compare pairs, lists ... *)
-struct
- let rec compare_lexical l =
- match l with
- | [] -> 0 (* Equal *)
- | f::l ->
- let cmp = f () in
- if cmp = 0 then compare_lexical l else cmp
-
- let rec compare_list cmp l1 l2 =
- match l1 , l2 with
- | [] , [] -> 0
- | [] , _ -> -1
- | _ , [] -> 1
- | e1::l1 , e2::l2 ->
- let c = cmp e1 e2 in
- if c = 0 then compare_list cmp l1 l2 else c
-
- let hash_list hash l =
- let rec xhash res l =
- match l with
- | [] -> res
- | e::l -> xhash ((hash e) lxor res) l in
- xhash (Hashtbl.hash []) l
-
-end
-
-module Interval =
-struct
- (** The type of intervals. **)
- type intrvl = Empty | Point of num | Itv of num option * num option
-
- (**
- Different intervals can denote the same set of variables e.g.,
- Point n && Itv (Some n, Some n)
- Itv (Some x) (Some y) && Empty if x > y
- see the 'belongs_to' function.
- **)
-
- (* The set of numerics that belong to an interval *)
- let belongs_to n = function
- | Empty -> false
- | Point x -> n =/ x
- | Itv(Some x, Some y) -> x <=/ n && n <=/ y
- | Itv(None,Some y) -> n <=/ y
- | Itv(Some x,None) -> x <=/ n
- | Itv(None,None) -> true
-
- let string_of_bound = function
- | None -> "oo"
- | Some n -> Printf.sprintf "Bd(%s)" (string_of_num n)
-
- let string_of_intrvl = function
- | Empty -> "[]"
- | Point n -> Printf.sprintf "[%s]" (string_of_num n)
- | Itv(bd1,bd2) ->
- Printf.sprintf "[%s,%s]" (string_of_bound bd1) (string_of_bound bd2)
-
- let pick_closed_to_zero = function
- | Empty -> None
- | Point n -> Some n
- | Itv(None,None) -> Some (Int 0)
- | Itv(None,Some i) ->
- Some (if (Int 0) <=/ (floor_num i) then Int 0 else floor_num i)
- | Itv(Some i,None) ->
- Some (if i <=/ (Int 0) then Int 0 else ceiling_num i)
- | Itv(Some i,Some j) ->
- Some (
- if i <=/ Int 0 && Int 0 <=/ j
- then Int 0
- else if ceiling_num i <=/ floor_num j
- then ceiling_num i (* why not *) else i)
-
- type status =
- | O | Qonly | Z | Q
-
- let interval_kind = function
- | Empty -> O
- | Point n -> if ceiling_num n =/ n then Z else Qonly
- | Itv(None,None) -> Z
- | Itv(None,Some i) -> if ceiling_num i <>/ i then Q else Z
- | Itv(Some i,None) -> if ceiling_num i <>/ i then Q else Z
- | Itv(Some i,Some j) ->
- if ceiling_num i <>/ i or floor_num j <>/ j then Q else Z
-
- let empty_z = function
- | Empty -> true
- | Point n -> ceiling_num n <>/ n
- | Itv(None,None) | Itv(None,Some _) | Itv(Some _,None) -> false
- | Itv(Some i,Some j) -> ceiling_num i >/ floor_num j
-
-
- let normalise b1 b2 =
- match b1 , b2 with
- | Some i , Some j ->
- (match compare_num i j with
- | 1 -> Empty
- | 0 -> Point i
- | _ -> Itv(b1,b2)
- )
- | _ -> Itv(b1,b2)
-
-
-
- let min x y =
- match x , y with
- | None , x | x , None -> x
- | Some i , Some j -> Some (min_num i j)
-
- let max x y =
- match x , y with
- | None , x | x , None -> x
- | Some i , Some j -> Some (max_num i j)
-
- let inter i1 i2 =
- match i1,i2 with
- | Empty , _ -> Empty
- | _ , Empty -> Empty
- | Point n , Point m -> if n =/ m then i1 else Empty
- | Point n , Itv (mn,mx) | Itv (mn,mx) , Point n->
- if (match mn with
- | None -> true
- | Some mn -> mn <=/ n) &&
- (match mx with
- | None -> true
- | Some mx -> n <=/ mx) then Point n else Empty
- | Itv (min1,max1) , Itv (min2,max2) ->
- let bmin = max min1 min2
- and bmax = min max1 max2 in
- normalise bmin bmax
-
- (* a.x >= b*)
- let bound_of_constraint (a,b) =
- match compare_num a (Int 0) with
- | 0 ->
- if compare_num b (Int 0) = 1
- then Empty
- (*actually this is a contradiction failwith "bound_of_constraint" *)
- else Itv (None,None)
- | 1 -> Itv (Some (div_num b a),None)
- | -1 -> Itv (None, Some (div_num b a))
- | x -> failwith "bound_of_constraint(2)"
-
-
- let bounded x =
- match x with
- | Itv(None,_) | Itv(_,None) -> false
- | _ -> true
-
-
- let range = function
- | Empty -> Some (Int 0)
- | Point n -> Some (Int (if ceiling_num n =/ n then 1 else 0))
- | Itv(None,_) | Itv(_,None)-> None
- | Itv(Some i,Some j) -> Some (floor_num j -/ceiling_num i +/ (Int 1))
-
- (* Returns the interval of smallest range *)
- let smaller_itv i1 i2 =
- match range i1 , range i2 with
- | None , _ -> false
- | _ , None -> true
- | Some i , Some j -> i <=/ j
-
-end
-open Interval
-
-(* A set of constraints *)
-module Sys(V:Vector.S) (* : Vector.SystemS with module Vect = V*) =
-struct
-
- module Vect = V
-
- module Cstr = Vector.Cstr(V)
- open Cstr
-
-
- module CMap = Map.Make(
- struct
- type t = Vect.t
- let compare = Vect.compare
- end)
-
- module CstrBag =
- struct
-
- type mut_itv = { mutable itv : intrvl}
-
- type t = mut_itv CMap.t
-
- exception Contradiction
-
- let cstr_to_itv cstr =
- let (n,l) = V.normalise cstr.coeffs in
- if n =/ (Int 0)
- then (Vect.null, bound_of_constraint (Int 0,cstr.cst)) (* Might be empty *)
- else
- match cstr.op with
- | Eq -> let n = cstr.cst // n in (l, Point n)
- | Ge ->
- match compare_num n (Int 0) with
- | 0 -> failwith "intrvl_of_constraint"
- | 1 -> (l,Itv (Some (cstr.cst // n), None))
- | -1 -> (l, Itv(None,Some (cstr.cst // n)))
- | _ -> failwith "cstr_to_itv"
-
-
- let empty = CMap.empty
-
-
-
-
- let is_empty = CMap.is_empty
-
- let find_vect v bag =
- try
- (bag,CMap.find v bag)
- with Not_found -> let x = { itv = Itv(None,None)} in (CMap.add v x bag ,x)
-
-
- let add (v,b) bag =
- match b with
- | Empty -> raise Contradiction
- | Itv(None,None) -> bag
- | _ ->
- let (bag,intrl) = find_vect v bag in
- match inter b intrl.itv with
- | Empty -> raise Contradiction
- | itv -> intrl.itv <- itv ; bag
-
- exception Found of cstr
-
- let find_equation bag =
- try
- CMap.fold (fun v i () ->
- match i.itv with
- | Point n -> let e = {coeffs = v ; op = Eq ; cst = n}
- in raise (Found e)
- | _ -> () ) bag () ; None
- with Found c -> Some c
-
-
- let fold f bag acc =
- CMap.fold (fun v itv acc ->
- match itv.itv with
- | Empty | Itv(None,None) -> failwith "fold Empty"
- | Itv(None ,Some i) ->
- f {coeffs = V.mul (Int (-1)) v ; op = Ge ; cst = minus_num i} acc
- | Point n -> f {coeffs = v ; op = Eq ; cst = n} acc
- | Itv(x,y) ->
- (match x with
- | None -> (fun x -> x)
- | Some i -> f {coeffs = v ; op = Ge ; cst = i})
- (match y with
- | None -> acc
- | Some i ->
- f {coeffs = V.mul (Int (-1)) v ; op = Ge ; cst = minus_num i} acc
- ) ) bag acc
-
-
- let remove l _ = failwith "remove:Not implemented"
-
- module Map =
- Map.Make(
- struct
- type t = int
- let compare : int -> int -> int = Pervasives.compare
- end)
-
- let split f (t:t) =
- let res =
- fold (fun e m -> let i = f e in
- Map.add i (add (cstr_to_itv e)
- (try Map.find i m with
- Not_found -> empty)) m) t Map.empty in
- (fun i -> try Map.find i res with Not_found -> empty)
-
- type map = (int list * int list) Map.t
-
-
- let status (b:t) =
- let _ , map = fold (fun c ( (idx:int),(res: map)) ->
- ( idx + 1,
- List.fold_left (fun (res:map) (pos,s) ->
- let (lp,ln) = try Map.find pos res with Not_found -> ([],[]) in
- match s with
- | Vect.Pos -> Map.add pos (idx::lp,ln) res
- | Vect.Neg ->
- Map.add pos (lp, idx::ln) res) res
- (Vect.status c.coeffs))) b (0,Map.empty) in
- Map.fold (fun k e res -> (k,e)::res) map []
-
-
- type it = num CMap.t
-
- let iterator x = x
-
- let element it = failwith "element:Not implemented"
-
- end
-end
-
-module Fourier(Vect : Vector.S) =
-struct
- module Vect = Vect
- module Sys = Sys( Vect)
- module Cstr = Sys.Cstr
- module Bag = Sys.CstrBag
-
- open Cstr
- open Sys
-
- let debug = false
-
- let print_bag msg b =
- print_endline msg;
- CstrBag.fold (fun e () -> print_endline (Cstr.string_of_cstr e)) b ()
-
- let print_bag_file file msg b =
- let f = open_out file in
- output_string f msg;
- CstrBag.fold (fun e () ->
- Printf.fprintf f "%s\n" (Cstr.string_of_cstr e)) b ()
-
-
- (* A system with only inequations --
- *)
- let partition i m =
- let splitter cstr = compare_num (Vect.get i cstr.coeffs ) (Int 0) in
- let split = CstrBag.split splitter m in
- (split (-1) , split 0, split 1)
-
-
- (* op of the result is arbitrary Ge *)
- let lin_comb n1 c1 n2 c2 =
- { coeffs = Vect.lin_comb n1 c1.coeffs n2 c2.coeffs ;
- op = Ge ;
- cst = (n1 */ c1.cst) +/ (n2 */ c2.cst)}
-
- (* BUG? : operator of the result ? *)
-
- let combine_project i c1 c2 =
- let p = Vect.get i c1.coeffs
- and n = Vect.get i c2.coeffs in
- assert (n </ Int 0 && p >/ Int 0) ;
- let nopp = minus_num n in
- let c =lin_comb nopp c1 p c2 in
- let op = if c1.op = Ge || c2.op = Ge then Ge else Eq in
- CstrBag.cstr_to_itv {coeffs = c.coeffs ; op = op ; cst= c.cst }
-
-
- let project i m =
- let (neg,zero,pos) = partition i m in
- let project1 cpos acc =
- CstrBag.fold (fun cneg res ->
- CstrBag.add (combine_project i cpos cneg) res) neg acc in
- (CstrBag.fold project1 pos zero)
-
- (* Given a vector [x1 -> v1; ... ; xn -> vn]
- and a constraint {x1 ; .... xn >= c }
- *)
- let evaluate_constraint i map cstr =
- let {coeffs = _coeffs ; op = _op ; cst = _cst} = cstr in
- let vi = Vect.get i _coeffs in
- let v = Vect.set i (Int 0) _coeffs in
- (vi, _cst -/ Vect.dotp map v)
-
-
- let rec bounds m itv =
- match m with
- | [] -> itv
- | e::m -> bounds m (inter itv (bound_of_constraint e))
-
-
-
- let compare_status (i,(lp,ln)) (i',(lp',ln')) =
- let cmp = Pervasives.compare
- ((List.length lp) * (List.length ln))
- ((List.length lp') * (List.length ln')) in
- if cmp = 0
- then Pervasives.compare i i'
- else cmp
-
- let cardinal m = CstrBag.fold (fun _ x -> x + 1) m 0
-
- let lightest_projection l c m =
- let bound = c in
- if debug then (Printf.printf "l%i" bound; flush stdout) ;
- let rec xlight best l =
- match l with
- | [] -> best
- | i::l ->
- let proj = (project i m) in
- let cproj = cardinal proj in
- (*Printf.printf " p %i " cproj; flush stdout;*)
- match best with
- | None ->
- if cproj < bound
- then Some(cproj,proj,i)
- else xlight (Some(cproj,proj,i)) l
- | Some (cbest,_,_) ->
- if cproj < cbest
- then
- if cproj < bound then Some(cproj,proj,i)
- else xlight (Some(cproj,proj,i)) l
- else xlight best l in
- match xlight None l with
- | None -> None
- | Some(_,p,i) -> Some (p,i)
-
-
-
- exception Equality of cstr
-
- let find_equality m = Bag.find_equation m
-
-
-
- let pivot (n,v) eq ge =
- assert (eq.op = Eq) ;
- let res =
- match
- compare_num v (Int 0),
- compare_num (Vect.get n ge.coeffs) (Int 0)
- with
- | 0 , _ -> failwith "Buggy"
- | _ ,0 -> (CstrBag.cstr_to_itv ge)
- | 1 , -1 -> combine_project n eq ge
- | -1 , 1 -> combine_project n ge eq
- | 1 , 1 ->
- combine_project n ge
- {coeffs = Vect.mul (Int (-1)) eq.coeffs;
- op = eq.op ;
- cst = minus_num eq.cst}
- | -1 , -1 ->
- combine_project n
- {coeffs = Vect.mul (Int (-1)) eq.coeffs;
- op = eq.op ; cst = minus_num eq.cst} ge
- | _ -> failwith "pivot" in
- res
-
- let check_cstr v c =
- let {coeffs = _coeffs ; op = _op ; cst = _cst} = c in
- let vl = Vect.dotp v _coeffs in
- match _op with
- | Eq -> vl =/ _cst
- | Ge -> vl >= _cst
-
-
- let forall p sys =
- try
- CstrBag.fold (fun c () -> if p c then () else raise Not_found) sys (); true
- with Not_found -> false
-
-
- let check_sys v sys = forall (check_cstr v) sys
-
- let check_null_cstr c =
- let {coeffs = _coeffs ; op = _op ; cst = _cst} = c in
- match _op with
- | Eq -> (Int 0) =/ _cst
- | Ge -> (Int 0) >= _cst
-
- let check_null sys = forall check_null_cstr sys
-
-
- let optimise_ge
- quick_check choose choose_idx return_empty return_ge return_eq m =
- let c = cardinal m in
- let bound = 2 * c in
- if debug then (Printf.printf "optimise_ge: %i\n" c; flush stdout);
-
- let rec xoptimise m =
- if debug then (Printf.printf "x%i" (cardinal m) ; flush stdout);
- if debug then (print_bag "xoptimise" m ; flush stdout);
- if quick_check m
- then return_empty m
- else
- match find_equality m with
- | None -> xoptimise_ge m
- | Some eq -> xoptimise_eq eq m
-
- and xoptimise_ge m =
- begin
- let c = cardinal m in
- let l = List.map fst (List.sort compare_status (CstrBag.status m)) in
- let idx = choose bound l c m in
- match idx with
- | None -> return_empty m
- | Some (proj,i) ->
- match xoptimise proj with
- | None -> None
- | Some mapping -> return_ge m i mapping
- end
- and xoptimise_eq eq m =
- let l = List.map fst (Vect.status eq.coeffs) in
- match choose_idx l with
- | None -> (*if l = [] then None else*) return_empty m
- | Some i ->
- let p = (i,Vect.get i eq.coeffs) in
- let m' = CstrBag.fold
- (fun ge res -> CstrBag.add (pivot p eq ge) res) m CstrBag.empty in
- match xoptimise ( m') with
- | None -> None
- | Some mapp -> return_eq m eq i mapp in
- try
- let res = xoptimise m in res
- with CstrBag.Contradiction -> (*print_string "contradiction" ;*) None
-
-
-
- let minimise m =
- let opt_zero_choose bound l c m =
- if c > bound
- then lightest_projection l c m
- else match l with
- | [] -> None
- | i::_ -> Some (project i m, i) in
-
- let choose_idx = function [] -> None | x::l -> Some x in
-
- let opt_zero_return_empty m = Some Vect.null in
-
-
- let opt_zero_return_ge m i mapping =
- let (it:intrvl) = CstrBag.fold (fun cstr itv -> Interval.inter
- (bound_of_constraint (evaluate_constraint i mapping cstr)) itv) m
- (Itv (None, None)) in
- match pick_closed_to_zero it with
- | None -> print_endline "Cannot pick" ; None
- | Some v ->
- let res = (Vect.set i v mapping) in
- if debug
- then Printf.printf "xoptimise res %i [%s]" i (Vect.string res) ;
- Some res in
-
- let opt_zero_return_eq m eq i mapp =
- let (a,b) = evaluate_constraint i mapp eq in
- Some (Vect.set i (div_num b a) mapp) in
-
- optimise_ge check_null opt_zero_choose
- choose_idx opt_zero_return_empty opt_zero_return_ge opt_zero_return_eq m
-
- let normalise cstr = [CstrBag.cstr_to_itv cstr]
-
- let find_point l =
- (* List.iter (fun e -> print_endline (Cstr.string_of_cstr e)) l;*)
- try
- let m = List.fold_left (fun sys e -> CstrBag.add (CstrBag.cstr_to_itv e) sys)
- CstrBag.empty l in
- match minimise m with
- | None -> None
- | Some res ->
- if debug then Printf.printf "[%s]" (Vect.string res);
- Some res
- with CstrBag.Contradiction -> None
-
-
- let find_q_interval_for x m =
- if debug then Printf.printf "find_q_interval_for %i\n" x ;
-
- let choose bound l c m =
- let rec xchoose l =
- match l with
- | [] -> None
- | i::l -> if i = x then xchoose l else Some (project i m,i) in
- xchoose l in
-
- let rec choose_idx = function
- [] -> None
- | e::l -> if e = x then choose_idx l else Some e in
-
- let return_empty m = (* Beurk *)
- (* returns the interval of x *)
- Some (CstrBag.fold (fun cstr itv ->
- let i = if cstr.op = Eq
- then Point (cstr.cst // Vect.get x cstr.coeffs)
- else if Vect.is_null (Vect.set x (Int 0) cstr.coeffs)
- then bound_of_constraint (Vect.get x cstr.coeffs , cstr.cst)
- else itv
- in
- Interval.inter i itv) m (Itv (None, None))) in
-
- let return_ge m i res = Some res in
-
- let return_eq m eq i res = Some res in
-
- try
- optimise_ge
- (fun x -> false) choose choose_idx return_empty return_ge return_eq m
- with CstrBag.Contradiction -> None
-
-
- let find_q_intervals sys =
- let variables =
- List.map fst (List.sort compare_status (CstrBag.status sys)) in
- List.map (fun x -> (x,find_q_interval_for x sys)) variables
-
- let pp_option f o = function
- None -> Printf.fprintf o "None"
- | Some x -> Printf.fprintf o "Some %a" f x
-
- let optimise vect sys =
- (* we have to modify the system with a dummy variable *)
- let fresh =
- List.fold_left (fun fr c -> Pervasives.max fr (Vect.fresh c.coeffs)) 0 sys in
- assert (List.for_all (fun x -> Vect.get fresh x.coeffs =/ Int 0) sys);
- let cstr = {
- coeffs = Vect.set fresh (Int (-1)) vect ;
- op = Eq ;
- cst = (Int 0)} in
- try
- find_q_interval_for fresh
- (List.fold_left
- (fun bg c -> CstrBag.add (CstrBag.cstr_to_itv c) bg)
- CstrBag.empty (cstr::sys))
- with CstrBag.Contradiction -> None
-
-
- let optimise vect sys =
- let res = optimise vect sys in
- if debug
- then Printf.printf "optimise %s -> %a\n"
- (Vect.string vect) (pp_option (fun o x -> Printf.printf "%s" (string_of_intrvl x))) res
- ; res
-
- let find_Q_interval sys =
- try
- let sys =
- (List.fold_left
- (fun bg c -> CstrBag.add (CstrBag.cstr_to_itv c) bg) CstrBag.empty sys) in
- let candidates =
- List.fold_left
- (fun l (x,i) -> match i with
- None -> (x,Empty)::l
- | Some i -> (x,i)::l) [] (find_q_intervals sys) in
- match List.fold_left
- (fun (x1,i1) (x2,i2) ->
- if smaller_itv i1 i2
- then (x1,i1) else (x2,i2)) (-1,Itv(None,None)) candidates
- with
- | (i,Empty) -> None
- | (x,Itv(Some i, Some j)) -> Some(i,x,j)
- | (x,Point n) -> Some(n,x,n)
- | _ -> None
- with CstrBag.Contradiction -> None
-
-
-end
-
diff --git a/contrib/micromega/micromega.ml b/contrib/micromega/micromega.ml
deleted file mode 100644
index e151e4e1..00000000
--- a/contrib/micromega/micromega.ml
+++ /dev/null
@@ -1,1512 +0,0 @@
-type __ = Obj.t
-let __ = let rec f _ = Obj.repr f in Obj.repr f
-
-type bool =
- | True
- | False
-
-(** val negb : bool -> bool **)
-
-let negb = function
- | True -> False
- | False -> True
-
-type nat =
- | O
- | S of nat
-
-type 'a option =
- | Some of 'a
- | None
-
-type ('a, 'b) prod =
- | Pair of 'a * 'b
-
-type comparison =
- | Eq
- | Lt
- | Gt
-
-(** val compOpp : comparison -> comparison **)
-
-let compOpp = function
- | Eq -> Eq
- | Lt -> Gt
- | Gt -> Lt
-
-type sumbool =
- | Left
- | Right
-
-type 'a sumor =
- | Inleft of 'a
- | Inright
-
-type 'a list =
- | Nil
- | Cons of 'a * 'a list
-
-(** val app : 'a1 list -> 'a1 list -> 'a1 list **)
-
-let rec app l m =
- match l with
- | Nil -> m
- | Cons (a, l1) -> Cons (a, (app l1 m))
-
-(** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **)
-
-let rec nth n0 l default =
- match n0 with
- | O -> (match l with
- | Nil -> default
- | Cons (x, l') -> x)
- | S m ->
- (match l with
- | Nil -> default
- | Cons (x, t0) -> nth m t0 default)
-
-(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **)
-
-let rec map f = function
- | Nil -> Nil
- | Cons (a, t0) -> Cons ((f a), (map f t0))
-
-type positive =
- | XI of positive
- | XO of positive
- | XH
-
-(** val psucc : positive -> positive **)
-
-let rec psucc = function
- | XI p -> XO (psucc p)
- | XO p -> XI p
- | XH -> XO XH
-
-(** val pplus : positive -> positive -> positive **)
-
-let rec pplus x y =
- match x with
- | XI p ->
- (match y with
- | XI q0 -> XO (pplus_carry p q0)
- | XO q0 -> XI (pplus p q0)
- | XH -> XO (psucc p))
- | XO p ->
- (match y with
- | XI q0 -> XI (pplus p q0)
- | XO q0 -> XO (pplus p q0)
- | XH -> XI p)
- | XH ->
- (match y with
- | XI q0 -> XO (psucc q0)
- | XO q0 -> XI q0
- | XH -> XO XH)
-
-(** val pplus_carry : positive -> positive -> positive **)
-
-and pplus_carry x y =
- match x with
- | XI p ->
- (match y with
- | XI q0 -> XI (pplus_carry p q0)
- | XO q0 -> XO (pplus_carry p q0)
- | XH -> XI (psucc p))
- | XO p ->
- (match y with
- | XI q0 -> XO (pplus_carry p q0)
- | XO q0 -> XI (pplus p q0)
- | XH -> XO (psucc p))
- | XH ->
- (match y with
- | XI q0 -> XI (psucc q0)
- | XO q0 -> XO (psucc q0)
- | XH -> XI XH)
-
-(** val p_of_succ_nat : nat -> positive **)
-
-let rec p_of_succ_nat = function
- | O -> XH
- | S x -> psucc (p_of_succ_nat x)
-
-(** val pdouble_minus_one : positive -> positive **)
-
-let rec pdouble_minus_one = function
- | XI p -> XI (XO p)
- | XO p -> XI (pdouble_minus_one p)
- | XH -> XH
-
-type positive_mask =
- | IsNul
- | IsPos of positive
- | IsNeg
-
-(** val pdouble_plus_one_mask : positive_mask -> positive_mask **)
-
-let pdouble_plus_one_mask = function
- | IsNul -> IsPos XH
- | IsPos p -> IsPos (XI p)
- | IsNeg -> IsNeg
-
-(** val pdouble_mask : positive_mask -> positive_mask **)
-
-let pdouble_mask = function
- | IsNul -> IsNul
- | IsPos p -> IsPos (XO p)
- | IsNeg -> IsNeg
-
-(** val pdouble_minus_two : positive -> positive_mask **)
-
-let pdouble_minus_two = function
- | XI p -> IsPos (XO (XO p))
- | XO p -> IsPos (XO (pdouble_minus_one p))
- | XH -> IsNul
-
-(** val pminus_mask : positive -> positive -> positive_mask **)
-
-let rec pminus_mask x y =
- match x with
- | XI p ->
- (match y with
- | XI q0 -> pdouble_mask (pminus_mask p q0)
- | XO q0 -> pdouble_plus_one_mask (pminus_mask p q0)
- | XH -> IsPos (XO p))
- | XO p ->
- (match y with
- | XI q0 -> pdouble_plus_one_mask (pminus_mask_carry p q0)
- | XO q0 -> pdouble_mask (pminus_mask p q0)
- | XH -> IsPos (pdouble_minus_one p))
- | XH -> (match y with
- | XH -> IsNul
- | _ -> IsNeg)
-
-(** val pminus_mask_carry : positive -> positive -> positive_mask **)
-
-and pminus_mask_carry x y =
- match x with
- | XI p ->
- (match y with
- | XI q0 -> pdouble_plus_one_mask (pminus_mask_carry p q0)
- | XO q0 -> pdouble_mask (pminus_mask p q0)
- | XH -> IsPos (pdouble_minus_one p))
- | XO p ->
- (match y with
- | XI q0 -> pdouble_mask (pminus_mask_carry p q0)
- | XO q0 -> pdouble_plus_one_mask (pminus_mask_carry p q0)
- | XH -> pdouble_minus_two p)
- | XH -> IsNeg
-
-(** val pminus : positive -> positive -> positive **)
-
-let pminus x y =
- match pminus_mask x y with
- | IsPos z0 -> z0
- | _ -> XH
-
-(** val pmult : positive -> positive -> positive **)
-
-let rec pmult x y =
- match x with
- | XI p -> pplus y (XO (pmult p y))
- | XO p -> XO (pmult p y)
- | XH -> y
-
-(** val pcompare : positive -> positive -> comparison -> comparison **)
-
-let rec pcompare x y r =
- match x with
- | XI p ->
- (match y with
- | XI q0 -> pcompare p q0 r
- | XO q0 -> pcompare p q0 Gt
- | XH -> Gt)
- | XO p ->
- (match y with
- | XI q0 -> pcompare p q0 Lt
- | XO q0 -> pcompare p q0 r
- | XH -> Gt)
- | XH -> (match y with
- | XH -> r
- | _ -> Lt)
-
-type n =
- | N0
- | Npos of positive
-
-type z =
- | Z0
- | Zpos of positive
- | Zneg of positive
-
-(** val zdouble_plus_one : z -> z **)
-
-let zdouble_plus_one = function
- | Z0 -> Zpos XH
- | Zpos p -> Zpos (XI p)
- | Zneg p -> Zneg (pdouble_minus_one p)
-
-(** val zdouble_minus_one : z -> z **)
-
-let zdouble_minus_one = function
- | Z0 -> Zneg XH
- | Zpos p -> Zpos (pdouble_minus_one p)
- | Zneg p -> Zneg (XI p)
-
-(** val zdouble : z -> z **)
-
-let zdouble = function
- | Z0 -> Z0
- | Zpos p -> Zpos (XO p)
- | Zneg p -> Zneg (XO p)
-
-(** val zPminus : positive -> positive -> z **)
-
-let rec zPminus x y =
- match x with
- | XI p ->
- (match y with
- | XI q0 -> zdouble (zPminus p q0)
- | XO q0 -> zdouble_plus_one (zPminus p q0)
- | XH -> Zpos (XO p))
- | XO p ->
- (match y with
- | XI q0 -> zdouble_minus_one (zPminus p q0)
- | XO q0 -> zdouble (zPminus p q0)
- | XH -> Zpos (pdouble_minus_one p))
- | XH ->
- (match y with
- | XI q0 -> Zneg (XO q0)
- | XO q0 -> Zneg (pdouble_minus_one q0)
- | XH -> Z0)
-
-(** val zplus : z -> z -> z **)
-
-let zplus x y =
- match x with
- | Z0 -> y
- | Zpos x' ->
- (match y with
- | Z0 -> Zpos x'
- | Zpos y' -> Zpos (pplus x' y')
- | Zneg y' ->
- (match pcompare x' y' Eq with
- | Eq -> Z0
- | Lt -> Zneg (pminus y' x')
- | Gt -> Zpos (pminus x' y')))
- | Zneg x' ->
- (match y with
- | Z0 -> Zneg x'
- | Zpos y' ->
- (match pcompare x' y' Eq with
- | Eq -> Z0
- | Lt -> Zpos (pminus y' x')
- | Gt -> Zneg (pminus x' y'))
- | Zneg y' -> Zneg (pplus x' y'))
-
-(** val zopp : z -> z **)
-
-let zopp = function
- | Z0 -> Z0
- | Zpos x0 -> Zneg x0
- | Zneg x0 -> Zpos x0
-
-(** val zminus : z -> z -> z **)
-
-let zminus m n0 =
- zplus m (zopp n0)
-
-(** val zmult : z -> z -> z **)
-
-let zmult x y =
- match x with
- | Z0 -> Z0
- | Zpos x' ->
- (match y with
- | Z0 -> Z0
- | Zpos y' -> Zpos (pmult x' y')
- | Zneg y' -> Zneg (pmult x' y'))
- | Zneg x' ->
- (match y with
- | Z0 -> Z0
- | Zpos y' -> Zneg (pmult x' y')
- | Zneg y' -> Zpos (pmult x' y'))
-
-(** val zcompare : z -> z -> comparison **)
-
-let zcompare x y =
- match x with
- | Z0 -> (match y with
- | Z0 -> Eq
- | Zpos y' -> Lt
- | Zneg y' -> Gt)
- | Zpos x' -> (match y with
- | Zpos y' -> pcompare x' y' Eq
- | _ -> Gt)
- | Zneg x' ->
- (match y with
- | Zneg y' -> compOpp (pcompare x' y' Eq)
- | _ -> Lt)
-
-(** val dcompare_inf : comparison -> sumbool sumor **)
-
-let dcompare_inf = function
- | Eq -> Inleft Left
- | Lt -> Inleft Right
- | Gt -> Inright
-
-(** val zcompare_rec :
- z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **)
-
-let zcompare_rec x y h1 h2 h3 =
- match dcompare_inf (zcompare x y) with
- | Inleft x0 -> (match x0 with
- | Left -> h1 __
- | Right -> h2 __)
- | Inright -> h3 __
-
-(** val z_gt_dec : z -> z -> sumbool **)
-
-let z_gt_dec x y =
- zcompare_rec x y (fun _ -> Right) (fun _ -> Right) (fun _ -> Left)
-
-(** val zle_bool : z -> z -> bool **)
-
-let zle_bool x y =
- match zcompare x y with
- | Gt -> False
- | _ -> True
-
-(** val zge_bool : z -> z -> bool **)
-
-let zge_bool x y =
- match zcompare x y with
- | Lt -> False
- | _ -> True
-
-(** val zgt_bool : z -> z -> bool **)
-
-let zgt_bool x y =
- match zcompare x y with
- | Gt -> True
- | _ -> False
-
-(** val zeq_bool : z -> z -> bool **)
-
-let zeq_bool x y =
- match zcompare x y with
- | Eq -> True
- | _ -> False
-
-(** val n_of_nat : nat -> n **)
-
-let n_of_nat = function
- | O -> N0
- | S n' -> Npos (p_of_succ_nat n')
-
-(** val zdiv_eucl_POS : positive -> z -> (z, z) prod **)
-
-let rec zdiv_eucl_POS a b =
- match a with
- | XI a' ->
- let Pair (q0, r) = zdiv_eucl_POS a' b in
- let r' = zplus (zmult (Zpos (XO XH)) r) (Zpos XH) in
- (match zgt_bool b r' with
- | True -> Pair ((zmult (Zpos (XO XH)) q0), r')
- | False -> Pair ((zplus (zmult (Zpos (XO XH)) q0) (Zpos XH)),
- (zminus r' b)))
- | XO a' ->
- let Pair (q0, r) = zdiv_eucl_POS a' b in
- let r' = zmult (Zpos (XO XH)) r in
- (match zgt_bool b r' with
- | True -> Pair ((zmult (Zpos (XO XH)) q0), r')
- | False -> Pair ((zplus (zmult (Zpos (XO XH)) q0) (Zpos XH)),
- (zminus r' b)))
- | XH ->
- (match zge_bool b (Zpos (XO XH)) with
- | True -> Pair (Z0, (Zpos XH))
- | False -> Pair ((Zpos XH), Z0))
-
-(** val zdiv_eucl : z -> z -> (z, z) prod **)
-
-let zdiv_eucl a b =
- match a with
- | Z0 -> Pair (Z0, Z0)
- | Zpos a' ->
- (match b with
- | Z0 -> Pair (Z0, Z0)
- | Zpos p -> zdiv_eucl_POS a' b
- | Zneg b' ->
- let Pair (q0, r) = zdiv_eucl_POS a' (Zpos b') in
- (match r with
- | Z0 -> Pair ((zopp q0), Z0)
- | _ -> Pair ((zopp (zplus q0 (Zpos XH))), (zplus b r))))
- | Zneg a' ->
- (match b with
- | Z0 -> Pair (Z0, Z0)
- | Zpos p ->
- let Pair (q0, r) = zdiv_eucl_POS a' b in
- (match r with
- | Z0 -> Pair ((zopp q0), Z0)
- | _ -> Pair ((zopp (zplus q0 (Zpos XH))), (zminus b r)))
- | Zneg b' ->
- let Pair (q0, r) = zdiv_eucl_POS a' (Zpos b') in
- Pair (q0, (zopp r)))
-
-type 'c pol =
- | Pc of 'c
- | Pinj of positive * 'c pol
- | PX of 'c pol * positive * 'c pol
-
-(** val p0 : 'a1 -> 'a1 pol **)
-
-let p0 cO =
- Pc cO
-
-(** val p1 : 'a1 -> 'a1 pol **)
-
-let p1 cI =
- Pc cI
-
-(** val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool **)
-
-let rec peq ceqb p p' =
- match p with
- | Pc c -> (match p' with
- | Pc c' -> ceqb c c'
- | _ -> False)
- | Pinj (j, q0) ->
- (match p' with
- | Pinj (j', q') ->
- (match pcompare j j' Eq with
- | Eq -> peq ceqb q0 q'
- | _ -> False)
- | _ -> False)
- | PX (p2, i, q0) ->
- (match p' with
- | PX (p'0, i', q') ->
- (match pcompare i i' Eq with
- | Eq ->
- (match peq ceqb p2 p'0 with
- | True -> peq ceqb q0 q'
- | False -> False)
- | _ -> False)
- | _ -> False)
-
-(** val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol **)
-
-let mkPinj_pred j p =
- match j with
- | XI j0 -> Pinj ((XO j0), p)
- | XO j0 -> Pinj ((pdouble_minus_one j0), p)
- | XH -> p
-
-(** val mkPX :
- 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **)
-
-let mkPX cO ceqb p i q0 =
- match p with
- | Pc c ->
- (match ceqb c cO with
- | True ->
- (match q0 with
- | Pc c0 -> q0
- | Pinj (j', q1) -> Pinj ((pplus XH j'), q1)
- | PX (p2, p3, p4) -> Pinj (XH, q0))
- | False -> PX (p, i, q0))
- | Pinj (p2, p3) -> PX (p, i, q0)
- | PX (p', i', q') ->
- (match peq ceqb q' (p0 cO) with
- | True -> PX (p', (pplus i' i), q0)
- | False -> PX (p, i, q0))
-
-(** val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol **)
-
-let mkXi cO cI i =
- PX ((p1 cI), i, (p0 cO))
-
-(** val mkX : 'a1 -> 'a1 -> 'a1 pol **)
-
-let mkX cO cI =
- mkXi cO cI XH
-
-(** val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol **)
-
-let rec popp copp = function
- | Pc c -> Pc (copp c)
- | Pinj (j, q0) -> Pinj (j, (popp copp q0))
- | PX (p2, i, q0) -> PX ((popp copp p2), i, (popp copp q0))
-
-(** val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **)
-
-let rec paddC cadd p c =
- match p with
- | Pc c1 -> Pc (cadd c1 c)
- | Pinj (j, q0) -> Pinj (j, (paddC cadd q0 c))
- | PX (p2, i, q0) -> PX (p2, i, (paddC cadd q0 c))
-
-(** val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **)
-
-let rec psubC csub p c =
- match p with
- | Pc c1 -> Pc (csub c1 c)
- | Pinj (j, q0) -> Pinj (j, (psubC csub q0 c))
- | PX (p2, i, q0) -> PX (p2, i, (psubC csub q0 c))
-
-(** val paddI :
- ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol ->
- positive -> 'a1 pol -> 'a1 pol **)
-
-let rec paddI cadd pop q0 j = function
- | Pc c ->
- let p2 = paddC cadd q0 c in
- (match p2 with
- | Pc c0 -> p2
- | Pinj (j', q1) -> Pinj ((pplus j j'), q1)
- | PX (p3, p4, p5) -> Pinj (j, p2))
- | Pinj (j', q') ->
- (match zPminus j' j with
- | Z0 ->
- let p2 = pop q' q0 in
- (match p2 with
- | Pc c -> p2
- | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1)
- | PX (p3, p4, p5) -> Pinj (j, p2))
- | Zpos k ->
- let p2 = pop (Pinj (k, q')) q0 in
- (match p2 with
- | Pc c -> p2
- | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1)
- | PX (p3, p4, p5) -> Pinj (j, p2))
- | Zneg k ->
- let p2 = paddI cadd pop q0 k q' in
- (match p2 with
- | Pc c -> p2
- | Pinj (j'0, q1) -> Pinj ((pplus j' j'0), q1)
- | PX (p3, p4, p5) -> Pinj (j', p2)))
- | PX (p2, i, q') ->
- (match j with
- | XI j0 -> PX (p2, i, (paddI cadd pop q0 (XO j0) q'))
- | XO j0 -> PX (p2, i, (paddI cadd pop q0 (pdouble_minus_one j0) q'))
- | XH -> PX (p2, i, (pop q' q0)))
-
-(** val psubI :
- ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) ->
- 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **)
-
-let rec psubI cadd copp pop q0 j = function
- | Pc c ->
- let p2 = paddC cadd (popp copp q0) c in
- (match p2 with
- | Pc c0 -> p2
- | Pinj (j', q1) -> Pinj ((pplus j j'), q1)
- | PX (p3, p4, p5) -> Pinj (j, p2))
- | Pinj (j', q') ->
- (match zPminus j' j with
- | Z0 ->
- let p2 = pop q' q0 in
- (match p2 with
- | Pc c -> p2
- | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1)
- | PX (p3, p4, p5) -> Pinj (j, p2))
- | Zpos k ->
- let p2 = pop (Pinj (k, q')) q0 in
- (match p2 with
- | Pc c -> p2
- | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1)
- | PX (p3, p4, p5) -> Pinj (j, p2))
- | Zneg k ->
- let p2 = psubI cadd copp pop q0 k q' in
- (match p2 with
- | Pc c -> p2
- | Pinj (j'0, q1) -> Pinj ((pplus j' j'0), q1)
- | PX (p3, p4, p5) -> Pinj (j', p2)))
- | PX (p2, i, q') ->
- (match j with
- | XI j0 -> PX (p2, i, (psubI cadd copp pop q0 (XO j0) q'))
- | XO j0 -> PX (p2, i,
- (psubI cadd copp pop q0 (pdouble_minus_one j0) q'))
- | XH -> PX (p2, i, (pop q' q0)))
-
-(** val paddX :
- 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol
- -> positive -> 'a1 pol -> 'a1 pol **)
-
-let rec paddX cO ceqb pop p' i' p = match p with
- | Pc c -> PX (p', i', p)
- | Pinj (j, q') ->
- (match j with
- | XI j0 -> PX (p', i', (Pinj ((XO j0), q')))
- | XO j0 -> PX (p', i', (Pinj ((pdouble_minus_one j0), q')))
- | XH -> PX (p', i', q'))
- | PX (p2, i, q') ->
- (match zPminus i i' with
- | Z0 -> mkPX cO ceqb (pop p2 p') i q'
- | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q'
- | Zneg k -> mkPX cO ceqb (paddX cO ceqb pop p' k p2) i q')
-
-(** val psubX :
- 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1
- pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **)
-
-let rec psubX cO copp ceqb pop p' i' p = match p with
- | Pc c -> PX ((popp copp p'), i', p)
- | Pinj (j, q') ->
- (match j with
- | XI j0 -> PX ((popp copp p'), i', (Pinj ((XO j0), q')))
- | XO j0 -> PX ((popp copp p'), i', (Pinj (
- (pdouble_minus_one j0), q')))
- | XH -> PX ((popp copp p'), i', q'))
- | PX (p2, i, q') ->
- (match zPminus i i' with
- | Z0 -> mkPX cO ceqb (pop p2 p') i q'
- | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q'
- | Zneg k -> mkPX cO ceqb (psubX cO copp ceqb pop p' k p2) i q')
-
-(** val padd :
- 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol
- -> 'a1 pol **)
-
-let rec padd cO cadd ceqb p = function
- | Pc c' -> paddC cadd p c'
- | Pinj (j', q') -> paddI cadd (fun x x0 -> padd cO cadd ceqb x x0) q' j' p
- | PX (p'0, i', q') ->
- (match p with
- | Pc c -> PX (p'0, i', (paddC cadd q' c))
- | Pinj (j, q0) ->
- (match j with
- | XI j0 -> PX (p'0, i',
- (padd cO cadd ceqb (Pinj ((XO j0), q0)) q'))
- | XO j0 -> PX (p'0, i',
- (padd cO cadd ceqb (Pinj ((pdouble_minus_one j0), q0))
- q'))
- | XH -> PX (p'0, i', (padd cO cadd ceqb q0 q')))
- | PX (p2, i, q0) ->
- (match zPminus i i' with
- | Z0 ->
- mkPX cO ceqb (padd cO cadd ceqb p2 p'0) i
- (padd cO cadd ceqb q0 q')
- | Zpos k ->
- mkPX cO ceqb
- (padd cO cadd ceqb (PX (p2, k, (p0 cO))) p'0) i'
- (padd cO cadd ceqb q0 q')
- | Zneg k ->
- mkPX cO ceqb
- (paddX cO ceqb (fun x x0 -> padd cO cadd ceqb x x0) p'0
- k p2) i (padd cO cadd ceqb q0 q')))
-
-(** val psub :
- 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1
- -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **)
-
-let rec psub cO cadd csub copp ceqb p = function
- | Pc c' -> psubC csub p c'
- | Pinj (j', q') ->
- psubI cadd copp (fun x x0 -> psub cO cadd csub copp ceqb x x0) q' j' p
- | PX (p'0, i', q') ->
- (match p with
- | Pc c -> PX ((popp copp p'0), i', (paddC cadd (popp copp q') c))
- | Pinj (j, q0) ->
- (match j with
- | XI j0 -> PX ((popp copp p'0), i',
- (psub cO cadd csub copp ceqb (Pinj ((XO j0), q0)) q'))
- | XO j0 -> PX ((popp copp p'0), i',
- (psub cO cadd csub copp ceqb (Pinj
- ((pdouble_minus_one j0), q0)) q'))
- | XH -> PX ((popp copp p'0), i',
- (psub cO cadd csub copp ceqb q0 q')))
- | PX (p2, i, q0) ->
- (match zPminus i i' with
- | Z0 ->
- mkPX cO ceqb (psub cO cadd csub copp ceqb p2 p'0) i
- (psub cO cadd csub copp ceqb q0 q')
- | Zpos k ->
- mkPX cO ceqb
- (psub cO cadd csub copp ceqb (PX (p2, k, (p0 cO))) p'0)
- i' (psub cO cadd csub copp ceqb q0 q')
- | Zneg k ->
- mkPX cO ceqb
- (psubX cO copp ceqb (fun x x0 ->
- psub cO cadd csub copp ceqb x x0) p'0 k p2) i
- (psub cO cadd csub copp ceqb q0 q')))
-
-(** val pmulC_aux :
- 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 ->
- 'a1 pol **)
-
-let rec pmulC_aux cO cmul ceqb p c =
- match p with
- | Pc c' -> Pc (cmul c' c)
- | Pinj (j, q0) ->
- let p2 = pmulC_aux cO cmul ceqb q0 c in
- (match p2 with
- | Pc c0 -> p2
- | Pinj (j', q1) -> Pinj ((pplus j j'), q1)
- | PX (p3, p4, p5) -> Pinj (j, p2))
- | PX (p2, i, q0) ->
- mkPX cO ceqb (pmulC_aux cO cmul ceqb p2 c) i
- (pmulC_aux cO cmul ceqb q0 c)
-
-(** val pmulC :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol ->
- 'a1 -> 'a1 pol **)
-
-let pmulC cO cI cmul ceqb p c =
- match ceqb c cO with
- | True -> p0 cO
- | False ->
- (match ceqb c cI with
- | True -> p
- | False -> pmulC_aux cO cmul ceqb p c)
-
-(** val pmulI :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol ->
- 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **)
-
-let rec pmulI cO cI cmul ceqb pmul0 q0 j = function
- | Pc c ->
- let p2 = pmulC cO cI cmul ceqb q0 c in
- (match p2 with
- | Pc c0 -> p2
- | Pinj (j', q1) -> Pinj ((pplus j j'), q1)
- | PX (p3, p4, p5) -> Pinj (j, p2))
- | Pinj (j', q') ->
- (match zPminus j' j with
- | Z0 ->
- let p2 = pmul0 q' q0 in
- (match p2 with
- | Pc c -> p2
- | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1)
- | PX (p3, p4, p5) -> Pinj (j, p2))
- | Zpos k ->
- let p2 = pmul0 (Pinj (k, q')) q0 in
- (match p2 with
- | Pc c -> p2
- | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1)
- | PX (p3, p4, p5) -> Pinj (j, p2))
- | Zneg k ->
- let p2 = pmulI cO cI cmul ceqb pmul0 q0 k q' in
- (match p2 with
- | Pc c -> p2
- | Pinj (j'0, q1) -> Pinj ((pplus j' j'0), q1)
- | PX (p3, p4, p5) -> Pinj (j', p2)))
- | PX (p', i', q') ->
- (match j with
- | XI j' ->
- mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i'
- (pmulI cO cI cmul ceqb pmul0 q0 (XO j') q')
- | XO j' ->
- mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i'
- (pmulI cO cI cmul ceqb pmul0 q0 (pdouble_minus_one j') q')
- | XH ->
- mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 XH p') i'
- (pmul0 q' q0))
-
-(** val pmul :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
- -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **)
-
-let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with
- | Pc c -> pmulC cO cI cmul ceqb p c
- | Pinj (j', q') ->
- pmulI cO cI cmul ceqb (fun x x0 -> pmul cO cI cadd cmul ceqb x x0) q'
- j' p
- | PX (p', i', q') ->
- (match p with
- | Pc c -> pmulC cO cI cmul ceqb p'' c
- | Pinj (j, q0) ->
- mkPX cO ceqb (pmul cO cI cadd cmul ceqb p p') i'
- (match j with
- | XI j0 ->
- pmul cO cI cadd cmul ceqb (Pinj ((XO j0), q0)) q'
- | XO j0 ->
- pmul cO cI cadd cmul ceqb (Pinj
- ((pdouble_minus_one j0), q0)) q'
- | XH -> pmul cO cI cadd cmul ceqb q0 q')
- | PX (p2, i, q0) ->
- padd cO cadd ceqb
- (mkPX cO ceqb
- (padd cO cadd ceqb
- (mkPX cO ceqb (pmul cO cI cadd cmul ceqb p2 p') i (p0 cO))
- (pmul cO cI cadd cmul ceqb
- (match q0 with
- | Pc c -> q0
- | Pinj (j', q1) -> Pinj ((pplus XH j'), q1)
- | PX (p3, p4, p5) -> Pinj (XH, q0)) p')) i'
- (p0 cO))
- (mkPX cO ceqb
- (pmulI cO cI cmul ceqb (fun x x0 ->
- pmul cO cI cadd cmul ceqb x x0) q' XH p2) i
- (pmul cO cI cadd cmul ceqb q0 q')))
-
-type 'c pExpr =
- | PEc of 'c
- | PEX of positive
- | PEadd of 'c pExpr * 'c pExpr
- | PEsub of 'c pExpr * 'c pExpr
- | PEmul of 'c pExpr * 'c pExpr
- | PEopp of 'c pExpr
- | PEpow of 'c pExpr * n
-
-(** val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol **)
-
-let mk_X cO cI j =
- mkPinj_pred j (mkX cO cI)
-
-(** val ppow_pos :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
- -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1
- pol **)
-
-let rec ppow_pos cO cI cadd cmul ceqb subst_l res p = function
- | XI p3 ->
- subst_l
- (pmul cO cI cadd cmul ceqb
- (ppow_pos cO cI cadd cmul ceqb subst_l
- (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3) p)
- | XO p3 ->
- ppow_pos cO cI cadd cmul ceqb subst_l
- (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3
- | XH -> subst_l (pmul cO cI cadd cmul ceqb res p)
-
-(** val ppow_N :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
- -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol **)
-
-let ppow_N cO cI cadd cmul ceqb subst_l p = function
- | N0 -> p1 cI
- | Npos p2 -> ppow_pos cO cI cadd cmul ceqb subst_l (p1 cI) p p2
-
-(** val norm_aux :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
- -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **)
-
-let rec norm_aux cO cI cadd cmul csub copp ceqb = function
- | PEc c -> Pc c
- | PEX j -> mk_X cO cI j
- | PEadd (pe1, pe2) ->
- (match pe1 with
- | PEopp pe3 ->
- psub cO cadd csub copp ceqb
- (norm_aux cO cI cadd cmul csub copp ceqb pe2)
- (norm_aux cO cI cadd cmul csub copp ceqb pe3)
- | _ ->
- (match pe2 with
- | PEopp pe3 ->
- psub cO cadd csub copp ceqb
- (norm_aux cO cI cadd cmul csub copp ceqb pe1)
- (norm_aux cO cI cadd cmul csub copp ceqb pe3)
- | _ ->
- padd cO cadd ceqb
- (norm_aux cO cI cadd cmul csub copp ceqb pe1)
- (norm_aux cO cI cadd cmul csub copp ceqb pe2)))
- | PEsub (pe1, pe2) ->
- psub cO cadd csub copp ceqb
- (norm_aux cO cI cadd cmul csub copp ceqb pe1)
- (norm_aux cO cI cadd cmul csub copp ceqb pe2)
- | PEmul (pe1, pe2) ->
- pmul cO cI cadd cmul ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1)
- (norm_aux cO cI cadd cmul csub copp ceqb pe2)
- | PEopp pe1 -> popp copp (norm_aux cO cI cadd cmul csub copp ceqb pe1)
- | PEpow (pe1, n0) ->
- ppow_N cO cI cadd cmul ceqb (fun p -> p)
- (norm_aux cO cI cadd cmul csub copp ceqb pe1) n0
-
-type 'a bFormula =
- | TT
- | FF
- | X
- | A of 'a
- | Cj of 'a bFormula * 'a bFormula
- | D of 'a bFormula * 'a bFormula
- | N of 'a bFormula
- | I of 'a bFormula * 'a bFormula
-
-type 'term' clause = 'term' list
-
-type 'term' cnf = 'term' clause list
-
-(** val tt : 'a1 cnf **)
-
-let tt =
- Nil
-
-(** val ff : 'a1 cnf **)
-
-let ff =
- Cons (Nil, Nil)
-
-(** val or_clause_cnf : 'a1 clause -> 'a1 cnf -> 'a1 cnf **)
-
-let or_clause_cnf t0 f =
- map (fun x -> app t0 x) f
-
-(** val or_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **)
-
-let rec or_cnf f f' =
- match f with
- | Nil -> tt
- | Cons (e, rst) -> app (or_cnf rst f') (or_clause_cnf e f')
-
-(** val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **)
-
-let and_cnf f1 f2 =
- app f1 f2
-
-(** val xcnf :
- ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **)
-
-let rec xcnf normalise0 negate0 pol0 = function
- | TT -> (match pol0 with
- | True -> tt
- | False -> ff)
- | FF -> (match pol0 with
- | True -> ff
- | False -> tt)
- | X -> ff
- | A x -> (match pol0 with
- | True -> normalise0 x
- | False -> negate0 x)
- | Cj (e1, e2) ->
- (match pol0 with
- | True ->
- and_cnf (xcnf normalise0 negate0 pol0 e1)
- (xcnf normalise0 negate0 pol0 e2)
- | False ->
- or_cnf (xcnf normalise0 negate0 pol0 e1)
- (xcnf normalise0 negate0 pol0 e2))
- | D (e1, e2) ->
- (match pol0 with
- | True ->
- or_cnf (xcnf normalise0 negate0 pol0 e1)
- (xcnf normalise0 negate0 pol0 e2)
- | False ->
- and_cnf (xcnf normalise0 negate0 pol0 e1)
- (xcnf normalise0 negate0 pol0 e2))
- | N e -> xcnf normalise0 negate0 (negb pol0) e
- | I (e1, e2) ->
- (match pol0 with
- | True ->
- or_cnf (xcnf normalise0 negate0 (negb pol0) e1)
- (xcnf normalise0 negate0 pol0 e2)
- | False ->
- and_cnf (xcnf normalise0 negate0 (negb pol0) e1)
- (xcnf normalise0 negate0 pol0 e2))
-
-(** val cnf_checker :
- ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool **)
-
-let rec cnf_checker checker f l =
- match f with
- | Nil -> True
- | Cons (e, f0) ->
- (match l with
- | Nil -> False
- | Cons (c, l0) ->
- (match checker e c with
- | True -> cnf_checker checker f0 l0
- | False -> False))
-
-(** val tauto_checker :
- ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1
- bFormula -> 'a3 list -> bool **)
-
-let tauto_checker normalise0 negate0 checker f w =
- cnf_checker checker (xcnf normalise0 negate0 True f) w
-
-type 'c pExprC = 'c pExpr
-
-type 'c polC = 'c pol
-
-type op1 =
- | Equal
- | NonEqual
- | Strict
- | NonStrict
-
-type 'c nFormula = ('c pExprC, op1) prod
-
-type monoidMember = nat list
-
-type 'c coneMember =
- | S_In of nat
- | S_Ideal of 'c pExprC * 'c coneMember
- | S_Square of 'c pExprC
- | S_Monoid of monoidMember
- | S_Mult of 'c coneMember * 'c coneMember
- | S_Add of 'c coneMember * 'c coneMember
- | S_Pos of 'c
- | S_Z
-
-(** val nformula_times : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula **)
-
-let nformula_times f f' =
- let Pair (p, op) = f in
- let Pair (p', op') = f' in
- Pair ((PEmul (p, p')),
- (match op with
- | Equal -> Equal
- | NonEqual -> NonEqual
- | Strict -> op'
- | NonStrict -> NonStrict))
-
-(** val nformula_plus : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula **)
-
-let nformula_plus f f' =
- let Pair (p, op) = f in
- let Pair (p', op') = f' in
- Pair ((PEadd (p, p')),
- (match op with
- | Equal -> op'
- | NonEqual -> NonEqual
- | Strict -> Strict
- | NonStrict -> (match op' with
- | Strict -> Strict
- | _ -> NonStrict)))
-
-(** val eval_monoid :
- 'a1 -> 'a1 nFormula list -> monoidMember -> 'a1 pExprC **)
-
-let rec eval_monoid cI l = function
- | Nil -> PEc cI
- | Cons (n0, ns0) -> PEmul
- ((let Pair (q0, o) = nth n0 l (Pair ((PEc cI), NonEqual)) in
- (match o with
- | NonEqual -> q0
- | _ -> PEc cI)), (eval_monoid cI l ns0))
-
-(** val eval_cone :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1
- nFormula list -> 'a1 coneMember -> 'a1 nFormula **)
-
-let rec eval_cone cO cI ceqb cleb l = function
- | S_In n0 ->
- let Pair (p, o) = nth n0 l (Pair ((PEc cO), Equal)) in
- (match o with
- | NonEqual -> Pair ((PEc cO), Equal)
- | _ -> nth n0 l (Pair ((PEc cO), Equal)))
- | S_Ideal (p, cm') ->
- let f = eval_cone cO cI ceqb cleb l cm' in
- let Pair (q0, op) = f in
- (match op with
- | Equal -> Pair ((PEmul (q0, p)), Equal)
- | _ -> f)
- | S_Square p -> Pair ((PEmul (p, p)), NonStrict)
- | S_Monoid m -> let p = eval_monoid cI l m in Pair ((PEmul (p, p)), Strict)
- | S_Mult (p, q0) ->
- nformula_times (eval_cone cO cI ceqb cleb l p)
- (eval_cone cO cI ceqb cleb l q0)
- | S_Add (p, q0) ->
- nformula_plus (eval_cone cO cI ceqb cleb l p)
- (eval_cone cO cI ceqb cleb l q0)
- | S_Pos c ->
- (match match cleb cO c with
- | True -> negb (ceqb cO c)
- | False -> False with
- | True -> Pair ((PEc c), Strict)
- | False -> Pair ((PEc cO), Equal))
- | S_Z -> Pair ((PEc cO), Equal)
-
-(** val normalise_pexpr :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
- -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 polC **)
-
-let normalise_pexpr cO cI cplus ctimes cminus copp ceqb x =
- norm_aux cO cI cplus ctimes cminus copp ceqb x
-
-(** val check_inconsistent :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
- -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool)
- -> 'a1 nFormula -> bool **)
-
-let check_inconsistent cO cI cplus ctimes cminus copp ceqb cleb = function
- | Pair (e, op) ->
- (match normalise_pexpr cO cI cplus ctimes cminus copp ceqb e with
- | Pc c ->
- (match op with
- | Equal -> negb (ceqb c cO)
- | NonEqual -> False
- | Strict -> cleb c cO
- | NonStrict ->
- (match cleb c cO with
- | True -> negb (ceqb c cO)
- | False -> False))
- | _ -> False)
-
-(** val check_normalised_formulas :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
- -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool)
- -> 'a1 nFormula list -> 'a1 coneMember -> bool **)
-
-let check_normalised_formulas cO cI cplus ctimes cminus copp ceqb cleb l cm =
- check_inconsistent cO cI cplus ctimes cminus copp ceqb cleb
- (eval_cone cO cI ceqb cleb l cm)
-
-type op2 =
- | OpEq
- | OpNEq
- | OpLe
- | OpGe
- | OpLt
- | OpGt
-
-type 'c formula = { flhs : 'c pExprC; fop : op2; frhs : 'c pExprC }
-
-(** val flhs : 'a1 formula -> 'a1 pExprC **)
-
-let flhs x = x.flhs
-
-(** val fop : 'a1 formula -> op2 **)
-
-let fop x = x.fop
-
-(** val frhs : 'a1 formula -> 'a1 pExprC **)
-
-let frhs x = x.frhs
-
-(** val xnormalise : 'a1 formula -> 'a1 nFormula list **)
-
-let xnormalise t0 =
- let { flhs = lhs; fop = o; frhs = rhs } = t0 in
- (match o with
- | OpEq -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), (Cons ((Pair
- ((PEsub (rhs, lhs)), Strict)), Nil)))
- | OpNEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil)
- | OpLe -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), Nil)
- | OpGe -> Cons ((Pair ((PEsub (rhs, lhs)), Strict)), Nil)
- | OpLt -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil)
- | OpGt -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil))
-
-(** val cnf_normalise : 'a1 formula -> 'a1 nFormula cnf **)
-
-let cnf_normalise t0 =
- map (fun x -> Cons (x, Nil)) (xnormalise t0)
-
-(** val xnegate : 'a1 formula -> 'a1 nFormula list **)
-
-let xnegate t0 =
- let { flhs = lhs; fop = o; frhs = rhs } = t0 in
- (match o with
- | OpEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil)
- | OpNEq -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), (Cons ((Pair
- ((PEsub (rhs, lhs)), Strict)), Nil)))
- | OpLe -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil)
- | OpGe -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil)
- | OpLt -> Cons ((Pair ((PEsub (rhs, lhs)), Strict)), Nil)
- | OpGt -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), Nil))
-
-(** val cnf_negate : 'a1 formula -> 'a1 nFormula cnf **)
-
-let cnf_negate t0 =
- map (fun x -> Cons (x, Nil)) (xnegate t0)
-
-(** val simpl_expr :
- 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 pExprC **)
-
-let rec simpl_expr cI ceqb e = match e with
- | PEadd (x, y) -> PEadd ((simpl_expr cI ceqb x), (simpl_expr cI ceqb y))
- | PEmul (y, z0) ->
- let y' = simpl_expr cI ceqb y in
- (match y' with
- | PEc c ->
- (match ceqb c cI with
- | True -> simpl_expr cI ceqb z0
- | False -> PEmul (y', (simpl_expr cI ceqb z0)))
- | _ -> PEmul (y', (simpl_expr cI ceqb z0)))
- | _ -> e
-
-(** val simpl_cone :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1
- coneMember -> 'a1 coneMember **)
-
-let simpl_cone cO cI ctimes ceqb e = match e with
- | S_Square t0 ->
- (match simpl_expr cI ceqb t0 with
- | PEc c ->
- (match ceqb cO c with
- | True -> S_Z
- | False -> S_Pos (ctimes c c))
- | _ -> S_Square (simpl_expr cI ceqb t0))
- | S_Mult (t1, t2) ->
- (match t1 with
- | S_Mult (x, x0) ->
- (match x with
- | S_Pos p2 ->
- (match t2 with
- | S_Pos c -> S_Mult ((S_Pos (ctimes c p2)), x0)
- | S_Z -> S_Z
- | _ -> e)
- | _ ->
- (match x0 with
- | S_Pos p2 ->
- (match t2 with
- | S_Pos c -> S_Mult ((S_Pos (ctimes c p2)), x)
- | S_Z -> S_Z
- | _ -> e)
- | _ ->
- (match t2 with
- | S_Pos c ->
- (match ceqb cI c with
- | True -> t1
- | False -> S_Mult (t1, t2))
- | S_Z -> S_Z
- | _ -> e)))
- | S_Pos c ->
- (match t2 with
- | S_Mult (x, x0) ->
- (match x with
- | S_Pos p2 -> S_Mult ((S_Pos (ctimes c p2)), x0)
- | _ ->
- (match x0 with
- | S_Pos p2 -> S_Mult ((S_Pos (ctimes c p2)), x)
- | _ ->
- (match ceqb cI c with
- | True -> t2
- | False -> S_Mult (t1, t2))))
- | S_Add (y, z0) -> S_Add ((S_Mult ((S_Pos c), y)), (S_Mult
- ((S_Pos c), z0)))
- | S_Pos c0 -> S_Pos (ctimes c c0)
- | S_Z -> S_Z
- | _ ->
- (match ceqb cI c with
- | True -> t2
- | False -> S_Mult (t1, t2)))
- | S_Z -> S_Z
- | _ ->
- (match t2 with
- | S_Pos c ->
- (match ceqb cI c with
- | True -> t1
- | False -> S_Mult (t1, t2))
- | S_Z -> S_Z
- | _ -> e))
- | S_Add (t1, t2) ->
- (match t1 with
- | S_Z -> t2
- | _ -> (match t2 with
- | S_Z -> t1
- | _ -> S_Add (t1, t2)))
- | _ -> e
-
-type q = { qnum : z; qden : positive }
-
-(** val qnum : q -> z **)
-
-let qnum x = x.qnum
-
-(** val qden : q -> positive **)
-
-let qden x = x.qden
-
-(** val qplus : q -> q -> q **)
-
-let qplus x y =
- { qnum = (zplus (zmult x.qnum (Zpos y.qden)) (zmult y.qnum (Zpos x.qden)));
- qden = (pmult x.qden y.qden) }
-
-(** val qmult : q -> q -> q **)
-
-let qmult x y =
- { qnum = (zmult x.qnum y.qnum); qden = (pmult x.qden y.qden) }
-
-(** val qopp : q -> q **)
-
-let qopp x =
- { qnum = (zopp x.qnum); qden = x.qden }
-
-(** val qminus : q -> q -> q **)
-
-let qminus x y =
- qplus x (qopp y)
-
-type 'a t =
- | Empty
- | Leaf of 'a
- | Node of 'a t * 'a * 'a t
-
-(** val find : 'a1 -> 'a1 t -> positive -> 'a1 **)
-
-let rec find default vm p =
- match vm with
- | Empty -> default
- | Leaf i -> i
- | Node (l, e, r) ->
- (match p with
- | XI p2 -> find default r p2
- | XO p2 -> find default l p2
- | XH -> e)
-
-type zWitness = z coneMember
-
-(** val zWeakChecker : z nFormula list -> z coneMember -> bool **)
-
-let zWeakChecker x x0 =
- check_normalised_formulas Z0 (Zpos XH) zplus zmult zminus zopp zeq_bool
- zle_bool x x0
-
-(** val xnormalise0 : z formula -> z nFormula list **)
-
-let xnormalise0 t0 =
- let { flhs = lhs; fop = o; frhs = rhs } = t0 in
- (match o with
- | OpEq -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))),
- NonStrict)), (Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos
- XH)))))), NonStrict)), Nil)))
- | OpNEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil)
- | OpLe -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))),
- NonStrict)), Nil)
- | OpGe -> Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos XH)))))),
- NonStrict)), Nil)
- | OpLt -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil)
- | OpGt -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil))
-
-(** val normalise : z formula -> z nFormula cnf **)
-
-let normalise t0 =
- map (fun x -> Cons (x, Nil)) (xnormalise0 t0)
-
-(** val xnegate0 : z formula -> z nFormula list **)
-
-let xnegate0 t0 =
- let { flhs = lhs; fop = o; frhs = rhs } = t0 in
- (match o with
- | OpEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil)
- | OpNEq -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))),
- NonStrict)), (Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos
- XH)))))), NonStrict)), Nil)))
- | OpLe -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil)
- | OpGe -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil)
- | OpLt -> Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos XH)))))),
- NonStrict)), Nil)
- | OpGt -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))),
- NonStrict)), Nil))
-
-(** val negate : z formula -> z nFormula cnf **)
-
-let negate t0 =
- map (fun x -> Cons (x, Nil)) (xnegate0 t0)
-
-(** val ceiling : z -> z -> z **)
-
-let ceiling a b =
- let Pair (q0, r) = zdiv_eucl a b in
- (match r with
- | Z0 -> q0
- | _ -> zplus q0 (Zpos XH))
-
-type proofTerm =
- | RatProof of zWitness
- | CutProof of z pExprC * q * zWitness * proofTerm
- | EnumProof of q * z pExprC * q * zWitness * zWitness * proofTerm list
-
-(** val makeLb : z pExpr -> q -> z nFormula **)
-
-let makeLb v q0 =
- let { qnum = n0; qden = d } = q0 in
- Pair ((PEsub ((PEmul ((PEc (Zpos d)), v)), (PEc n0))), NonStrict)
-
-(** val qceiling : q -> z **)
-
-let qceiling q0 =
- let { qnum = n0; qden = d } = q0 in ceiling n0 (Zpos d)
-
-(** val makeLbCut : z pExprC -> q -> z nFormula **)
-
-let makeLbCut v q0 =
- Pair ((PEsub (v, (PEc (qceiling q0)))), NonStrict)
-
-(** val neg_nformula : z nFormula -> (z pExpr, op1) prod **)
-
-let neg_nformula = function
- | Pair (e, o) -> Pair ((PEopp (PEadd (e, (PEc (Zpos XH))))), o)
-
-(** val cutChecker :
- z nFormula list -> z pExpr -> q -> zWitness -> z nFormula option **)
-
-let cutChecker l e lb pf =
- match zWeakChecker (Cons ((neg_nformula (makeLb e lb)), l)) pf with
- | True -> Some (makeLbCut e lb)
- | False -> None
-
-(** val zChecker : z nFormula list -> proofTerm -> bool **)
-
-let rec zChecker l = function
- | RatProof pf0 -> zWeakChecker l pf0
- | CutProof (e, q0, pf0, rst) ->
- (match cutChecker l e q0 pf0 with
- | Some c -> zChecker (Cons (c, l)) rst
- | None -> False)
- | EnumProof (lb, e, ub, pf1, pf2, rst) ->
- (match cutChecker l e lb pf1 with
- | Some n0 ->
- (match cutChecker l (PEopp e) (qopp ub) pf2 with
- | Some n1 ->
- let rec label pfs lb0 ub0 =
- match pfs with
- | Nil ->
- (match z_gt_dec lb0 ub0 with
- | Left -> True
- | Right -> False)
- | Cons (pf0, rsr) ->
- (match zChecker (Cons ((Pair ((PEsub (e, (PEc
- lb0))), Equal)), l)) pf0 with
- | True -> label rsr (zplus lb0 (Zpos XH)) ub0
- | False -> False)
- in label rst (qceiling lb) (zopp (qceiling (qopp ub)))
- | None -> False)
- | None -> False)
-
-(** val zTautoChecker : z formula bFormula -> proofTerm list -> bool **)
-
-let zTautoChecker f w =
- tauto_checker normalise negate zChecker f w
-
-(** val map_cone : (nat -> nat) -> zWitness -> zWitness **)
-
-let rec map_cone f e = match e with
- | S_In n0 -> S_In (f n0)
- | S_Ideal (e0, cm) -> S_Ideal (e0, (map_cone f cm))
- | S_Monoid l -> S_Monoid (map f l)
- | S_Mult (cm1, cm2) -> S_Mult ((map_cone f cm1), (map_cone f cm2))
- | S_Add (cm1, cm2) -> S_Add ((map_cone f cm1), (map_cone f cm2))
- | _ -> e
-
-(** val indexes : zWitness -> nat list **)
-
-let rec indexes = function
- | S_In n0 -> Cons (n0, Nil)
- | S_Ideal (e0, cm) -> indexes cm
- | S_Monoid l -> l
- | S_Mult (cm1, cm2) -> app (indexes cm1) (indexes cm2)
- | S_Add (cm1, cm2) -> app (indexes cm1) (indexes cm2)
- | _ -> Nil
-
-(** val n_of_Z : z -> n **)
-
-let n_of_Z = function
- | Zpos p -> Npos p
- | _ -> N0
-
-(** val qeq_bool : q -> q -> bool **)
-
-let qeq_bool p q0 =
- zeq_bool (zmult p.qnum (Zpos q0.qden)) (zmult q0.qnum (Zpos p.qden))
-
-(** val qle_bool : q -> q -> bool **)
-
-let qle_bool x y =
- zle_bool (zmult x.qnum (Zpos y.qden)) (zmult y.qnum (Zpos x.qden))
-
-type qWitness = q coneMember
-
-(** val qWeakChecker : q nFormula list -> q coneMember -> bool **)
-
-let qWeakChecker x x0 =
- check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH);
- qden = XH } qplus qmult qminus qopp qeq_bool qle_bool x x0
-
-(** val qTautoChecker : q formula bFormula -> qWitness list -> bool **)
-
-let qTautoChecker f w =
- tauto_checker (fun x -> cnf_normalise x) (fun x ->
- cnf_negate x) qWeakChecker f w
-
diff --git a/contrib/micromega/micromega.mli b/contrib/micromega/micromega.mli
deleted file mode 100644
index f94f091e..00000000
--- a/contrib/micromega/micromega.mli
+++ /dev/null
@@ -1,398 +0,0 @@
-type __ = Obj.t
-
-type bool =
- | True
- | False
-
-val negb : bool -> bool
-
-type nat =
- | O
- | S of nat
-
-type 'a option =
- | Some of 'a
- | None
-
-type ('a, 'b) prod =
- | Pair of 'a * 'b
-
-type comparison =
- | Eq
- | Lt
- | Gt
-
-val compOpp : comparison -> comparison
-
-type sumbool =
- | Left
- | Right
-
-type 'a sumor =
- | Inleft of 'a
- | Inright
-
-type 'a list =
- | Nil
- | Cons of 'a * 'a list
-
-val app : 'a1 list -> 'a1 list -> 'a1 list
-
-val nth : nat -> 'a1 list -> 'a1 -> 'a1
-
-val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list
-
-type positive =
- | XI of positive
- | XO of positive
- | XH
-
-val psucc : positive -> positive
-
-val pplus : positive -> positive -> positive
-
-val pplus_carry : positive -> positive -> positive
-
-val p_of_succ_nat : nat -> positive
-
-val pdouble_minus_one : positive -> positive
-
-type positive_mask =
- | IsNul
- | IsPos of positive
- | IsNeg
-
-val pdouble_plus_one_mask : positive_mask -> positive_mask
-
-val pdouble_mask : positive_mask -> positive_mask
-
-val pdouble_minus_two : positive -> positive_mask
-
-val pminus_mask : positive -> positive -> positive_mask
-
-val pminus_mask_carry : positive -> positive -> positive_mask
-
-val pminus : positive -> positive -> positive
-
-val pmult : positive -> positive -> positive
-
-val pcompare : positive -> positive -> comparison -> comparison
-
-type n =
- | N0
- | Npos of positive
-
-type z =
- | Z0
- | Zpos of positive
- | Zneg of positive
-
-val zdouble_plus_one : z -> z
-
-val zdouble_minus_one : z -> z
-
-val zdouble : z -> z
-
-val zPminus : positive -> positive -> z
-
-val zplus : z -> z -> z
-
-val zopp : z -> z
-
-val zminus : z -> z -> z
-
-val zmult : z -> z -> z
-
-val zcompare : z -> z -> comparison
-
-val dcompare_inf : comparison -> sumbool sumor
-
-val zcompare_rec : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1
-
-val z_gt_dec : z -> z -> sumbool
-
-val zle_bool : z -> z -> bool
-
-val zge_bool : z -> z -> bool
-
-val zgt_bool : z -> z -> bool
-
-val zeq_bool : z -> z -> bool
-
-val n_of_nat : nat -> n
-
-val zdiv_eucl_POS : positive -> z -> (z, z) prod
-
-val zdiv_eucl : z -> z -> (z, z) prod
-
-type 'c pol =
- | Pc of 'c
- | Pinj of positive * 'c pol
- | PX of 'c pol * positive * 'c pol
-
-val p0 : 'a1 -> 'a1 pol
-
-val p1 : 'a1 -> 'a1 pol
-
-val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool
-
-val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol
-
-val mkPX :
- 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol
-
-val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol
-
-val mkX : 'a1 -> 'a1 -> 'a1 pol
-
-val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol
-
-val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol
-
-val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol
-
-val paddI :
- ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol ->
- positive -> 'a1 pol -> 'a1 pol
-
-val psubI :
- ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) ->
- 'a1 pol -> positive -> 'a1 pol -> 'a1 pol
-
-val paddX :
- 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol
- -> positive -> 'a1 pol -> 'a1 pol
-
-val psubX :
- 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1
- pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol
-
-val padd :
- 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol ->
- 'a1 pol
-
-val psub :
- 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1
- -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol
-
-val pmulC_aux :
- 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1
- pol
-
-val pmulC :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1
- -> 'a1 pol
-
-val pmulI :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol ->
- 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol
-
-val pmul :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
- bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol
-
-type 'c pExpr =
- | PEc of 'c
- | PEX of positive
- | PEadd of 'c pExpr * 'c pExpr
- | PEsub of 'c pExpr * 'c pExpr
- | PEmul of 'c pExpr * 'c pExpr
- | PEopp of 'c pExpr
- | PEpow of 'c pExpr * n
-
-val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol
-
-val ppow_pos :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
- bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol
-
-val ppow_N :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
- bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol
-
-val norm_aux :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
- 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol
-
-type 'a bFormula =
- | TT
- | FF
- | X
- | A of 'a
- | Cj of 'a bFormula * 'a bFormula
- | D of 'a bFormula * 'a bFormula
- | N of 'a bFormula
- | I of 'a bFormula * 'a bFormula
-
-type 'term' clause = 'term' list
-
-type 'term' cnf = 'term' clause list
-
-val tt : 'a1 cnf
-
-val ff : 'a1 cnf
-
-val or_clause_cnf : 'a1 clause -> 'a1 cnf -> 'a1 cnf
-
-val or_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf
-
-val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf
-
-val xcnf :
- ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf
-
-val cnf_checker : ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool
-
-val tauto_checker :
- ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1
- bFormula -> 'a3 list -> bool
-
-type 'c pExprC = 'c pExpr
-
-type 'c polC = 'c pol
-
-type op1 =
- | Equal
- | NonEqual
- | Strict
- | NonStrict
-
-type 'c nFormula = ('c pExprC, op1) prod
-
-type monoidMember = nat list
-
-type 'c coneMember =
- | S_In of nat
- | S_Ideal of 'c pExprC * 'c coneMember
- | S_Square of 'c pExprC
- | S_Monoid of monoidMember
- | S_Mult of 'c coneMember * 'c coneMember
- | S_Add of 'c coneMember * 'c coneMember
- | S_Pos of 'c
- | S_Z
-
-val nformula_times : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula
-
-val nformula_plus : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula
-
-val eval_monoid : 'a1 -> 'a1 nFormula list -> monoidMember -> 'a1 pExprC
-
-val eval_cone :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula
- list -> 'a1 coneMember -> 'a1 nFormula
-
-val normalise_pexpr :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
- 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 polC
-
-val check_inconsistent :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
- 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1
- nFormula -> bool
-
-val check_normalised_formulas :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
- 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1
- nFormula list -> 'a1 coneMember -> bool
-
-type op2 =
- | OpEq
- | OpNEq
- | OpLe
- | OpGe
- | OpLt
- | OpGt
-
-type 'c formula = { flhs : 'c pExprC; fop : op2; frhs : 'c pExprC }
-
-val flhs : 'a1 formula -> 'a1 pExprC
-
-val fop : 'a1 formula -> op2
-
-val frhs : 'a1 formula -> 'a1 pExprC
-
-val xnormalise : 'a1 formula -> 'a1 nFormula list
-
-val cnf_normalise : 'a1 formula -> 'a1 nFormula cnf
-
-val xnegate : 'a1 formula -> 'a1 nFormula list
-
-val cnf_negate : 'a1 formula -> 'a1 nFormula cnf
-
-val simpl_expr : 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 pExprC
-
-val simpl_cone :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 coneMember
- -> 'a1 coneMember
-
-type q = { qnum : z; qden : positive }
-
-val qnum : q -> z
-
-val qden : q -> positive
-
-val qplus : q -> q -> q
-
-val qmult : q -> q -> q
-
-val qopp : q -> q
-
-val qminus : q -> q -> q
-
-type 'a t =
- | Empty
- | Leaf of 'a
- | Node of 'a t * 'a * 'a t
-
-val find : 'a1 -> 'a1 t -> positive -> 'a1
-
-type zWitness = z coneMember
-
-val zWeakChecker : z nFormula list -> z coneMember -> bool
-
-val xnormalise0 : z formula -> z nFormula list
-
-val normalise : z formula -> z nFormula cnf
-
-val xnegate0 : z formula -> z nFormula list
-
-val negate : z formula -> z nFormula cnf
-
-val ceiling : z -> z -> z
-
-type proofTerm =
- | RatProof of zWitness
- | CutProof of z pExprC * q * zWitness * proofTerm
- | EnumProof of q * z pExprC * q * zWitness * zWitness * proofTerm list
-
-val makeLb : z pExpr -> q -> z nFormula
-
-val qceiling : q -> z
-
-val makeLbCut : z pExprC -> q -> z nFormula
-
-val neg_nformula : z nFormula -> (z pExpr, op1) prod
-
-val cutChecker :
- z nFormula list -> z pExpr -> q -> zWitness -> z nFormula option
-
-val zChecker : z nFormula list -> proofTerm -> bool
-
-val zTautoChecker : z formula bFormula -> proofTerm list -> bool
-
-val map_cone : (nat -> nat) -> zWitness -> zWitness
-
-val indexes : zWitness -> nat list
-
-val n_of_Z : z -> n
-
-val qeq_bool : q -> q -> bool
-
-val qle_bool : q -> q -> bool
-
-type qWitness = q coneMember
-
-val qWeakChecker : q nFormula list -> q coneMember -> bool
-
-val qTautoChecker : q formula bFormula -> qWitness list -> bool
-
diff --git a/contrib/micromega/mutils.ml b/contrib/micromega/mutils.ml
deleted file mode 100644
index 2473608f..00000000
--- a/contrib/micromega/mutils.ml
+++ /dev/null
@@ -1,305 +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 *)
-(************************************************************************)
-(* *)
-(* Micromega: A reflexive tactic using the Positivstellensatz *)
-(* *)
-(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
-(* *)
-(************************************************************************)
-
-let debug = false
-
-let fst' (Micromega.Pair(x,y)) = x
-let snd' (Micromega.Pair(x,y)) = y
-
-let rec try_any l x =
- match l with
- | [] -> None
- | (f,s)::l -> match f x with
- | None -> try_any l x
- | x -> x
-
-let list_try_find f =
- let rec try_find_f = function
- | [] -> failwith "try_find"
- | h::t -> try f h with Failure _ -> try_find_f t
- in
- try_find_f
-
-let rec list_fold_right_elements f l =
- let rec aux = function
- | [] -> invalid_arg "list_fold_right_elements"
- | [x] -> x
- | x::l -> f x (aux l) in
- aux l
-
-let interval n m =
- let rec interval_n (l,m) =
- if n > m then l else interval_n (m::l,pred m)
- in
- interval_n ([],m)
-
-open Num
-open Big_int
-
-let ppcm x y =
- let g = gcd_big_int x y in
- let x' = div_big_int x g in
- let y' = div_big_int y g in
- mult_big_int g (mult_big_int x' y')
-
-
-let denominator = function
- | Int _ | Big_int _ -> unit_big_int
- | Ratio r -> Ratio.denominator_ratio r
-
-let numerator = function
- | Ratio r -> Ratio.numerator_ratio r
- | Int i -> Big_int.big_int_of_int i
- | Big_int i -> i
-
-let rec ppcm_list c l =
- match l with
- | [] -> c
- | e::l -> ppcm_list (ppcm c (denominator e)) l
-
-let rec rec_gcd_list c l =
- match l with
- | [] -> c
- | e::l -> rec_gcd_list (gcd_big_int c (numerator e)) l
-
-let rec gcd_list l =
- let res = rec_gcd_list zero_big_int l in
- if compare_big_int res zero_big_int = 0
- then unit_big_int else res
-
-
-
-let rats_to_ints l =
- let c = ppcm_list unit_big_int l in
- List.map (fun x -> (div_big_int (mult_big_int (numerator x) c)
- (denominator x))) l
-
-(* Nasty reordering of lists - useful to trim certificate down *)
-let mapi f l =
- let rec xmapi i l =
- match l with
- | [] -> []
- | e::l -> (f e i)::(xmapi (i+1) l) in
- xmapi 0 l
-
-
-let concatMapi f l = List.rev (mapi (fun e i -> (i,f e)) l)
-
-(* assoc_pos j [a0...an] = [j,a0....an,j+n],j+n+1 *)
-let assoc_pos j l = (mapi (fun e i -> e,i+j) l, j + (List.length l))
-
-let assoc_pos_assoc l =
- let rec xpos i l =
- match l with
- | [] -> []
- | (x,l) ::rst -> let (l',j) = assoc_pos i l in
- (x,l')::(xpos j rst) in
- xpos 0 l
-
-let filter_pos f l =
- (* Could sort ... take care of duplicates... *)
- let rec xfilter l =
- match l with
- | [] -> []
- | (x,e)::l ->
- if List.exists (fun ee -> List.mem ee f) (List.map snd e)
- then (x,e)::(xfilter l)
- else xfilter l in
- xfilter l
-
-let select_pos lpos l =
- let rec xselect i lpos l =
- match lpos with
- | [] -> []
- | j::rpos ->
- match l with
- | [] -> failwith "select_pos"
- | e::l ->
- if i = j
- then e:: (xselect (i+1) rpos l)
- else xselect (i+1) lpos l in
- xselect 0 lpos l
-
-
-module CoqToCaml =
-struct
- open Micromega
-
- let rec nat = function
- | O -> 0
- | S n -> (nat n) + 1
-
-
- let rec positive p =
- match p with
- | XH -> 1
- | XI p -> 1+ 2*(positive p)
- | XO p -> 2*(positive p)
-
-
- let n nt =
- match nt with
- | N0 -> 0
- | Npos p -> positive p
-
-
- let rec index i = (* Swap left-right ? *)
- match i with
- | XH -> 1
- | XI i -> 1+(2*(index i))
- | XO i -> 2*(index i)
-
-
- let z x =
- match x with
- | Z0 -> 0
- | Zpos p -> (positive p)
- | Zneg p -> - (positive p)
-
- open Big_int
-
- let rec positive_big_int p =
- match p with
- | XH -> unit_big_int
- | XI p -> add_int_big_int 1 (mult_int_big_int 2 (positive_big_int p))
- | XO p -> (mult_int_big_int 2 (positive_big_int p))
-
-
- let z_big_int x =
- match x with
- | Z0 -> zero_big_int
- | Zpos p -> (positive_big_int p)
- | Zneg p -> minus_big_int (positive_big_int p)
-
-
- let num x = Num.Big_int (z_big_int x)
-
- let rec list elt l =
- match l with
- | Nil -> []
- | Cons(e,l) -> (elt e)::(list elt l)
-
- let q_to_num {qnum = x ; qden = y} =
- Big_int (z_big_int x) // (Big_int (z_big_int (Zpos y)))
-
-end
-
-
-module CamlToCoq =
-struct
- open Micromega
-
- let rec nat = function
- | 0 -> O
- | n -> S (nat (n-1))
-
-
- let rec positive n =
- if n=1 then XH
- else if n land 1 = 1 then XI (positive (n lsr 1))
- else XO (positive (n lsr 1))
-
- let n nt =
- if nt < 0
- then assert false
- else if nt = 0 then N0
- else Npos (positive nt)
-
-
-
-
-
- let rec index n =
- if n=1 then XH
- else if n land 1 = 1 then XI (index (n lsr 1))
- else XO (index (n lsr 1))
-
-
- let idx n =
- (*a.k.a path_of_int *)
- (* returns the list of digits of n in reverse order with
- initial 1 removed *)
- let rec digits_of_int n =
- if n=1 then []
- else (n mod 2 = 1)::(digits_of_int (n lsr 1))
- in
- List.fold_right
- (fun b c -> (if b then XI c else XO c))
- (List.rev (digits_of_int n))
- (XH)
-
-
-
- let z x =
- match compare x 0 with
- | 0 -> Z0
- | 1 -> Zpos (positive x)
- | _ -> (* this should be -1 *)
- Zneg (positive (-x))
-
- open Big_int
-
- let positive_big_int n =
- let two = big_int_of_int 2 in
- let rec _pos n =
- if eq_big_int n unit_big_int then XH
- else
- let (q,m) = quomod_big_int n two in
- if eq_big_int unit_big_int m
- then XI (_pos q)
- else XO (_pos q) in
- _pos n
-
- let bigint x =
- match sign_big_int x with
- | 0 -> Z0
- | 1 -> Zpos (positive_big_int x)
- | _ -> Zneg (positive_big_int (minus_big_int x))
-
- let q n =
- {Micromega.qnum = bigint (numerator n) ;
- Micromega.qden = positive_big_int (denominator n)}
-
-
- let list elt l = List.fold_right (fun x l -> Cons(elt x, l)) l Nil
-
-end
-
-module Cmp =
-struct
-
- let rec compare_lexical l =
- match l with
- | [] -> 0 (* Equal *)
- | f::l ->
- let cmp = f () in
- if cmp = 0 then compare_lexical l else cmp
-
- let rec compare_list cmp l1 l2 =
- match l1 , l2 with
- | [] , [] -> 0
- | [] , _ -> -1
- | _ , [] -> 1
- | e1::l1 , e2::l2 ->
- let c = cmp e1 e2 in
- if c = 0 then compare_list cmp l1 l2 else c
-
- let hash_list hash l =
- let rec _hash_list l h =
- match l with
- | [] -> h lxor (Hashtbl.hash [])
- | e::l -> _hash_list l ((hash e) lxor h) in
-
- _hash_list l 0
-end
diff --git a/contrib/micromega/sos.ml b/contrib/micromega/sos.ml
deleted file mode 100644
index e3d72ed9..00000000
--- a/contrib/micromega/sos.ml
+++ /dev/null
@@ -1,1919 +0,0 @@
-(* ========================================================================= *)
-(* - This code originates from John Harrison's HOL LIGHT 2.20 *)
-(* (see file LICENSE.sos for license, copyright and disclaimer) *)
-(* - Laurent Théry (thery@sophia.inria.fr) has isolated the HOL *)
-(* independent bits *)
-(* - Frédéric Besson (fbesson@irisa.fr) is using it to feed micromega *)
-(* - Addition of a csdp cache by the Coq development team *)
-(* ========================================================================= *)
-
-(* ========================================================================= *)
-(* Nonlinear universal reals procedure using SOS decomposition. *)
-(* ========================================================================= *)
-
-open Num;;
-open List;;
-
-let debugging = ref false;;
-
-exception Sanity;;
-
-exception Unsolvable;;
-
-(* ------------------------------------------------------------------------- *)
-(* Comparisons that are reflexive on NaN and also short-circuiting. *)
-(* ------------------------------------------------------------------------- *)
-
-let (=?) = fun x y -> Pervasives.compare x y = 0;;
-let (<?) = fun x y -> Pervasives.compare x y < 0;;
-let (<=?) = fun x y -> Pervasives.compare x y <= 0;;
-let (>?) = fun x y -> Pervasives.compare x y > 0;;
-let (>=?) = fun x y -> Pervasives.compare x y >= 0;;
-
-(* ------------------------------------------------------------------------- *)
-(* Combinators. *)
-(* ------------------------------------------------------------------------- *)
-
-let (o) = fun f g x -> f(g x);;
-
-(* ------------------------------------------------------------------------- *)
-(* Some useful functions on "num" type. *)
-(* ------------------------------------------------------------------------- *)
-
-
-let num_0 = Int 0
-and num_1 = Int 1
-and num_2 = Int 2
-and num_10 = Int 10;;
-
-let pow2 n = power_num num_2 (Int n);;
-let pow10 n = power_num num_10 (Int n);;
-
-let numdom r =
- let r' = Ratio.normalize_ratio (ratio_of_num r) in
- num_of_big_int(Ratio.numerator_ratio r'),
- num_of_big_int(Ratio.denominator_ratio r');;
-
-let numerator = (o) fst numdom
-and denominator = (o) snd numdom;;
-
-let gcd_num n1 n2 =
- num_of_big_int(Big_int.gcd_big_int (big_int_of_num n1) (big_int_of_num n2));;
-
-let lcm_num x y =
- if x =/ num_0 & y =/ num_0 then num_0
- else abs_num((x */ y) // gcd_num x y);;
-
-
-(* ------------------------------------------------------------------------- *)
-(* List basics. *)
-(* ------------------------------------------------------------------------- *)
-
-let rec el n l =
- if n = 0 then hd l else el (n - 1) (tl l);;
-
-
-(* ------------------------------------------------------------------------- *)
-(* Various versions of list iteration. *)
-(* ------------------------------------------------------------------------- *)
-
-let rec itlist f l b =
- match l with
- [] -> b
- | (h::t) -> f h (itlist f t b);;
-
-let rec end_itlist f l =
- match l with
- [] -> failwith "end_itlist"
- | [x] -> x
- | (h::t) -> f h (end_itlist f t);;
-
-let rec itlist2 f l1 l2 b =
- match (l1,l2) with
- ([],[]) -> b
- | (h1::t1,h2::t2) -> f h1 h2 (itlist2 f t1 t2 b)
- | _ -> failwith "itlist2";;
-
-(* ------------------------------------------------------------------------- *)
-(* All pairs arising from applying a function over two lists. *)
-(* ------------------------------------------------------------------------- *)
-
-let rec allpairs f l1 l2 =
- match l1 with
- h1::t1 -> itlist (fun x a -> f h1 x :: a) l2 (allpairs f t1 l2)
- | [] -> [];;
-
-(* ------------------------------------------------------------------------- *)
-(* String operations (surely there is a better way...) *)
-(* ------------------------------------------------------------------------- *)
-
-let implode l = itlist (^) l "";;
-
-let explode s =
- let rec exap n l =
- if n < 0 then l else
- exap (n - 1) ((String.sub s n 1)::l) in
- exap (String.length s - 1) [];;
-
-
-(* ------------------------------------------------------------------------- *)
-(* Attempting function or predicate applications. *)
-(* ------------------------------------------------------------------------- *)
-
-let can f x = try (f x; true) with Failure _ -> false;;
-
-
-(* ------------------------------------------------------------------------- *)
-(* Repetition of a function. *)
-(* ------------------------------------------------------------------------- *)
-
-let rec funpow n f x =
- if n < 1 then x else funpow (n-1) f (f x);;
-
-
-(* ------------------------------------------------------------------------- *)
-(* term?? *)
-(* ------------------------------------------------------------------------- *)
-
-type vname = string;;
-
-type term =
-| Zero
-| Const of Num.num
-| Var of vname
-| Inv of term
-| Opp of term
-| Add of (term * term)
-| Sub of (term * term)
-| Mul of (term * term)
-| Div of (term * term)
-| Pow of (term * int);;
-
-
-(* ------------------------------------------------------------------------- *)
-(* Data structure for Positivstellensatz refutations. *)
-(* ------------------------------------------------------------------------- *)
-
-type positivstellensatz =
- Axiom_eq of int
- | Axiom_le of int
- | Axiom_lt of int
- | Rational_eq of num
- | Rational_le of num
- | Rational_lt of num
- | Square of term
- | Monoid of int list
- | Eqmul of term * positivstellensatz
- | Sum of positivstellensatz * positivstellensatz
- | Product of positivstellensatz * positivstellensatz;;
-
-
-
-(* ------------------------------------------------------------------------- *)
-(* Replication and sequences. *)
-(* ------------------------------------------------------------------------- *)
-
-let rec replicate x n =
- if n < 1 then []
- else x::(replicate x (n - 1));;
-
-let rec (--) = fun m n -> if m > n then [] else m::((m + 1) -- n);;
-
-(* ------------------------------------------------------------------------- *)
-(* Various useful list operations. *)
-(* ------------------------------------------------------------------------- *)
-
-let rec forall p l =
- match l with
- [] -> true
- | h::t -> p(h) & forall p t;;
-
-let rec tryfind f l =
- match l with
- [] -> failwith "tryfind"
- | (h::t) -> try f h with Failure _ -> tryfind f t;;
-
-let index x =
- let rec ind n l =
- match l with
- [] -> failwith "index"
- | (h::t) -> if x =? h then n else ind (n + 1) t in
- ind 0;;
-
-(* ------------------------------------------------------------------------- *)
-(* "Set" operations on lists. *)
-(* ------------------------------------------------------------------------- *)
-
-let rec mem x lis =
- match lis with
- [] -> false
- | (h::t) -> x =? h or mem x t;;
-
-let insert x l =
- if mem x l then l else x::l;;
-
-let union l1 l2 = itlist insert l1 l2;;
-
-let subtract l1 l2 = filter (fun x -> not (mem x l2)) l1;;
-
-(* ------------------------------------------------------------------------- *)
-(* Merging and bottom-up mergesort. *)
-(* ------------------------------------------------------------------------- *)
-
-let rec merge ord l1 l2 =
- match l1 with
- [] -> l2
- | h1::t1 -> match l2 with
- [] -> l1
- | h2::t2 -> if ord h1 h2 then h1::(merge ord t1 l2)
- else h2::(merge ord l1 t2);;
-
-
-(* ------------------------------------------------------------------------- *)
-(* Common measure predicates to use with "sort". *)
-(* ------------------------------------------------------------------------- *)
-
-let increasing f x y = f x <? f y;;
-
-let decreasing f x y = f x >? f y;;
-
-(* ------------------------------------------------------------------------- *)
-(* Zipping, unzipping etc. *)
-(* ------------------------------------------------------------------------- *)
-
-let rec zip l1 l2 =
- match (l1,l2) with
- ([],[]) -> []
- | (h1::t1,h2::t2) -> (h1,h2)::(zip t1 t2)
- | _ -> failwith "zip";;
-
-let rec unzip =
- function [] -> [],[]
- | ((a,b)::rest) -> let alist,blist = unzip rest in
- (a::alist,b::blist);;
-
-(* ------------------------------------------------------------------------- *)
-(* Iterating functions over lists. *)
-(* ------------------------------------------------------------------------- *)
-
-let rec do_list f l =
- match l with
- [] -> ()
- | (h::t) -> (f h; do_list f t);;
-
-(* ------------------------------------------------------------------------- *)
-(* Sorting. *)
-(* ------------------------------------------------------------------------- *)
-
-let rec sort cmp lis =
- match lis with
- [] -> []
- | piv::rest ->
- let r,l = partition (cmp piv) rest in
- (sort cmp l) @ (piv::(sort cmp r));;
-
-(* ------------------------------------------------------------------------- *)
-(* Removing adjacent (NB!) equal elements from list. *)
-(* ------------------------------------------------------------------------- *)
-
-let rec uniq l =
- match l with
- x::(y::_ as t) -> let t' = uniq t in
- if x =? y then t' else
- if t'==t then l else x::t'
- | _ -> l;;
-
-(* ------------------------------------------------------------------------- *)
-(* Convert list into set by eliminating duplicates. *)
-(* ------------------------------------------------------------------------- *)
-
-let setify s = uniq (sort (<=?) s);;
-
-(* ------------------------------------------------------------------------- *)
-(* Polymorphic finite partial functions via Patricia trees. *)
-(* *)
-(* The point of this strange representation is that it is canonical (equal *)
-(* functions have the same encoding) yet reasonably efficient on average. *)
-(* *)
-(* Idea due to Diego Olivier Fernandez Pons (OCaml list, 2003/11/10). *)
-(* ------------------------------------------------------------------------- *)
-
-type ('a,'b)func =
- Empty
- | Leaf of int * ('a*'b)list
- | Branch of int * int * ('a,'b)func * ('a,'b)func;;
-
-(* ------------------------------------------------------------------------- *)
-(* Undefined function. *)
-(* ------------------------------------------------------------------------- *)
-
-let undefined = Empty;;
-
-(* ------------------------------------------------------------------------- *)
-(* In case of equality comparison worries, better use this. *)
-(* ------------------------------------------------------------------------- *)
-
-let is_undefined f =
- match f with
- Empty -> true
- | _ -> false;;
-
-(* ------------------------------------------------------------------------- *)
-(* Operation analagous to "map" for lists. *)
-(* ------------------------------------------------------------------------- *)
-
-let mapf =
- let rec map_list f l =
- match l with
- [] -> []
- | (x,y)::t -> (x,f(y))::(map_list f t) in
- let rec mapf f t =
- match t with
- Empty -> Empty
- | Leaf(h,l) -> Leaf(h,map_list f l)
- | Branch(p,b,l,r) -> Branch(p,b,mapf f l,mapf f r) in
- mapf;;
-
-(* ------------------------------------------------------------------------- *)
-(* Operations analogous to "fold" for lists. *)
-(* ------------------------------------------------------------------------- *)
-
-let foldl =
- let rec foldl_list f a l =
- match l with
- [] -> a
- | (x,y)::t -> foldl_list f (f a x y) t in
- let rec foldl f a t =
- match t with
- Empty -> a
- | Leaf(h,l) -> foldl_list f a l
- | Branch(p,b,l,r) -> foldl f (foldl f a l) r in
- foldl;;
-
-let foldr =
- let rec foldr_list f l a =
- match l with
- [] -> a
- | (x,y)::t -> f x y (foldr_list f t a) in
- let rec foldr f t a =
- match t with
- Empty -> a
- | Leaf(h,l) -> foldr_list f l a
- | Branch(p,b,l,r) -> foldr f l (foldr f r a) in
- foldr;;
-
-(* ------------------------------------------------------------------------- *)
-(* Redefinition and combination. *)
-(* ------------------------------------------------------------------------- *)
-
-let (|->),combine =
- let ldb x y = let z = x lxor y in z land (-z) in
- let newbranch p1 t1 p2 t2 =
- let b = ldb p1 p2 in
- let p = p1 land (b - 1) in
- if p1 land b = 0 then Branch(p,b,t1,t2)
- else Branch(p,b,t2,t1) in
- let rec define_list (x,y as xy) l =
- match l with
- (a,b as ab)::t ->
- if x =? a then xy::t
- else if x <? a then xy::l
- else ab::(define_list xy t)
- | [] -> [xy]
- and combine_list op z l1 l2 =
- match (l1,l2) with
- [],_ -> l2
- | _,[] -> l1
- | ((x1,y1 as xy1)::t1,(x2,y2 as xy2)::t2) ->
- if x1 <? x2 then xy1::(combine_list op z t1 l2)
- else if x2 <? x1 then xy2::(combine_list op z l1 t2) else
- let y = op y1 y2 and l = combine_list op z t1 t2 in
- if z(y) then l else (x1,y)::l in
- let (|->) x y =
- let k = Hashtbl.hash x in
- let rec upd t =
- match t with
- Empty -> Leaf (k,[x,y])
- | Leaf(h,l) ->
- if h = k then Leaf(h,define_list (x,y) l)
- else newbranch h t k (Leaf(k,[x,y]))
- | Branch(p,b,l,r) ->
- if k land (b - 1) <> p then newbranch p t k (Leaf(k,[x,y]))
- else if k land b = 0 then Branch(p,b,upd l,r)
- else Branch(p,b,l,upd r) in
- upd in
- let rec combine op z t1 t2 =
- match (t1,t2) with
- Empty,_ -> t2
- | _,Empty -> t1
- | Leaf(h1,l1),Leaf(h2,l2) ->
- if h1 = h2 then
- let l = combine_list op z l1 l2 in
- if l = [] then Empty else Leaf(h1,l)
- else newbranch h1 t1 h2 t2
- | (Leaf(k,lis) as lf),(Branch(p,b,l,r) as br) |
- (Branch(p,b,l,r) as br),(Leaf(k,lis) as lf) ->
- if k land (b - 1) = p then
- if k land b = 0 then
- let l' = combine op z lf l in
- if is_undefined l' then r else Branch(p,b,l',r)
- else
- let r' = combine op z lf r in
- if is_undefined r' then l else Branch(p,b,l,r')
- else
- newbranch k lf p br
- | Branch(p1,b1,l1,r1),Branch(p2,b2,l2,r2) ->
- if b1 < b2 then
- if p2 land (b1 - 1) <> p1 then newbranch p1 t1 p2 t2
- else if p2 land b1 = 0 then
- let l = combine op z l1 t2 in
- if is_undefined l then r1 else Branch(p1,b1,l,r1)
- else
- let r = combine op z r1 t2 in
- if is_undefined r then l1 else Branch(p1,b1,l1,r)
- else if b2 < b1 then
- if p1 land (b2 - 1) <> p2 then newbranch p1 t1 p2 t2
- else if p1 land b2 = 0 then
- let l = combine op z t1 l2 in
- if is_undefined l then r2 else Branch(p2,b2,l,r2)
- else
- let r = combine op z t1 r2 in
- if is_undefined r then l2 else Branch(p2,b2,l2,r)
- else if p1 = p2 then
- let l = combine op z l1 l2 and r = combine op z r1 r2 in
- if is_undefined l then r
- else if is_undefined r then l else Branch(p1,b1,l,r)
- else
- newbranch p1 t1 p2 t2 in
- (|->),combine;;
-
-(* ------------------------------------------------------------------------- *)
-(* Special case of point function. *)
-(* ------------------------------------------------------------------------- *)
-
-let (|=>) = fun x y -> (x |-> y) undefined;;
-
-
-(* ------------------------------------------------------------------------- *)
-(* Grab an arbitrary element. *)
-(* ------------------------------------------------------------------------- *)
-
-let rec choose t =
- match t with
- Empty -> failwith "choose: completely undefined function"
- | Leaf(h,l) -> hd l
- | Branch(b,p,t1,t2) -> choose t1;;
-
-(* ------------------------------------------------------------------------- *)
-(* Application. *)
-(* ------------------------------------------------------------------------- *)
-
-let applyd =
- let rec apply_listd l d x =
- match l with
- (a,b)::t -> if x =? a then b
- else if x >? a then apply_listd t d x else d x
- | [] -> d x in
- fun f d x ->
- let k = Hashtbl.hash x in
- let rec look t =
- match t with
- Leaf(h,l) when h = k -> apply_listd l d x
- | Branch(p,b,l,r) -> look (if k land b = 0 then l else r)
- | _ -> d x in
- look f;;
-
-let apply f = applyd f (fun x -> failwith "apply");;
-
-let tryapplyd f a d = applyd f (fun x -> d) a;;
-
-let defined f x = try apply f x; true with Failure _ -> false;;
-
-(* ------------------------------------------------------------------------- *)
-(* Undefinition. *)
-(* ------------------------------------------------------------------------- *)
-
-let undefine =
- let rec undefine_list x l =
- match l with
- (a,b as ab)::t ->
- if x =? a then t
- else if x <? a then l else
- let t' = undefine_list x t in
- if t' == t then l else ab::t'
- | [] -> [] in
- fun x ->
- let k = Hashtbl.hash x in
- let rec und t =
- match t with
- Leaf(h,l) when h = k ->
- let l' = undefine_list x l in
- if l' == l then t
- else if l' = [] then Empty
- else Leaf(h,l')
- | Branch(p,b,l,r) when k land (b - 1) = p ->
- if k land b = 0 then
- let l' = und l in
- if l' == l then t
- else if is_undefined l' then r
- else Branch(p,b,l',r)
- else
- let r' = und r in
- if r' == r then t
- else if is_undefined r' then l
- else Branch(p,b,l,r')
- | _ -> t in
- und;;
-
-
-(* ------------------------------------------------------------------------- *)
-(* Mapping to sorted-list representation of the graph, domain and range. *)
-(* ------------------------------------------------------------------------- *)
-
-let graph f = setify (foldl (fun a x y -> (x,y)::a) [] f);;
-
-let dom f = setify(foldl (fun a x y -> x::a) [] f);;
-
-let ran f = setify(foldl (fun a x y -> y::a) [] f);;
-
-(* ------------------------------------------------------------------------- *)
-(* Turn a rational into a decimal string with d sig digits. *)
-(* ------------------------------------------------------------------------- *)
-
-let decimalize =
- let rec normalize y =
- if abs_num y </ Int 1 // Int 10 then normalize (Int 10 */ y) - 1
- else if abs_num y >=/ Int 1 then normalize (y // Int 10) + 1
- else 0 in
- fun d x ->
- if x =/ Int 0 then "0.0" else
- let y = abs_num x in
- let e = normalize y in
- let z = pow10(-e) */ y +/ Int 1 in
- let k = round_num(pow10 d */ z) in
- (if x </ Int 0 then "-0." else "0.") ^
- implode(tl(explode(string_of_num k))) ^
- (if e = 0 then "" else "e"^string_of_int e);;
-
-
-(* ------------------------------------------------------------------------- *)
-(* Iterations over numbers, and lists indexed by numbers. *)
-(* ------------------------------------------------------------------------- *)
-
-let rec itern k l f a =
- match l with
- [] -> a
- | h::t -> itern (k + 1) t f (f h k a);;
-
-let rec iter (m,n) f a =
- if n < m then a
- else iter (m+1,n) f (f m a);;
-
-(* ------------------------------------------------------------------------- *)
-(* The main types. *)
-(* ------------------------------------------------------------------------- *)
-
-type vector = int*(int,num)func;;
-
-type matrix = (int*int)*(int*int,num)func;;
-
-type monomial = (vname,int)func;;
-
-type poly = (monomial,num)func;;
-
-(* ------------------------------------------------------------------------- *)
-(* Assignment avoiding zeros. *)
-(* ------------------------------------------------------------------------- *)
-
-let (|-->) x y a = if y =/ Int 0 then a else (x |-> y) a;;
-
-(* ------------------------------------------------------------------------- *)
-(* This can be generic. *)
-(* ------------------------------------------------------------------------- *)
-
-let element (d,v) i = tryapplyd v i (Int 0);;
-
-let mapa f (d,v) =
- d,foldl (fun a i c -> (i |--> f(c)) a) undefined v;;
-
-let is_zero (d,v) =
- match v with
- Empty -> true
- | _ -> false;;
-
-(* ------------------------------------------------------------------------- *)
-(* Vectors. Conventionally indexed 1..n. *)
-(* ------------------------------------------------------------------------- *)
-
-let vector_0 n = (n,undefined:vector);;
-
-let dim (v:vector) = fst v;;
-
-let vector_const c n =
- if c =/ Int 0 then vector_0 n
- else (n,itlist (fun k -> k |-> c) (1--n) undefined :vector);;
-
-let vector_1 = vector_const (Int 1);;
-
-let vector_cmul c (v:vector) =
- let n = dim v in
- if c =/ Int 0 then vector_0 n
- else n,mapf (fun x -> c */ x) (snd v);;
-
-let vector_neg (v:vector) = (fst v,mapf minus_num (snd v) :vector);;
-
-let vector_add (v1:vector) (v2:vector) =
- let m = dim v1 and n = dim v2 in
- if m <> n then failwith "vector_add: incompatible dimensions" else
- (n,combine (+/) (fun x -> x =/ Int 0) (snd v1) (snd v2) :vector);;
-
-let vector_sub v1 v2 = vector_add v1 (vector_neg v2);;
-
-let vector_of_list l =
- let n = length l in
- (n,itlist2 (|->) (1--n) l undefined :vector);;
-
-(* ------------------------------------------------------------------------- *)
-(* Matrices; again rows and columns indexed from 1. *)
-(* ------------------------------------------------------------------------- *)
-
-let matrix_0 (m,n) = ((m,n),undefined:matrix);;
-
-let dimensions (m:matrix) = fst m;;
-
-let matrix_const c (m,n as mn) =
- if m <> n then failwith "matrix_const: needs to be square"
- else if c =/ Int 0 then matrix_0 mn
- else (mn,itlist (fun k -> (k,k) |-> c) (1--n) undefined :matrix);;
-
-let matrix_1 = matrix_const (Int 1);;
-
-let matrix_cmul c (m:matrix) =
- let (i,j) = dimensions m in
- if c =/ Int 0 then matrix_0 (i,j)
- else (i,j),mapf (fun x -> c */ x) (snd m);;
-
-let matrix_neg (m:matrix) = (dimensions m,mapf minus_num (snd m) :matrix);;
-
-let matrix_add (m1:matrix) (m2:matrix) =
- let d1 = dimensions m1 and d2 = dimensions m2 in
- if d1 <> d2 then failwith "matrix_add: incompatible dimensions"
- else (d1,combine (+/) (fun x -> x =/ Int 0) (snd m1) (snd m2) :matrix);;
-
-let matrix_sub m1 m2 = matrix_add m1 (matrix_neg m2);;
-
-let row k (m:matrix) =
- let i,j = dimensions m in
- (j,
- foldl (fun a (i,j) c -> if i = k then (j |-> c) a else a) undefined (snd m)
- : vector);;
-
-let column k (m:matrix) =
- let i,j = dimensions m in
- (i,
- foldl (fun a (i,j) c -> if j = k then (i |-> c) a else a) undefined (snd m)
- : vector);;
-
-let transp (m:matrix) =
- let i,j = dimensions m in
- ((j,i),foldl (fun a (i,j) c -> ((j,i) |-> c) a) undefined (snd m) :matrix);;
-
-let diagonal (v:vector) =
- let n = dim v in
- ((n,n),foldl (fun a i c -> ((i,i) |-> c) a) undefined (snd v) : matrix);;
-
-let matrix_of_list l =
- let m = length l in
- if m = 0 then matrix_0 (0,0) else
- let n = length (hd l) in
- (m,n),itern 1 l (fun v i -> itern 1 v (fun c j -> (i,j) |-> c)) undefined;;
-
-(* ------------------------------------------------------------------------- *)
-(* Monomials. *)
-(* ------------------------------------------------------------------------- *)
-
-let monomial_eval assig (m:monomial) =
- foldl (fun a x k -> a */ power_num (apply assig x) (Int k))
- (Int 1) m;;
-
-let monomial_1 = (undefined:monomial);;
-
-let monomial_var x = (x |=> 1 :monomial);;
-
-let (monomial_mul:monomial->monomial->monomial) =
- combine (+) (fun x -> false);;
-
-let monomial_pow (m:monomial) k =
- if k = 0 then monomial_1
- else mapf (fun x -> k * x) m;;
-
-let monomial_divides (m1:monomial) (m2:monomial) =
- foldl (fun a x k -> tryapplyd m2 x 0 >= k & a) true m1;;
-
-let monomial_div (m1:monomial) (m2:monomial) =
- let m = combine (+) (fun x -> x = 0) m1 (mapf (fun x -> -x) m2) in
- if foldl (fun a x k -> k >= 0 & a) true m then m
- else failwith "monomial_div: non-divisible";;
-
-let monomial_degree x (m:monomial) = tryapplyd m x 0;;
-
-let monomial_lcm (m1:monomial) (m2:monomial) =
- (itlist (fun x -> x |-> max (monomial_degree x m1) (monomial_degree x m2))
- (union (dom m1) (dom m2)) undefined :monomial);;
-
-let monomial_multidegree (m:monomial) = foldl (fun a x k -> k + a) 0 m;;
-
-let monomial_variables m = dom m;;
-
-(* ------------------------------------------------------------------------- *)
-(* Polynomials. *)
-(* ------------------------------------------------------------------------- *)
-
-let eval assig (p:poly) =
- foldl (fun a m c -> a +/ c */ monomial_eval assig m) (Int 0) p;;
-
-let poly_0 = (undefined:poly);;
-
-let poly_isconst (p:poly) = foldl (fun a m c -> m = monomial_1 & a) true p;;
-
-let poly_var x = ((monomial_var x) |=> Int 1 :poly);;
-
-let poly_const c =
- if c =/ Int 0 then poly_0 else (monomial_1 |=> c);;
-
-let poly_cmul c (p:poly) =
- if c =/ Int 0 then poly_0
- else mapf (fun x -> c */ x) p;;
-
-let poly_neg (p:poly) = (mapf minus_num p :poly);;
-
-let poly_add (p1:poly) (p2:poly) =
- (combine (+/) (fun x -> x =/ Int 0) p1 p2 :poly);;
-
-let poly_sub p1 p2 = poly_add p1 (poly_neg p2);;
-
-let poly_cmmul (c,m) (p:poly) =
- if c =/ Int 0 then poly_0
- else if m = monomial_1 then mapf (fun d -> c */ d) p
- else foldl (fun a m' d -> (monomial_mul m m' |-> c */ d) a) poly_0 p;;
-
-let poly_mul (p1:poly) (p2:poly) =
- foldl (fun a m c -> poly_add (poly_cmmul (c,m) p2) a) poly_0 p1;;
-
-let poly_div (p1:poly) (p2:poly) =
- if not(poly_isconst p2) then failwith "poly_div: non-constant" else
- let c = eval undefined p2 in
- if c =/ Int 0 then failwith "poly_div: division by zero"
- else poly_cmul (Int 1 // c) p1;;
-
-let poly_square p = poly_mul p p;;
-
-let rec poly_pow p k =
- if k = 0 then poly_const (Int 1)
- else if k = 1 then p
- else let q = poly_square(poly_pow p (k / 2)) in
- if k mod 2 = 1 then poly_mul p q else q;;
-
-let poly_exp p1 p2 =
- if not(poly_isconst p2) then failwith "poly_exp: not a constant" else
- poly_pow p1 (Num.int_of_num (eval undefined p2));;
-
-let degree x (p:poly) = foldl (fun a m c -> max (monomial_degree x m) a) 0 p;;
-
-let multidegree (p:poly) =
- foldl (fun a m c -> max (monomial_multidegree m) a) 0 p;;
-
-let poly_variables (p:poly) =
- foldr (fun m c -> union (monomial_variables m)) p [];;
-
-(* ------------------------------------------------------------------------- *)
-(* Order monomials for human presentation. *)
-(* ------------------------------------------------------------------------- *)
-
-let humanorder_varpow (x1,k1) (x2,k2) = x1 < x2 or (x1 = x2 & k1 > k2);;
-
-let humanorder_monomial =
- let rec ord l1 l2 = match (l1,l2) with
- _,[] -> true
- | [],_ -> false
- | h1::t1,h2::t2 -> humanorder_varpow h1 h2 or (h1 = h2 & ord t1 t2) in
- fun m1 m2 -> m1 = m2 or
- ord (sort humanorder_varpow (graph m1))
- (sort humanorder_varpow (graph m2));;
-
-(* ------------------------------------------------------------------------- *)
-(* Conversions to strings. *)
-(* ------------------------------------------------------------------------- *)
-
-let string_of_vector min_size max_size (v:vector) =
- let n_raw = dim v in
- if n_raw = 0 then "[]" else
- let n = max min_size (min n_raw max_size) in
- let xs = map ((o) string_of_num (element v)) (1--n) in
- "[" ^ end_itlist (fun s t -> s ^ ", " ^ t) xs ^
- (if n_raw > max_size then ", ...]" else "]");;
-
-let string_of_matrix max_size (m:matrix) =
- let i_raw,j_raw = dimensions m in
- let i = min max_size i_raw and j = min max_size j_raw in
- let rstr = map (fun k -> string_of_vector j j (row k m)) (1--i) in
- "["^end_itlist(fun s t -> s^";\n "^t) rstr ^
- (if j > max_size then "\n ...]" else "]");;
-
-let string_of_vname (v:vname): string = (v: string);;
-
-let rec string_of_term t =
- match t with
- Opp t1 -> "(- " ^ string_of_term t1 ^ ")"
-| Add (t1, t2) ->
- "(" ^ (string_of_term t1) ^ " + " ^ (string_of_term t2) ^ ")"
-| Sub (t1, t2) ->
- "(" ^ (string_of_term t1) ^ " - " ^ (string_of_term t2) ^ ")"
-| Mul (t1, t2) ->
- "(" ^ (string_of_term t1) ^ " * " ^ (string_of_term t2) ^ ")"
-| Inv t1 -> "(/ " ^ string_of_term t1 ^ ")"
-| Div (t1, t2) ->
- "(" ^ (string_of_term t1) ^ " / " ^ (string_of_term t2) ^ ")"
-| Pow (t1, n1) ->
- "(" ^ (string_of_term t1) ^ " ^ " ^ (string_of_int n1) ^ ")"
-| Zero -> "0"
-| Var v -> "x" ^ (string_of_vname v)
-| Const x -> string_of_num x;;
-
-
-let string_of_varpow x k =
- if k = 1 then string_of_vname x else string_of_vname x^"^"^string_of_int k;;
-
-let string_of_monomial m =
- if m = monomial_1 then "1" else
- let vps = List.fold_right (fun (x,k) a -> string_of_varpow x k :: a)
- (sort humanorder_varpow (graph m)) [] in
- end_itlist (fun s t -> s^"*"^t) vps;;
-
-let string_of_cmonomial (c,m) =
- if m = monomial_1 then string_of_num c
- else if c =/ Int 1 then string_of_monomial m
- else string_of_num c ^ "*" ^ string_of_monomial m;;
-
-let string_of_poly (p:poly) =
- if p = poly_0 then "<<0>>" else
- let cms = sort (fun (m1,_) (m2,_) -> humanorder_monomial m1 m2) (graph p) in
- let s =
- List.fold_left (fun a (m,c) ->
- if c </ Int 0 then a ^ " - " ^ string_of_cmonomial(minus_num c,m)
- else a ^ " + " ^ string_of_cmonomial(c,m))
- "" cms in
- let s1 = String.sub s 0 3
- and s2 = String.sub s 3 (String.length s - 3) in
- "<<" ^(if s1 = " + " then s2 else "-"^s2)^">>";;
-
-(* ------------------------------------------------------------------------- *)
-(* Printers. *)
-(* ------------------------------------------------------------------------- *)
-
-let print_vector v = Format.print_string(string_of_vector 0 20 v);;
-
-let print_matrix m = Format.print_string(string_of_matrix 20 m);;
-
-let print_monomial m = Format.print_string(string_of_monomial m);;
-
-let print_poly m = Format.print_string(string_of_poly m);;
-
-(*
-#install_printer print_vector;;
-#install_printer print_matrix;;
-#install_printer print_monomial;;
-#install_printer print_poly;;
-*)
-
-(* ------------------------------------------------------------------------- *)
-(* Conversion from term. *)
-(* ------------------------------------------------------------------------- *)
-
-let rec poly_of_term t = match t with
- Zero -> poly_0
-| Const n -> poly_const n
-| Var x -> poly_var x
-| Opp t1 -> poly_neg (poly_of_term t1)
-| Inv t1 ->
- let p = poly_of_term t1 in
- if poly_isconst p then poly_const(Int 1 // eval undefined p)
- else failwith "poly_of_term: inverse of non-constant polyomial"
-| Add (l, r) -> poly_add (poly_of_term l) (poly_of_term r)
-| Sub (l, r) -> poly_sub (poly_of_term l) (poly_of_term r)
-| Mul (l, r) -> poly_mul (poly_of_term l) (poly_of_term r)
-| Div (l, r) ->
- let p = poly_of_term l and q = poly_of_term r in
- if poly_isconst q then poly_cmul (Int 1 // eval undefined q) p
- else failwith "poly_of_term: division by non-constant polynomial"
-| Pow (t, n) ->
- poly_pow (poly_of_term t) n;;
-
-(* ------------------------------------------------------------------------- *)
-(* String of vector (just a list of space-separated numbers). *)
-(* ------------------------------------------------------------------------- *)
-
-let sdpa_of_vector (v:vector) =
- let n = dim v in
- let strs = map (o (decimalize 20) (element v)) (1--n) in
- end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";;
-
-(* ------------------------------------------------------------------------- *)
-(* String for block diagonal matrix numbered k. *)
-(* ------------------------------------------------------------------------- *)
-
-let sdpa_of_blockdiagonal k m =
- let pfx = string_of_int k ^" " in
- let ents =
- foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in
- let entss = sort (increasing fst) ents in
- itlist (fun ((b,i,j),c) a ->
- pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^
- " " ^ decimalize 20 c ^ "\n" ^ a) entss "";;
-
-(* ------------------------------------------------------------------------- *)
-(* String for a matrix numbered k, in SDPA sparse format. *)
-(* ------------------------------------------------------------------------- *)
-
-let sdpa_of_matrix k (m:matrix) =
- let pfx = string_of_int k ^ " 1 " in
- let ms = foldr (fun (i,j) c a -> if i > j then a else ((i,j),c)::a)
- (snd m) [] in
- let mss = sort (increasing fst) ms in
- itlist (fun ((i,j),c) a ->
- pfx ^ string_of_int i ^ " " ^ string_of_int j ^
- " " ^ decimalize 20 c ^ "\n" ^ a) mss "";;
-
-(* ------------------------------------------------------------------------- *)
-(* String in SDPA sparse format for standard SDP problem: *)
-(* *)
-(* X = v_1 * [M_1] + ... + v_m * [M_m] - [M_0] must be PSD *)
-(* Minimize obj_1 * v_1 + ... obj_m * v_m *)
-(* ------------------------------------------------------------------------- *)
-
-let sdpa_of_problem comment obj mats =
- let m = length mats - 1
- and n,_ = dimensions (hd mats) in
- "\"" ^ comment ^ "\"\n" ^
- string_of_int m ^ "\n" ^
- "1\n" ^
- string_of_int n ^ "\n" ^
- sdpa_of_vector obj ^
- itlist2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a)
- (1--length mats) mats "";;
-
-(* ------------------------------------------------------------------------- *)
-(* More parser basics. *)
-(* ------------------------------------------------------------------------- *)
-
-exception Noparse;;
-
-
-let isspace,issep,isbra,issymb,isalpha,isnum,isalnum =
- let charcode s = Char.code(String.get s 0) in
- let spaces = " \t\n\r"
- and separators = ",;"
- and brackets = "()[]{}"
- and symbs = "\\!@#$%^&*-+|\\<=>/?~.:"
- and alphas = "'abcdefghijklmnopqrstuvwxyz_ABCDEFGHIJKLMNOPQRSTUVWXYZ"
- and nums = "0123456789" in
- let allchars = spaces^separators^brackets^symbs^alphas^nums in
- let csetsize = itlist ((o) max charcode) (explode allchars) 256 in
- let ctable = Array.make csetsize 0 in
- do_list (fun c -> Array.set ctable (charcode c) 1) (explode spaces);
- do_list (fun c -> Array.set ctable (charcode c) 2) (explode separators);
- do_list (fun c -> Array.set ctable (charcode c) 4) (explode brackets);
- do_list (fun c -> Array.set ctable (charcode c) 8) (explode symbs);
- do_list (fun c -> Array.set ctable (charcode c) 16) (explode alphas);
- do_list (fun c -> Array.set ctable (charcode c) 32) (explode nums);
- let isspace c = Array.get ctable (charcode c) = 1
- and issep c = Array.get ctable (charcode c) = 2
- and isbra c = Array.get ctable (charcode c) = 4
- and issymb c = Array.get ctable (charcode c) = 8
- and isalpha c = Array.get ctable (charcode c) = 16
- and isnum c = Array.get ctable (charcode c) = 32
- and isalnum c = Array.get ctable (charcode c) >= 16 in
- isspace,issep,isbra,issymb,isalpha,isnum,isalnum;;
-
-let (||) parser1 parser2 input =
- try parser1 input
- with Noparse -> parser2 input;;
-
-let (++) parser1 parser2 input =
- let result1,rest1 = parser1 input in
- let result2,rest2 = parser2 rest1 in
- (result1,result2),rest2;;
-
-let rec many prs input =
- try let result,next = prs input in
- let results,rest = many prs next in
- (result::results),rest
- with Noparse -> [],input;;
-
-let (>>) prs treatment input =
- let result,rest = prs input in
- treatment(result),rest;;
-
-let fix err prs input =
- try prs input
- with Noparse -> failwith (err ^ " expected");;
-
-let rec listof prs sep err =
- prs ++ many (sep ++ fix err prs >> snd) >> (fun (h,t) -> h::t);;
-
-let possibly prs input =
- try let x,rest = prs input in [x],rest
- with Noparse -> [],input;;
-
-let some p =
- function
- [] -> raise Noparse
- | (h::t) -> if p h then (h,t) else raise Noparse;;
-
-let a tok = some (fun item -> item = tok);;
-
-let rec atleast n prs i =
- (if n <= 0 then many prs
- else prs ++ atleast (n - 1) prs >> (fun (h,t) -> h::t)) i;;
-
-let finished input =
- if input = [] then 0,input else failwith "Unparsed input";;
-
-let word s =
- end_itlist (fun p1 p2 -> (p1 ++ p2) >> (fun (s,t) -> s^t))
- (map a (explode s));;
-
-let token s =
- many (some isspace) ++ word s ++ many (some isspace)
- >> (fun ((_,t),_) -> t);;
-
-let decimal =
- let numeral = some isnum in
- let decimalint = atleast 1 numeral >> ((o) Num.num_of_string implode) in
- let decimalfrac = atleast 1 numeral
- >> (fun s -> Num.num_of_string(implode s) // pow10 (length s)) in
- let decimalsig =
- decimalint ++ possibly (a "." ++ decimalfrac >> snd)
- >> (function (h,[]) -> h | (h,[x]) -> h +/ x | _ -> failwith "decimalsig") in
- let signed prs =
- a "-" ++ prs >> ((o) minus_num snd)
- || a "+" ++ prs >> snd
- || prs in
- let exponent = (a "e" || a "E") ++ signed decimalint >> snd in
- signed decimalsig ++ possibly exponent
- >> (function (h,[]) -> h | (h,[x]) -> h */ power_num (Int 10) x | _ ->
- failwith "exponent");;
-
-let mkparser p s =
- let x,rst = p(explode s) in
- if rst = [] then x else failwith "mkparser: unparsed input";;
-
-let parse_decimal = mkparser decimal;;
-
-(* ------------------------------------------------------------------------- *)
-(* Parse back a vector. *)
-(* ------------------------------------------------------------------------- *)
-
-let parse_csdpoutput =
- let rec skipupto dscr prs inp =
- (dscr ++ prs >> snd
- || some (fun c -> true) ++ skipupto dscr prs >> snd) inp in
- let ignore inp = (),[] in
- let csdpoutput =
- (decimal ++ many(a " " ++ decimal >> snd) >> (fun (h,t) -> h::t)) ++
- (a " " ++ a "\n" ++ ignore) >> ((o) vector_of_list fst) in
- mkparser csdpoutput;;
-
-(* ------------------------------------------------------------------------- *)
-(* CSDP parameters; so far I'm sticking with the defaults. *)
-(* ------------------------------------------------------------------------- *)
-
-let csdp_default_parameters =
-"axtol=1.0e-8
-atytol=1.0e-8
-objtol=1.0e-8
-pinftol=1.0e8
-dinftol=1.0e8
-maxiter=100
-minstepfrac=0.9
-maxstepfrac=0.97
-minstepp=1.0e-8
-minstepd=1.0e-8
-usexzgap=1
-tweakgap=0
-affine=0
-printlevel=1
-";;
-
-let csdp_params = csdp_default_parameters;;
-
-(* ------------------------------------------------------------------------- *)
-(* The same thing with CSDP. *)
-(* Modified by the Coq development team to use a cache *)
-(* ------------------------------------------------------------------------- *)
-
-let buffer_add_line buff line =
- Buffer.add_string buff line; Buffer.add_char buff '\n'
-
-let string_of_file filename =
- let fd = open_in filename in
- let buff = Buffer.create 16 in
- try while true do buffer_add_line buff (input_line fd) done; failwith ""
- with End_of_file -> (close_in fd; Buffer.contents buff)
-
-let file_of_string filename s =
- let fd = Pervasives.open_out filename in
- output_string fd s; close_out fd
-
-let request_mark = "*** REQUEST ***"
-let answer_mark = "*** ANSWER ***"
-let end_mark = "*** END ***"
-let infeasible_mark = "Infeasible\n"
-let failure_mark = "Failure\n"
-
-let cache_name = "csdp.cache"
-
-let look_in_cache string_problem =
- let n = String.length string_problem in
- try
- let inch = open_in cache_name in
- let rec search () =
- while input_line inch <> request_mark do () done;
- let i = ref 0 in
- while !i < n & string_problem.[!i] = input_char inch do incr i done;
- if !i < n or input_line inch <> answer_mark then
- search ()
- else begin
- let buff = Buffer.create 16 in
- let line = ref (input_line inch) in
- while (!line <> end_mark) do
- buffer_add_line buff !line; line := input_line inch
- done;
- close_in inch;
- Buffer.contents buff
- end in
- try search () with End_of_file -> close_in inch; raise Not_found
- with Sys_error _ -> raise Not_found
-
-let flush_to_cache string_problem string_result =
- try
- let flags = [Open_append;Open_text;Open_creat] in
- let outch = open_out_gen flags 0o666 cache_name in
- begin
- try
- Printf.fprintf outch "%s\n" request_mark;
- Printf.fprintf outch "%s" string_problem;
- Printf.fprintf outch "%s\n" answer_mark;
- Printf.fprintf outch "%s" string_result;
- Printf.fprintf outch "%s\n" end_mark;
- with Sys_error _ as e -> close_out outch; raise e
- end;
- close_out outch
- with Sys_error _ ->
- print_endline "Warning: Could not open or write to csdp cache"
-
-exception CsdpInfeasible
-
-let run_csdp dbg string_problem =
- try
- let res = look_in_cache string_problem in
- if res = infeasible_mark then raise CsdpInfeasible;
- if res = failure_mark then failwith "csdp error";
- res
- with Not_found ->
- let input_file = Filename.temp_file "sos" ".dat-s" in
- let output_file = Filename.temp_file "sos" ".dat-s" in
- let temp_path = Filename.dirname input_file in
- let params_file = Filename.concat temp_path "param.csdp" in
- file_of_string input_file string_problem;
- file_of_string params_file csdp_params;
- let rv = Sys.command("cd "^temp_path^"; csdp "^input_file^" "^output_file^
- (if dbg then "" else "> /dev/null")) in
- if rv = 1 or rv = 2 then
- (flush_to_cache string_problem infeasible_mark; raise CsdpInfeasible);
- if rv = 127 then
- (print_string "csdp not found, exiting..."; exit 1);
- if rv <> 0 & rv <> 3 (* reduced accuracy *) then
- (flush_to_cache string_problem failure_mark;
- failwith("csdp: error "^string_of_int rv));
- let string_result = string_of_file output_file in
- flush_to_cache string_problem string_result;
- if not dbg then
- (Sys.remove input_file; Sys.remove output_file; Sys.remove params_file);
- string_result
-
-let csdp obj mats =
- try parse_csdpoutput (run_csdp !debugging (sdpa_of_problem "" obj mats))
- with CsdpInfeasible -> failwith "csdp: Problem is infeasible"
-
-(* ------------------------------------------------------------------------- *)
-(* Try some apparently sensible scaling first. Note that this is purely to *)
-(* get a cleaner translation to floating-point, and doesn't affect any of *)
-(* the results, in principle. In practice it seems a lot better when there *)
-(* are extreme numbers in the original problem. *)
-(* ------------------------------------------------------------------------- *)
-
-let scale_then =
- let common_denominator amat acc =
- foldl (fun a m c -> lcm_num (denominator c) a) acc amat
- and maximal_element amat acc =
- foldl (fun maxa m c -> max_num maxa (abs_num c)) acc amat in
- fun solver obj mats ->
- let cd1 = itlist common_denominator mats (Int 1)
- and cd2 = common_denominator (snd obj) (Int 1) in
- let mats' = map (mapf (fun x -> cd1 */ x)) mats
- and obj' = vector_cmul cd2 obj in
- let max1 = itlist maximal_element mats' (Int 0)
- and max2 = maximal_element (snd obj') (Int 0) in
- let scal1 = pow2 (20-int_of_float(log(float_of_num max1) /. log 2.0))
- and scal2 = pow2 (20-int_of_float(log(float_of_num max2) /. log 2.0)) in
- let mats'' = map (mapf (fun x -> x */ scal1)) mats'
- and obj'' = vector_cmul scal2 obj' in
- solver obj'' mats'';;
-
-(* ------------------------------------------------------------------------- *)
-(* Round a vector to "nice" rationals. *)
-(* ------------------------------------------------------------------------- *)
-
-let nice_rational n x = round_num (n */ x) // n;;
-
-let nice_vector n = mapa (nice_rational n);;
-
-(* ------------------------------------------------------------------------- *)
-(* Reduce linear program to SDP (diagonal matrices) and test with CSDP. This *)
-(* one tests A [-1;x1;..;xn] >= 0 (i.e. left column is negated constants). *)
-(* ------------------------------------------------------------------------- *)
-
-let linear_program_basic a =
- let m,n = dimensions a in
- let mats = map (fun j -> diagonal (column j a)) (1--n)
- and obj = vector_const (Int 1) m in
- try ignore (run_csdp false (sdpa_of_problem "" obj mats)); true
- with CsdpInfeasible -> false
-
-(* ------------------------------------------------------------------------- *)
-(* Test whether a point is in the convex hull of others. Rather than use *)
-(* computational geometry, express as linear inequalities and call CSDP. *)
-(* This is a bit lazy of me, but it's easy and not such a bottleneck so far. *)
-(* ------------------------------------------------------------------------- *)
-
-let in_convex_hull pts pt =
- let pts1 = (1::pt) :: map (fun x -> 1::x) pts in
- let pts2 = map (fun p -> map (fun x -> -x) p @ p) pts1 in
- let n = length pts + 1
- and v = 2 * (length pt + 1) in
- let m = v + n - 1 in
- let mat =
- (m,n),
- itern 1 pts2 (fun pts j -> itern 1 pts (fun x i -> (i,j) |-> Int x))
- (iter (1,n) (fun i -> (v + i,i+1) |-> Int 1) undefined) in
- linear_program_basic mat;;
-
-(* ------------------------------------------------------------------------- *)
-(* Filter down a set of points to a minimal set with the same convex hull. *)
-(* ------------------------------------------------------------------------- *)
-
-let minimal_convex_hull =
- let augment1 = function (m::ms) -> if in_convex_hull ms m then ms else ms@[m]
- | _ -> failwith "augment1"
- in
- let augment m ms = funpow 3 augment1 (m::ms) in
- fun mons ->
- let mons' = itlist augment (tl mons) [hd mons] in
- funpow (length mons') augment1 mons';;
-
-(* ------------------------------------------------------------------------- *)
-(* Stuff for "equations" (generic A->num functions). *)
-(* ------------------------------------------------------------------------- *)
-
-let equation_cmul c eq =
- if c =/ Int 0 then Empty else mapf (fun d -> c */ d) eq;;
-
-let equation_add eq1 eq2 = combine (+/) (fun x -> x =/ Int 0) eq1 eq2;;
-
-let equation_eval assig eq =
- let value v = apply assig v in
- foldl (fun a v c -> a +/ value(v) */ c) (Int 0) eq;;
-
-(* ------------------------------------------------------------------------- *)
-(* Eliminate among linear equations: return unconstrained variables and *)
-(* assignments for the others in terms of them. We give one pseudo-variable *)
-(* "one" that's used for a constant term. *)
-(* ------------------------------------------------------------------------- *)
-
-
-let eliminate_equations =
- let rec extract_first p l =
- match l with
- [] -> failwith "extract_first"
- | h::t -> if p(h) then h,t else
- let k,s = extract_first p t in
- k,h::s in
- let rec eliminate vars dun eqs =
- match vars with
- [] -> if forall is_undefined eqs then dun
- else (raise Unsolvable)
- | v::vs ->
- try let eq,oeqs = extract_first (fun e -> defined e v) eqs in
- let a = apply eq v in
- let eq' = equation_cmul (Int(-1) // a) (undefine v eq) in
- let elim e =
- let b = tryapplyd e v (Int 0) in
- if b =/ Int 0 then e else
- equation_add e (equation_cmul (minus_num b // a) eq) in
- eliminate vs ((v |-> eq') (mapf elim dun)) (map elim oeqs)
- with Failure _ -> eliminate vs dun eqs in
- fun one vars eqs ->
- let assig = eliminate vars undefined eqs in
- let vs = foldl (fun a x f -> subtract (dom f) [one] @ a) [] assig in
- setify vs,assig;;
-
-(* ------------------------------------------------------------------------- *)
-(* Eliminate all variables, in an essentially arbitrary order. *)
-(* ------------------------------------------------------------------------- *)
-
-let eliminate_all_equations one =
- let choose_variable eq =
- let (v,_) = choose eq in
- if v = one then
- let eq' = undefine v eq in
- if is_undefined eq' then failwith "choose_variable" else
- let (w,_) = choose eq' in w
- else v in
- let rec eliminate dun eqs =
- match eqs with
- [] -> dun
- | eq::oeqs ->
- if is_undefined eq then eliminate dun oeqs else
- let v = choose_variable eq in
- let a = apply eq v in
- let eq' = equation_cmul (Int(-1) // a) (undefine v eq) in
- let elim e =
- let b = tryapplyd e v (Int 0) in
- if b =/ Int 0 then e else
- equation_add e (equation_cmul (minus_num b // a) eq) in
- eliminate ((v |-> eq') (mapf elim dun)) (map elim oeqs) in
- fun eqs ->
- let assig = eliminate undefined eqs in
- let vs = foldl (fun a x f -> subtract (dom f) [one] @ a) [] assig in
- setify vs,assig;;
-
-(* ------------------------------------------------------------------------- *)
-(* Solve equations by assigning arbitrary numbers. *)
-(* ------------------------------------------------------------------------- *)
-
-let solve_equations one eqs =
- let vars,assigs = eliminate_all_equations one eqs in
- let vfn = itlist (fun v -> (v |-> Int 0)) vars (one |=> Int(-1)) in
- let ass =
- combine (+/) (fun c -> false) (mapf (equation_eval vfn) assigs) vfn in
- if forall (fun e -> equation_eval ass e =/ Int 0) eqs
- then undefine one ass else raise Sanity;;
-
-(* ------------------------------------------------------------------------- *)
-(* Hence produce the "relevant" monomials: those whose squares lie in the *)
-(* Newton polytope of the monomials in the input. (This is enough according *)
-(* to Reznik: "Extremal PSD forms with few terms", Duke Math. Journal, *)
-(* vol 45, pp. 363--374, 1978. *)
-(* *)
-(* These are ordered in sort of decreasing degree. In particular the *)
-(* constant monomial is last; this gives an order in diagonalization of the *)
-(* quadratic form that will tend to display constants. *)
-(* ------------------------------------------------------------------------- *)
-
-let newton_polytope pol =
- let vars = poly_variables pol in
- let mons = map (fun m -> map (fun x -> monomial_degree x m) vars) (dom pol)
- and ds = map (fun x -> (degree x pol + 1) / 2) vars in
- let all = itlist (fun n -> allpairs (fun h t -> h::t) (0--n)) ds [[]]
- and mons' = minimal_convex_hull mons in
- let all' =
- filter (fun m -> in_convex_hull mons' (map (fun x -> 2 * x) m)) all in
- map (fun m -> itlist2 (fun v i a -> if i = 0 then a else (v |-> i) a)
- vars m monomial_1) (rev all');;
-
-(* ------------------------------------------------------------------------- *)
-(* Diagonalize (Cholesky/LDU) the matrix corresponding to a quadratic form. *)
-(* ------------------------------------------------------------------------- *)
-
-let diag m =
- let nn = dimensions m in
- let n = fst nn in
- if snd nn <> n then failwith "diagonalize: non-square matrix" else
- let rec diagonalize i m =
- if is_zero m then [] else
- let a11 = element m (i,i) in
- if a11 </ Int 0 then failwith "diagonalize: not PSD"
- else if a11 =/ Int 0 then
- if is_zero(row i m) then diagonalize (i + 1) m
- else failwith "diagonalize: not PSD"
- else
- let v = row i m in
- let v' = mapa (fun a1k -> a1k // a11) v in
- let m' =
- (n,n),
- iter (i+1,n) (fun j ->
- iter (i+1,n) (fun k ->
- ((j,k) |--> (element m (j,k) -/ element v j */ element v' k))))
- undefined in
- (a11,v')::diagonalize (i + 1) m' in
- diagonalize 1 m;;
-
-(* ------------------------------------------------------------------------- *)
-(* Adjust a diagonalization to collect rationals at the start. *)
-(* ------------------------------------------------------------------------- *)
-
-let deration d =
- if d = [] then Int 0,d else
- let adj(c,l) =
- let a = foldl (fun a i c -> lcm_num a (denominator c)) (Int 1) (snd l) //
- foldl (fun a i c -> gcd_num a (numerator c)) (Int 0) (snd l) in
- (c // (a */ a)),mapa (fun x -> a */ x) l in
- let d' = map adj d in
- let a = itlist ((o) lcm_num ((o) denominator fst)) d' (Int 1) //
- itlist ((o) gcd_num ((o) numerator fst)) d' (Int 0) in
- (Int 1 // a),map (fun (c,l) -> (a */ c,l)) d';;
-
-(* ------------------------------------------------------------------------- *)
-(* Enumeration of monomials with given multidegree bound. *)
-(* ------------------------------------------------------------------------- *)
-
-let rec enumerate_monomials d vars =
- if d < 0 then []
- else if d = 0 then [undefined]
- else if vars = [] then [monomial_1] else
- let alts =
- map (fun k -> let oths = enumerate_monomials (d - k) (tl vars) in
- map (fun ks -> if k = 0 then ks else (hd vars |-> k) ks) oths)
- (0--d) in
- end_itlist (@) alts;;
-
-(* ------------------------------------------------------------------------- *)
-(* Enumerate products of distinct input polys with degree <= d. *)
-(* We ignore any constant input polynomials. *)
-(* Give the output polynomial and a record of how it was derived. *)
-(* ------------------------------------------------------------------------- *)
-
-let rec enumerate_products d pols =
- if d = 0 then [poly_const num_1,Rational_lt num_1] else if d < 0 then [] else
- match pols with
- [] -> [poly_const num_1,Rational_lt num_1]
- | (p,b)::ps -> let e = multidegree p in
- if e = 0 then enumerate_products d ps else
- enumerate_products d ps @
- map (fun (q,c) -> poly_mul p q,Product(b,c))
- (enumerate_products (d - e) ps);;
-
-(* ------------------------------------------------------------------------- *)
-(* Multiply equation-parametrized poly by regular poly and add accumulator. *)
-(* ------------------------------------------------------------------------- *)
-
-let epoly_pmul p q acc =
- foldl (fun a m1 c ->
- foldl (fun b m2 e ->
- let m = monomial_mul m1 m2 in
- let es = tryapplyd b m undefined in
- (m |-> equation_add (equation_cmul c e) es) b)
- a q) acc p;;
-
-(* ------------------------------------------------------------------------- *)
-(* Usual operations on equation-parametrized poly. *)
-(* ------------------------------------------------------------------------- *)
-
-let epoly_cmul c l =
- if c =/ Int 0 then undefined else mapf (equation_cmul c) l;;
-
-let epoly_neg x = epoly_cmul (Int(-1)) x;;
-
-let epoly_add x = combine equation_add is_undefined x;;
-
-let epoly_sub p q = epoly_add p (epoly_neg q);;
-
-(* ------------------------------------------------------------------------- *)
-(* Convert regular polynomial. Note that we treat (0,0,0) as -1. *)
-(* ------------------------------------------------------------------------- *)
-
-let epoly_of_poly p =
- foldl (fun a m c -> (m |-> ((0,0,0) |=> minus_num c)) a) undefined p;;
-
-(* ------------------------------------------------------------------------- *)
-(* String for block diagonal matrix numbered k. *)
-(* ------------------------------------------------------------------------- *)
-
-let sdpa_of_blockdiagonal k m =
- let pfx = string_of_int k ^" " in
- let ents =
- foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in
- let entss = sort (increasing fst) ents in
- itlist (fun ((b,i,j),c) a ->
- pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^
- " " ^ decimalize 20 c ^ "\n" ^ a) entss "";;
-
-(* ------------------------------------------------------------------------- *)
-(* SDPA for problem using block diagonal (i.e. multiple SDPs) *)
-(* ------------------------------------------------------------------------- *)
-
-let sdpa_of_blockproblem comment nblocks blocksizes obj mats =
- let m = length mats - 1 in
- "\"" ^ comment ^ "\"\n" ^
- string_of_int m ^ "\n" ^
- string_of_int nblocks ^ "\n" ^
- (end_itlist (fun s t -> s^" "^t) (map string_of_int blocksizes)) ^
- "\n" ^
- sdpa_of_vector obj ^
- itlist2 (fun k m a -> sdpa_of_blockdiagonal (k - 1) m ^ a)
- (1--length mats) mats "";;
-
-(* ------------------------------------------------------------------------- *)
-(* Hence run CSDP on a problem in block diagonal form. *)
-(* ------------------------------------------------------------------------- *)
-
-let csdp_blocks nblocks blocksizes obj mats =
- let string_problem = sdpa_of_blockproblem "" nblocks blocksizes obj mats in
- try parse_csdpoutput (run_csdp !debugging string_problem)
- with CsdpInfeasible -> failwith "csdp: Problem is infeasible"
-
-(* ------------------------------------------------------------------------- *)
-(* 3D versions of matrix operations to consider blocks separately. *)
-(* ------------------------------------------------------------------------- *)
-
-let bmatrix_add = combine (+/) (fun x -> x =/ Int 0);;
-
-let bmatrix_cmul c bm =
- if c =/ Int 0 then undefined
- else mapf (fun x -> c */ x) bm;;
-
-let bmatrix_neg = bmatrix_cmul (Int(-1));;
-
-let bmatrix_sub m1 m2 = bmatrix_add m1 (bmatrix_neg m2);;
-
-(* ------------------------------------------------------------------------- *)
-(* Smash a block matrix into components. *)
-(* ------------------------------------------------------------------------- *)
-
-let blocks blocksizes bm =
- map (fun (bs,b0) ->
- let m = foldl
- (fun a (b,i,j) c -> if b = b0 then ((i,j) |-> c) a else a)
- undefined bm in
- (*let d = foldl (fun a (i,j) c -> max a (max i j)) 0 m in*)
- (((bs,bs),m):matrix))
- (zip blocksizes (1--length blocksizes));;
-
-(* ------------------------------------------------------------------------- *)
-(* Positiv- and Nullstellensatz. Flag "linf" forces a linear representation. *)
-(* ------------------------------------------------------------------------- *)
-
-let real_positivnullstellensatz_general linf d eqs leqs pol
- : poly list * (positivstellensatz * (num * poly) list) list =
-
- let vars = itlist ((o) union poly_variables) (pol::eqs @ map fst leqs) [] in
- let monoid =
- if linf then
- (poly_const num_1,Rational_lt num_1)::
- (filter (fun (p,c) -> multidegree p <= d) leqs)
- else enumerate_products d leqs in
- let nblocks = length monoid in
- let mk_idmultiplier k p =
- let e = d - multidegree p in
- let mons = enumerate_monomials e vars in
- let nons = zip mons (1--length mons) in
- mons,
- itlist (fun (m,n) -> (m |-> ((-k,-n,n) |=> Int 1))) nons undefined in
- let mk_sqmultiplier k (p,c) =
- let e = (d - multidegree p) / 2 in
- let mons = enumerate_monomials e vars in
- let nons = zip mons (1--length mons) in
- mons,
- itlist (fun (m1,n1) ->
- itlist (fun (m2,n2) a ->
- let m = monomial_mul m1 m2 in
- if n1 > n2 then a else
- let c = if n1 = n2 then Int 1 else Int 2 in
- let e = tryapplyd a m undefined in
- (m |-> equation_add ((k,n1,n2) |=> c) e) a)
- nons)
- nons undefined in
- let sqmonlist,sqs = unzip(map2 mk_sqmultiplier (1--length monoid) monoid)
- and idmonlist,ids = unzip(map2 mk_idmultiplier (1--length eqs) eqs) in
- let blocksizes = map length sqmonlist in
- let bigsum =
- itlist2 (fun p q a -> epoly_pmul p q a) eqs ids
- (itlist2 (fun (p,c) s a -> epoly_pmul p s a) monoid sqs
- (epoly_of_poly(poly_neg pol))) in
- let eqns = foldl (fun a m e -> e::a) [] bigsum in
- let pvs,assig = eliminate_all_equations (0,0,0) eqns in
- let qvars = (0,0,0)::pvs in
- let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in
- let mk_matrix v =
- foldl (fun m (b,i,j) ass -> if b < 0 then m else
- let c = tryapplyd ass v (Int 0) in
- if c =/ Int 0 then m else
- ((b,j,i) |-> c) (((b,i,j) |-> c) m))
- undefined allassig in
- let diagents = foldl
- (fun a (b,i,j) e -> if b > 0 & i = j then equation_add e a else a)
- undefined allassig in
- let mats = map mk_matrix qvars
- and obj = length pvs,
- itern 1 pvs (fun v i -> (i |--> tryapplyd diagents v (Int 0)))
- undefined in
- let raw_vec = if pvs = [] then vector_0 0
- else scale_then (csdp_blocks nblocks blocksizes) obj mats in
- let find_rounding d =
- (if !debugging then
- (Format.print_string("Trying rounding with limit "^string_of_num d);
- Format.print_newline())
- else ());
- let vec = nice_vector d raw_vec in
- let blockmat = iter (1,dim vec)
- (fun i a -> bmatrix_add (bmatrix_cmul (element vec i) (el i mats)) a)
- (bmatrix_neg (el 0 mats)) in
- let allmats = blocks blocksizes blockmat in
- vec,map diag allmats in
- let vec,ratdias =
- if pvs = [] then find_rounding num_1
- else tryfind find_rounding (map Num.num_of_int (1--31) @
- map pow2 (5--66)) in
- let newassigs =
- itlist (fun k -> el (k - 1) pvs |-> element vec k)
- (1--dim vec) ((0,0,0) |=> Int(-1)) in
- let finalassigs =
- foldl (fun a v e -> (v |-> equation_eval newassigs e) a) newassigs
- allassig in
- let poly_of_epoly p =
- foldl (fun a v e -> (v |--> equation_eval finalassigs e) a)
- undefined p in
- let mk_sos mons =
- let mk_sq (c,m) =
- c,itlist (fun k a -> (el (k - 1) mons |--> element m k) a)
- (1--length mons) undefined in
- map mk_sq in
- let sqs = map2 mk_sos sqmonlist ratdias
- and cfs = map poly_of_epoly ids in
- let msq = filter (fun (a,b) -> b <> []) (map2 (fun a b -> a,b) monoid sqs) in
- let eval_sq sqs = itlist
- (fun (c,q) -> poly_add (poly_cmul c (poly_mul q q))) sqs poly_0 in
- let sanity =
- itlist (fun ((p,c),s) -> poly_add (poly_mul p (eval_sq s))) msq
- (itlist2 (fun p q -> poly_add (poly_mul p q)) cfs eqs
- (poly_neg pol)) in
- if not(is_undefined sanity) then raise Sanity else
- cfs,map (fun (a,b) -> snd a,b) msq;;
-
-
-let term_of_monoid l1 m = itlist (fun i m -> Mul (nth l1 i,m)) m (Const num_1)
-
-let rec term_of_pos l1 x = match x with
- Axiom_eq i -> failwith "term_of_pos"
- | Axiom_le i -> nth l1 i
- | Axiom_lt i -> nth l1 i
- | Monoid m -> term_of_monoid l1 m
- | Rational_eq n -> Const n
- | Rational_le n -> Const n
- | Rational_lt n -> Const n
- | Square t -> Pow (t, 2)
- | Eqmul (t, y) -> Mul (t, term_of_pos l1 y)
- | Sum (y, z) -> Add (term_of_pos l1 y, term_of_pos l1 z)
- | Product (y, z) -> Mul (term_of_pos l1 y, term_of_pos l1 z);;
-
-
-let dest_monomial mon = sort (increasing fst) (graph mon);;
-
-let monomial_order =
- let rec lexorder l1 l2 =
- match (l1,l2) with
- [],[] -> true
- | vps,[] -> false
- | [],vps -> true
- | ((x1,n1)::vs1),((x2,n2)::vs2) ->
- if x1 < x2 then true
- else if x2 < x1 then false
- else if n1 < n2 then false
- else if n2 < n1 then true
- else lexorder vs1 vs2 in
- fun m1 m2 ->
- if m2 = monomial_1 then true else if m1 = monomial_1 then false else
- let mon1 = dest_monomial m1 and mon2 = dest_monomial m2 in
- let deg1 = itlist ((o) (+) snd) mon1 0
- and deg2 = itlist ((o) (+) snd) mon2 0 in
- if deg1 < deg2 then false else if deg1 > deg2 then true
- else lexorder mon1 mon2;;
-
-let dest_poly p =
- map (fun (m,c) -> c,dest_monomial m)
- (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p));;
-
-(* ------------------------------------------------------------------------- *)
-(* Map back polynomials and their composites to term. *)
-(* ------------------------------------------------------------------------- *)
-
-let term_of_varpow =
- fun x k ->
- if k = 1 then Var x else Pow (Var x, k);;
-
-let term_of_monomial =
- fun m -> if m = monomial_1 then Const num_1 else
- let m' = dest_monomial m in
- let vps = itlist (fun (x,k) a -> term_of_varpow x k :: a) m' [] in
- end_itlist (fun s t -> Mul (s,t)) vps;;
-
-let term_of_cmonomial =
- fun (m,c) ->
- if m = monomial_1 then Const c
- else if c =/ num_1 then term_of_monomial m
- else Mul (Const c,term_of_monomial m);;
-
-let term_of_poly =
- fun p ->
- if p = poly_0 then Zero else
- let cms = map term_of_cmonomial
- (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p)) in
- end_itlist (fun t1 t2 -> Add (t1,t2)) cms;;
-
-let term_of_sqterm (c,p) =
- Product(Rational_lt c,Square(term_of_poly p));;
-
-let term_of_sos (pr,sqs) =
- if sqs = [] then pr
- else Product(pr,end_itlist (fun a b -> Sum(a,b)) (map term_of_sqterm sqs));;
-
-let rec deepen f n =
- try (*print_string "Searching with depth limit ";
- print_int n; print_newline();*) f n
- with Failure _ -> deepen f (n + 1);;
-
-
-
-
-
-exception TooDeep
-
-let deepen_until limit f n =
- match compare limit 0 with
- | 0 -> raise TooDeep
- | -1 -> deepen f n
- | _ ->
- let rec d_until f n =
- try if !debugging
- then (print_string "Searching with depth limit ";
- print_int n; print_newline()) ; f n
- with Failure x ->
- if !debugging then (Printf.printf "solver error : %s\n" x) ;
- if n = limit then raise TooDeep else d_until f (n + 1) in
- d_until f n
-
-
-(* patch to remove zero polynomials from equalities.
- In this case, hol light loops *)
-
-let real_nonlinear_prover depthmax eqs les lts =
- let eq = map poly_of_term eqs
- and le = map poly_of_term les
- and lt = map poly_of_term lts in
- let pol = itlist poly_mul lt (poly_const num_1)
- and lep = map (fun (t,i) -> t,Axiom_le i) (zip le (0--(length le - 1)))
- and ltp = map (fun (t,i) -> t,Axiom_lt i) (zip lt (0--(length lt - 1)))
- and eqp = itlist2 (fun t i res ->
- if t = undefined then res else (t,Axiom_eq i)::res) eq (0--(length eq - 1)) []
- in
-
- let proof =
- let leq = lep @ ltp in
- let eq = List.map fst eqp in
- let tryall d =
- let e = multidegree pol (*and pol' = poly_neg pol*) in
- let k = if e = 0 then 1 else d / e in
- tryfind (fun i -> d,i,
- real_positivnullstellensatz_general false d eq leq
- (poly_neg(poly_pow pol i)))
- (0--k) in
- let d,i,(cert_ideal,cert_cone) = deepen_until depthmax tryall 0 in
- let proofs_ideal =
- map2 (fun q i -> Eqmul(term_of_poly q,i))
- cert_ideal (List.map snd eqp)
- and proofs_cone = map term_of_sos cert_cone
- and proof_ne =
- if lt = [] then Rational_lt num_1 else
- let p = end_itlist (fun s t -> Product(s,t)) (map snd ltp) in
- funpow i (fun q -> Product(p,q)) (Rational_lt num_1) in
- end_itlist (fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in
- if !debugging then (print_string("Translating proof certificate to Coq"); print_newline());
- proof;;
-
-
-(* ------------------------------------------------------------------------- *)
-(* Now pure SOS stuff. *)
-(* ------------------------------------------------------------------------- *)
-
-(* ------------------------------------------------------------------------- *)
-(* Some combinatorial helper functions. *)
-(* ------------------------------------------------------------------------- *)
-
-let rec allpermutations l =
- if l = [] then [[]] else
- itlist (fun h acc -> map (fun t -> h::t)
- (allpermutations (subtract l [h])) @ acc) l [];;
-
-let allvarorders l =
- map (fun vlis x -> index x vlis) (allpermutations l);;
-
-let changevariables_monomial zoln (m:monomial) =
- foldl (fun a x k -> (assoc x zoln |-> k) a) monomial_1 m;;
-
-let changevariables zoln pol =
- foldl (fun a m c -> (changevariables_monomial zoln m |-> c) a)
- poly_0 pol;;
-
-(* ------------------------------------------------------------------------- *)
-(* Sum-of-squares function with some lowbrow symmetry reductions. *)
-(* ------------------------------------------------------------------------- *)
-
-let sumofsquares_general_symmetry tool pol =
- let vars = poly_variables pol
- and lpps = newton_polytope pol in
- let n = length lpps in
- let sym_eqs =
- let invariants = filter
- (fun vars' ->
- is_undefined(poly_sub pol (changevariables (zip vars vars') pol)))
- (allpermutations vars) in
-(* let lpps2 = allpairs monomial_mul lpps lpps in*)
-(* let lpp2_classes =
- setify(map (fun m ->
- setify(map (fun vars' -> changevariables_monomial (zip vars vars') m)
- invariants)) lpps2) in *)
- let lpns = zip lpps (1--length lpps) in
- let lppcs =
- filter (fun (m,(n1,n2)) -> n1 <= n2)
- (allpairs
- (fun (m1,n1) (m2,n2) -> (m1,m2),(n1,n2)) lpns lpns) in
- let clppcs = end_itlist (@)
- (map (fun ((m1,m2),(n1,n2)) ->
- map (fun vars' ->
- (changevariables_monomial (zip vars vars') m1,
- changevariables_monomial (zip vars vars') m2),(n1,n2))
- invariants)
- lppcs) in
- let clppcs_dom = setify(map fst clppcs) in
- let clppcs_cls = map (fun d -> filter (fun (e,_) -> e = d) clppcs)
- clppcs_dom in
- let eqvcls = map (o setify (map snd)) clppcs_cls in
- let mk_eq cls acc =
- match cls with
- [] -> raise Sanity
- | [h] -> acc
- | h::t -> map (fun k -> (k |-> Int(-1)) (h |=> Int 1)) t @ acc in
- itlist mk_eq eqvcls [] in
- let eqs = foldl (fun a x y -> y::a) []
- (itern 1 lpps (fun m1 n1 ->
- itern 1 lpps (fun m2 n2 f ->
- let m = monomial_mul m1 m2 in
- if n1 > n2 then f else
- let c = if n1 = n2 then Int 1 else Int 2 in
- (m |-> ((n1,n2) |-> c) (tryapplyd f m undefined)) f))
- (foldl (fun a m c -> (m |-> ((0,0)|=>c)) a)
- undefined pol)) @
- sym_eqs in
- let pvs,assig = eliminate_all_equations (0,0) eqs in
- let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in
- let qvars = (0,0)::pvs in
- let diagents =
- end_itlist equation_add (map (fun i -> apply allassig (i,i)) (1--n)) in
- let mk_matrix v =
- ((n,n),
- foldl (fun m (i,j) ass -> let c = tryapplyd ass v (Int 0) in
- if c =/ Int 0 then m else
- ((j,i) |-> c) (((i,j) |-> c) m))
- undefined allassig :matrix) in
- let mats = map mk_matrix qvars
- and obj = length pvs,
- itern 1 pvs (fun v i -> (i |--> tryapplyd diagents v (Int 0)))
- undefined in
- let raw_vec = if pvs = [] then vector_0 0 else tool obj mats in
- let find_rounding d =
- (if !debugging then
- (Format.print_string("Trying rounding with limit "^string_of_num d);
- Format.print_newline())
- else ());
- let vec = nice_vector d raw_vec in
- let mat = iter (1,dim vec)
- (fun i a -> matrix_add (matrix_cmul (element vec i) (el i mats)) a)
- (matrix_neg (el 0 mats)) in
- deration(diag mat) in
- let rat,dia =
- if pvs = [] then
- let mat = matrix_neg (el 0 mats) in
- deration(diag mat)
- else
- tryfind find_rounding (map Num.num_of_int (1--31) @
- map pow2 (5--66)) in
- let poly_of_lin(d,v) =
- d,foldl(fun a i c -> (el (i - 1) lpps |-> c) a) undefined (snd v) in
- let lins = map poly_of_lin dia in
- let sqs = map (fun (d,l) -> poly_mul (poly_const d) (poly_pow l 2)) lins in
- let sos = poly_cmul rat (end_itlist poly_add sqs) in
- if is_undefined(poly_sub sos pol) then rat,lins else raise Sanity;;
-
-let (sumofsquares: poly -> Num.num * (( Num.num * poly) list)) =
-sumofsquares_general_symmetry csdp;;
diff --git a/contrib/micromega/sos.mli b/contrib/micromega/sos.mli
deleted file mode 100644
index 31c9518c..00000000
--- a/contrib/micromega/sos.mli
+++ /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 *)
-(************************************************************************)
-
-
-type vname = string;;
-
-type term =
-| Zero
-| Const of Num.num
-| Var of vname
-| Inv of term
-| Opp of term
-| Add of (term * term)
-| Sub of (term * term)
-| Mul of (term * term)
-| Div of (term * term)
-| Pow of (term * int)
-
-type positivstellensatz =
- Axiom_eq of int
- | Axiom_le of int
- | Axiom_lt of int
- | Rational_eq of Num.num
- | Rational_le of Num.num
- | Rational_lt of Num.num
- | Square of term
- | Monoid of int list
- | Eqmul of term * positivstellensatz
- | Sum of positivstellensatz * positivstellensatz
- | Product of positivstellensatz * positivstellensatz
-
-type poly
-
-val poly_isconst : poly -> bool
-
-val poly_neg : poly -> poly
-
-val poly_mul : poly -> poly -> poly
-
-val poly_pow : poly -> int -> poly
-
-val poly_const : Num.num -> poly
-
-val poly_of_term : term -> poly
-
-val term_of_poly : poly -> term
-
-val term_of_sos : positivstellensatz * (Num.num * poly) list ->
- positivstellensatz
-
-val string_of_poly : poly -> string
-
-exception TooDeep
-
-val deepen_until : int -> (int -> 'a) -> int -> 'a
-
-val real_positivnullstellensatz_general : bool -> int -> poly list ->
- (poly * positivstellensatz) list ->
- poly -> poly list * (positivstellensatz * (Num.num * poly) list) list
-
-val sumofsquares : poly -> Num.num * ( Num.num * poly) list
diff --git a/contrib/micromega/vector.ml b/contrib/micromega/vector.ml
deleted file mode 100644
index fee4ebfc..00000000
--- a/contrib/micromega/vector.ml
+++ /dev/null
@@ -1,674 +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 *)
-(************************************************************************)
-(* *)
-(* Micromega: A reflexive tactic using the Positivstellensatz *)
-(* *)
-(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
-(* *)
-(************************************************************************)
-
-open Num
-
-module type S =
-sig
- type t
-
- val fresh : t -> int
-
- val null : t
-
- val is_null : t -> bool
-
- val get : int -> t -> num
-
- val update : int -> (num -> num) -> t -> t
- (* behaviour is undef if index < 0 -- might loop*)
-
- val set : int -> num -> t -> t
-
- (*
- For efficiency...
-
- val get_update : int -> (num -> num) -> t -> num * t
- *)
-
- val mul : num -> t -> t
-
- val uminus : t -> t
-
- val add : t -> t -> t
-
- val dotp : t -> t -> num
-
- val lin_comb : num -> t -> num -> t -> t
- (* lin_comb n1 t1 n2 t2 = (n1 * t1) + (n2 * t2) *)
-
- val gcd : t -> Big_int.big_int
-
- val normalise : t -> num * t
-
- val hash : t -> int
-
- val compare : t -> t -> int
-
- type it
-
- val iterator : t -> it
- val element : it -> (num*it) option
-
- val string : t -> string
-
- type status = Pos | Neg
-
- (* the result list is ordered by fst *)
- val status : t -> (int * status) list
-
- val from_list : num list -> t
- val to_list : t -> num list
-
-end
-
-
-module type SystemS =
-sig
-
- module Vect : S
-
- module Cstr :
- sig
- type kind = Eq | Ge
- val string_of_kind : kind -> string
- type cstr = {coeffs : Vect.t ; op : kind ; cst : num}
- val string_of_cstr : cstr -> string
- val compare : cstr -> cstr -> int
- end
- open Cstr
-
-
- module CstrBag :
- sig
- type t
- exception Contradiction
-
- val empty : t
-
- val is_empty : t -> bool
-
- val add : cstr -> t -> t
- (* c can be deduced from add c t *)
-
- val find : (cstr -> bool) -> t -> cstr option
-
- val fold : (cstr -> 'a -> 'a) -> t -> 'a -> 'a
-
- val status : t -> (int * (int list * int list)) list
- (* aggregate of vector statuses *)
-
- val remove : cstr -> t -> t
-
- (* remove_list the ith element -- it is the ith element visited by 'fold' *)
-
- val split : (cstr -> int) -> t -> (int -> t)
-
- type it
- val iterator : t -> it
- val element : it -> (cstr*it) option
-
- end
-
-end
-
-let zero_num = Int 0
-let unit_num = Int 1
-
-
-
-
-module Cstr(V:S) =
-struct
- type kind = Eq | Ge
- let string_of_kind = function Eq -> "Eq" | Ge -> "Ge"
-
- type cstr = {coeffs : V.t ; op : kind ; cst : num}
-
- let string_of_cstr {coeffs =a ; op = b ; cst =c} =
- Printf.sprintf "{coeffs = %s;op=%s;cst=%s}" (V.string a) (string_of_kind b) (string_of_num c)
-
- type t = cstr
- let compare
- {coeffs = v1 ; op = op1 ; cst = c1}
- {coeffs = v2 ; op = op2 ; cst = c2} =
- Mutils.Cmp.compare_lexical [
- (fun () -> V.compare v1 v2);
- (fun () -> Pervasives.compare op1 op2);
- (fun () -> compare_num c1 c2)
- ]
-
-
-end
-
-
-
-module VList : S with type t = num list =
-struct
- type t = num list
-
- let fresh l = failwith "not implemented"
-
- let null = []
-
- let is_null = List.for_all ((=/) zero_num)
-
- let normalise l = failwith "Not implemented"
- (*match l with (* Buggy : What if the first num is zero! *)
- | [] -> (Int 0,[])
- | [n] -> (n,[Int 1])
- | n::l -> (n, (Int 1) :: List.map (fun x -> x // n) l)
- *)
-
-
- let get i l = try List.nth l i with _ -> zero_num
-
- (* This is not tail-recursive *)
- let rec update i f t =
- match t with
- | [] -> if i = 0 then [f zero_num] else (zero_num)::(update (i-1) f [])
- | e::t -> if i = 0 then (f e)::t else e::(update (i-1) f t)
-
- let rec set i n t =
- match t with
- | [] -> if i = 0 then [n] else (zero_num)::(set (i-1) n [])
- | e::t -> if i = 0 then (n)::t else e::(set (i-1) n t)
-
-
-
-
- let rec mul z t =
- match z with
- | Int 0 -> null
- | Int 1 -> t
- | _ -> List.map (mult_num z) t
-
- let uminus t = mul (Int (-1)) t
-
- let rec add t1 t2 =
- match t1,t2 with
- | [], _ -> t2
- | _ , [] -> t1
- | e1::t1,e2::t2 -> (e1 +/ e2 )::(add t1 t2)
-
- let dotp t1 t2 =
- let rec _dotp t1 t2 acc =
- match t1, t2 with
- | [] , _ -> acc
- | _ , [] -> acc
- | e1::t1,e2::t2 -> _dotp t1 t2 (acc +/ (e1 */ e2)) in
- _dotp t1 t2 zero_num
-
- let add_mul n t1 t2 =
- match n with
- | Int 0 -> t2
- | Int 1 -> add t1 t2
- | _ ->
- let rec _add_mul t1 t2 =
- match t1,t2 with
- | [], _ -> t2
- | _ , [] -> mul n t1
- | e1::t1,e2::t2 -> ( (n */e1) +/ e2 )::(_add_mul t1 t2) in
- _add_mul t1 t2
-
- let lin_comb n1 t1 n2 t2 =
- match n1,n2 with
- | Int 0 , _ -> mul n2 t2
- | Int 1 , _ -> add_mul n2 t2 t1
- | _ , Int 0 -> mul n1 t1
- | _ , Int 1 -> add_mul n1 t1 t2
- | _ ->
- let rec _lin_comb t1 t2 =
- match t1,t2 with
- | [], _ -> mul n2 t2
- | _ , [] -> mul n1 t1
- | e1::t1,e2::t2 -> ( (n1 */e1) +/ (n2 */ e2 ))::(_lin_comb t1 t2) in
- _lin_comb t1 t2
-
- (* could be computed on the fly *)
- let gcd t =Mutils.gcd_list t
-
-
-
-
- let hash = Mutils.Cmp.hash_list int_of_num
-
- let compare = Mutils.Cmp.compare_list compare_num
-
- type it = t
- let iterator (x:t) : it = x
- let element it =
- match it with
- | [] -> None
- | e::l -> Some (e,l)
-
- (* TODO: Buffer! *)
- let string l = List.fold_right (fun n s -> (string_of_num n)^";"^s) l ""
-
- type status = Pos | Neg
-
- let status l =
- let rec xstatus i l =
- match l with
- | [] -> []
- | e::l ->
- begin
- match compare_num e (Int 0) with
- | 1 -> (i,Pos):: (xstatus (i+1) l)
- | 0 -> xstatus (i+1) l
- | -1 -> (i,Neg) :: (xstatus (i+1) l)
- | _ -> assert false
- end in
- xstatus 0 l
-
- let from_list l = l
- let to_list l = l
-
-end
-
-module VMap : S =
-struct
- module Map = Map.Make(struct type t = int let compare (x:int) (y:int) = Pervasives.compare x y end)
-
- type t = num Map.t
-
- let null = Map.empty
-
- let fresh m = failwith "not implemented"
-
- let is_null = Map.is_empty
-
- let normalise m = failwith "Not implemented"
-
-
-
- let get i l = try Map.find i l with _ -> zero_num
-
- let update i f t =
- try
- let res = f (Map.find i t) in
- if res =/ zero_num
- then Map.remove i t
- else Map.add i res t
- with
- Not_found ->
- let res = f zero_num in
- if res =/ zero_num then t else Map.add i res t
-
- let set i n t =
- if n =/ zero_num then Map.remove i t
- else Map.add i n t
-
-
- let rec mul z t =
- match z with
- | Int 0 -> null
- | Int 1 -> t
- | _ -> Map.map (mult_num z) t
-
- let uminus t = mul (Int (-1)) t
-
-
- let map2 f m1 m2 =
- let res,m2' =
- Map.fold (fun k e (res,m2) ->
- let v = f e (get k m2) in
- if v =/ zero_num
- then (res,Map.remove k m2)
- else (Map.add k v res,Map.remove k m2)) m1 (Map.empty,m2) in
- Map.fold (fun k e res ->
- let v = f zero_num e in
- if v =/ zero_num
- then res else Map.add k v res) m2' res
-
- let add t1 t2 = map2 (+/) t1 t2
-
-
- let dotp t1 t2 =
- Map.fold (fun k e res ->
- res +/ (e */ get k t2)) t1 zero_num
-
-
-
- let add_mul n t1 t2 =
- match n with
- | Int 0 -> t2
- | Int 1 -> add t1 t2
- | _ -> map2 (fun x y -> (n */ x) +/ y) t1 t2
-
- let lin_comb n1 t1 n2 t2 =
- match n1,n2 with
- | Int 0 , _ -> mul n2 t2
- | Int 1 , _ -> add_mul n2 t2 t1
- | _ , Int 0 -> mul n1 t1
- | _ , Int 1 -> add_mul n1 t1 t2
- | _ -> map2 (fun x y -> (n1 */ x) +/ (n2 */ y)) t1 t2
-
-
- let hash map = Map.fold (fun k e res -> k lxor (int_of_num e) lxor res) map 0
-
- let compare = Map.compare compare_num
-
- type it = t * int
-
- let iterator (x:t) : it = (x,0)
-
- let element (mp,id) =
- try
- Some (Map.find id mp, (mp, id+1))
- with
- Not_found -> None
-
- (* TODO: Buffer! *)
- type status = Pos | Neg
-
- let status l = Map.fold (fun k e l ->
- match compare_num e (Int 0) with
- | 1 -> (k,Pos)::l
- | 0 -> l
- | -1 -> (k,Neg) :: l
- | _ -> assert false) l []
- let from_list l =
- let rec from_list i l map =
- match l with
- | [] -> map
- | e::l -> from_list (i+1) l (if e <>/ Int 0 then Map.add i e map else map) in
- from_list 0 l Map.empty
-
- let gcd m =
- let res = Map.fold (fun _ e x -> Big_int.gcd_big_int x (Mutils.numerator e)) m Big_int.zero_big_int in
- if Big_int.compare_big_int res Big_int.zero_big_int = 0
- then Big_int.unit_big_int else res
-
-
- let to_list m =
- let l = List.rev (Map.fold (fun k e l -> (k,e)::l) m []) in
- let rec xto_list i l =
- match l with
- | [] -> []
- | (x,v)::l' -> if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in
- xto_list 0 l
-
- let string l = VList.string (to_list l)
-
-
-end
-
-
-module VSparse : S =
-struct
-
- type t = (int*num) list
-
- let null = []
-
- let fresh l = List.fold_left (fun acc (i,_) -> max (i+1) acc) 0 l
-
- let is_null l = l = []
-
- let rec is_sorted l =
- match l with
- | [] -> true
- | [e] -> true
- | (i,_)::(j,x)::l -> i < j && is_sorted ((j,x)::l)
-
-
- let check l = (List.for_all (fun (_,n) -> compare_num n (Int 0) <> 0) l) && (is_sorted l)
-
- (* let get i t =
- assert (check t);
- try List.assoc i t with Not_found -> zero_num *)
-
- let rec get (i:int) t =
- match t with
- | [] -> zero_num
- | (j,n)::t ->
- match compare i j with
- | 0 -> n
- | 1 -> get i t
- | _ -> zero_num
-
- let cons i v rst = if v =/ Int 0 then rst else (i,v)::rst
-
- let rec update i f t =
- match t with
- | [] -> cons i (f zero_num) []
- | (k,v)::l ->
- match Pervasives.compare i k with
- | 0 -> cons k (f v) l
- | -1 -> cons i (f zero_num) t
- | 1 -> (k,v) ::(update i f l)
- | _ -> failwith "compare_num"
-
- let update i f t =
- assert (check t);
- let res = update i f t in
- assert (check t) ; res
-
-
- let rec set i n t =
- match t with
- | [] -> cons i n []
- | (k,v)::l ->
- match Pervasives.compare i k with
- | 0 -> cons k n l
- | -1 -> cons i n t
- | 1 -> (k,v) :: (set i n l)
- | _ -> failwith "compare_num"
-
-
- let rec map f l =
- match l with
- | [] -> []
- | (i,e)::l -> cons i (f e) (map f l)
-
- let rec mul z t =
- match z with
- | Int 0 -> null
- | Int 1 -> t
- | _ -> List.map (fun (i,n) -> (i, mult_num z n)) t
-
- let mul z t =
- assert (check t) ;
- let res = mul z t in
- assert (check res) ;
- res
-
- let uminus t = mul (Int (-1)) t
-
-
- let normalise l =
- match l with
- | [] -> (Int 0,[])
- | (i,n)::_ -> (n, mul ((Int 1) // n) l)
-
-
- let rec map2 f m1 m2 =
- match m1, m2 with
- | [] , [] -> []
- | l , [] -> map (fun x -> f x zero_num) l
- | [] ,l -> map (f zero_num) l
- | (i,e)::l1,(i',e')::l2 ->
- match Pervasives.compare i i' with
- | 0 -> cons i (f e e') (map2 f l1 l2)
- | -1 -> cons i (f e zero_num) (map2 f l1 m2)
- | 1 -> cons i' (f zero_num e') (map2 f m1 l2)
- | _ -> assert false
-
- (* let add t1 t2 = map2 (+/) t1 t2*)
-
- let rec add (m1:t) (m2:t) =
- match m1, m2 with
- | [] , [] -> []
- | l , [] -> l
- | [] ,l -> l
- | (i,e)::l1,(i',e')::l2 ->
- match Pervasives.compare i i' with
- | 0 -> cons i ( e +/ e') (add l1 l2)
- | -1 -> (i,e) :: (add l1 m2)
- | 1 -> (i', e') :: (add m1 l2)
- | _ -> assert false
-
-
-
-
- let add t1 t2 =
- assert (check t1 && check t2);
- let res = add t1 t2 in
- assert (check res);
- res
-
-
- let rec dotp (t1:t) (t2:t) =
- match t1, t2 with
- | [] , _ -> zero_num
- | _ , [] -> zero_num
- | (i,e)::l1 , (i',e')::l2 ->
- match Pervasives.compare i i' with
- | 0 -> (e */ e') +/ (dotp l1 l2)
- | -1 -> dotp l1 t2
- | 1 -> dotp t1 l2
- | _ -> assert false
-
- let dotp t1 t2 =
- assert (check t1 && check t2) ; dotp t1 t2
-
- let add_mul n t1 t2 =
- match n with
- | Int 0 -> t2
- | Int 1 -> add t1 t2
- | _ -> map2 (fun x y -> (n */ x) +/ y) t1 t2
-
- let add_mul n (t1:t) (t2:t) =
- match n with
- | Int 0 -> t2
- | Int 1 -> add t1 t2
- | _ ->
- let rec xadd_mul m1 m2 =
- match m1, m2 with
- | [] , [] -> []
- | _ , [] -> mul n m1
- | [] , _ -> m2
- | (i,e)::l1,(i',e')::l2 ->
- match Pervasives.compare i i' with
- | 0 -> cons i ( n */ e +/ e') (xadd_mul l1 l2)
- | -1 -> (i,n */ e) :: (xadd_mul l1 m2)
- | 1 -> (i', e') :: (xadd_mul m1 l2)
- | _ -> assert false in
- xadd_mul t1 t2
-
-
-
-
- let lin_comb n1 t1 n2 t2 =
- match n1,n2 with
- | Int 0 , _ -> mul n2 t2
- | Int 1 , _ -> add_mul n2 t2 t1
- | _ , Int 0 -> mul n1 t1
- | _ , Int 1 -> add_mul n1 t1 t2
- | _ -> (*map2 (fun x y -> (n1 */ x) +/ (n2 */ y)) t1 t2*)
- let rec xlin_comb m1 m2 =
- match m1, m2 with
- | [] , [] -> []
- | _ , [] -> mul n1 m1
- | [] , _ -> mul n2 m2
- | (i,e)::l1,(i',e')::l2 ->
- match Pervasives.compare i i' with
- | 0 -> cons i ( n1 */ e +/ n2 */ e') (xlin_comb l1 l2)
- | -1 -> (i,n1 */ e) :: (xlin_comb l1 m2)
- | 1 -> (i', n2 */ e') :: (xlin_comb m1 l2)
- | _ -> assert false in
- xlin_comb t1 t2
-
-
-
-
-
- let lin_comb n1 t1 n2 t2 =
- assert (check t1 && check t2);
- let res = lin_comb n1 t1 n2 t2 in
- assert (check res); res
-
- let hash = Mutils.Cmp.hash_list (fun (x,y) -> (Hashtbl.hash x) lxor (int_of_num y))
-
-
- let compare = Mutils.Cmp.compare_list (fun x y -> Mutils.Cmp.compare_lexical
- [
- (fun () -> Pervasives.compare (fst x) (fst y));
- (fun () -> compare_num (snd x) (snd y))])
-
- (*
- let compare (x:t) (y:t) =
- let rec xcompare acc1 acc2 x y =
- match x , y with
- | [] , [] -> xcomp acc1 acc2
- | [] , _ -> -1
- | _ , [] -> 1
- | (i,n1)::l1 , (j,n2)::l2 ->
- match Pervasives.compare i j with
- | 0 -> xcompare (n1::acc1) (n2::acc2) l1 l2
- | c -> c
- and xcomp acc1 acc2 = Mutils.Cmp.compare_list compare_num acc1 acc2 in
- xcompare [] [] x y
- *)
-
- type it = t
-
- let iterator (x:t) : it = x
-
- let element l = failwith "Not_implemented"
-
- (* TODO: Buffer! *)
- type status = Pos | Neg
-
- let status l = List.map (fun (i,e) ->
- match compare_num e (Int 0) with
- | 1 -> i,Pos
- | -1 -> i,Neg
- | _ -> assert false) l
-
- let from_list (l: num list) =
- let rec xfrom_list i l =
- match l with
- | [] -> []
- | e::l ->
- if e <>/ Int 0
- then (i,e)::(xfrom_list (i+1) l)
- else xfrom_list (i+1) l in
-
- let res = xfrom_list 0 l in
- assert (check res) ; res
-
-
- let gcd m =
- let res = List.fold_left (fun x (i,e) -> Big_int.gcd_big_int x (Mutils.numerator e)) Big_int.zero_big_int m in
- if Big_int.compare_big_int res Big_int.zero_big_int = 0
- then Big_int.unit_big_int else res
-
- let to_list m =
- let rec xto_list i l =
- match l with
- | [] -> []
- | (x,v)::l' ->
- if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in
- xto_list 0 m
-
- let to_list l =
- assert (check l);
- to_list l
-
-
- let string l = VList.string (to_list l)
-
-end