From 1b92c226e563643da187b8614d5888dc4855eb43 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Tue, 27 Dec 2016 16:53:30 +0100 Subject: Imported Upstream version 8.6 --- plugins/micromega/Env.v | 6 +- plugins/micromega/EnvRing.v | 2 +- plugins/micromega/Lia.v | 34 +- plugins/micromega/Lqa.v | 51 + plugins/micromega/Lra.v | 52 + plugins/micromega/MExtraction.v | 2 +- plugins/micromega/Psatz.v | 71 +- plugins/micromega/QMicromega.v | 2 +- plugins/micromega/RMicromega.v | 2 +- plugins/micromega/RingMicromega.v | 2 +- plugins/micromega/VarMap.v | 29 +- plugins/micromega/ZMicromega.v | 2 +- plugins/micromega/certificate.ml | 1565 ++++++++-------- plugins/micromega/coq_micromega.ml | 887 ++++++--- plugins/micromega/g_micromega.ml4 | 53 +- plugins/micromega/mfourier.ml | 26 +- plugins/micromega/micromega.ml | 2827 +++-------------------------- plugins/micromega/micromega.mli | 950 ++-------- plugins/micromega/micromega_plugin.mllib | 10 - plugins/micromega/micromega_plugin.mlpack | 9 + plugins/micromega/mutils.ml | 21 +- plugins/micromega/persistent_cache.ml | 10 +- plugins/micromega/vo.itarget | 4 +- 23 files changed, 2121 insertions(+), 4496 deletions(-) create mode 100644 plugins/micromega/Lqa.v create mode 100644 plugins/micromega/Lra.v delete mode 100644 plugins/micromega/micromega_plugin.mllib create mode 100644 plugins/micromega/micromega_plugin.mlpack (limited to 'plugins/micromega') diff --git a/plugins/micromega/Env.v b/plugins/micromega/Env.v index a19e9df9..7e3ef892 100644 --- a/plugins/micromega/Env.v +++ b/plugins/micromega/Env.v @@ -93,7 +93,7 @@ End S. Ltac jump_simpl := repeat match goal with - | |- appcontext [jump xH] => rewrite (jump_simpl xH) - | |- appcontext [jump (xO ?p)] => rewrite (jump_simpl (xO p)) - | |- appcontext [jump (xI ?p)] => rewrite (jump_simpl (xI p)) + | |- context [jump xH] => rewrite (jump_simpl xH) + | |- context [jump (xO ?p)] => rewrite (jump_simpl (xO p)) + | |- context [jump (xI ?p)] => rewrite (jump_simpl (xI p)) end. diff --git a/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v index fd4bb248..904ee4da 100644 --- a/plugins/micromega/EnvRing.v +++ b/plugins/micromega/EnvRing.v @@ -914,7 +914,7 @@ Qed. revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros. - discriminate. - assert (H':=PNSubst_ok n P3 M2 P2'). destruct PNSubst. - * injection H; intros <-. rewrite <- PSubstL1_ok; intuition. + * injection H as <-. rewrite <- PSubstL1_ok; intuition. * now apply IH. Qed. diff --git a/plugins/micromega/Lia.v b/plugins/micromega/Lia.v index 3e58e81a..47b6f7c7 100644 --- a/plugins/micromega/Lia.v +++ b/plugins/micromega/Lia.v @@ -8,7 +8,7 @@ (* *) (* Micromega: A reflexive tactic using the Positivstellensatz *) (* *) -(* Frédéric Besson (Irisa/Inria) 2013 *) +(* Frédéric Besson (Irisa/Inria) 2013-2016 *) (* *) (************************************************************************) @@ -16,27 +16,27 @@ Require Import ZMicromega. Require Import ZArith. Require Import RingMicromega. Require Import VarMap. -Require Tauto. +Require Coq.micromega.Tauto. Declare ML Module "micromega_plugin". + Ltac preprocess := zify ; unfold Z.succ in * ; unfold Z.pred in *. -Ltac lia := - preprocess; - xlia ; - abstract ( - intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; - apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)). - -Ltac nia := - preprocess; - xnlia ; - abstract ( - intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; - apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)). +Ltac zchange := + intros __wit __varmap __ff ; + change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; + apply (ZTautoChecker_sound __ff __wit). + +Ltac zchecker_no_abstract := zchange ; vm_compute ; reflexivity. + +Ltac zchecker_abstract := zchange ; vm_cast_no_check (eq_refl true). + +Ltac zchecker := zchecker_no_abstract. + +Ltac lia := preprocess; xlia zchecker. + +Ltac nia := preprocess; xnlia zchecker. (* Local Variables: *) diff --git a/plugins/micromega/Lqa.v b/plugins/micromega/Lqa.v new file mode 100644 index 00000000..acd2751a --- /dev/null +++ b/plugins/micromega/Lqa.v @@ -0,0 +1,51 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + ((sos_Q rchecker) || (psatz_Q d rchecker)) + | _ => 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). + + +(* Local Variables: *) +(* coding: utf-8 *) +(* End: *) diff --git a/plugins/micromega/Lra.v b/plugins/micromega/Lra.v new file mode 100644 index 00000000..5b97d8ed --- /dev/null +++ b/plugins/micromega/Lra.v @@ -0,0 +1,52 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + (sos_R rchecker) || (psatz_R d rchecker) + | _ => 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). + + +(* Local Variables: *) +(* coding: utf-8 *) +(* End: *) diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v index 0a41af45..d28bb828 100644 --- a/plugins/micromega/MExtraction.v +++ b/plugins/micromega/MExtraction.v @@ -50,7 +50,7 @@ Extract Constant Rinv => "fun x -> 1 / x". Extraction "micromega.ml" List.map simpl_cone (*map_cone indexes*) - denorm Qpower + denorm Qpower vm_add n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. diff --git a/plugins/micromega/Psatz.v b/plugins/micromega/Psatz.v index a461b26a..8acf0ff8 100644 --- a/plugins/micromega/Psatz.v +++ b/plugins/micromega/Psatz.v @@ -8,7 +8,7 @@ (* *) (* Micromega: A reflexive tactic using the Positivstellensatz *) (* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) +(* Frédéric Besson (Irisa/Inria) 2006-2016 *) (* *) (************************************************************************) @@ -20,75 +20,36 @@ Require Import ZArith. Require Import Rdefinitions. Require Import RingMicromega. Require Import VarMap. -Require Tauto. -Declare ML Module "micromega_plugin". +Require Coq.micromega.Tauto. +Require Lia. +Require Lra. +Require Lqa. -Ltac preprocess := - zify ; unfold Z.succ in * ; unfold Z.pred in *. +Declare ML Module "micromega_plugin". -Ltac lia := - preprocess; - xlia ; - abstract ( - intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; - apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)). +Ltac lia := Lia.lia. -Ltac nia := - preprocess; - xnlia ; - abstract ( - intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; - apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)). +Ltac nia := Lia.nia. Ltac xpsatz dom d := let tac := lazymatch dom with | Z => - (sos_Z || psatz_Z d) ; - abstract( - intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; - apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)) + (sos_Z Lia.zchecker) || (psatz_Z d Lia.zchecker) | R => - (sos_R || psatz_R d) ; - (* If csdp is not installed, the previous step might not produce any - progress: the rest of the tactical will then fail. Hence the 'try'. *) - try (abstract(intros __wit __varmap __ff ; - change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; - apply (RTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true))) - | Q => - (sos_Q || psatz_Q d) ; - (* If csdp is not installed, the previous step might not produce any - progress: the rest of the tactical will then fail. Hence the 'try'. *) - try (abstract(intros __wit __varmap __ff ; - change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; - apply (QTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true))) + (sos_R Lra.rchecker) || (psatz_R d Lra.rchecker) + | Q => (sos_Q Lqa.rchecker) || (psatz_Q d Lqa.rchecker) | _ => 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. +Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:(-1). Ltac psatzl dom := let tac := lazymatch dom with - | Z => lia - | Q => - psatzl_Q ; - (* If csdp is not installed, the previous step might not produce any - progress: the rest of the tactical will then fail. Hence the 'try'. *) - try (abstract(intros __wit __varmap __ff ; - change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; - apply (QTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true))) - | R => - unfold Rdiv in * ; - psatzl_R ; - (* If csdp is not installed, the previous step might not produce any - progress: the rest of the tactical will then fail. Hence the 'try'. *) - try abstract((intros __wit __varmap __ff ; - change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; - apply (RTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true))) + | Z => Lia.lia + | Q => Lqa.lra + | R => Lra.lra | _ => fail "Unsupported domain" end in tac. @@ -96,6 +57,8 @@ Ltac psatzl dom := Ltac lra := first [ psatzl R | psatzl Q ]. +Ltac nra := + first [ Lra.nra | Lqa.nra ]. (* Local Variables: *) diff --git a/plugins/micromega/QMicromega.v b/plugins/micromega/QMicromega.v index 43268363..b13285f5 100644 --- a/plugins/micromega/QMicromega.v +++ b/plugins/micromega/QMicromega.v @@ -168,7 +168,7 @@ Proof. exact H. Qed. -Require Import Tauto. +Require Import Coq.micromega.Tauto. Definition Qnormalise := @cnf_normalise Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. Definition Qnegate := @cnf_negate Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v index 72353a99..2352d78d 100644 --- a/plugins/micromega/RMicromega.v +++ b/plugins/micromega/RMicromega.v @@ -533,7 +533,7 @@ Proof. exact H. Qed. -Require Import Tauto. +Require Import Coq.micromega.Tauto. Definition Rnormalise := @cnf_normalise Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool. Definition Rnegate := @cnf_negate Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool. diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v index 751a81df..ed49c3df 100644 --- a/plugins/micromega/RingMicromega.v +++ b/plugins/micromega/RingMicromega.v @@ -794,7 +794,7 @@ Definition xnormalise (t:Formula C) : list (NFormula) := | OpLe => (psub lhs rhs ,Strict) :: nil end. -Require Import Tauto. +Require Import Coq.micromega.Tauto. Definition cnf_normalise (t:Formula C) : cnf (NFormula) := List.map (fun x => x::nil) (xnormalise t). diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v index 4981ddb3..2d2c0bc7 100644 --- a/plugins/micromega/VarMap.v +++ b/plugins/micromega/VarMap.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Leaf v + | xO p => Node (singleton p v) default Empty + | xI p => Node Empty default (singleton p v) + end. + + Fixpoint vm_add (x: positive) (v : A) (m : t) {struct m} : t := + match m with + | Empty => singleton x v + | Leaf vl => + match x with + | xH => Leaf v + | xO p => Node (singleton p v) vl Empty + | xI p => Node Empty vl (singleton p v) + end + | Node l o r => + match x with + | xH => Node l v r + | xI p => Node l o (vm_add p v r) + | xO p => Node (vm_add p v l) o r + end + end. + +End MakeVarMap. diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v index d7ddef2b..5aa8d03f 100644 --- a/plugins/micromega/ZMicromega.v +++ b/plugins/micromega/ZMicromega.v @@ -198,7 +198,7 @@ Definition xnormalise (t:Formula Z) : list (NFormula Z) := | OpLe => (psub lhs (padd rhs (Pc 1)),NonStrict) :: nil end. -Require Import Tauto BinNums. +Require Import Coq.micromega.Tauto BinNums. Definition normalise (t:Formula Z) : cnf (NFormula Z) := List.map (fun x => x::nil) (xnormalise t). diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index a5fceb56..459c72f9 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -63,82 +63,82 @@ 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 (C2Ml.positive 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 Int.equal 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 + | Mc.PEc z -> Poly.constant (n_spec.number_to_num z) + | Mc.PEX v -> Poly.variable (C2Ml.positive 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 Int.equal 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 v = Ml2C.positive v in - let mn = if Int.equal i 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in - if Pervasives.(=) acc (Mc.PEc (Mc.Zpos Mc.XH)) (** FIXME *) - then mn - else Mc.PEmul(mn,acc)) - mn - (Mc.PEc (Mc.Zpos Mc.XH)) + let v = Ml2C.positive v in + let mn = if Int.equal i 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in + if Pervasives.(=) acc (Mc.PEc (Mc.Zpos Mc.XH)) (** FIXME *) + 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 Pervasives.(=) c (Mc.PEc (Mc.Zpos Mc.XH)) - then var i - else Mc.PEmul (c,var i) in - let p' = if Pervasives.(=) 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 + else let c = Mc.PEc (Ml2C.bigint (numerator c)) in + let mn = + if Pervasives.(=) c (Mc.PEc (Mc.Zpos Mc.XH)) + then var i + else Mc.PEmul (c,var i) in + let p' = if Pervasives.(=) 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 Pervasives.(=) y' x then y' - else fixpoint f y' + if Pervasives.(=) 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.PsatzMulE(t1, t2) -> - simpl_cone (Mc.PsatzMulE (rec_simpl_cone t1, rec_simpl_cone t2)) - | Mc.PsatzAdd(t1,t2) -> - simpl_cone (Mc.PsatzAdd (rec_simpl_cone t1, rec_simpl_cone t2)) - | x -> simpl_cone x in - rec_simpl_cone e - - + | Mc.PsatzMulE(t1, t2) -> + simpl_cone (Mc.PsatzMulE (rec_simpl_cone t1, rec_simpl_cone t2)) + | Mc.PsatzAdd(t1,t2) -> + simpl_cone (Mc.PsatzAdd (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 + Const of cone +| Ideal of cone *cone +| Mult of cone * cone +| Other of cone and cone = Mc.zWitness @@ -147,32 +147,32 @@ let factorise_linear_cone c = let rec cone_list c l = match c with - | Mc.PsatzAdd (x,r) -> cone_list r (x::l) - | _ -> c :: l in - + | Mc.PsatzAdd (x,r) -> cone_list r (x::l) + | _ -> c :: l in + let factorise c1 c2 = match c1 , c2 with - | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') -> - if Pervasives.(=) x x' then Some (Mc.PsatzMulC(x, Mc.PsatzAdd(y,y'))) else None - | Mc.PsatzMulE(x,y) , Mc.PsatzMulE(x',y') -> - if Pervasives.(=) x x' then Some (Mc.PsatzMulE(x, Mc.PsatzAdd(y,y'))) else None - | _ -> None in - + | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') -> + if Pervasives.(=) x x' then Some (Mc.PsatzMulC(x, Mc.PsatzAdd(y,y'))) else None + | Mc.PsatzMulE(x,y) , Mc.PsatzMulE(x',y') -> + if Pervasives.(=) x x' then Some (Mc.PsatzMulE(x, Mc.PsatzAdd(y,y'))) else None + | _ -> None in + let rec rebuild_cone l pending = match l with - | [] -> (match pending with - | None -> Mc.PsatzZ - | Some p -> p - ) - | e::l -> - (match pending with - | None -> rebuild_cone l (Some e) - | Some p -> (match factorise p e with - | None -> Mc.PsatzAdd(p, rebuild_cone l (Some e)) - | Some f -> rebuild_cone l (Some f) ) - ) in + | [] -> (match pending with + | None -> Mc.PsatzZ + | Some p -> p + ) + | e::l -> + (match pending with + | None -> rebuild_cone l (Some e) + | Some p -> (match factorise p e with + | None -> Mc.PsatzAdd(p, rebuild_cone l (Some e)) + | Some f -> rebuild_cone l (Some f) ) + ) in - (rebuild_cone (List.sort Pervasives.compare (cone_list c [])) None) + (rebuild_cone (List.sort Pervasives.compare (cone_list c [])) None) @@ -199,28 +199,28 @@ open Mfourier let constrain_monomial mn l = let coeffs = List.fold_left (fun acc p -> (Poly.get mn p)::acc) [] l in - if Pervasives.(=) 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 } + if Pervasives.(=) 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) + | [] -> [] + | (_,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 + xpositivity 0 l let string_of_op = function @@ -241,23 +241,23 @@ let build_linear_system l = let monomials = List.fold_left (fun acc p -> - Poly.fold (fun m _ acc -> MonSet.add m acc) p acc) - (MonSet.singleton Monomial.const) l' + Poly.fold (fun m _ acc -> MonSet.add m acc) p acc) + (MonSet.singleton Monomial.const) l' in (* For each monomial, compute a constraint *) let s0 = MonSet.fold (fun mn res -> (constrain_monomial mn l')::res) monomials [] in - (* I need at least something strictly positive *) + (* 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)); + 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) + {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 @@ -266,32 +266,32 @@ let big_int_to_z = Ml2C.bigint -- 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 - | [] -> failwith "empty_certificate" - | e::cert' -> -(* let cst = match compare_big_int e zero_big_int with - | 0 -> Mc.PsatzZ - | 1 -> Mc.PsatzC (bint_to_cst e) - | _ -> failwith "positivity error" - in *) - let rec scalar_product cert l = - match cert with - | [] -> Mc.PsatzZ - | 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.PsatzAdd ( - Mc.PsatzMulC (Mc.Pc ( bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), - r) - | 0 -> r - | _ -> Mc.PsatzAdd ( - Mc.PsatzMulE (Mc.PsatzC (bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), - r) in - (factorise_linear_cone - (simplify_cone n_spec (scalar_product cert' li))) + match cert with + | [] -> failwith "empty_certificate" + | e::cert' -> + (* let cst = match compare_big_int e zero_big_int with + | 0 -> Mc.PsatzZ + | 1 -> Mc.PsatzC (bint_to_cst e) + | _ -> failwith "positivity error" + in *) + let rec scalar_product cert l = + match cert with + | [] -> Mc.PsatzZ + | 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.PsatzAdd ( + Mc.PsatzMulC (Mc.Pc ( bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), + r) + | 0 -> r + | _ -> Mc.PsatzAdd ( + Mc.PsatzMulE (Mc.PsatzC (bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), + r) in + (factorise_linear_cone + (simplify_cone n_spec (scalar_product cert' li))) exception Found of Monomial.t @@ -301,92 +301,155 @@ exception Strict module MonMap = Map.Make(Monomial) let primal l = - let vr = ref 0 in - - let vect_of_poly map p = - Poly.fold (fun mn vl (map,vect) -> - if Pervasives.(=) mn Monomial.const - then (map,vect) - else - let (mn,m) = try (MonMap.find mn map,map) with Not_found -> let res = (!vr, MonMap.add mn !vr map) in incr vr ; res in - (m,if Int.equal (sign_num vl) 0 then vect else (mn,vl)::vect)) p (map,[]) in - - let op_op = function Mc.NonStrict -> Ge |Mc.Equal -> Eq | _ -> raise Strict in + let vr = ref 0 in + + let vect_of_poly map p = + Poly.fold (fun mn vl (map,vect) -> + if Pervasives.(=) mn Monomial.const + then (map,vect) + else + let (mn,m) = try (MonMap.find mn map,map) with Not_found -> let res = (!vr, MonMap.add mn !vr map) in incr vr ; res in + (m,if Int.equal (sign_num vl) 0 then vect else (mn,vl)::vect)) p (map,[]) in + + let op_op = function Mc.NonStrict -> Ge |Mc.Equal -> Eq | _ -> raise Strict in - let cmp x y = Int.compare (fst x) (fst y) in + let cmp x y = Int.compare (fst x) (fst y) in - snd (List.fold_right (fun (p,op) (map,l) -> - let (mp,vect) = vect_of_poly map p in - let cstr = {coeffs = List.sort cmp vect; op = op_op op ; cst = minus_num (Poly.get Monomial.const p)} in + snd (List.fold_right (fun (p,op) (map,l) -> + let (mp,vect) = vect_of_poly map p in + let cstr = {coeffs = List.sort cmp vect; op = op_op op ; cst = minus_num (Poly.get Monomial.const p)} in - (mp,cstr::l)) l (MonMap.empty,[])) + (mp,cstr::l)) l (MonMap.empty,[])) let dual_raw_certificate (l: (Poly.t * Mc.op1) list) = -(* List.iter (fun (p,op) -> Printf.fprintf stdout "%a %s 0\n" Poly.pp p (string_of_op op) ) l ; *) - + (* List.iter (fun (p,op) -> Printf.fprintf stdout "%a %s 0\n" Poly.pp p (string_of_op op) ) l ; *) + let sys = build_linear_system l in - try - match Fourier.find_point sys with - | Inr _ -> None - | Inl cert -> Some (rats_to_ints (Vect.to_list cert)) - (* should not use rats_to_ints *) - with x when Errors.noncritical x -> - if debug - then (Printf.printf "raw certificate %s" (Printexc.to_string x); - flush stdout) ; - None + try + match Fourier.find_point sys with + | Inr _ -> None + | Inl cert -> Some (rats_to_ints (Vect.to_list cert)) + (* should not use rats_to_ints *) + with x when CErrors.noncritical x -> + if debug + then (Printf.printf "raw certificate %s" (Printexc.to_string x); + flush stdout) ; + None let raw_certificate l = - try - let p = primal l in - match Fourier.find_point p with - | Inr prf -> - if debug then Printf.printf "AProof : %a\n" pp_proof prf ; - let cert = List.map (fun (x,n) -> x+1,n) (fst (List.hd (Proof.mk_proof p prf))) in - if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ; - Some (rats_to_ints (Vect.to_list cert)) - | Inl _ -> None - with Strict -> + try + let p = primal l in + match Fourier.find_point p with + | Inr prf -> + if debug then Printf.printf "AProof : %a\n" pp_proof prf ; + let cert = List.map (fun (x,n) -> x+1,n) (fst (List.hd (Proof.mk_proof p prf))) in + if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ; + Some (rats_to_ints (Vect.to_list cert)) + | Inl _ -> None + with Strict -> (* Fourier elimination should handle > *) - dual_raw_certificate l + dual_raw_certificate l let simple_linear_prover l = let (lc,li) = List.split l in - match raw_certificate lc with - | None -> None (* No certificate *) - | Some cert -> Some (cert,li) - + match raw_certificate lc with + | None -> None (* No certificate *) + | Some cert -> Some (cert,li) + let linear_prover n_spec l = - let build_system n_spec l = - let li = List.combine l (interval 0 (List.length l -1)) in - let (l1,l') = List.partition - (fun (x,_) -> if Pervasives.(=) (snd x) Mc.NonEqual then true else false) li in - List.map - (fun ((x,y),i) -> match y with - Mc.NonEqual -> failwith "cannot happen" - | y -> ((dev_form n_spec x, y),i)) l' in - let l' = build_system n_spec l in - simple_linear_prover (*n_spec*) l' + let build_system n_spec l = + let li = List.combine l (interval 0 (List.length l -1)) in + let (l1,l') = List.partition + (fun (x,_) -> if Pervasives.(=) (snd x) Mc.NonEqual then true else false) li in + List.map + (fun ((x,y),i) -> match y with + Mc.NonEqual -> failwith "cannot happen" + | y -> ((dev_form n_spec x, y),i)) l' in + let l' = build_system n_spec l in + simple_linear_prover (*n_spec*) l' let linear_prover n_spec l = try linear_prover n_spec l - with x when Errors.noncritical x -> - (print_string (Printexc.to_string x); None) + with x when CErrors.noncritical x -> + (print_string (Printexc.to_string x); None) + +let compute_max_nb_cstr l d = + let len = List.length l in + max len (max d (len * d)) + +let linear_prover_with_cert prfdepth spec l = + max_nb_cstr := compute_max_nb_cstr l prfdepth ; + match linear_prover spec l with + | None -> None + | Some cert -> Some (make_certificate spec cert) + +let nlinear_prover prfdepth (sys: (Mc.q Mc.pExpr * Mc.op1) list) = + LinPoly.MonT.clear (); + max_nb_cstr := compute_max_nb_cstr sys prfdepth ; + (* Assign a proof to the initial hypotheses *) + let sys = mapi (fun c i -> (c,Mc.PsatzIn (Ml2C.nat i))) sys in + + + (* Add all the product of hypotheses *) + let prod = all_pairs (fun ((c,o),p) ((c',o'),p') -> + ((Mc.PEmul(c,c') , Mc.opMult o o') , Mc.PsatzMulE(p,p'))) sys in + + (* Only filter those have a meaning *) + let prod = List.fold_left (fun l ((c,o),p) -> + match o with + | None -> l + | Some o -> ((c,o),p) :: l) [] prod in + + let sys = sys @ prod in + + let square = + (* Collect the squares and state that they are positive *) + let pols = List.map (fun ((p,_),_) -> dev_form q_spec p) sys in + let square = + List.fold_left (fun acc p -> + Poly.fold + (fun m _ acc -> + match Monomial.sqrt m with + | None -> acc + | Some s -> MonMap.add s m acc) p acc) MonMap.empty pols in -let linear_prover_with_cert spec l = - match linear_prover spec l with - | None -> None - | Some cert -> Some (make_certificate spec cert) + let pol_of_mon m = + Monomial.fold (fun x v p -> Mc.PEmul(Mc.PEpow(Mc.PEX(Ml2C.positive x),Ml2C.n v),p)) m (Mc.PEc q_spec.unit) in + + let norm0 = + Mc.norm q_spec.zero q_spec.unit Mc.qplus Mc.qmult Mc.qminus Mc.qopp Mc.qeq_bool in + + + MonMap.fold (fun s m acc -> ((pol_of_mon m , Mc.NonStrict), Mc.PsatzSquare(norm0 (pol_of_mon s)))::acc) square [] in + + let sys = sys @ square in + (* Call the linear prover without the proofs *) + let sys_no_prf = List.map fst sys in + + match linear_prover q_spec sys_no_prf with + | None -> None + | Some cert -> + let cert = make_certificate q_spec cert in + let rec map_psatz = function + | Mc.PsatzIn n -> snd (List.nth sys (C2Ml.nat n)) + | Mc.PsatzSquare c -> Mc.PsatzSquare c + | Mc.PsatzMulC(c,p) -> Mc.PsatzMulC(c, map_psatz p) + | Mc.PsatzMulE(p1,p2) -> Mc.PsatzMulE(map_psatz p1,map_psatz p2) + | Mc.PsatzAdd(p1,p2) -> Mc.PsatzAdd(map_psatz p1,map_psatz p2) + | Mc.PsatzC c -> Mc.PsatzC c + | Mc.PsatzZ -> Mc.PsatzZ in + Some (map_psatz cert) + let make_linear_system l = @@ -395,11 +458,11 @@ let make_linear_system l = (Poly.constant (Int 0)) l' in let monomials = Poly.fold (fun mn _ l -> if Pervasives.(=) 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) + (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) let pplus x y = Mc.PEadd(x,y) @@ -413,7 +476,7 @@ let rec 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) + remove_assoc p x l else e::(remove_assoc p x l) let eq x y = Int.equal (Vect.compare x y) 0 @@ -424,39 +487,39 @@ let remove e l = List.fold_left (fun l x -> if eq x e then l else x::l) [] l only searching for naive cutting planes *) let develop_constraint z_spec (e,k) = - match k with - | Mc.NonStrict -> (dev_form z_spec e , Ge) - | Mc.Equal -> (dev_form z_spec e , Eq) - | _ -> assert false + match k with + | Mc.NonStrict -> (dev_form z_spec e , Ge) + | Mc.Equal -> (dev_form z_spec e , Eq) + | _ -> assert false let op_of_op_compat = function - | Ge -> Mc.NonStrict - | Eq -> Mc.Equal + | Ge -> Mc.NonStrict + | Eq -> Mc.Equal let integer_vector coeffs = - let vars , coeffs = List.split coeffs in - List.combine vars (List.map (fun x -> Big_int x) (rats_to_ints coeffs)) + let vars , coeffs = List.split coeffs in + List.combine vars (List.map (fun x -> Big_int x) (rats_to_ints coeffs)) let integer_cstr {coeffs = coeffs ; op = op ; cst = cst } = - let vars , coeffs = List.split coeffs in - match rats_to_ints (cst::coeffs) with - | cst :: coeffs -> - { - coeffs = List.combine vars (List.map (fun x -> Big_int x) coeffs) ; - op = op ; cst = Big_int cst} - | _ -> assert false - + let vars , coeffs = List.split coeffs in + match rats_to_ints (cst::coeffs) with + | cst :: coeffs -> + { + coeffs = List.combine vars (List.map (fun x -> Big_int x) coeffs) ; + op = op ; cst = Big_int cst} + | _ -> assert false + let pexpr_of_cstr_compat var cstr = - let {coeffs = coeffs ; op = op ; cst = cst } = integer_cstr cstr in - try - let expr = list_to_polynomial var (Vect.to_list coeffs) in - let d = Ml2C.bigint (denominator cst) in - let n = Ml2C.bigint (numerator cst) in - (pplus (pmult (pconst d) expr) (popp (pconst n)), op_of_op_compat op) - with Failure _ -> failwith "pexpr_of_cstr_compat" + let {coeffs = coeffs ; op = op ; cst = cst } = integer_cstr cstr in + try + let expr = list_to_polynomial var (Vect.to_list coeffs) in + let d = Ml2C.bigint (denominator cst) in + let n = Ml2C.bigint (numerator cst) in + (pplus (pmult (pconst d) expr) (popp (pconst n)), op_of_op_compat op) + with Failure _ -> failwith "pexpr_of_cstr_compat" @@ -465,41 +528,41 @@ open Sos_types 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 Int.equal (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" + | 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 Int.equal (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' + 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 Int.equal j i then res else get (j+1) (res+1) l ) - else get j (res+1) l in - get 0 0 l + | [] -> failwith "bad index" + | e::l -> if f e + then + (if Int.equal 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 @@ -511,97 +574,97 @@ let rec scale_certificate pos = match pos with | 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' + 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) + 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)) + 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) + 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 term_to_q_pol e = Mc.norm_aux (Ml2C.q (Int 0)) (Ml2C.q (Int 1)) Mc.qplus Mc.qmult Mc.qminus Mc.qopp Mc.qeq_bool (term_to_q_expr e) - - - let rec product l = - match l with - | [] -> Mc.PsatzZ - | [i] -> Mc.PsatzIn (Ml2C.nat i) - | i ::l -> Mc.PsatzMulE(Mc.PsatzIn (Ml2C.nat i), product l) +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 term_to_q_pol e = Mc.norm_aux (Ml2C.q (Int 0)) (Ml2C.q (Int 1)) Mc.qplus Mc.qmult Mc.qminus Mc.qopp Mc.qeq_bool (term_to_q_expr e) + + +let rec product l = + match l with + | [] -> Mc.PsatzZ + | [i] -> Mc.PsatzIn (Ml2C.nat i) + | i ::l -> Mc.PsatzMulE(Mc.PsatzIn (Ml2C.nat i), product l) let q_cert_of_pos pos = let rec _cert_of_pos = function - Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) + Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) | Monoid l -> product l | Rational_eq n | Rational_le n | Rational_lt n -> - if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else - Mc.PsatzC (Ml2C.q n) + if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else + Mc.PsatzC (Ml2C.q n) | Square t -> Mc.PsatzSquare (term_to_q_pol t) | Eqmul (t, y) -> Mc.PsatzMulC(term_to_q_pol t, _cert_of_pos y) | Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z) | Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) in - simplify_cone q_spec (_cert_of_pos pos) + 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 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 term_to_z_pol e = Mc.norm_aux (Ml2C.z 0) (Ml2C.z 1) Mc.Z.add Mc.Z.mul Mc.Z.sub Mc.Z.opp Mc.zeq_bool (term_to_z_expr e) +let term_to_z_pol e = Mc.norm_aux (Ml2C.z 0) (Ml2C.z 1) Mc.Z.add Mc.Z.mul Mc.Z.sub Mc.Z.opp Mc.zeq_bool (term_to_z_expr e) let z_cert_of_pos pos = let s,pos = (scale_certificate pos) in let rec _cert_of_pos = function - Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) + Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) | Monoid l -> product l | Rational_eq n | Rational_le n | Rational_lt n -> - if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else - Mc.PsatzC (Ml2C.bigint (big_int_of_num n)) + if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else + Mc.PsatzC (Ml2C.bigint (big_int_of_num n)) | Square t -> Mc.PsatzSquare (term_to_z_pol t) | Eqmul (t, y) -> - let is_unit = - match t with - | Const n -> n =/ Int 1 - | _ -> false in - if is_unit - then _cert_of_pos y - else Mc.PsatzMulC(term_to_z_pol t, _cert_of_pos y) + let is_unit = + match t with + | Const n -> n =/ Int 1 + | _ -> false in + if is_unit + then _cert_of_pos y + else Mc.PsatzMulC(term_to_z_pol t, _cert_of_pos y) | Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z) | Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) in - simplify_cone z_spec (_cert_of_pos pos) + simplify_cone z_spec (_cert_of_pos pos) (** All constraints (initial or derived) have an index and have a justification i.e., proof. Given a constraint, all the coefficients are always integers. @@ -612,116 +675,109 @@ open Num open Big_int open Polynomial -(*module Mc = Micromega*) -(*module Ml2C = Mutils.CamlToCoq -module C2Ml = Mutils.CoqToCaml -*) -let debug = false - - module Env = struct - type t = int list + type t = int list - let id_of_hyp hyp l = - let rec xid_of_hyp i l = - match l with - | [] -> failwith "id_of_hyp" - | hyp'::l -> if Pervasives.(=) hyp hyp' then i else xid_of_hyp (i+1) l in - xid_of_hyp 0 l + let id_of_hyp hyp l = + let rec xid_of_hyp i l = + match l with + | [] -> failwith "id_of_hyp" + | hyp'::l -> if Pervasives.(=) hyp hyp' then i else xid_of_hyp (i+1) l in + xid_of_hyp 0 l end let coq_poly_of_linpol (p,c) = - let pol_of_mon m = - Monomial.fold (fun x v p -> Mc.PEmul(Mc.PEpow(Mc.PEX(Ml2C.positive x),Ml2C.n v),p)) m (Mc.PEc (Mc.Zpos Mc.XH)) in + let pol_of_mon m = + Monomial.fold (fun x v p -> Mc.PEmul(Mc.PEpow(Mc.PEX(Ml2C.positive x),Ml2C.n v),p)) m (Mc.PEc (Mc.Zpos Mc.XH)) in - List.fold_left (fun acc (x,v) -> - let mn = LinPoly.MonT.retrieve x in - Mc.PEadd(Mc.PEmul(Mc.PEc (Ml2C.bigint (numerator v)), pol_of_mon mn),acc)) (Mc.PEc (Ml2C.bigint (numerator c))) p - + List.fold_left (fun acc (x,v) -> + let mn = LinPoly.MonT.retrieve x in + Mc.PEadd(Mc.PEmul(Mc.PEc (Ml2C.bigint (numerator v)), pol_of_mon mn),acc)) (Mc.PEc (Ml2C.bigint (numerator c))) p + let rec cmpl_prf_rule env = function - | Hyp i | Def i -> Mc.PsatzIn (Ml2C.nat (Env.id_of_hyp i env)) - | Cst i -> Mc.PsatzC (Ml2C.bigint i) - | Zero -> Mc.PsatzZ - | MulPrf(p1,p2) -> Mc.PsatzMulE(cmpl_prf_rule env p1, cmpl_prf_rule env p2) - | AddPrf(p1,p2) -> Mc.PsatzAdd(cmpl_prf_rule env p1 , cmpl_prf_rule env p2) - | MulC(lp,p) -> let lp = Mc.norm0 (coq_poly_of_linpol lp) in - Mc.PsatzMulC(lp,cmpl_prf_rule env p) - | Square lp -> Mc.PsatzSquare (Mc.norm0 (coq_poly_of_linpol lp)) - | _ -> failwith "Cuts should already be compiled" - + | Hyp i | Def i -> Mc.PsatzIn (Ml2C.nat (Env.id_of_hyp i env)) + | Cst i -> Mc.PsatzC (Ml2C.bigint i) + | Zero -> Mc.PsatzZ + | MulPrf(p1,p2) -> Mc.PsatzMulE(cmpl_prf_rule env p1, cmpl_prf_rule env p2) + | AddPrf(p1,p2) -> Mc.PsatzAdd(cmpl_prf_rule env p1 , cmpl_prf_rule env p2) + | MulC(lp,p) -> let lp = Mc.norm0 (coq_poly_of_linpol lp) in + Mc.PsatzMulC(lp,cmpl_prf_rule env p) + | Square lp -> Mc.PsatzSquare (Mc.norm0 (coq_poly_of_linpol lp)) + | _ -> failwith "Cuts should already be compiled" + let rec cmpl_proof env = function - | Done -> Mc.DoneProof - | Step(i,p,prf) -> - begin - match p with - | CutPrf p' -> - Mc.CutProof(cmpl_prf_rule env p', cmpl_proof (i::env) prf) - | _ -> Mc.RatProof(cmpl_prf_rule env p,cmpl_proof (i::env) prf) - end - | Enum(i,p1,_,p2,l) -> - Mc.EnumProof(cmpl_prf_rule env p1,cmpl_prf_rule env p2,List.map (cmpl_proof (i::env)) l) + | Done -> Mc.DoneProof + | Step(i,p,prf) -> + begin + match p with + | CutPrf p' -> + Mc.CutProof(cmpl_prf_rule env p', cmpl_proof (i::env) prf) + | _ -> Mc.RatProof(cmpl_prf_rule env p,cmpl_proof (i::env) prf) + end + | Enum(i,p1,_,p2,l) -> + Mc.EnumProof(cmpl_prf_rule env p1,cmpl_prf_rule env p2,List.map (cmpl_proof (i::env)) l) let compile_proof env prf = - let id = 1 + proof_max_id prf in - let _,prf = normalise_proof id prf in - if debug then Printf.fprintf stdout "compiled proof %a\n" output_proof prf; - cmpl_proof env prf + let id = 1 + proof_max_id prf in + let _,prf = normalise_proof id prf in + if debug then Printf.fprintf stdout "compiled proof %a\n" output_proof prf; + cmpl_proof env prf type prf_sys = (cstr_compat * prf_rule) list let xlinear_prover sys = - match Fourier.find_point sys with - | Inr prf -> - if debug then Printf.printf "AProof : %a\n" pp_proof prf ; - let cert = (*List.map (fun (x,n) -> x+1,n)*) (fst (List.hd (Proof.mk_proof sys prf))) in - if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ; - Some (rats_to_ints (Vect.to_list cert)) - | Inl _ -> None + match Fourier.find_point sys with + | Inr prf -> + if debug then Printf.printf "AProof : %a\n" pp_proof prf ; + let cert = (*List.map (fun (x,n) -> x+1,n)*) (fst (List.hd (Proof.mk_proof sys prf))) in + if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ; + Some (rats_to_ints (Vect.to_list cert)) + | Inl _ -> None let output_num o n = output_string o (string_of_num n) let output_bigint o n = output_string o (string_of_big_int n) let proof_of_farkas prf cert = -(* Printf.printf "\nproof_of_farkas %a , %a \n" (pp_list output_prf_rule) prf (pp_list output_bigint) cert ; *) - let rec mk_farkas acc prf cert = - match prf, cert with - | _ , [] -> acc - | [] , _ -> failwith "proof_of_farkas : not enough hyps" - | p::prf,c::cert -> - mk_farkas (add_proof (mul_proof c p) acc) prf cert in - let res = mk_farkas Zero prf cert in + (* Printf.printf "\nproof_of_farkas %a , %a \n" (pp_list output_prf_rule) prf (pp_list output_bigint) cert ; *) + let rec mk_farkas acc prf cert = + match prf, cert with + | _ , [] -> acc + | [] , _ -> failwith "proof_of_farkas : not enough hyps" + | p::prf,c::cert -> + mk_farkas (add_proof (mul_proof c p) acc) prf cert in + let res = mk_farkas Zero prf cert in (*Printf.printf "==> %a" output_prf_rule res ; *) - res + res let linear_prover sys = - let (sysi,prfi) = List.split sys in - match xlinear_prover sysi with - | None -> None - | Some cert -> Some (proof_of_farkas prfi cert) + let (sysi,prfi) = List.split sys in + match xlinear_prover sysi with + | None -> None + | Some cert -> Some (proof_of_farkas prfi cert) let linear_prover = - if debug - then - fun sys -> - Printf.printf ""; flush stdout ; - res - else linear_prover + if debug + then + fun sys -> + Printf.printf ""; flush stdout ; + res + else linear_prover @@ -733,11 +789,11 @@ let linear_prover = *) type checksat = - | Tauto (* Tautology *) - | Unsat of prf_rule (* Unsatisfiable *) - | Cut of cstr_compat * prf_rule (* Cutting plane *) - | Normalise of cstr_compat * prf_rule (* coefficients are relatively prime *) - +| Tauto (* Tautology *) +| Unsat of prf_rule (* Unsatisfiable *) +| Cut of cstr_compat * prf_rule (* Cutting plane *) +| Normalise of cstr_compat * prf_rule (* coefficients are relatively prime *) + (** [check_sat] - detects constraints that are not satisfiable; @@ -745,83 +801,83 @@ type checksat = *) let check_sat (cstr,prf) = - let {coeffs=coeffs ; op=op ; cst=cst} = cstr in - match coeffs with - | [] -> - if eval_op op (Int 0) cst then Tauto else Unsat prf - | _ -> - let gcdi = (gcd_list (List.map snd coeffs)) in - let gcd = Big_int gcdi in - if eq_num gcd (Int 1) - then Normalise(cstr,prf) - else - if Int.equal (sign_num (mod_num cst gcd)) 0 - then (* We can really normalise *) - begin - assert (sign_num gcd >=1 ) ; - let cstr = { - coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs; - op = op ; cst = cst // gcd - } in - Normalise(cstr,Gcd(gcdi,prf)) - (* Normalise(cstr,CutPrf prf)*) - end - else - match op with - | Eq -> Unsat (CutPrf prf) - | Ge -> - let cstr = { - coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs; - op = op ; cst = ceiling_num (cst // gcd) - } in Cut(cstr,CutPrf prf) + let {coeffs=coeffs ; op=op ; cst=cst} = cstr in + match coeffs with + | [] -> + if eval_op op (Int 0) cst then Tauto else Unsat prf + | _ -> + let gcdi = (gcd_list (List.map snd coeffs)) in + let gcd = Big_int gcdi in + if eq_num gcd (Int 1) + then Normalise(cstr,prf) + else + if Int.equal (sign_num (mod_num cst gcd)) 0 + then (* We can really normalise *) + begin + assert (sign_num gcd >=1 ) ; + let cstr = { + coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs; + op = op ; cst = cst // gcd + } in + Normalise(cstr,Gcd(gcdi,prf)) + (* Normalise(cstr,CutPrf prf)*) + end + else + match op with + | Eq -> Unsat (CutPrf prf) + | Ge -> + let cstr = { + coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs; + op = op ; cst = ceiling_num (cst // gcd) + } in Cut(cstr,CutPrf prf) (** Proof generating pivoting over variable v *) let pivot v (c1,p1) (c2,p2) = - let {coeffs = v1 ; op = op1 ; cst = n1} = c1 - and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in + let {coeffs = v1 ; op = op1 ; cst = n1} = c1 + and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in (* Could factorise gcd... *) - let xpivot cv1 cv2 = - ( - {coeffs = Vect.add (Vect.mul cv1 v1) (Vect.mul cv2 v2) ; - op = Proof.add_op op1 op2 ; - cst = n1 */ cv1 +/ n2 */ cv2 }, + let xpivot cv1 cv2 = + ( + {coeffs = Vect.add (Vect.mul cv1 v1) (Vect.mul cv2 v2) ; + op = Proof.add_op op1 op2 ; + cst = n1 */ cv1 +/ n2 */ cv2 }, - AddPrf(mul_proof (numerator cv1) p1,mul_proof (numerator cv2) p2)) in + AddPrf(mul_proof (numerator cv1) p1,mul_proof (numerator cv2) p2)) in + + match Vect.get v v1 , Vect.get v v2 with + | None , _ | _ , None -> None + | Some a , Some b -> + if Int.equal ((sign_num a) * (sign_num b)) (-1) + then + let cv1 = abs_num b + and cv2 = abs_num a in + Some (xpivot cv1 cv2) + else + if op1 == Eq + then + let cv1 = minus_num (b */ (Int (sign_num a))) + and cv2 = abs_num a in + Some (xpivot cv1 cv2) + else if op2 == Eq + then + let cv1 = abs_num b + and cv2 = minus_num (a */ (Int (sign_num b))) in + Some (xpivot cv1 cv2) + else None (* op2 could be Eq ... this might happen *) - match Vect.get v v1 , Vect.get v v2 with - | None , _ | _ , None -> None - | Some a , Some b -> - if Int.equal ((sign_num a) * (sign_num b)) (-1) - then - let cv1 = abs_num b - and cv2 = abs_num a in - Some (xpivot cv1 cv2) - else - if op1 == Eq - then - let cv1 = minus_num (b */ (Int (sign_num a))) - and cv2 = abs_num a in - Some (xpivot cv1 cv2) - else if op2 == Eq - then - let cv1 = abs_num b - and cv2 = minus_num (a */ (Int (sign_num b))) in - Some (xpivot cv1 cv2) - else None (* op2 could be Eq ... this might happen *) - exception FoundProof of prf_rule let simpl_sys sys = - List.fold_left (fun acc (c,p) -> - match check_sat (c,p) with - | Tauto -> acc - | Unsat prf -> raise (FoundProof prf) - | Cut(c,p) -> (c,p)::acc - | Normalise (c,p) -> (c,p)::acc) [] sys + List.fold_left (fun acc (c,p) -> + match check_sat (c,p) with + | Tauto -> acc + | Unsat prf -> raise (FoundProof prf) + | Cut(c,p) -> (c,p)::acc + | Normalise (c,p) -> (c,p)::acc) [] sys (** [ext_gcd a b] is the extended Euclid algorithm. @@ -829,77 +885,77 @@ let simpl_sys sys = Source: http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm *) let rec ext_gcd a b = - if Int.equal (sign_big_int b) 0 - then (unit_big_int,zero_big_int) - else - let (q,r) = quomod_big_int a b in - let (s,t) = ext_gcd b r in - (t, sub_big_int s (mult_big_int q t)) + if Int.equal (sign_big_int b) 0 + then (unit_big_int,zero_big_int) + else + let (q,r) = quomod_big_int a b in + let (s,t) = ext_gcd b r in + (t, sub_big_int s (mult_big_int q t)) let pp_ext_gcd a b = - let a' = big_int_of_int a in - let b' = big_int_of_int b in - - let (x,y) = ext_gcd a' b' in - Printf.fprintf stdout "%s * %s + %s * %s = %s\n" - (string_of_big_int x) (string_of_big_int a') - (string_of_big_int y) (string_of_big_int b') - (string_of_big_int (add_big_int (mult_big_int x a') (mult_big_int y b'))) + let a' = big_int_of_int a in + let b' = big_int_of_int b in + + let (x,y) = ext_gcd a' b' in + Printf.fprintf stdout "%s * %s + %s * %s = %s\n" + (string_of_big_int x) (string_of_big_int a') + (string_of_big_int y) (string_of_big_int b') + (string_of_big_int (add_big_int (mult_big_int x a') (mult_big_int y b'))) exception Result of (int * (proof * cstr_compat)) let split_equations psys = - List.partition (fun (c,p) -> c.op == Eq) + List.partition (fun (c,p) -> c.op == Eq) let extract_coprime (c1,p1) (c2,p2) = - let rec exist2 vect1 vect2 = - match vect1 , vect2 with - | _ , [] | [], _ -> None - | (v1,n1)::vect1' , (v2, n2) :: vect2' -> - if Pervasives.(=) v1 v2 - then - if Int.equal (compare_big_int (gcd_big_int (numerator n1) (numerator n2)) unit_big_int) 0 - then Some (v1,n1,n2) - else - exist2 vect1' vect2' - else - if v1 < v2 - then exist2 vect1' vect2 - else exist2 vect1 vect2' in - - if c1.op == Eq && c2.op == Eq - then exist2 c1.coeffs c2.coeffs - else None + let rec exist2 vect1 vect2 = + match vect1 , vect2 with + | _ , [] | [], _ -> None + | (v1,n1)::vect1' , (v2, n2) :: vect2' -> + if Pervasives.(=) v1 v2 + then + if Int.equal (compare_big_int (gcd_big_int (numerator n1) (numerator n2)) unit_big_int) 0 + then Some (v1,n1,n2) + else + exist2 vect1' vect2' + else + if v1 < v2 + then exist2 vect1' vect2 + else exist2 vect1 vect2' in + + if c1.op == Eq && c2.op == Eq + then exist2 c1.coeffs c2.coeffs + else None let extract2 pred l = - let rec xextract2 rl l = - match l with - | [] -> (None,rl) (* Did not find *) - | e::l -> - match extract (pred e) l with - | None,_ -> xextract2 (e::rl) l - | Some (r,e'),l' -> Some (r,e,e'), List.rev_append rl l' in - - xextract2 [] l + let rec xextract2 rl l = + match l with + | [] -> (None,rl) (* Did not find *) + | e::l -> + match extract (pred e) l with + | None,_ -> xextract2 (e::rl) l + | Some (r,e'),l' -> Some (r,e,e'), List.rev_append rl l' in + + xextract2 [] l let extract_coprime_equation psys = - extract2 extract_coprime psys + extract2 extract_coprime psys let apply_and_normalise f psys = - List.fold_left (fun acc pc' -> - match f pc' with - | None -> pc'::acc - | Some pc' -> - match check_sat pc' with - | Tauto -> acc - | Unsat prf -> raise (FoundProof prf) - | Cut(c,p) -> (c,p)::acc - | Normalise (c,p) -> (c,p)::acc - ) [] psys + List.fold_left (fun acc pc' -> + match f pc' with + | None -> pc'::acc + | Some pc' -> + match check_sat pc' with + | Tauto -> acc + | Unsat prf -> raise (FoundProof prf) + | Cut(c,p) -> (c,p)::acc + | Normalise (c,p) -> (c,p)::acc + ) [] psys @@ -908,314 +964,317 @@ let pivot_sys v pc psys = apply_and_normalise (pivot v pc) psys let reduce_coprime psys = - let oeq,sys = extract_coprime_equation psys in - match oeq with - | None -> None (* Nothing to do *) - | Some((v,n1,n2),(c1,p1),(c2,p2) ) -> - let (l1,l2) = ext_gcd (numerator n1) (numerator n2) in - let l1' = Big_int l1 and l2' = Big_int l2 in - let cstr = - {coeffs = Vect.add (Vect.mul l1' c1.coeffs) (Vect.mul l2' c2.coeffs); - op = Eq ; - cst = (l1' */ c1.cst) +/ (l2' */ c2.cst) - } in - let prf = add_proof (mul_proof (numerator l1') p1) (mul_proof (numerator l2') p2) in - - Some (pivot_sys v (cstr,prf) ((c1,p1)::sys)) + let oeq,sys = extract_coprime_equation psys in + match oeq with + | None -> None (* Nothing to do *) + | Some((v,n1,n2),(c1,p1),(c2,p2) ) -> + let (l1,l2) = ext_gcd (numerator n1) (numerator n2) in + let l1' = Big_int l1 and l2' = Big_int l2 in + let cstr = + {coeffs = Vect.add (Vect.mul l1' c1.coeffs) (Vect.mul l2' c2.coeffs); + op = Eq ; + cst = (l1' */ c1.cst) +/ (l2' */ c2.cst) + } in + let prf = add_proof (mul_proof (numerator l1') p1) (mul_proof (numerator l2') p2) in + + Some (pivot_sys v (cstr,prf) ((c1,p1)::sys)) (** If there is an equation [eq] of the form 1.x + e = c, do a pivot over x with equation [eq] *) let reduce_unary psys = - let is_unary_equation (cstr,prf) = - if cstr.op == Eq - then - try - Some (fst (List.find (fun (_,n) -> n =/ (Int 1) || n=/ (Int (-1))) cstr.coeffs)) - with Not_found -> None - else None in - - let (oeq,sys) = extract is_unary_equation psys in - match oeq with - | None -> None (* Nothing to do *) - | Some(v,pc) -> - Some(pivot_sys v pc sys) + let is_unary_equation (cstr,prf) = + if cstr.op == Eq + then + try + Some (fst (List.find (fun (_,n) -> n =/ (Int 1) || n=/ (Int (-1))) cstr.coeffs)) + with Not_found -> None + else None in + + let (oeq,sys) = extract is_unary_equation psys in + match oeq with + | None -> None (* Nothing to do *) + | Some(v,pc) -> + Some(pivot_sys v pc sys) let reduce_non_lin_unary psys = - let is_unary_equation (cstr,prf) = - if cstr.op == Eq - then - try - let x = fst (List.find (fun (x,n) -> (n =/ (Int 1) || n=/ (Int (-1))) && Monomial.is_var (LinPoly.MonT.retrieve x) ) cstr.coeffs) in - let x' = LinPoly.MonT.retrieve x in - if List.for_all (fun (y,_) -> Pervasives.(=) y x || Int.equal (snd (Monomial.div (LinPoly.MonT.retrieve y) x')) 0) cstr.coeffs - then Some x - else None - with Not_found -> None - else None in - - - let (oeq,sys) = extract is_unary_equation psys in - match oeq with - | None -> None (* Nothing to do *) - | Some(v,pc) -> - Some(apply_and_normalise (LinPoly.pivot_eq v pc) sys) + let is_unary_equation (cstr,prf) = + if cstr.op == Eq + then + try + let x = fst (List.find (fun (x,n) -> (n =/ (Int 1) || n=/ (Int (-1))) && Monomial.is_var (LinPoly.MonT.retrieve x) ) cstr.coeffs) in + let x' = LinPoly.MonT.retrieve x in + if List.for_all (fun (y,_) -> Pervasives.(=) y x || Int.equal (snd (Monomial.div (LinPoly.MonT.retrieve y) x')) 0) cstr.coeffs + then Some x + else None + with Not_found -> None + else None in + + + let (oeq,sys) = extract is_unary_equation psys in + match oeq with + | None -> None (* Nothing to do *) + | Some(v,pc) -> + Some(apply_and_normalise (LinPoly.pivot_eq v pc) sys) let reduce_var_change psys = - let rec rel_prime vect = - match vect with - | [] -> None - | (x,v)::vect -> - let v = numerator v in - try - let (x',v') = List.find (fun (_,v') -> - let v' = numerator v' in - eq_big_int (gcd_big_int v v') unit_big_int) vect in - Some ((x,v),(x',numerator v')) - with Not_found -> rel_prime vect in - - let rel_prime (cstr,prf) = if cstr.op == Eq then rel_prime cstr.coeffs else None in - - let (oeq,sys) = extract rel_prime psys in - - match oeq with - | None -> None - | Some(((x,v),(x',v')),(c,p)) -> - let (l1,l2) = ext_gcd v v' in - let l1,l2 = Big_int l1 , Big_int l2 in + let rec rel_prime vect = + match vect with + | [] -> None + | (x,v)::vect -> + let v = numerator v in + try + let (x',v') = List.find (fun (_,v') -> + let v' = numerator v' in + eq_big_int (gcd_big_int v v') unit_big_int) vect in + Some ((x,v),(x',numerator v')) + with Not_found -> rel_prime vect in + + let rel_prime (cstr,prf) = if cstr.op == Eq then rel_prime cstr.coeffs else None in - let get v vect = - match Vect.get v vect with - | None -> Int 0 - | Some n -> n in + let (oeq,sys) = extract rel_prime psys in + + match oeq with + | None -> None + | Some(((x,v),(x',v')),(c,p)) -> + let (l1,l2) = ext_gcd v v' in + let l1,l2 = Big_int l1 , Big_int l2 in - let pivot_eq (c',p') = - let {coeffs = coeffs ; op = op ; cst = cst} = c' in - let vx = get x coeffs in - let vx' = get x' coeffs in - let m = minus_num (vx */ l1 +/ vx' */ l2) in - Some ({coeffs = - Vect.add (Vect.mul m c.coeffs) coeffs ; op = op ; cst = m */ c.cst +/ cst} , - AddPrf(MulC(([], m),p),p')) in + let get v vect = + match Vect.get v vect with + | None -> Int 0 + | Some n -> n in - Some (apply_and_normalise pivot_eq sys) + let pivot_eq (c',p') = + let {coeffs = coeffs ; op = op ; cst = cst} = c' in + let vx = get x coeffs in + let vx' = get x' coeffs in + let m = minus_num (vx */ l1 +/ vx' */ l2) in + Some ({coeffs = + Vect.add (Vect.mul m c.coeffs) coeffs ; op = op ; cst = m */ c.cst +/ cst} , + AddPrf(MulC(([], m),p),p')) in + Some (apply_and_normalise pivot_eq sys) - let reduce_pivot psys = - let is_equation (cstr,prf) = - if cstr.op == Eq - then - try - Some (fst (List.hd cstr.coeffs)) - with Not_found -> None - else None in - let (oeq,sys) = extract is_equation psys in - match oeq with - | None -> None (* Nothing to do *) - | Some(v,pc) -> - if debug then - Printf.printf "Bad news : loss of completeness %a=%s" Vect.pp_vect (fst pc).coeffs (string_of_num (fst pc).cst); - Some(pivot_sys v pc sys) +let reduce_pivot psys = + let is_equation (cstr,prf) = + if cstr.op == Eq + then + try + Some (fst (List.hd cstr.coeffs)) + with Not_found -> None + else None in + let (oeq,sys) = extract is_equation psys in + match oeq with + | None -> None (* Nothing to do *) + | Some(v,pc) -> + if debug then + Printf.printf "Bad news : loss of completeness %a=%s" Vect.pp_vect (fst pc).coeffs (string_of_num (fst pc).cst); + Some(pivot_sys v pc sys) - let iterate_until_stable f x = - let rec iter x = - match f x with - | None -> x - | Some x' -> iter x' in - iter x - let rec app_funs l x = - match l with - | [] -> None - | f::fl -> - match f x with - | None -> app_funs fl x - | Some x' -> Some x' +let iterate_until_stable f x = + let rec iter x = + match f x with + | None -> x + | Some x' -> iter x' in + iter x - let reduction_equations psys = - iterate_until_stable (app_funs - [reduce_unary ; reduce_coprime ; - reduce_var_change (*; reduce_pivot*)]) psys +let rec app_funs l x = + match l with + | [] -> None + | f::fl -> + match f x with + | None -> app_funs fl x + | Some x' -> Some x' - let reduction_non_lin_equations psys = - iterate_until_stable (app_funs - [reduce_non_lin_unary (*; reduce_coprime ; - reduce_var_change ; reduce_pivot *)]) psys +let reduction_equations psys = + iterate_until_stable (app_funs + [reduce_unary ; reduce_coprime ; + reduce_var_change (*; reduce_pivot*)]) psys + +let reduction_non_lin_equations psys = + iterate_until_stable (app_funs + [reduce_non_lin_unary (*; reduce_coprime ; + reduce_var_change ; reduce_pivot *)]) psys (** [get_bound sys] returns upon success an interval (lb,e,ub) with proofs *) - let get_bound sys = - let is_small (v,i) = - match Itv.range i with - | None -> false - | Some i -> i <=/ (Int 1) in - - let select_best (x1,i1) (x2,i2) = - if Itv.smaller_itv i1 i2 - then (x1,i1) else (x2,i2) in +let get_bound sys = + let is_small (v,i) = + match Itv.range i with + | None -> false + | Some i -> i <=/ (Int 1) in + + let select_best (x1,i1) (x2,i2) = + if Itv.smaller_itv i1 i2 + then (x1,i1) else (x2,i2) in (* For lia, there are no equations => these precautions are not needed *) (* For nlia, there are equations => do not enumerate over equations! *) - let all_planes sys = - let (eq,ineq) = List.partition (fun c -> c.op == Eq) sys in - match eq with - | [] -> List.rev_map (fun c -> c.coeffs) ineq - | _ -> - List.fold_left (fun acc c -> - if List.exists (fun c' -> Vect.equal c.coeffs c'.coeffs) eq - then acc else c.coeffs ::acc) [] ineq in - - let smallest_interval = - List.fold_left - (fun acc vect -> - if is_small acc - then acc - else - match Fourier.optimise vect sys with - | None -> acc - | Some i -> - if debug then Printf.printf "Found a new bound %a" Vect.pp_vect vect ; - select_best (vect,i) acc) (Vect.null, (None,None)) (all_planes sys) in - let smallest_interval = - match smallest_interval - with - | (x,(Some i, Some j)) -> Some(i,x,j) - | x -> None (* This should not be possible *) - in - match smallest_interval with - | Some (lb,e,ub) -> - let (lbn,lbd) = (sub_big_int (numerator lb) unit_big_int, denominator lb) in - let (ubn,ubd) = (add_big_int unit_big_int (numerator ub) , denominator ub) in - (match + let all_planes sys = + let (eq,ineq) = List.partition (fun c -> c.op == Eq) sys in + match eq with + | [] -> List.rev_map (fun c -> c.coeffs) ineq + | _ -> + List.fold_left (fun acc c -> + if List.exists (fun c' -> Vect.equal c.coeffs c'.coeffs) eq + then acc else c.coeffs ::acc) [] ineq in + + let smallest_interval = + List.fold_left + (fun acc vect -> + if is_small acc + then acc + else + match Fourier.optimise vect sys with + | None -> acc + | Some i -> + if debug then Printf.printf "Found a new bound %a" Vect.pp_vect vect ; + select_best (vect,i) acc) (Vect.null, (None,None)) (all_planes sys) in + let smallest_interval = + match smallest_interval + with + | (x,(Some i, Some j)) -> Some(i,x,j) + | x -> None (* This should not be possible *) + in + match smallest_interval with + | Some (lb,e,ub) -> + let (lbn,lbd) = (sub_big_int (numerator lb) unit_big_int, denominator lb) in + let (ubn,ubd) = (add_big_int unit_big_int (numerator ub) , denominator ub) in + (match (* x <= ub -> x > ub *) - xlinear_prover ({coeffs = Vect.mul (Big_int ubd) e ; op = Ge ; cst = Big_int ubn} :: sys), + xlinear_prover ({coeffs = Vect.mul (Big_int ubd) e ; op = Ge ; cst = Big_int ubn} :: sys), (* lb <= x -> lb > x *) - xlinear_prover - ({coeffs = Vect.mul (minus_num (Big_int lbd)) e ; op = Ge ; cst = minus_num (Big_int lbn)} :: sys) - with - | Some cub , Some clb -> Some(List.tl clb,(lb,e,ub), List.tl cub) - | _ -> failwith "Interval without proof" - ) - | None -> None - - - let check_sys sys = - List.for_all (fun (c,p) -> List.for_all (fun (_,n) -> sign_num n <> 0) c.coeffs) sys - - - let xlia reduction_equations sys = - - let rec enum_proof (id:int) (sys:prf_sys) : proof option = - if debug then (Printf.printf "enum_proof\n" ; flush stdout) ; - assert (check_sys sys) ; - - let nsys,prf = List.split sys in - match get_bound nsys with - | None -> None (* Is the systeme really unbounded ? *) - | Some(prf1,(lb,e,ub),prf2) -> - if debug then Printf.printf "Found interval: %a in [%s;%s] -> " Vect.pp_vect e (string_of_num lb) (string_of_num ub) ; - (match start_enum id e (ceiling_num lb) (floor_num ub) sys - with - | Some prfl -> - Some(Enum(id,proof_of_farkas prf prf1,e, proof_of_farkas prf prf2,prfl)) - | None -> None - ) - - and start_enum id e clb cub sys = - if clb >/ cub - then Some [] - else - let eq = {coeffs = e ; op = Eq ; cst = clb} in - match aux_lia (id+1) ((eq, Def id) :: sys) with - | None -> None - | Some prf -> - match start_enum id e (clb +/ (Int 1)) cub sys with - | None -> None - | Some l -> Some (prf::l) - - and aux_lia (id:int) (sys:prf_sys) : proof option = - assert (check_sys sys) ; - if debug then Printf.printf "xlia: %a \n" (pp_list (fun o (c,_) -> output_cstr o c)) sys ; - try - let sys = reduction_equations sys in - if debug then + xlinear_prover + ({coeffs = Vect.mul (minus_num (Big_int lbd)) e ; op = Ge ; cst = minus_num (Big_int lbn)} :: sys) + with + | Some cub , Some clb -> Some(List.tl clb,(lb,e,ub), List.tl cub) + | _ -> failwith "Interval without proof" + ) + | None -> None + + +let check_sys sys = + List.for_all (fun (c,p) -> List.for_all (fun (_,n) -> sign_num n <> 0) c.coeffs) sys + + +let xlia (can_enum:bool) reduction_equations sys = + + + let rec enum_proof (id:int) (sys:prf_sys) : proof option = + if debug then (Printf.printf "enum_proof\n" ; flush stdout) ; + assert (check_sys sys) ; + + let nsys,prf = List.split sys in + match get_bound nsys with + | None -> None (* Is the systeme really unbounded ? *) + | Some(prf1,(lb,e,ub),prf2) -> + if debug then Printf.printf "Found interval: %a in [%s;%s] -> " Vect.pp_vect e (string_of_num lb) (string_of_num ub) ; + (match start_enum id e (ceiling_num lb) (floor_num ub) sys + with + | Some prfl -> + Some(Enum(id,proof_of_farkas prf prf1,e, proof_of_farkas prf prf2,prfl)) + | None -> None + ) + + and start_enum id e clb cub sys = + if clb >/ cub + then Some [] + else + let eq = {coeffs = e ; op = Eq ; cst = clb} in + match aux_lia (id+1) ((eq, Def id) :: sys) with + | None -> None + | Some prf -> + match start_enum id e (clb +/ (Int 1)) cub sys with + | None -> None + | Some l -> Some (prf::l) + + and aux_lia (id:int) (sys:prf_sys) : proof option = + assert (check_sys sys) ; + if debug then Printf.printf "xlia: %a \n" (pp_list (fun o (c,_) -> output_cstr o c)) sys ; + try + let sys = reduction_equations sys in + if debug then Printf.printf "after reduction: %a \n" (pp_list (fun o (c,_) -> output_cstr o c)) sys ; - match linear_prover sys with - | Some prf -> Some (Step(id,prf,Done)) - | None -> enum_proof id sys - with FoundProof prf -> + match linear_prover sys with + | Some prf -> Some (Step(id,prf,Done)) + | None -> if can_enum then enum_proof id sys else None + with FoundProof prf -> (* [reduction_equations] can find a proof *) - Some(Step(id,prf,Done)) in + Some(Step(id,prf,Done)) in (* let sys' = List.map (fun (p,o) -> Mc.norm0 p , o) sys in*) - let id = List.length sys in - let orpf = - try - let sys = simpl_sys sys in - aux_lia id sys - with FoundProof pr -> Some(Step(id,pr,Done)) in - match orpf with - | None -> None - | Some prf -> + let id = List.length sys in + let orpf = + try + let sys = simpl_sys sys in + aux_lia id sys + with FoundProof pr -> Some(Step(id,pr,Done)) in + match orpf with + | None -> None + | Some prf -> (*Printf.printf "direct proof %a\n" output_proof prf ; *) - let env = mapi (fun _ i -> i) sys in - let prf = compile_proof env prf in + let env = mapi (fun _ i -> i) sys in + let prf = compile_proof env prf in (*try if Mc.zChecker sys' prf then Some prf else raise Certificate.BadCertificate with Failure s -> (Printf.printf "%s" s ; Some prf) *) Some prf - - - let cstr_compat_of_poly (p,o) = - let (v,c) = LinPoly.linpol_of_pol p in - {coeffs = v ; op = o ; cst = minus_num c } - - - let lia sys = - LinPoly.MonT.clear (); - let sys = List.map (develop_constraint z_spec) sys in - let (sys:cstr_compat list) = List.map cstr_compat_of_poly sys in - let sys = mapi (fun c i -> (c,Hyp i)) sys in - xlia reduction_equations sys - - - let nlia sys = - LinPoly.MonT.clear (); - let sys = List.map (develop_constraint z_spec) sys in - let sys = mapi (fun c i -> (c,Hyp i)) sys in - - let is_linear = List.for_all (fun ((p,_),_) -> Poly.is_linear p) sys in - - let collect_square = - List.fold_left (fun acc ((p,_),_) -> Poly.fold - (fun m _ acc -> - match Monomial.sqrt m with - | None -> acc - | Some s -> MonMap.add s m acc) p acc) MonMap.empty sys in - let sys = MonMap.fold (fun s m acc -> - let s = LinPoly.linpol_of_pol (Poly.add s (Int 1) (Poly.constant (Int 0))) in - let m = Poly.add m (Int 1) (Poly.constant (Int 0)) in - ((m, Ge), (Square s))::acc) collect_square sys in - -(* List.iter (fun ((p,_),_) -> Printf.printf "square %a\n" Poly.pp p) gen_square*) - - let sys = - if is_linear then sys - else sys @ (all_sym_pairs (fun ((c,o),p) ((c',o'),p') -> - ((Poly.product c c',opMult o o'), MulPrf(p,p'))) sys) in + - let sys = List.map (fun (c,p) -> cstr_compat_of_poly c,p) sys in - assert (check_sys sys) ; - xlia (if is_linear then reduction_equations else reduction_non_lin_equations) sys +let cstr_compat_of_poly (p,o) = + let (v,c) = LinPoly.linpol_of_pol p in + {coeffs = v ; op = o ; cst = minus_num c } + + +let lia (can_enum:bool) (prfdepth:int) sys = + LinPoly.MonT.clear (); + max_nb_cstr := compute_max_nb_cstr sys prfdepth ; + let sys = List.map (develop_constraint z_spec) sys in + let (sys:cstr_compat list) = List.map cstr_compat_of_poly sys in + let sys = mapi (fun c i -> (c,Hyp i)) sys in + xlia can_enum reduction_equations sys + + +let nlia enum prfdepth sys = + LinPoly.MonT.clear (); + max_nb_cstr := compute_max_nb_cstr sys prfdepth; + let sys = List.map (develop_constraint z_spec) sys in + let sys = mapi (fun c i -> (c,Hyp i)) sys in + + let is_linear = List.for_all (fun ((p,_),_) -> Poly.is_linear p) sys in + + let collect_square = + List.fold_left (fun acc ((p,_),_) -> Poly.fold + (fun m _ acc -> + match Monomial.sqrt m with + | None -> acc + | Some s -> MonMap.add s m acc) p acc) MonMap.empty sys in + let sys = MonMap.fold (fun s m acc -> + let s = LinPoly.linpol_of_pol (Poly.add s (Int 1) (Poly.constant (Int 0))) in + let m = Poly.add m (Int 1) (Poly.constant (Int 0)) in + ((m, Ge), (Square s))::acc) collect_square sys in + + (* List.iter (fun ((p,_),_) -> Printf.printf "square %a\n" Poly.pp p) gen_square*) + + let sys = + if is_linear then sys + else sys @ (all_sym_pairs (fun ((c,o),p) ((c',o'),p') -> + ((Poly.product c c',opMult o o'), MulPrf(p,p'))) sys) in + + let sys = List.map (fun (c,p) -> cstr_compat_of_poly c,p) sys in + assert (check_sys sys) ; + xlia enum (if is_linear then reduction_equations else reduction_non_lin_equations) sys diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index cce0a728..e4b58a56 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -18,6 +18,7 @@ open Pp open Mutils +open Goptions (** * Debug flag @@ -37,6 +38,53 @@ let time str f x = flush stdout); res + +(* Limit the proof search *) + +let max_depth = max_int + +(* Search limit for provers over Q R *) +let lra_proof_depth = ref max_depth + + +(* Search limit for provers over Z *) +let lia_enum = ref true +let lia_proof_depth = ref max_depth + +let get_lia_option () = + (!lia_enum,!lia_proof_depth) + +let get_lra_option () = + !lra_proof_depth + + + +let _ = + + let int_opt l vref = + { + optsync = true; + optdepr = false; + optname = List.fold_right (^) l ""; + optkey = l ; + optread = (fun () -> Some !vref); + optwrite = (fun x -> vref := (match x with None -> max_depth | Some v -> v)) + } in + + let lia_enum_opt = + { + optsync = true; + optdepr = false; + optname = "Lia Enum"; + optkey = ["Lia";"Enum"]; + optread = (fun () -> !lia_enum); + optwrite = (fun x -> lia_enum := x) + } in + let _ = declare_int_option (int_opt ["Lra"; "Depth"] lra_proof_depth) in + let _ = declare_int_option (int_opt ["Lia"; "Depth"] lia_proof_depth) in + let _ = declare_bool_option lia_enum_opt in + () + (** * Initialize a tag type to the Tag module declaration (see Mutils). *) @@ -99,6 +147,17 @@ let rec map_atoms fct f = | N f -> N(map_atoms fct f) | I(f1,o,f2) -> I(map_atoms fct f1, o , map_atoms fct f2) +let rec map_prop fct f = + match f with + | TT -> TT + | FF -> FF + | X x -> X (fct x) + | A (at,tg,cstr) -> A(at,tg,cstr) + | C (f1,f2) -> C(map_prop fct f1, map_prop fct f2) + | D (f1,f2) -> D(map_prop fct f1, map_prop fct f2) + | N f -> N(map_prop fct f) + | I(f1,o,f2) -> I(map_prop fct f1, o , map_prop fct f2) + (** * Collect the identifiers of a (string of) implications. Implication labels * are inherited from Coq/CoC's higher order dependent type constructor (Pi). @@ -244,7 +303,8 @@ let rec add_term t0 = function *) module ISet = Set.Make(Int) - +module IMap = Map.Make(Int) + (** * Given a set of integers s=\{i0,...,iN\} and a list m, return the list of * elements of m that are at position i0,...,iN. @@ -303,7 +363,8 @@ struct let r_modules = [["Coq";"Reals" ; "Rdefinitions"]; ["Coq";"Reals" ; "Rpow_def"] ; -] + ["Coq";"Reals" ; "Raxioms"] ; + ] let z_modules = [["Coq";"ZArith";"BinInt"]] @@ -322,6 +383,8 @@ struct let coq_and = lazy (init_constant "and") let coq_or = lazy (init_constant "or") let coq_not = lazy (init_constant "not") + let coq_not_gl_ref = (Nametab.locate ( Libnames.qualid_of_string "Coq.Init.Logic.not")) + let coq_iff = lazy (init_constant "iff") let coq_True = lazy (init_constant "True") let coq_False = lazy (init_constant "False") @@ -359,6 +422,7 @@ struct let coq_Qmake = lazy (constant "Qmake") let coq_Rcst = lazy (constant "Rcst") + let coq_C0 = lazy (m_constant "C0") let coq_C1 = lazy (m_constant "C1") let coq_CQ = lazy (m_constant "CQ") @@ -415,8 +479,9 @@ struct let coq_Rdiv = lazy (r_constant "Rdiv") let coq_Rinv = lazy (r_constant "Rinv") let coq_Rpower = lazy (r_constant "pow") + let coq_IZR = lazy (r_constant "IZR") let coq_IQR = lazy (constant "IQR") - let coq_IZR = lazy (constant "IZR") + let coq_PEX = lazy (constant "PEX" ) let coq_PEc = lazy (constant"PEc") @@ -896,8 +961,20 @@ struct 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) + (env, CamlToCoq.positive n) + + let get_rank env v = + let rec _get_rank env n = + match env with + | [] -> raise (Invalid_argument "get_rank") + | e::l -> + if eq_constr e v + then n + else _get_rank l (n+1) in + _get_rank env 1 + + let empty = [] let elements env = env @@ -910,7 +987,7 @@ struct let parse_expr parse_constant parse_exp ops_spec env term = if debug - then Pp.msg_debug (Pp.str "parse_expr: " ++ Printer.prterm term); + then Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.prterm term); (* let constant_or_variable env term = @@ -947,7 +1024,7 @@ struct let (expr,env) = parse_expr env args.(0) in let power = (parse_exp expr args.(1)) in (power , env) - with e when Errors.noncritical e -> + with e when CErrors.noncritical e -> (* if the exponent is a variable *) let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) end @@ -994,7 +1071,7 @@ struct coq_Rplus , (fun x y -> Mc.CPlus(x,y)) ; coq_Rminus , (fun x y -> Mc.CMinus(x,y)) ; coq_Rmult , (fun x y -> Mc.CMult(x,y)) ; - coq_Rdiv , (fun x y -> Mc.CMult(x,Mc.CInv y)) ; + (* coq_Rdiv , (fun x y -> Mc.CMult(x,Mc.CInv y)) ;*) ] let rec rconstant term = @@ -1016,10 +1093,14 @@ struct with ParseError -> match op with - | op when Constr.equal op (Lazy.force coq_Rinv) -> Mc.CInv(rconstant args.(0)) - | op when Constr.equal op (Lazy.force coq_IQR) -> Mc.CQ (parse_q args.(0)) -(* | op when op = Lazy.force coq_IZR -> Mc.CZ (parse_z args.(0))*) - | _ -> raise ParseError + | op when Constr.equal op (Lazy.force coq_Rinv) -> + let arg = rconstant args.(0) in + if Mc.qeq_bool (Mc.q_of_Rcst arg) {Mc.qnum = Mc.Z0 ; Mc.qden = Mc.XH} + then raise ParseError (* This is a division by zero -- no semantics *) + else Mc.CInv(arg) + | op when Constr.equal op (Lazy.force coq_IQR) -> Mc.CQ (parse_q args.(0)) + | op when Constr.equal op (Lazy.force coq_IZR) -> Mc.CZ (parse_z args.(0)) + | _ -> raise ParseError end | _ -> raise ParseError @@ -1027,7 +1108,7 @@ struct let rconstant term = if debug - then Pp.msg_debug (Pp.str "rconstant: " ++ Printer.prterm term ++ fnl ()); + then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.prterm term ++ fnl ()); let res = rconstant term in if debug then (Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ; @@ -1067,7 +1148,7 @@ struct let parse_arith parse_op parse_expr env cstr gl = if debug - then Pp.msg_debug (Pp.str "parse_arith: " ++ Printer.prterm cstr ++ fnl ()); + then Feedback.msg_debug (Pp.str "parse_arith: " ++ Printer.prterm cstr ++ fnl ()); match kind_of_term cstr with | App(op,args) -> let (op,lhs,rhs) = parse_op gl (op,args) in @@ -1094,10 +1175,6 @@ struct | 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) let mkD f1 f2 = D(f1,f2) @@ -1119,34 +1196,40 @@ struct try let (at,env) = parse_atom env t gl in (A(at,tg,t), env,Tag.next tg) - with e when Errors.noncritical e -> (X(t),env,tg) in + with e when CErrors.noncritical e -> (X(t),env,tg) in + let is_prop term = + let sort = Retyping.get_sort_of (Tacmach.pf_env gl) (Tacmach.project gl) term in + Term.is_prop_sort sort in + let rec xparse_formula env tg term = - match kind_of_term term with + match kind_of_term term with | App(l,rst) -> - (match rst with - | [|a;b|] when eq_constr l (Lazy.force coq_and) -> - let f,env,tg = xparse_formula env tg a in - let g,env, tg = xparse_formula env tg b in - mkformula_binary mkC term f g,env,tg - | [|a;b|] when eq_constr l (Lazy.force coq_or) -> - let f,env,tg = xparse_formula env tg a in - let g,env,tg = xparse_formula env tg b in - mkformula_binary mkD term f g,env,tg - | [|a|] when eq_constr l (Lazy.force coq_not) -> - let (f,env,tg) = xparse_formula env tg a in (N(f), env,tg) - | [|a;b|] when eq_constr l (Lazy.force coq_iff) -> - let f,env,tg = xparse_formula env tg a in - let g,env,tg = xparse_formula env tg b in - mkformula_binary mkIff term f g,env,tg - | _ -> parse_atom env tg term) - | Prod(typ,a,b) when not (Termops.dependent (mkRel 1) b) -> + (match rst with + | [|a;b|] when eq_constr l (Lazy.force coq_and) -> + let f,env,tg = xparse_formula env tg a in + let g,env, tg = xparse_formula env tg b in + mkformula_binary mkC term f g,env,tg + | [|a;b|] when eq_constr l (Lazy.force coq_or) -> + let f,env,tg = xparse_formula env tg a in + let g,env,tg = xparse_formula env tg b in + mkformula_binary mkD term f g,env,tg + | [|a|] when eq_constr l (Lazy.force coq_not) -> + let (f,env,tg) = xparse_formula env tg a in (N(f), env,tg) + | [|a;b|] when eq_constr l (Lazy.force coq_iff) -> let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in - mkformula_binary mkI term f g,env,tg + mkformula_binary mkIff term f g,env,tg + | _ -> parse_atom env tg term) + | Prod(typ,a,b) when not (Termops.dependent (mkRel 1) b)-> + let f,env,tg = xparse_formula env tg a in + let g,env,tg = xparse_formula env tg b in + mkformula_binary mkI term f g,env,tg | _ when eq_constr term (Lazy.force coq_True) -> (TT,env,tg) | _ when eq_constr term (Lazy.force coq_False) -> (FF,env,tg) - | _ -> X(term),env,tg in + | _ when is_prop term -> X(term),env,tg + | _ -> raise ParseError + in xparse_formula env tg ((*Reductionops.whd_zeta*) term) let dump_formula typ dump_atom f = @@ -1162,12 +1245,214 @@ struct | X(t) -> mkApp(Lazy.force coq_X,[|typ ; t|]) in xdump f - (** - * Given a conclusion and a list of affectations, rebuild a term prefixed by - * the appropriate letins. - * TODO: reverse the list of bindings! - *) + let prop_env_of_formula form = + let rec doit env = function + | TT | FF | A(_,_,_) -> env + | X t -> fst (Env.compute_rank_add env t) + | C(f1,f2) | D(f1,f2) | I(f1,_,f2) -> + doit (doit env f1) f2 + | N f -> doit env f in + + doit [] form + + let var_env_of_formula form = + + let rec vars_of_expr = function + | Mc.PEX n -> ISet.singleton (CoqToCaml.positive n) + | Mc.PEc z -> ISet.empty + | Mc.PEadd(e1,e2) | Mc.PEmul(e1,e2) | Mc.PEsub(e1,e2) -> + ISet.union (vars_of_expr e1) (vars_of_expr e2) + | Mc.PEopp e | Mc.PEpow(e,_)-> vars_of_expr e + in + + let vars_of_atom {Mc.flhs ; Mc.fop; Mc.frhs} = + ISet.union (vars_of_expr flhs) (vars_of_expr frhs) in + + let rec doit = function + | TT | FF | X _ -> ISet.empty + | A (a,t,c) -> vars_of_atom a + | C(f1,f2) | D(f1,f2) |I (f1,_,f2) -> ISet.union (doit f1) (doit f2) + | N f -> doit f in + + doit form + + + + + type 'cst dump_expr = (* 'cst is the type of the syntactic constants *) + { + interp_typ : constr; + dump_cst : 'cst -> constr; + dump_add : constr; + dump_sub : constr; + dump_opp : constr; + dump_mul : constr; + dump_pow : constr; + dump_pow_arg : Mc.n -> constr; + dump_op : (Mc.op2 * Term.constr) list + } + +let dump_zexpr = lazy + { + interp_typ = Lazy.force coq_Z; + dump_cst = dump_z; + dump_add = Lazy.force coq_Zplus; + dump_sub = Lazy.force coq_Zminus; + dump_opp = Lazy.force coq_Zopp; + dump_mul = Lazy.force coq_Zmult; + dump_pow = Lazy.force coq_Zpower; + dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n))); + dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) zop_table + } + +let dump_qexpr = lazy + { + interp_typ = Lazy.force coq_Q; + dump_cst = dump_q; + dump_add = Lazy.force coq_Qplus; + dump_sub = Lazy.force coq_Qminus; + dump_opp = Lazy.force coq_Qopp; + dump_mul = Lazy.force coq_Qmult; + dump_pow = Lazy.force coq_Qpower; + dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n))); + dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) qop_table + } + + let dump_positive_as_R p = + let mult = Lazy.force coq_Rmult in + let add = Lazy.force coq_Rplus in + + let one = Lazy.force coq_R1 in + let mk_add x y = mkApp(add,[|x;y|]) in + let mk_mult x y = mkApp(mult,[|x;y|]) in + + let two = mk_add one one in + + let rec dump_positive p = + match p with + | Mc.XH -> one + | Mc.XO p -> mk_mult two (dump_positive p) + | Mc.XI p -> mk_add one (mk_mult two (dump_positive p)) in + + dump_positive p + +let dump_n_as_R n = + let z = CoqToCaml.n n in + if z = 0 + then Lazy.force coq_R0 + else dump_positive_as_R (CamlToCoq.positive z) + + +let rec dump_Rcst_as_R cst = + match cst with + | Mc.C0 -> Lazy.force coq_R0 + | Mc.C1 -> Lazy.force coq_R1 + | Mc.CQ q -> Term.mkApp(Lazy.force coq_IQR, [| dump_q q |]) + | Mc.CZ z -> Term.mkApp(Lazy.force coq_IZR, [| dump_z z |]) + | Mc.CPlus(x,y) -> Term.mkApp(Lazy.force coq_Rplus, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) + | Mc.CMinus(x,y) -> Term.mkApp(Lazy.force coq_Rminus, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) + | Mc.CMult(x,y) -> Term.mkApp(Lazy.force coq_Rmult, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) + | Mc.CInv t -> Term.mkApp(Lazy.force coq_Rinv, [| dump_Rcst_as_R t |]) + | Mc.COpp t -> Term.mkApp(Lazy.force coq_Ropp, [| dump_Rcst_as_R t |]) + + +let dump_rexpr = lazy + { + interp_typ = Lazy.force coq_R; + dump_cst = dump_Rcst_as_R; + dump_add = Lazy.force coq_Rplus; + dump_sub = Lazy.force coq_Rminus; + dump_opp = Lazy.force coq_Ropp; + dump_mul = Lazy.force coq_Rmult; + dump_pow = Lazy.force coq_Rpower; + dump_pow_arg = (fun n -> dump_nat (CamlToCoq.nat (CoqToCaml.n n))); + dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) rop_table + } + + + + +(** [make_goal_of_formula depxr vars props form] where + - vars is an environment for the arithmetic variables occuring in form + - props is an environment for the propositions occuring in form + @return a goal where all the variables and propositions of the formula are quantified + +*) + +let rec make_goal_of_formula dexpr form = + + let vars_idx = + List.mapi (fun i v -> (v, i+1)) (ISet.elements (var_env_of_formula form)) in + + (* List.iter (fun (v,i) -> Printf.fprintf stdout "var %i has index %i\n" v i) vars_idx ;*) + + let props = prop_env_of_formula form in + + let vars_n = List.map (fun (_,i) -> (Names.id_of_string (Printf.sprintf "__x%i" i)) , dexpr.interp_typ) vars_idx in + let props_n = List.mapi (fun i _ -> (Names.id_of_string (Printf.sprintf "__p%i" (i+1))) , Term.mkProp) props in + + let var_name_pos = List.map2 (fun (idx,_) (id,_) -> id,idx) vars_idx vars_n in + + let dump_expr i e = + let rec dump_expr = function + | Mc.PEX n -> mkRel (i+(List.assoc (CoqToCaml.positive n) vars_idx)) + | Mc.PEc z -> dexpr.dump_cst z + | Mc.PEadd(e1,e2) -> mkApp(dexpr.dump_add, + [| dump_expr e1;dump_expr e2|]) + | Mc.PEsub(e1,e2) -> mkApp(dexpr.dump_sub, + [| dump_expr e1;dump_expr e2|]) + | Mc.PEopp e -> mkApp(dexpr.dump_opp, + [| dump_expr e|]) + | Mc.PEmul(e1,e2) -> mkApp(dexpr.dump_mul, + [| dump_expr e1;dump_expr e2|]) + | Mc.PEpow(e,n) -> mkApp(dexpr.dump_pow, + [| dump_expr e; dexpr.dump_pow_arg n|]) + in dump_expr e in + + let mkop op e1 e2 = + try + Term.mkApp(List.assoc op dexpr.dump_op, [| e1; e2|]) + with Not_found -> + Term.mkApp(Lazy.force coq_Eq,[|dexpr.interp_typ ; e1 ;e2|]) in + + let dump_cstr i { Mc.flhs ; Mc.fop ; Mc.frhs } = + mkop fop (dump_expr i flhs) (dump_expr i frhs) in + + let rec xdump pi xi f = + match f with + | TT -> Lazy.force coq_True + | FF -> Lazy.force coq_False + | C(x,y) -> mkApp(Lazy.force coq_and,[|xdump pi xi x ; xdump pi xi y|]) + | D(x,y) -> mkApp(Lazy.force coq_or,[| xdump pi xi x ; xdump pi xi y|]) + | I(x,_,y) -> mkArrow (xdump pi xi x) (xdump (pi+1) (xi+1) y) + | N(x) -> mkArrow (xdump pi xi x) (Lazy.force coq_False) + | A(x,_,_) -> dump_cstr xi x + | X(t) -> let idx = Env.get_rank props t in + mkRel (pi+idx) in + + let nb_vars = List.length vars_n in + let nb_props = List.length props_n in + + (* Printf.fprintf stdout "NBProps : %i\n" nb_props ;*) + + let subst_prop p = + let idx = Env.get_rank props p in + mkVar (Names.id_of_string (Printf.sprintf "__p%i" idx)) in + + let form' = map_prop subst_prop form in + + (Term.prodn nb_props (List.map (fun (x,y) -> Names.Name x,y) props_n) + (Term.prodn nb_vars (List.map (fun (x,y) -> Names.Name x,y) vars_n) + (xdump (List.length vars_n) 0 form)), + List.rev props_n, List.rev var_name_pos,form') + + (** + * Given a conclusion and a list of affectations, rebuild a term prefixed by + * the appropriate letins. + * TODO: reverse the list of bindings! + *) + let set l concl = let rec xset acc = function | [] -> acc @@ -1242,29 +1527,25 @@ 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 when Errors.noncritical 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 coq_VarMap = lazy + (Coqlib.gen_constant_in_modules "VarMap" + [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t") + + +let rec dump_varmap typ m = + match m with + | Mc.Empty -> Term.mkApp(Lazy.force coq_Empty,[| typ |]) + | Mc.Leaf v -> Term.mkApp(Lazy.force coq_Leaf,[| typ; v|]) + | Mc.Node(l,o,r) -> + Term.mkApp (Lazy.force coq_Node, [| typ; dump_varmap typ l; o ; dump_varmap typ r |]) + + +let vm_of_list env = + match env with + | [] -> Mc.Empty + | (d,_)::_ -> + List.fold_left (fun vm (c,i) -> + Mc.vm_add d (CamlToCoq.positive i) c vm) Mc.Empty env let rec pp_varmap o vm = @@ -1329,7 +1610,7 @@ let rec parse_hyps gl parse_arith env tg hyps = try let (c,env,tg) = parse_formula gl parse_arith env tg t in ((i,c)::lhyps, env,tg) - with e when Errors.noncritical e -> (lhyps,env,tg) + with e when CErrors.noncritical e -> (lhyps,env,tg) (*(if debug then Printf.printf "parse_arith : %s\n" x);*) @@ -1377,50 +1658,81 @@ let rcst_domain_spec = lazy { dump_proof = dump_psatz coq_Q dump_q } +open Proofview.Notations + +(** Naive topological sort of constr according to the subterm-ordering *) + +(* An element is minimal x is minimal w.r.t y if + x <= y or (x and y are incomparable) *) + +let is_min le x y = + if le x y then true + else if le y x then false else true + +let is_minimal le l c = List.for_all (is_min le c) l + +let find_rem p l = + let rec xfind_rem acc l = + match l with + | [] -> (None, acc) + | x :: l -> if p x then (Some x, acc @ l) + else xfind_rem (x::acc) l in + xfind_rem [] l + +let find_minimal le l = find_rem (is_minimal le l) l + +let rec mk_topo_order le l = + match find_minimal le l with + | (None , _) -> [] + | (Some v,l') -> v :: (mk_topo_order le l') + + +let topo_sort_constr l = mk_topo_order Termops.dependent l + + (** * Instanciate the current Coq goal with a Micromega formula, a varmap, and a * witness. *) - - -let micromega_order_change spec cert cert_typ env ff : Tacmach.tactic = - let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__z"^(string_of_int i)))) 0 env in +let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic*) = + (* let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *) 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 - (* todo : directly generate the proof term - or generalize befor conversion? *) - Tacticals.tclTHENSEQ [ - (fun gl -> - Proofview.V82.of_tactic (Tactics.change_concl - (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); - Tactics.generalize env ; - Tacticals.tclTHENSEQ (List.map (fun id -> Proofview.V82.of_tactic (Tactics.introduction id)) ids) ; - ] - + let vm = dump_varmap (spec.typ) (vm_of_list env) in + (* todo : directly generate the proof term - or generalize before conversion? *) + Proofview.Goal.nf_enter { enter = begin fun gl -> + let gl = Tacmach.New.of_old (fun x -> x) gl in + Tacticals.New.tclTHENLIST + [ + Tactics.change_concl + (set + [ + ("__ff", ff, Term.mkApp(Lazy.force coq_Formula, [|formula_typ |])); + ("__varmap", vm, Term.mkApp(Lazy.force coq_VarMap, [|spec.typ|])); + ("__wit", cert, cert_typ) + ] + (Tacmach.pf_concl gl)) + ] + end } (** * The datastructures that aggregate prover attributes. *) -type ('a,'prf) prover = { +type ('option,'a,'prf) prover = { name : string ; (* name of the prover *) - prover : 'a list -> 'prf option ; (* the prover itself *) + get_option : unit ->'option ; (* find the options of the prover *) + prover : 'option * 'a list -> 'prf option ; (* the prover itself *) hyps : 'prf -> ISet.t ; (* extract the indexes of the hypotheses really used in the proof *) compact : 'prf -> (int -> int) -> 'prf ; (* remap the hyp indexes according to function *) pp_prf : out_channel -> 'prf -> unit ;(* pretting printing of proof *) pp_f : out_channel -> 'a -> unit (* pretty printing of the formulas (polynomials)*) } + + (** * Given a list of provers and a disjunction of atoms, find a proof of any of * the atoms. Returns an (optional) pair of a proof and a prover @@ -1430,7 +1742,7 @@ type ('a,'prf) prover = { let find_witness provers polys1 = let provers = List.map (fun p -> (fun l -> - match p.prover l with + match p.prover (p.get_option (),l) with | None -> None | Some prf -> Some(prf,p)) , p.name) provers in try_any provers (List.map fst polys1) @@ -1482,10 +1794,10 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = (pp_ml_list prover.pp_f) (List.map fst new_cl) ; flush stdout end ; *) - let res = try prover.compact prf remap with x when Errors.noncritical x -> + let res = try prover.compact prf remap with x when CErrors.noncritical x -> if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ; (* This should not happen -- this is the recovery plan... *) - match prover.prover (List.map fst new_cl) with + match prover.prover (prover.get_option () ,List.map fst new_cl) with | None -> failwith "proof compaction error" | Some p -> p in @@ -1562,6 +1874,7 @@ let rec abstract_wrt_formula f1 f2 = exception CsdpNotFound + (** * This is the core of Micromega: apply the prover, analyze the result and * prune unused fomulas, and finally modify the proof state. @@ -1586,12 +1899,12 @@ let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 if debug then begin - Pp.pp (Pp.str "Formula....\n") ; + Feedback.msg_notice (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 (); - Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff + Feedback.msg_notice (Printer.prterm ff); + Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff end; match witness_list_tags prover cnf_ff with @@ -1611,11 +1924,11 @@ let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 if debug then begin - Pp.pp (Pp.str "\nAFormula\n") ; + Feedback.msg_notice (Pp.str "\nAFormula\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 (); + Feedback.msg_notice (Printer.prterm ff'); Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff' end; @@ -1646,58 +1959,103 @@ let micromega_gen (negate:'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) unsat deduce - 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 gl parse_arith Env.empty hyps concl in - let env = Env.elements env in - let spec = Lazy.force spec in - + spec dumpexpr prover tac = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let gl = Tacmach.New.of_old (fun x -> x) gl in + let concl = Tacmach.pf_concl gl in + let hyps = Tacmach.pf_hyps_types gl in + try + let (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in + let env = Env.elements env in + let spec = Lazy.force spec in + let dumpexpr = Lazy.force dumpexpr in + match micromega_tauto negate normalise unsat deduce spec prover env hyps concl gl with - | None -> Tacticals.tclFAIL 0 (Pp.str " Cannot find witness") gl - | Some (ids,ff',res') -> - (Tacticals.tclTHENSEQ - [ - Tactics.generalize (List.map Term.mkVar ids) ; - micromega_order_change spec res' - (Term.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env ff' - ]) gl - with - | ParseError -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl - | CsdpNotFound -> flush stdout ; Pp.pp_flush () ; - Tacticals.tclFAIL 0 (Pp.str - (" Skipping what remains of this tactic: the complexity of the goal requires " - ^ "the use of a specialized external tool called csdp. \n\n" - ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" - ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) gl - - - -let micromega_order_changer cert env ff gl = + | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") + | Some (ids,ff',res') -> + let (arith_goal,props,vars,ff_arith) = make_goal_of_formula dumpexpr ff' in + let intro (id,_) = Tactics.introduction id in + + let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in + let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in + let ipat_of_name id = Some (Loc.ghost, Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in + let goal_name = Tactics.fresh_id [] (Names.Id.of_string "__arith") gl in + let env' = List.map (fun (id,i) -> Term.mkVar id,i) vars in + + let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; + micromega_order_change spec res' + (Term.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env' ff_arith ] in + + let goal_props = List.rev (prop_env_of_formula ff') in + + let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in + + let arith_args = goal_props @ goal_vars in + + let kill_arith = + Tacticals.New.tclTHEN + (Tactics.keep []) + ((*Tactics.tclABSTRACT None*) + (Tacticals.New.tclTHEN tac_arith tac)) in + + Tacticals.New.tclTHENS + (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal) + [ + kill_arith; + (Tacticals.New.tclTHENLIST + [(Tactics.generalize (List.map Term.mkVar ids)); + Tactics.exact_check (Term.applist (Term.mkVar goal_name, arith_args)) + ] ) + ] + with + | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment") + | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout") + | CsdpNotFound -> flush stdout ; + Tacticals.New.tclFAIL 0 (Pp.str + (" Skipping what remains of this tactic: the complexity of the goal requires " + ^ "the use of a specialized external tool called csdp. \n\n" + ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" + ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) + end } + +let micromega_gen parse_arith + (negate:'cst atom -> 'cst mc_cnf) + (normalise:'cst atom -> 'cst mc_cnf) + unsat deduce + spec prover = + (micromega_gen parse_arith negate normalise unsat deduce spec prover) + + + +let micromega_order_changer cert env ff = + (*let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *) let coeff = Lazy.force coq_Rcst in let dump_coeff = dump_Rcst in let typ = Lazy.force coq_R in let cert_typ = (Term.mkApp(Lazy.force coq_list, [|Lazy.force coq_QWitness |])) in - - let formula_typ = (Term.mkApp (Lazy.force coq_Cstr,[| coeff|])) in - let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in - let vm = dump_varmap (typ) env in - Proofview.V82.of_tactic (Tactics.change_concl - (set + + let formula_typ = (Term.mkApp (Lazy.force coq_Cstr,[| coeff|])) in + let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in + let vm = dump_varmap (typ) (vm_of_list env) in + Proofview.Goal.nf_enter { enter = begin fun gl -> + let gl = Tacmach.New.of_old (fun x -> x) gl in + Tacticals.New.tclTHENLIST [ - ("__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", [|typ|])); - ("__wit", cert, cert_typ) + (Tactics.change_concl + (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", [|typ|])); + ("__wit", cert, cert_typ) + ] + (Tacmach.pf_concl gl))); + (* Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids)*) ] - (Tacmach.pf_concl gl) - )) - gl - + end } -let micromega_genr prover gl = +let micromega_genr prover tac = let parse_arith = parse_rarith in let negate = Mc.rnegate in let normalise = Mc.rnormalise in @@ -1710,41 +2068,77 @@ let micromega_genr prover gl = proof_typ = Lazy.force coq_QWitness ; dump_proof = dump_psatz coq_Q dump_q } in - - let concl = Tacmach.pf_concl gl in - let hyps = Tacmach.pf_hyps_types gl in - try - let (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in - let env = Env.elements env in - let spec = Lazy.force spec in - - let hyps' = List.map (fun (n,f) -> (n, map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in - let concl' = map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) concl in - - match micromega_tauto negate normalise unsat deduce spec prover env hyps' concl' gl with - | None -> Tacticals.tclFAIL 0 (Pp.str " Cannot find witness") gl + Proofview.Goal.nf_enter { enter = begin fun gl -> + let gl = Tacmach.New.of_old (fun x -> x) gl in + let concl = Tacmach.pf_concl gl in + let hyps = Tacmach.pf_hyps_types gl in + + try + let (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in + let env = Env.elements env in + let spec = Lazy.force spec in + + let hyps' = List.map (fun (n,f) -> (n, map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in + let concl' = map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) concl in + + match micromega_tauto negate normalise unsat deduce spec prover env hyps' concl' gl with + | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") | Some (ids,ff',res') -> - let (ff,ids') = formula_hyps_concl + let (ff,ids) = formula_hyps_concl (List.filter (fun (n,_) -> List.mem n ids) hyps) concl in + let ff' = abstract_wrt_formula ff' ff in + + let (arith_goal,props,vars,ff_arith) = make_goal_of_formula (Lazy.force dump_rexpr) ff' in + let intro (id,_) = Tactics.introduction id in + + let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in + let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in + let ipat_of_name id = Some (Loc.ghost, Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in + let goal_name = Tactics.fresh_id [] (Names.Id.of_string "__arith") gl in + let env' = List.map (fun (id,i) -> Term.mkVar id,i) vars in + + let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; + micromega_order_changer res' env' ff_arith ] in + + let goal_props = List.rev (prop_env_of_formula ff') in + + let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in + + let arith_args = goal_props @ goal_vars in + + let kill_arith = + Tacticals.New.tclTHEN + (Tactics.keep []) + ((*Tactics.tclABSTRACT None*) + (Tacticals.New.tclTHEN tac_arith tac)) in - (Tacticals.tclTHENSEQ - [ - Tactics.generalize (List.map Term.mkVar ids) ; - micromega_order_changer res' env (abstract_wrt_formula ff' ff) - ]) gl - with - | ParseError -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl - | CsdpNotFound -> flush stdout ; Pp.pp_flush () ; - Tacticals.tclFAIL 0 (Pp.str - (" Skipping what remains of this tactic: the complexity of the goal requires " - ^ "the use of a specialized external tool called csdp. \n\n" - ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" - ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) gl + Tacticals.New.tclTHENS + (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal) + [ + kill_arith; + (Tacticals.New.tclTHENLIST + [(Tactics.generalize (List.map Term.mkVar ids)); + Tactics.exact_check (Term.applist (Term.mkVar goal_name, arith_args)) + ] ) + ] + with + | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment") + | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout") + | CsdpNotFound -> flush stdout ; + Tacticals.New.tclFAIL 0 (Pp.str + (" Skipping what remains of this tactic: the complexity of the goal requires " + ^ "the use of a specialized external tool called csdp. \n\n" + ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" + ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) + end } +let micromega_genr prover = (micromega_genr prover) + + let lift_ratproof prover l = match prover l with | None -> None @@ -1766,7 +2160,7 @@ module Cache = PHashtable(struct let hash = Hashtbl.hash end) -let csdp_cache = "csdp.cache" +let csdp_cache = ".csdp.cache" (** * Build the command to call csdpcert, and launch it. This in turn will call @@ -1818,7 +2212,7 @@ let call_csdpcert_q provername poly = let cert = Certificate.q_cert_of_pos cert in if Mc.qWeakChecker poly cert then Some cert - else ((print_string "buggy certificate" ; flush stdout) ;None) + else ((print_string "buggy certificate") ;None) let call_csdpcert_z provername poly = let l = List.map (fun (e,o) -> (z_to_q_pol e,o)) poly in @@ -1898,38 +2292,61 @@ let compact_pt pt f = let lift_pexpr_prover p l = p (List.map (fun (e,o) -> Mc.denorm e , o) l) -let linear_prover_Z = { - name = "linear prover" ; - prover = lift_ratproof (lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.z_spec)) ; - hyps = hyps_of_pt ; - compact = compact_pt ; - pp_prf = pp_proof_term; - pp_f = fun o x -> pp_pol pp_z o (fst x) -} +module CacheZ = PHashtable(struct + type prover_option = bool * int + + type t = prover_option * ((Mc.z Mc.pol * Mc.op1) list) + let equal = (=) + let hash = Hashtbl.hash +end) +module CacheQ = PHashtable(struct + type t = int * ((Mc.q Mc.pol * Mc.op1) list) + let equal = (=) + let hash = Hashtbl.hash +end) + +let memo_zlinear_prover = CacheZ.memo ".lia.cache" (fun ((ce,b),s) -> lift_pexpr_prover (Certificate.lia ce b) s) +let memo_nlia = CacheZ.memo ".nia.cache" (fun ((ce,b),s) -> lift_pexpr_prover (Certificate.nlia ce b) s) +let memo_nra = CacheQ.memo ".nra.cache" (fun (o,s) -> lift_pexpr_prover (Certificate.nlinear_prover o) s) + + + let linear_prover_Q = { - name = "linear prover"; - prover = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.q_spec) ; - hyps = hyps_of_cone ; - compact = compact_cone ; - pp_prf = pp_psatz pp_q ; - pp_f = fun o x -> pp_pol pp_q o (fst x) + name = "linear prover"; + get_option = get_lra_option ; + prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o Certificate.q_spec) l) ; + hyps = hyps_of_cone ; + compact = compact_cone ; + pp_prf = pp_psatz pp_q ; + pp_f = fun o x -> pp_pol pp_q o (fst x) } let linear_prover_R = { name = "linear prover"; - prover = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.q_spec) ; + get_option = get_lra_option ; + prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o Certificate.q_spec) l) ; hyps = hyps_of_cone ; compact = compact_cone ; pp_prf = pp_psatz pp_q ; pp_f = fun o x -> pp_pol pp_q o (fst x) } +let nlinear_prover_R = { + name = "nra"; + get_option = get_lra_option; + prover = memo_nra ; + hyps = hyps_of_cone ; + compact = compact_cone ; + pp_prf = pp_psatz pp_q ; + pp_f = fun o x -> pp_pol pp_q o (fst x) +} let non_linear_prover_Q str o = { name = "real nonlinear prover"; - prover = call_csdpcert_q (str, o); + get_option = (fun () -> (str,o)); + prover = (fun (o,l) -> call_csdpcert_q o l); hyps = hyps_of_cone; compact = compact_cone ; pp_prf = pp_psatz pp_q ; @@ -1938,7 +2355,8 @@ let non_linear_prover_Q str o = { let non_linear_prover_R str o = { name = "real nonlinear prover"; - prover = call_csdpcert_q (str, o); + get_option = (fun () -> (str,o)); + prover = (fun (o,l) -> call_csdpcert_q o l); hyps = hyps_of_cone; compact = compact_cone; pp_prf = pp_psatz pp_q; @@ -1947,30 +2365,18 @@ let non_linear_prover_R str o = { let non_linear_prover_Z str o = { name = "real nonlinear prover"; - prover = lift_ratproof (call_csdpcert_z (str, o)); + get_option = (fun () -> (str,o)); + prover = (fun (o,l) -> lift_ratproof (call_csdpcert_z o) l); hyps = hyps_of_pt; compact = compact_pt; pp_prf = pp_proof_term; pp_f = fun o x -> pp_pol pp_z o (fst x) } -module CacheZ = PHashtable(struct - type t = (Mc.z Mc.pol * Mc.op1) list - let equal = Pervasives.(=) - let hash = Hashtbl.hash -end) - -let memo_zlinear_prover = CacheZ.memo "lia.cache" (lift_pexpr_prover Certificate.lia) -let memo_nlia = CacheZ.memo "nlia.cache" (lift_pexpr_prover Certificate.nlia) - -(*let memo_zlinear_prover = (lift_pexpr_prover Lia.lia)*) -(*let memo_zlinear_prover = CacheZ.memo "lia.cache" (lift_pexpr_prover Certificate.zlinear_prover)*) - - - let linear_Z = { name = "lia"; - prover = memo_zlinear_prover ; + get_option = get_lia_option; + prover = memo_zlinear_prover ; hyps = hyps_of_pt; compact = compact_pt; pp_prf = pp_proof_term; @@ -1979,7 +2385,8 @@ let linear_Z = { let nlinear_Z = { name = "nlia"; - prover = memo_nlia ; + get_option = get_lia_option; + prover = memo_nlia ; hyps = hyps_of_pt; compact = compact_pt; pp_prf = pp_proof_term; @@ -2001,57 +2408,53 @@ let tauto_lia ff = * solvers *) -let psatzl_Z gl = - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec - [ linear_prover_Z ] gl - -let psatzl_Q gl = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec - [ linear_prover_Q ] gl - -let psatz_Q i gl = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec - [ non_linear_prover_Q "real_nonlinear_prover" (Some i) ] gl +let lra_Q = + micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr + [ linear_prover_Q ] +let psatz_Q i = + micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr + [ non_linear_prover_Q "real_nonlinear_prover" (Some i) ] -let psatzl_R gl = - micromega_genr [ linear_prover_R ] gl +let lra_R = + micromega_genr [ linear_prover_R ] +let psatz_R i = + micromega_genr [ non_linear_prover_R "real_nonlinear_prover" (Some i) ] -let psatz_R i gl = - micromega_genr [ non_linear_prover_R "real_nonlinear_prover" (Some i) ] gl +let psatz_Z i = + micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr + [ non_linear_prover_Z "real_nonlinear_prover" (Some i) ] -let psatz_Z i gl = - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec - [ non_linear_prover_Z "real_nonlinear_prover" (Some i) ] gl +let sos_Z = + micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr + [ non_linear_prover_Z "pure_sos" None ] -let sos_Z gl = - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec - [ non_linear_prover_Z "pure_sos" None ] gl +let sos_Q = + micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr + [ non_linear_prover_Q "pure_sos" None ] -let sos_Q gl = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec - [ non_linear_prover_Q "pure_sos" None ] gl +let sos_R = + micromega_genr [ non_linear_prover_R "pure_sos" None ] -let sos_R gl = - micromega_genr [ non_linear_prover_R "pure_sos" None ] gl +let xlia = micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr + [ linear_Z ] -let xlia gl = - try - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec - [ linear_Z ] gl - with reraise -> (*Printexc.print_backtrace stdout ;*) raise reraise +let xnlia = + micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr + [ nlinear_Z ] -let xnlia gl = - try - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec - [ nlinear_Z ] gl - with reraise -> (*Printexc.print_backtrace stdout ;*) raise reraise +let nra = + micromega_genr [ nlinear_prover_R ] +let nqa = + micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr + [ nlinear_prover_R ] + (* Local Variables: *) (* coding: utf-8 *) diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4 index 75237aaa..027f690f 100644 --- a/plugins/micromega/g_micromega.ml4 +++ b/plugins/micromega/g_micromega.ml4 @@ -16,63 +16,68 @@ (*i camlp4deps: "grammar/grammar.cma" i*) -open Errors -open Misctypes +open Constrarg DECLARE PLUGIN "micromega_plugin" -let out_arg = function - | ArgVar _ -> anomaly (Pp.str "Unevaluated or_var variable") - | ArgArg x -> x +TACTIC EXTEND RED +| [ "myred" ] -> [ Tactics.red_in_concl ] +END + + TACTIC EXTEND PsatzZ -| [ "psatz_Z" int_or_var(i) ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_Z (out_arg i)) ] -| [ "psatz_Z" ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_Z (-1)) ] +| [ "psatz_Z" int_or_var(i) tactic(t) ] -> [ (Coq_micromega.psatz_Z i + (Tacinterp.tactic_of_value ist t)) + ] +| [ "psatz_Z" tactic(t)] -> [ (Coq_micromega.psatz_Z (-1)) (Tacinterp.tactic_of_value ist t) ] END TACTIC EXTEND Lia -[ "xlia" ] -> [ Proofview.V82.tactic (Coq_micromega.xlia) ] +[ "xlia" tactic(t) ] -> [ (Coq_micromega.xlia (Tacinterp.tactic_of_value ist t)) ] END TACTIC EXTEND Nia -[ "xnlia" ] -> [ Proofview.V82.tactic (Coq_micromega.xnlia) ] +[ "xnlia" tactic(t) ] -> [ (Coq_micromega.xnlia (Tacinterp.tactic_of_value ist t)) ] +END + +TACTIC EXTEND NRA +[ "xnra" tactic(t) ] -> [ (Coq_micromega.nra (Tacinterp.tactic_of_value ist t))] END +TACTIC EXTEND NQA +[ "xnqa" tactic(t) ] -> [ (Coq_micromega.nqa (Tacinterp.tactic_of_value ist t))] +END + TACTIC EXTEND Sos_Z -| [ "sos_Z" ] -> [ Proofview.V82.tactic (Coq_micromega.sos_Z) ] +| [ "sos_Z" tactic(t) ] -> [ (Coq_micromega.sos_Z (Tacinterp.tactic_of_value ist t)) ] END TACTIC EXTEND Sos_Q -| [ "sos_Q" ] -> [ Proofview.V82.tactic (Coq_micromega.sos_Q) ] +| [ "sos_Q" tactic(t) ] -> [ (Coq_micromega.sos_Q (Tacinterp.tactic_of_value ist t)) ] END TACTIC EXTEND Sos_R -| [ "sos_R" ] -> [ Proofview.V82.tactic (Coq_micromega.sos_R) ] -END - -(* -TACTIC EXTEND Omicron -[ "psatzl_Z" ] -> [ Proofview.V82.tactic (Coq_micromega.psatzl_Z) ] +| [ "sos_R" tactic(t) ] -> [ (Coq_micromega.sos_R (Tacinterp.tactic_of_value ist t)) ] END -*) TACTIC EXTEND LRA_Q -[ "psatzl_Q" ] -> [ Proofview.V82.tactic (Coq_micromega.psatzl_Q) ] +[ "lra_Q" tactic(t) ] -> [ (Coq_micromega.lra_Q (Tacinterp.tactic_of_value ist t)) ] END TACTIC EXTEND LRA_R -[ "psatzl_R" ] -> [ Proofview.V82.tactic (Coq_micromega.psatzl_R) ] +[ "lra_R" tactic(t) ] -> [ (Coq_micromega.lra_R (Tacinterp.tactic_of_value ist t)) ] END TACTIC EXTEND PsatzR -| [ "psatz_R" int_or_var(i) ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_R (out_arg i)) ] -| [ "psatz_R" ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_R (-1)) ] +| [ "psatz_R" int_or_var(i) tactic(t) ] -> [ (Coq_micromega.psatz_R i (Tacinterp.tactic_of_value ist t)) ] +| [ "psatz_R" tactic(t) ] -> [ (Coq_micromega.psatz_R (-1) (Tacinterp.tactic_of_value ist t)) ] END TACTIC EXTEND PsatzQ -| [ "psatz_Q" int_or_var(i) ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_Q (out_arg i)) ] -| [ "psatz_Q" ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_Q (-1)) ] +| [ "psatz_Q" int_or_var(i) tactic(t) ] -> [ (Coq_micromega.psatz_Q i (Tacinterp.tactic_of_value ist t)) ] +| [ "psatz_Q" tactic(t) ] -> [ (Coq_micromega.psatz_Q (-1) (Tacinterp.tactic_of_value ist t)) ] END diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml index a36369d2..f4f9b3c2 100644 --- a/plugins/micromega/mfourier.ml +++ b/plugins/micromega/mfourier.ml @@ -98,12 +98,12 @@ module PSet = ISet module System = Hashtbl.Make(Vect) - type proof = - | Hyp of int - | Elim of var * proof * proof - | And of proof * proof - +type proof = +| Hyp of int +| Elim of var * proof * proof +| And of proof * proof +let max_nb_cstr = ref max_int type system = { sys : cstr_info ref System.t ; @@ -120,7 +120,7 @@ and cstr_info = { (** A system of constraints has the form [\{sys = s ; vars = v\}]. [s] is a hashtable mapping a normalised vector to a [cstr_info] record where - [bound] is an interval - - [prf_idx] is the set of hypothese indexes (i.e. constraints in the initial system) used to obtain the current constraint. + - [prf_idx] is the set of hypothesis indexes (i.e. constraints in the initial system) used to obtain the current constraint. In the initial system, each constraint is given an unique singleton proof_idx. When a new constraint c is computed by a function f(c1,...,cn), its proof_idx is ISet.fold union (List.map (fun x -> x.proof_idx) [c1;...;cn] - [pos] is the number of positive values of the vector @@ -208,8 +208,7 @@ let merge_cstr_info i1 i2 = *) let xadd_cstr vect cstr_info sys = - if debug && Int.equal (System.length sys mod 1000) 0 then (print_string "*" ; flush stdout) ; - try + try let info = System.find sys vect in match merge_cstr_info cstr_info !info with | None -> raise (SystemContradiction (And(cstr_info.prf, (!info).prf))) @@ -217,6 +216,13 @@ let xadd_cstr vect cstr_info sys = with | Not_found -> System.replace sys vect (ref cstr_info) +exception TimeOut + +let xadd_cstr vect cstr_info sys = + if debug && Int.equal (System.length sys mod 1000) 0 then (print_string "*" ; flush stdout) ; + if System.length sys < !max_nb_cstr + then xadd_cstr vect cstr_info sys + else raise TimeOut type cstr_ext = | Contradiction (** The constraint is contradictory. @@ -728,7 +734,7 @@ struct | Inl (s,_) -> try Some (bound_of_variable IMap.empty fresh s.sys) - with x when Errors.noncritical x -> + with x when CErrors.noncritical x -> Printf.printf "optimise Exception : %s" (Printexc.to_string x); None @@ -866,7 +872,7 @@ let mk_proof hyps prf = | Elim(v,prf1,prf2) -> let prfsl = mk_proof prf1 and prfsr = mk_proof prf2 in - (* I take only the pairs for which the elimination is meaningfull *) + (* I take only the pairs for which the elimination is meaningful *) forall_pairs (pivot v) prfsl prfsr | And(prf1,prf2) -> let prfsl1 = mk_proof prf1 diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml index 0537cdbe..5cf1da8e 100644 --- a/plugins/micromega/micromega.ml +++ b/plugins/micromega/micromega.ml @@ -1,6 +1,3 @@ -type __ = Obj.t -let __ = let rec f _ = Obj.repr f in Obj.repr f - (** val negb : bool -> bool **) let negb = function @@ -11,16 +8,6 @@ type nat = | O | S of nat -(** val fst : ('a1 * 'a2) -> 'a1 **) - -let fst = function -| x,y -> x - -(** val snd : ('a1 * 'a2) -> 'a2 **) - -let snd = function -| x,y -> y - (** val app : 'a1 list -> 'a1 list -> 'a1 list **) let rec app l m = @@ -40,42 +27,15 @@ let compOpp = function | Lt -> Gt | Gt -> Lt -type compareSpecT = -| CompEqT -| CompLtT -| CompGtT - -(** val compareSpec2Type : comparison -> compareSpecT **) - -let compareSpec2Type = function -| Eq -> CompEqT -| Lt -> CompLtT -| Gt -> CompGtT - -type 'a compSpecT = compareSpecT - -(** val compSpec2Type : 'a1 -> 'a1 -> comparison -> 'a1 compSpecT **) - -let compSpec2Type x y c = - compareSpec2Type c - -type 'a sig0 = - 'a - (* singleton inductive, whose constructor was exist *) - -(** val plus : nat -> nat -> nat **) - -let rec plus n0 m = - match n0 with - | O -> m - | S p -> S (plus p m) - -(** val nat_iter : nat -> ('a1 -> 'a1) -> 'a1 -> 'a1 **) +module Coq__1 = struct + (** val add : nat -> nat -> nat **) + let rec add n0 m = + match n0 with + | O -> m + | S p -> S (add p m) +end +let add = Coq__1.add -let rec nat_iter n0 f x = - match n0 with - | O -> x - | S n' -> f (nat_iter n' f x) type positive = | XI of positive @@ -91,592 +51,25 @@ type z = | Zpos of positive | Zneg of positive -module type TotalOrder' = - sig - type t - end - -module MakeOrderTac = - functor (O:TotalOrder') -> - struct - - end - -module MaxLogicalProperties = - functor (O:TotalOrder') -> - functor (M:sig - val max : O.t -> O.t -> O.t - end) -> - struct - module T = MakeOrderTac(O) - end - -module Pos = - struct - type t = positive - - (** val succ : positive -> positive **) - - let rec succ = function - | XI p -> XO (succ p) - | XO p -> XI p - | XH -> XO XH - - (** val add : positive -> positive -> positive **) - - let rec add x y = - match x with - | XI p -> - (match y with - | XI q0 -> XO (add_carry p q0) - | XO q0 -> XI (add p q0) - | XH -> XO (succ p)) - | XO p -> - (match y with - | XI q0 -> XI (add p q0) - | XO q0 -> XO (add p q0) - | XH -> XI p) - | XH -> - (match y with - | XI q0 -> XO (succ q0) - | XO q0 -> XI q0 - | XH -> XO XH) - - (** val add_carry : positive -> positive -> positive **) - - and add_carry x y = - match x with - | XI p -> - (match y with - | XI q0 -> XI (add_carry p q0) - | XO q0 -> XO (add_carry p q0) - | XH -> XI (succ p)) - | XO p -> - (match y with - | XI q0 -> XO (add_carry p q0) - | XO q0 -> XI (add p q0) - | XH -> XO (succ p)) - | XH -> - (match y with - | XI q0 -> XI (succ q0) - | XO q0 -> XO (succ q0) - | XH -> XI XH) - - (** val pred_double : positive -> positive **) - - let rec pred_double = function - | XI p -> XI (XO p) - | XO p -> XI (pred_double p) - | XH -> XH - - (** val pred : positive -> positive **) - - let pred = function - | XI p -> XO p - | XO p -> pred_double p - | XH -> XH - - (** val pred_N : positive -> n **) - - let pred_N = function - | XI p -> Npos (XO p) - | XO p -> Npos (pred_double p) - | XH -> N0 - +module Pos = + struct type mask = | IsNul | IsPos of positive | IsNeg - - (** val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **) - - let mask_rect f f0 f1 = function - | IsNul -> f - | IsPos x -> f0 x - | IsNeg -> f1 - - (** val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **) - - let mask_rec f f0 f1 = function - | IsNul -> f - | IsPos x -> f0 x - | IsNeg -> f1 - - (** val succ_double_mask : mask -> mask **) - - let succ_double_mask = function - | IsNul -> IsPos XH - | IsPos p -> IsPos (XI p) - | IsNeg -> IsNeg - - (** val double_mask : mask -> mask **) - - let double_mask = function - | IsPos p -> IsPos (XO p) - | x0 -> x0 - - (** val double_pred_mask : positive -> mask **) - - let double_pred_mask = function - | XI p -> IsPos (XO (XO p)) - | XO p -> IsPos (XO (pred_double p)) - | XH -> IsNul - - (** val pred_mask : mask -> mask **) - - let pred_mask = function - | IsPos q0 -> - (match q0 with - | XH -> IsNul - | _ -> IsPos (pred q0)) - | _ -> IsNeg - - (** val sub_mask : positive -> positive -> mask **) - - let rec sub_mask x y = - match x with - | XI p -> - (match y with - | XI q0 -> double_mask (sub_mask p q0) - | XO q0 -> succ_double_mask (sub_mask p q0) - | XH -> IsPos (XO p)) - | XO p -> - (match y with - | XI q0 -> succ_double_mask (sub_mask_carry p q0) - | XO q0 -> double_mask (sub_mask p q0) - | XH -> IsPos (pred_double p)) - | XH -> - (match y with - | XH -> IsNul - | _ -> IsNeg) - - (** val sub_mask_carry : positive -> positive -> mask **) - - and sub_mask_carry x y = - match x with - | XI p -> - (match y with - | XI q0 -> succ_double_mask (sub_mask_carry p q0) - | XO q0 -> double_mask (sub_mask p q0) - | XH -> IsPos (pred_double p)) - | XO p -> - (match y with - | XI q0 -> double_mask (sub_mask_carry p q0) - | XO q0 -> succ_double_mask (sub_mask_carry p q0) - | XH -> double_pred_mask p) - | XH -> IsNeg - - (** val sub : positive -> positive -> positive **) - - let sub x y = - match sub_mask x y with - | IsPos z0 -> z0 - | _ -> XH - - (** val mul : positive -> positive -> positive **) - - let rec mul x y = - match x with - | XI p -> add y (XO (mul p y)) - | XO p -> XO (mul p y) - | XH -> y - - (** val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 **) - - let rec iter n0 f x = - match n0 with - | XI n' -> f (iter n' f (iter n' f x)) - | XO n' -> iter n' f (iter n' f x) - | XH -> f x - - (** val pow : positive -> positive -> positive **) - - let pow x y = - iter y (mul x) XH - - (** val div2 : positive -> positive **) - - let div2 = function - | XI p2 -> p2 - | XO p2 -> p2 - | XH -> XH - - (** val div2_up : positive -> positive **) - - let div2_up = function - | XI p2 -> succ p2 - | XO p2 -> p2 - | XH -> XH - - (** val size_nat : positive -> nat **) - - let rec size_nat = function - | XI p2 -> S (size_nat p2) - | XO p2 -> S (size_nat p2) - | XH -> S O - - (** val size : positive -> positive **) - - let rec size = function - | XI p2 -> succ (size p2) - | XO p2 -> succ (size p2) - | XH -> XH - - (** val compare_cont : positive -> positive -> comparison -> comparison **) - - let rec compare_cont x y r = - match x with - | XI p -> - (match y with - | XI q0 -> compare_cont p q0 r - | XO q0 -> compare_cont p q0 Gt - | XH -> Gt) - | XO p -> - (match y with - | XI q0 -> compare_cont p q0 Lt - | XO q0 -> compare_cont p q0 r - | XH -> Gt) - | XH -> - (match y with - | XH -> r - | _ -> Lt) - - (** val compare : positive -> positive -> comparison **) - - let compare x y = - compare_cont x y Eq - - (** val min : positive -> positive -> positive **) - - let min p p' = - match compare p p' with - | Gt -> p' - | _ -> p - - (** val max : positive -> positive -> positive **) - - let max p p' = - match compare p p' with - | Gt -> p - | _ -> p' - - (** val eqb : positive -> positive -> bool **) - - let rec eqb p q0 = - match p with - | XI p2 -> - (match q0 with - | XI q1 -> eqb p2 q1 - | _ -> false) - | XO p2 -> - (match q0 with - | XO q1 -> eqb p2 q1 - | _ -> false) - | XH -> - (match q0 with - | XH -> true - | _ -> false) - - (** val leb : positive -> positive -> bool **) - - let leb x y = - match compare x y with - | Gt -> false - | _ -> true - - (** val ltb : positive -> positive -> bool **) - - let ltb x y = - match compare x y with - | Lt -> true - | _ -> false - - (** val sqrtrem_step : - (positive -> positive) -> (positive -> positive) -> (positive * mask) - -> positive * mask **) - - let sqrtrem_step f g = function - | s,y -> - (match y with - | IsPos r -> - let s' = XI (XO s) in - let r' = g (f r) in - if leb s' r' then (XI s),(sub_mask r' s') else (XO s),(IsPos r') - | _ -> (XO s),(sub_mask (g (f XH)) (XO (XO XH)))) - - (** val sqrtrem : positive -> positive * mask **) - - let rec sqrtrem = function - | XI p2 -> - (match p2 with - | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XI x) (sqrtrem p3) - | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XI x) (sqrtrem p3) - | XH -> XH,(IsPos (XO XH))) - | XO p2 -> - (match p2 with - | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XO x) (sqrtrem p3) - | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XO x) (sqrtrem p3) - | XH -> XH,(IsPos XH)) - | XH -> XH,IsNul - - (** val sqrt : positive -> positive **) - - let sqrt p = - fst (sqrtrem p) - - (** val gcdn : nat -> positive -> positive -> positive **) - - let rec gcdn n0 a b = - match n0 with - | O -> XH - | S n1 -> - (match a with - | XI a' -> - (match b with - | XI b' -> - (match compare a' b' with - | Eq -> a - | Lt -> gcdn n1 (sub b' a') a - | Gt -> gcdn n1 (sub a' b') b) - | XO b0 -> gcdn n1 a b0 - | XH -> XH) - | XO a0 -> - (match b with - | XI p -> gcdn n1 a0 b - | XO b0 -> XO (gcdn n1 a0 b0) - | XH -> XH) - | XH -> XH) - - (** val gcd : positive -> positive -> positive **) - - let gcd a b = - gcdn (plus (size_nat a) (size_nat b)) a b - - (** val ggcdn : - nat -> positive -> positive -> positive * (positive * positive) **) - - let rec ggcdn n0 a b = - match n0 with - | O -> XH,(a,b) - | S n1 -> - (match a with - | XI a' -> - (match b with - | XI b' -> - (match compare a' b' with - | Eq -> a,(XH,XH) - | Lt -> - let g,p = ggcdn n1 (sub b' a') a in - let ba,aa = p in g,(aa,(add aa (XO ba))) - | Gt -> - let g,p = ggcdn n1 (sub a' b') b in - let ab,bb = p in g,((add bb (XO ab)),bb)) - | XO b0 -> - let g,p = ggcdn n1 a b0 in let aa,bb = p in g,(aa,(XO bb)) - | XH -> XH,(a,XH)) - | XO a0 -> - (match b with - | XI p -> - let g,p2 = ggcdn n1 a0 b in let aa,bb = p2 in g,((XO aa),bb) - | XO b0 -> let g,p = ggcdn n1 a0 b0 in (XO g),p - | XH -> XH,(a,XH)) - | XH -> XH,(XH,b)) - - (** val ggcd : positive -> positive -> positive * (positive * positive) **) - - let ggcd a b = - ggcdn (plus (size_nat a) (size_nat b)) a b - - (** val coq_Nsucc_double : n -> n **) - - let coq_Nsucc_double = function - | N0 -> Npos XH - | Npos p -> Npos (XI p) - - (** val coq_Ndouble : n -> n **) - - let coq_Ndouble = function - | N0 -> N0 - | Npos p -> Npos (XO p) - - (** val coq_lor : positive -> positive -> positive **) - - let rec coq_lor p q0 = - match p with - | XI p2 -> - (match q0 with - | XI q1 -> XI (coq_lor p2 q1) - | XO q1 -> XI (coq_lor p2 q1) - | XH -> p) - | XO p2 -> - (match q0 with - | XI q1 -> XI (coq_lor p2 q1) - | XO q1 -> XO (coq_lor p2 q1) - | XH -> XI p2) - | XH -> - (match q0 with - | XO q1 -> XI q1 - | _ -> q0) - - (** val coq_land : positive -> positive -> n **) - - let rec coq_land p q0 = - match p with - | XI p2 -> - (match q0 with - | XI q1 -> coq_Nsucc_double (coq_land p2 q1) - | XO q1 -> coq_Ndouble (coq_land p2 q1) - | XH -> Npos XH) - | XO p2 -> - (match q0 with - | XI q1 -> coq_Ndouble (coq_land p2 q1) - | XO q1 -> coq_Ndouble (coq_land p2 q1) - | XH -> N0) - | XH -> - (match q0 with - | XO q1 -> N0 - | _ -> Npos XH) - - (** val ldiff : positive -> positive -> n **) - - let rec ldiff p q0 = - match p with - | XI p2 -> - (match q0 with - | XI q1 -> coq_Ndouble (ldiff p2 q1) - | XO q1 -> coq_Nsucc_double (ldiff p2 q1) - | XH -> Npos (XO p2)) - | XO p2 -> - (match q0 with - | XI q1 -> coq_Ndouble (ldiff p2 q1) - | XO q1 -> coq_Ndouble (ldiff p2 q1) - | XH -> Npos p) - | XH -> - (match q0 with - | XO q1 -> Npos XH - | _ -> N0) - - (** val coq_lxor : positive -> positive -> n **) - - let rec coq_lxor p q0 = - match p with - | XI p2 -> - (match q0 with - | XI q1 -> coq_Ndouble (coq_lxor p2 q1) - | XO q1 -> coq_Nsucc_double (coq_lxor p2 q1) - | XH -> Npos (XO p2)) - | XO p2 -> - (match q0 with - | XI q1 -> coq_Nsucc_double (coq_lxor p2 q1) - | XO q1 -> coq_Ndouble (coq_lxor p2 q1) - | XH -> Npos (XI p2)) - | XH -> - (match q0 with - | XI q1 -> Npos (XO q1) - | XO q1 -> Npos (XI q1) - | XH -> N0) - - (** val shiftl_nat : positive -> nat -> positive **) - - let shiftl_nat p n0 = - nat_iter n0 (fun x -> XO x) p - - (** val shiftr_nat : positive -> nat -> positive **) - - let shiftr_nat p n0 = - nat_iter n0 div2 p - - (** val shiftl : positive -> n -> positive **) - - let shiftl p = function - | N0 -> p - | Npos n1 -> iter n1 (fun x -> XO x) p - - (** val shiftr : positive -> n -> positive **) - - let shiftr p = function - | N0 -> p - | Npos n1 -> iter n1 div2 p - - (** val testbit_nat : positive -> nat -> bool **) - - let rec testbit_nat p n0 = - match p with - | XI p2 -> - (match n0 with - | O -> true - | S n' -> testbit_nat p2 n') - | XO p2 -> - (match n0 with - | O -> false - | S n' -> testbit_nat p2 n') - | XH -> - (match n0 with - | O -> true - | S n1 -> false) - - (** val testbit : positive -> n -> bool **) - - let rec testbit p n0 = - match p with - | XI p2 -> - (match n0 with - | N0 -> true - | Npos n1 -> testbit p2 (pred_N n1)) - | XO p2 -> - (match n0 with - | N0 -> false - | Npos n1 -> testbit p2 (pred_N n1)) - | XH -> - (match n0 with - | N0 -> true - | Npos p2 -> false) - - (** val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 **) - - let rec iter_op op p a = - match p with - | XI p2 -> op a (iter_op op p2 (op a a)) - | XO p2 -> iter_op op p2 (op a a) - | XH -> a - - (** val to_nat : positive -> nat **) - - let to_nat x = - iter_op plus x (S O) - - (** val of_nat : nat -> positive **) - - let rec of_nat = function - | O -> XH - | S x -> - (match x with - | O -> XH - | S n1 -> succ (of_nat x)) - - (** val of_succ_nat : nat -> positive **) - - let rec of_succ_nat = function - | O -> XH - | S x -> succ (of_succ_nat x) end -module Coq_Pos = - struct - module Coq__1 = struct - type t = positive - end - type t = Coq__1.t - +module Coq_Pos = + struct (** val succ : positive -> positive **) - + let rec succ = function | XI p -> XO (succ p) | XO p -> XI p | XH -> XO XH - + (** val add : positive -> positive -> positive **) - + let rec add x y = match x with | XI p -> @@ -694,9 +87,9 @@ module Coq_Pos = | XI q0 -> XO (succ q0) | XO q0 -> XI q0 | XH -> XO XH) - + (** val add_carry : positive -> positive -> positive **) - + and add_carry x y = match x with | XI p -> @@ -714,78 +107,41 @@ module Coq_Pos = | XI q0 -> XI (succ q0) | XO q0 -> XO (succ q0) | XH -> XI XH) - + (** val pred_double : positive -> positive **) - + let rec pred_double = function | XI p -> XI (XO p) | XO p -> XI (pred_double p) | XH -> XH - - (** val pred : positive -> positive **) - - let pred = function - | XI p -> XO p - | XO p -> pred_double p - | XH -> XH - - (** val pred_N : positive -> n **) - - let pred_N = function - | XI p -> Npos (XO p) - | XO p -> Npos (pred_double p) - | XH -> N0 - + type mask = Pos.mask = | IsNul | IsPos of positive | IsNeg - - (** val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **) - - let mask_rect f f0 f1 = function - | IsNul -> f - | IsPos x -> f0 x - | IsNeg -> f1 - - (** val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **) - - let mask_rec f f0 f1 = function - | IsNul -> f - | IsPos x -> f0 x - | IsNeg -> f1 - + (** val succ_double_mask : mask -> mask **) - + let succ_double_mask = function | IsNul -> IsPos XH | IsPos p -> IsPos (XI p) | IsNeg -> IsNeg - + (** val double_mask : mask -> mask **) - + let double_mask = function | IsPos p -> IsPos (XO p) | x0 -> x0 - + (** val double_pred_mask : positive -> mask **) - + let double_pred_mask = function | XI p -> IsPos (XO (XO p)) | XO p -> IsPos (XO (pred_double p)) | XH -> IsNul - - (** val pred_mask : mask -> mask **) - - let pred_mask = function - | IsPos q0 -> - (match q0 with - | XH -> IsNul - | _ -> IsPos (pred q0)) - | _ -> IsNeg - + (** val sub_mask : positive -> positive -> mask **) - + let rec sub_mask x y = match x with | XI p -> @@ -802,9 +158,9 @@ module Coq_Pos = (match y with | XH -> IsNul | _ -> IsNeg) - + (** val sub_mask_carry : positive -> positive -> mask **) - + and sub_mask_carry x y = match x with | XI p -> @@ -818,167 +174,56 @@ module Coq_Pos = | XO q0 -> succ_double_mask (sub_mask_carry p q0) | XH -> double_pred_mask p) | XH -> IsNeg - + (** val sub : positive -> positive -> positive **) - + let sub x y = match sub_mask x y with | IsPos z0 -> z0 | _ -> XH - + (** val mul : positive -> positive -> positive **) - + let rec mul x y = match x with | XI p -> add y (XO (mul p y)) | XO p -> XO (mul p y) | XH -> y - - (** val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 **) - - let rec iter n0 f x = - match n0 with - | XI n' -> f (iter n' f (iter n' f x)) - | XO n' -> iter n' f (iter n' f x) - | XH -> f x - - (** val pow : positive -> positive -> positive **) - - let pow x y = - iter y (mul x) XH - - (** val div2 : positive -> positive **) - - let div2 = function - | XI p2 -> p2 - | XO p2 -> p2 - | XH -> XH - - (** val div2_up : positive -> positive **) - - let div2_up = function - | XI p2 -> succ p2 - | XO p2 -> p2 - | XH -> XH - + (** val size_nat : positive -> nat **) - + let rec size_nat = function | XI p2 -> S (size_nat p2) | XO p2 -> S (size_nat p2) | XH -> S O - - (** val size : positive -> positive **) - - let rec size = function - | XI p2 -> succ (size p2) - | XO p2 -> succ (size p2) - | XH -> XH - - (** val compare_cont : positive -> positive -> comparison -> comparison **) - - let rec compare_cont x y r = + + (** val compare_cont : + comparison -> positive -> positive -> comparison **) + + let rec compare_cont r x y = match x with | XI p -> (match y with - | XI q0 -> compare_cont p q0 r - | XO q0 -> compare_cont p q0 Gt + | XI q0 -> compare_cont r p q0 + | XO q0 -> compare_cont Gt p q0 | XH -> Gt) | XO p -> (match y with - | XI q0 -> compare_cont p q0 Lt - | XO q0 -> compare_cont p q0 r + | XI q0 -> compare_cont Lt p q0 + | XO q0 -> compare_cont r p q0 | XH -> Gt) | XH -> (match y with | XH -> r | _ -> Lt) - + (** val compare : positive -> positive -> comparison **) - - let compare x y = - compare_cont x y Eq - - (** val min : positive -> positive -> positive **) - - let min p p' = - match compare p p' with - | Gt -> p' - | _ -> p - - (** val max : positive -> positive -> positive **) - - let max p p' = - match compare p p' with - | Gt -> p - | _ -> p' - - (** val eqb : positive -> positive -> bool **) - - let rec eqb p q0 = - match p with - | XI p2 -> - (match q0 with - | XI q1 -> eqb p2 q1 - | _ -> false) - | XO p2 -> - (match q0 with - | XO q1 -> eqb p2 q1 - | _ -> false) - | XH -> - (match q0 with - | XH -> true - | _ -> false) - - (** val leb : positive -> positive -> bool **) - - let leb x y = - match compare x y with - | Gt -> false - | _ -> true - - (** val ltb : positive -> positive -> bool **) - - let ltb x y = - match compare x y with - | Lt -> true - | _ -> false - - (** val sqrtrem_step : - (positive -> positive) -> (positive -> positive) -> (positive * mask) - -> positive * mask **) - - let sqrtrem_step f g = function - | s,y -> - (match y with - | IsPos r -> - let s' = XI (XO s) in - let r' = g (f r) in - if leb s' r' then (XI s),(sub_mask r' s') else (XO s),(IsPos r') - | _ -> (XO s),(sub_mask (g (f XH)) (XO (XO XH)))) - - (** val sqrtrem : positive -> positive * mask **) - - let rec sqrtrem = function - | XI p2 -> - (match p2 with - | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XI x) (sqrtrem p3) - | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XI x) (sqrtrem p3) - | XH -> XH,(IsPos (XO XH))) - | XO p2 -> - (match p2 with - | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XO x) (sqrtrem p3) - | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XO x) (sqrtrem p3) - | XH -> XH,(IsPos XH)) - | XH -> XH,IsNul - - (** val sqrt : positive -> positive **) - - let sqrt p = - fst (sqrtrem p) - + + let compare = + compare_cont Eq + (** val gcdn : nat -> positive -> positive -> positive **) - + let rec gcdn n0 a b = match n0 with | O -> XH @@ -995,1001 +240,30 @@ module Coq_Pos = | XH -> XH) | XO a0 -> (match b with - | XI p -> gcdn n1 a0 b + | XI _ -> gcdn n1 a0 b | XO b0 -> XO (gcdn n1 a0 b0) | XH -> XH) | XH -> XH) - + (** val gcd : positive -> positive -> positive **) - + let gcd a b = - gcdn (plus (size_nat a) (size_nat b)) a b - - (** val ggcdn : - nat -> positive -> positive -> positive * (positive * positive) **) - - let rec ggcdn n0 a b = - match n0 with - | O -> XH,(a,b) - | S n1 -> - (match a with - | XI a' -> - (match b with - | XI b' -> - (match compare a' b' with - | Eq -> a,(XH,XH) - | Lt -> - let g,p = ggcdn n1 (sub b' a') a in - let ba,aa = p in g,(aa,(add aa (XO ba))) - | Gt -> - let g,p = ggcdn n1 (sub a' b') b in - let ab,bb = p in g,((add bb (XO ab)),bb)) - | XO b0 -> - let g,p = ggcdn n1 a b0 in let aa,bb = p in g,(aa,(XO bb)) - | XH -> XH,(a,XH)) - | XO a0 -> - (match b with - | XI p -> - let g,p2 = ggcdn n1 a0 b in let aa,bb = p2 in g,((XO aa),bb) - | XO b0 -> let g,p = ggcdn n1 a0 b0 in (XO g),p - | XH -> XH,(a,XH)) - | XH -> XH,(XH,b)) - - (** val ggcd : positive -> positive -> positive * (positive * positive) **) - - let ggcd a b = - ggcdn (plus (size_nat a) (size_nat b)) a b - - (** val coq_Nsucc_double : n -> n **) - - let coq_Nsucc_double = function - | N0 -> Npos XH - | Npos p -> Npos (XI p) - - (** val coq_Ndouble : n -> n **) - - let coq_Ndouble = function - | N0 -> N0 - | Npos p -> Npos (XO p) - - (** val coq_lor : positive -> positive -> positive **) - - let rec coq_lor p q0 = - match p with - | XI p2 -> - (match q0 with - | XI q1 -> XI (coq_lor p2 q1) - | XO q1 -> XI (coq_lor p2 q1) - | XH -> p) - | XO p2 -> - (match q0 with - | XI q1 -> XI (coq_lor p2 q1) - | XO q1 -> XO (coq_lor p2 q1) - | XH -> XI p2) - | XH -> - (match q0 with - | XO q1 -> XI q1 - | _ -> q0) - - (** val coq_land : positive -> positive -> n **) - - let rec coq_land p q0 = - match p with - | XI p2 -> - (match q0 with - | XI q1 -> coq_Nsucc_double (coq_land p2 q1) - | XO q1 -> coq_Ndouble (coq_land p2 q1) - | XH -> Npos XH) - | XO p2 -> - (match q0 with - | XI q1 -> coq_Ndouble (coq_land p2 q1) - | XO q1 -> coq_Ndouble (coq_land p2 q1) - | XH -> N0) - | XH -> - (match q0 with - | XO q1 -> N0 - | _ -> Npos XH) - - (** val ldiff : positive -> positive -> n **) - - let rec ldiff p q0 = - match p with - | XI p2 -> - (match q0 with - | XI q1 -> coq_Ndouble (ldiff p2 q1) - | XO q1 -> coq_Nsucc_double (ldiff p2 q1) - | XH -> Npos (XO p2)) - | XO p2 -> - (match q0 with - | XI q1 -> coq_Ndouble (ldiff p2 q1) - | XO q1 -> coq_Ndouble (ldiff p2 q1) - | XH -> Npos p) - | XH -> - (match q0 with - | XO q1 -> Npos XH - | _ -> N0) - - (** val coq_lxor : positive -> positive -> n **) - - let rec coq_lxor p q0 = - match p with - | XI p2 -> - (match q0 with - | XI q1 -> coq_Ndouble (coq_lxor p2 q1) - | XO q1 -> coq_Nsucc_double (coq_lxor p2 q1) - | XH -> Npos (XO p2)) - | XO p2 -> - (match q0 with - | XI q1 -> coq_Nsucc_double (coq_lxor p2 q1) - | XO q1 -> coq_Ndouble (coq_lxor p2 q1) - | XH -> Npos (XI p2)) - | XH -> - (match q0 with - | XI q1 -> Npos (XO q1) - | XO q1 -> Npos (XI q1) - | XH -> N0) - - (** val shiftl_nat : positive -> nat -> positive **) - - let shiftl_nat p n0 = - nat_iter n0 (fun x -> XO x) p - - (** val shiftr_nat : positive -> nat -> positive **) - - let shiftr_nat p n0 = - nat_iter n0 div2 p - - (** val shiftl : positive -> n -> positive **) - - let shiftl p = function - | N0 -> p - | Npos n1 -> iter n1 (fun x -> XO x) p - - (** val shiftr : positive -> n -> positive **) - - let shiftr p = function - | N0 -> p - | Npos n1 -> iter n1 div2 p - - (** val testbit_nat : positive -> nat -> bool **) - - let rec testbit_nat p n0 = - match p with - | XI p2 -> - (match n0 with - | O -> true - | S n' -> testbit_nat p2 n') - | XO p2 -> - (match n0 with - | O -> false - | S n' -> testbit_nat p2 n') - | XH -> - (match n0 with - | O -> true - | S n1 -> false) - - (** val testbit : positive -> n -> bool **) - - let rec testbit p n0 = - match p with - | XI p2 -> - (match n0 with - | N0 -> true - | Npos n1 -> testbit p2 (pred_N n1)) - | XO p2 -> - (match n0 with - | N0 -> false - | Npos n1 -> testbit p2 (pred_N n1)) - | XH -> - (match n0 with - | N0 -> true - | Npos p2 -> false) - - (** val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 **) - - let rec iter_op op p a = - match p with - | XI p2 -> op a (iter_op op p2 (op a a)) - | XO p2 -> iter_op op p2 (op a a) - | XH -> a - - (** val to_nat : positive -> nat **) - - let to_nat x = - iter_op plus x (S O) - - (** val of_nat : nat -> positive **) - - let rec of_nat = function - | O -> XH - | S x -> - (match x with - | O -> XH - | S n1 -> succ (of_nat x)) - + gcdn (Coq__1.add (size_nat a) (size_nat b)) a b + (** val of_succ_nat : nat -> positive **) - + let rec of_succ_nat = function | O -> XH | S x -> succ (of_succ_nat x) - - (** val eq_dec : positive -> positive -> bool **) - - let rec eq_dec p y0 = - match p with - | XI p2 -> - (match y0 with - | XI p3 -> eq_dec p2 p3 - | _ -> false) - | XO p2 -> - (match y0 with - | XO p3 -> eq_dec p2 p3 - | _ -> false) - | XH -> - (match y0 with - | XH -> true - | _ -> false) - - (** val peano_rect : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 **) - - let rec peano_rect a f p = - let f2 = peano_rect (f XH a) (fun p2 x -> f (succ (XO p2)) (f (XO p2) x)) - in - (match p with - | XI q0 -> f (XO q0) (f2 q0) - | XO q0 -> f2 q0 - | XH -> a) - - (** val peano_rec : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 **) - - let peano_rec = - peano_rect - - type coq_PeanoView = - | PeanoOne - | PeanoSucc of positive * coq_PeanoView - - (** val coq_PeanoView_rect : - 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive -> - coq_PeanoView -> 'a1 **) - - let rec coq_PeanoView_rect f f0 p = function - | PeanoOne -> f - | PeanoSucc (p3, p4) -> f0 p3 p4 (coq_PeanoView_rect f f0 p3 p4) - - (** val coq_PeanoView_rec : - 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive -> - coq_PeanoView -> 'a1 **) - - let rec coq_PeanoView_rec f f0 p = function - | PeanoOne -> f - | PeanoSucc (p3, p4) -> f0 p3 p4 (coq_PeanoView_rec f f0 p3 p4) - - (** val peanoView_xO : positive -> coq_PeanoView -> coq_PeanoView **) - - let rec peanoView_xO p = function - | PeanoOne -> PeanoSucc (XH, PeanoOne) - | PeanoSucc (p2, q1) -> - PeanoSucc ((succ (XO p2)), (PeanoSucc ((XO p2), (peanoView_xO p2 q1)))) - - (** val peanoView_xI : positive -> coq_PeanoView -> coq_PeanoView **) - - let rec peanoView_xI p = function - | PeanoOne -> PeanoSucc ((succ XH), (PeanoSucc (XH, PeanoOne))) - | PeanoSucc (p2, q1) -> - PeanoSucc ((succ (XI p2)), (PeanoSucc ((XI p2), (peanoView_xI p2 q1)))) - - (** val peanoView : positive -> coq_PeanoView **) - - let rec peanoView = function - | XI p2 -> peanoView_xI p2 (peanoView p2) - | XO p2 -> peanoView_xO p2 (peanoView p2) - | XH -> PeanoOne - - (** val coq_PeanoView_iter : - 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> coq_PeanoView -> 'a1 **) - - let rec coq_PeanoView_iter a f p = function - | PeanoOne -> a - | PeanoSucc (p2, q1) -> f p2 (coq_PeanoView_iter a f p2 q1) - - (** val switch_Eq : comparison -> comparison -> comparison **) - - let switch_Eq c = function - | Eq -> c - | x -> x - - (** val mask2cmp : mask -> comparison **) - - let mask2cmp = function - | IsNul -> Eq - | IsPos p2 -> Gt - | IsNeg -> Lt - - module T = - struct - - end - - module ORev = - struct - type t = Coq__1.t - end - - module MRev = - struct - (** val max : t -> t -> t **) - - let max x y = - min y x - end - - module MPRev = MaxLogicalProperties(ORev)(MRev) - - module P = - struct - (** val max_case_strong : - t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) - -> 'a1 **) - - let max_case_strong n0 m compat hl hr = - let c = compSpec2Type n0 m (compare n0 m) in - (match c with - | CompGtT -> compat n0 (max n0 m) __ (hl __) - | _ -> compat m (max n0 m) __ (hr __)) - - (** val max_case : - t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) - - let max_case n0 m x x0 x1 = - max_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) - - (** val max_dec : t -> t -> bool **) - - let max_dec n0 m = - max_case n0 m (fun x y _ h0 -> h0) true false - - (** val min_case_strong : - t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) - -> 'a1 **) - - let min_case_strong n0 m compat hl hr = - let c = compSpec2Type n0 m (compare n0 m) in - (match c with - | CompGtT -> compat m (min n0 m) __ (hr __) - | _ -> compat n0 (min n0 m) __ (hl __)) - - (** val min_case : - t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) - - let min_case n0 m x x0 x1 = - min_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) - - (** val min_dec : t -> t -> bool **) - - let min_dec n0 m = - min_case n0 m (fun x y _ h0 -> h0) true false - end - - (** val max_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) - - let max_case_strong n0 m x x0 = - P.max_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 - - (** val max_case : t -> t -> 'a1 -> 'a1 -> 'a1 **) - - let max_case n0 m x x0 = - max_case_strong n0 m (fun _ -> x) (fun _ -> x0) - - (** val max_dec : t -> t -> bool **) - - let max_dec = - P.max_dec - - (** val min_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) - - let min_case_strong n0 m x x0 = - P.min_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 - - (** val min_case : t -> t -> 'a1 -> 'a1 -> 'a1 **) - - let min_case n0 m x x0 = - min_case_strong n0 m (fun _ -> x) (fun _ -> x0) - - (** val min_dec : t -> t -> bool **) - - let min_dec = - P.min_dec end -module N = - struct - type t = n - - (** val zero : n **) - - let zero = - N0 - - (** val one : n **) - - let one = - Npos XH - - (** val two : n **) - - let two = - Npos (XO XH) - - (** val succ_double : n -> n **) - - let succ_double = function - | N0 -> Npos XH - | Npos p -> Npos (XI p) - - (** val double : n -> n **) - - let double = function - | N0 -> N0 - | Npos p -> Npos (XO p) - - (** val succ : n -> n **) - - let succ = function - | N0 -> Npos XH - | Npos p -> Npos (Coq_Pos.succ p) - - (** val pred : n -> n **) - - let pred = function - | N0 -> N0 - | Npos p -> Coq_Pos.pred_N p - - (** val succ_pos : n -> positive **) - - let succ_pos = function - | N0 -> XH - | Npos p -> Coq_Pos.succ p - - (** val add : n -> n -> n **) - - let add n0 m = - match n0 with - | N0 -> m - | Npos p -> - (match m with - | N0 -> n0 - | Npos q0 -> Npos (Coq_Pos.add p q0)) - - (** val sub : n -> n -> n **) - - let sub n0 m = - match n0 with - | N0 -> N0 - | Npos n' -> - (match m with - | N0 -> n0 - | Npos m' -> - (match Coq_Pos.sub_mask n' m' with - | Coq_Pos.IsPos p -> Npos p - | _ -> N0)) - - (** val mul : n -> n -> n **) - - let mul n0 m = - match n0 with - | N0 -> N0 - | Npos p -> - (match m with - | N0 -> N0 - | Npos q0 -> Npos (Coq_Pos.mul p q0)) - - (** val compare : n -> n -> comparison **) - - let compare n0 m = - match n0 with - | N0 -> - (match m with - | N0 -> Eq - | Npos m' -> Lt) - | Npos n' -> - (match m with - | N0 -> Gt - | Npos m' -> Coq_Pos.compare n' m') - - (** val eqb : n -> n -> bool **) - - let eqb n0 m = - match n0 with - | N0 -> - (match m with - | N0 -> true - | Npos p -> false) - | Npos p -> - (match m with - | N0 -> false - | Npos q0 -> Coq_Pos.eqb p q0) - - (** val leb : n -> n -> bool **) - - let leb x y = - match compare x y with - | Gt -> false - | _ -> true - - (** val ltb : n -> n -> bool **) - - let ltb x y = - match compare x y with - | Lt -> true - | _ -> false - - (** val min : n -> n -> n **) - - let min n0 n' = - match compare n0 n' with - | Gt -> n' - | _ -> n0 - - (** val max : n -> n -> n **) - - let max n0 n' = - match compare n0 n' with - | Gt -> n0 - | _ -> n' - - (** val div2 : n -> n **) - - let div2 = function - | N0 -> N0 - | Npos p2 -> - (match p2 with - | XI p -> Npos p - | XO p -> Npos p - | XH -> N0) - - (** val even : n -> bool **) - - let even = function - | N0 -> true - | Npos p -> - (match p with - | XO p2 -> true - | _ -> false) - - (** val odd : n -> bool **) - - let odd n0 = - negb (even n0) - - (** val pow : n -> n -> n **) - - let pow n0 = function - | N0 -> Npos XH - | Npos p2 -> - (match n0 with - | N0 -> N0 - | Npos q0 -> Npos (Coq_Pos.pow q0 p2)) - - (** val log2 : n -> n **) - - let log2 = function - | N0 -> N0 - | Npos p2 -> - (match p2 with - | XI p -> Npos (Coq_Pos.size p) - | XO p -> Npos (Coq_Pos.size p) - | XH -> N0) - - (** val size : n -> n **) - - let size = function - | N0 -> N0 - | Npos p -> Npos (Coq_Pos.size p) - - (** val size_nat : n -> nat **) - - let size_nat = function - | N0 -> O - | Npos p -> Coq_Pos.size_nat p - - (** val pos_div_eucl : positive -> n -> n * n **) - - let rec pos_div_eucl a b = - match a with - | XI a' -> - let q0,r = pos_div_eucl a' b in - let r' = succ_double r in - if leb b r' then (succ_double q0),(sub r' b) else (double q0),r' - | XO a' -> - let q0,r = pos_div_eucl a' b in - let r' = double r in - if leb b r' then (succ_double q0),(sub r' b) else (double q0),r' - | XH -> - (match b with - | N0 -> N0,(Npos XH) - | Npos p -> - (match p with - | XH -> (Npos XH),N0 - | _ -> N0,(Npos XH))) - - (** val div_eucl : n -> n -> n * n **) - - let div_eucl a b = - match a with - | N0 -> N0,N0 - | Npos na -> - (match b with - | N0 -> N0,a - | Npos p -> pos_div_eucl na b) - - (** val div : n -> n -> n **) - - let div a b = - fst (div_eucl a b) - - (** val modulo : n -> n -> n **) - - let modulo a b = - snd (div_eucl a b) - - (** val gcd : n -> n -> n **) - - let gcd a b = - match a with - | N0 -> b - | Npos p -> - (match b with - | N0 -> a - | Npos q0 -> Npos (Coq_Pos.gcd p q0)) - - (** val ggcd : n -> n -> n * (n * n) **) - - let ggcd a b = - match a with - | N0 -> b,(N0,(Npos XH)) - | Npos p -> - (match b with - | N0 -> a,((Npos XH),N0) - | Npos q0 -> - let g,p2 = Coq_Pos.ggcd p q0 in - let aa,bb = p2 in (Npos g),((Npos aa),(Npos bb))) - - (** val sqrtrem : n -> n * n **) - - let sqrtrem = function - | N0 -> N0,N0 - | Npos p -> - let s,m = Coq_Pos.sqrtrem p in - (match m with - | Coq_Pos.IsPos r -> (Npos s),(Npos r) - | _ -> (Npos s),N0) - - (** val sqrt : n -> n **) - - let sqrt = function - | N0 -> N0 - | Npos p -> Npos (Coq_Pos.sqrt p) - - (** val coq_lor : n -> n -> n **) - - let coq_lor n0 m = - match n0 with - | N0 -> m - | Npos p -> - (match m with - | N0 -> n0 - | Npos q0 -> Npos (Coq_Pos.coq_lor p q0)) - - (** val coq_land : n -> n -> n **) - - let coq_land n0 m = - match n0 with - | N0 -> N0 - | Npos p -> - (match m with - | N0 -> N0 - | Npos q0 -> Coq_Pos.coq_land p q0) - - (** val ldiff : n -> n -> n **) - - let ldiff n0 m = - match n0 with - | N0 -> N0 - | Npos p -> - (match m with - | N0 -> n0 - | Npos q0 -> Coq_Pos.ldiff p q0) - - (** val coq_lxor : n -> n -> n **) - - let coq_lxor n0 m = - match n0 with - | N0 -> m - | Npos p -> - (match m with - | N0 -> n0 - | Npos q0 -> Coq_Pos.coq_lxor p q0) - - (** val shiftl_nat : n -> nat -> n **) - - let shiftl_nat a n0 = - nat_iter n0 double a - - (** val shiftr_nat : n -> nat -> n **) - - let shiftr_nat a n0 = - nat_iter n0 div2 a - - (** val shiftl : n -> n -> n **) - - let shiftl a n0 = - match a with - | N0 -> N0 - | Npos a0 -> Npos (Coq_Pos.shiftl a0 n0) - - (** val shiftr : n -> n -> n **) - - let shiftr a = function - | N0 -> a - | Npos p -> Coq_Pos.iter p div2 a - - (** val testbit_nat : n -> nat -> bool **) - - let testbit_nat = function - | N0 -> (fun x -> false) - | Npos p -> Coq_Pos.testbit_nat p - - (** val testbit : n -> n -> bool **) - - let testbit a n0 = - match a with - | N0 -> false - | Npos p -> Coq_Pos.testbit p n0 - - (** val to_nat : n -> nat **) - - let to_nat = function - | N0 -> O - | Npos p -> Coq_Pos.to_nat p - +module N = + struct (** val of_nat : nat -> n **) - + let of_nat = function | O -> N0 | S n' -> Npos (Coq_Pos.of_succ_nat n') - - (** val iter : n -> ('a1 -> 'a1) -> 'a1 -> 'a1 **) - - let iter n0 f x = - match n0 with - | N0 -> x - | Npos p -> Coq_Pos.iter p f x - - (** val eq_dec : n -> n -> bool **) - - let eq_dec n0 m = - match n0 with - | N0 -> - (match m with - | N0 -> true - | Npos p -> false) - | Npos x -> - (match m with - | N0 -> false - | Npos p2 -> Coq_Pos.eq_dec x p2) - - (** val discr : n -> positive option **) - - let discr = function - | N0 -> None - | Npos p -> Some p - - (** val binary_rect : - 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 **) - - let binary_rect f0 f2 fS2 n0 = - let f2' = fun p -> f2 (Npos p) in - let fS2' = fun p -> fS2 (Npos p) in - (match n0 with - | N0 -> f0 - | Npos p -> - let rec f = function - | XI p3 -> fS2' p3 (f p3) - | XO p3 -> f2' p3 (f p3) - | XH -> fS2 N0 f0 - in f p) - - (** val binary_rec : - 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 **) - - let binary_rec = - binary_rect - - (** val peano_rect : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 **) - - let peano_rect f0 f n0 = - let f' = fun p -> f (Npos p) in - (match n0 with - | N0 -> f0 - | Npos p -> Coq_Pos.peano_rect (f N0 f0) f' p) - - (** val peano_rec : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 **) - - let peano_rec = - peano_rect - - module BootStrap = - struct - - end - - (** val recursion : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 **) - - let recursion x = - peano_rect x - - module OrderElts = - struct - type t = n - end - - module OrderTac = MakeOrderTac(OrderElts) - - module NZPowP = - struct - - end - - module NZSqrtP = - struct - - end - - (** val sqrt_up : n -> n **) - - let sqrt_up a = - match compare N0 a with - | Lt -> succ (sqrt (pred a)) - | _ -> N0 - - (** val log2_up : n -> n **) - - let log2_up a = - match compare (Npos XH) a with - | Lt -> succ (log2 (pred a)) - | _ -> N0 - - module NZDivP = - struct - - end - - (** val lcm : n -> n -> n **) - - let lcm a b = - mul a (div b (gcd a b)) - - (** val b2n : bool -> n **) - - let b2n = function - | true -> Npos XH - | false -> N0 - - (** val setbit : n -> n -> n **) - - let setbit a n0 = - coq_lor a (shiftl (Npos XH) n0) - - (** val clearbit : n -> n -> n **) - - let clearbit a n0 = - ldiff a (shiftl (Npos XH) n0) - - (** val ones : n -> n **) - - let ones n0 = - pred (shiftl (Npos XH) n0) - - (** val lnot : n -> n -> n **) - - let lnot a n0 = - coq_lxor a (ones n0) - - module T = - struct - - end - - module ORev = - struct - type t = n - end - - module MRev = - struct - (** val max : n -> n -> n **) - - let max x y = - min y x - end - - module MPRev = MaxLogicalProperties(ORev)(MRev) - - module P = - struct - (** val max_case_strong : - n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) - -> 'a1 **) - - let max_case_strong n0 m compat hl hr = - let c = compSpec2Type n0 m (compare n0 m) in - (match c with - | CompGtT -> compat n0 (max n0 m) __ (hl __) - | _ -> compat m (max n0 m) __ (hr __)) - - (** val max_case : - n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) - - let max_case n0 m x x0 x1 = - max_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) - - (** val max_dec : n -> n -> bool **) - - let max_dec n0 m = - max_case n0 m (fun x y _ h0 -> h0) true false - - (** val min_case_strong : - n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) - -> 'a1 **) - - let min_case_strong n0 m compat hl hr = - let c = compSpec2Type n0 m (compare n0 m) in - (match c with - | CompGtT -> compat m (min n0 m) __ (hr __) - | _ -> compat n0 (min n0 m) __ (hl __)) - - (** val min_case : - n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) - - let min_case n0 m x x0 x1 = - min_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) - - (** val min_dec : n -> n -> bool **) - - let min_dec n0 m = - min_case n0 m (fun x y _ h0 -> h0) true false - end - - (** val max_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) - - let max_case_strong n0 m x x0 = - P.max_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 - - (** val max_case : n -> n -> 'a1 -> 'a1 -> 'a1 **) - - let max_case n0 m x x0 = - max_case_strong n0 m (fun _ -> x) (fun _ -> x0) - - (** val max_dec : n -> n -> bool **) - - let max_dec = - P.max_dec - - (** val min_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) - - let min_case_strong n0 m x x0 = - P.min_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 - - (** val min_case : n -> n -> 'a1 -> 'a1 -> 'a1 **) - - let min_case n0 m x x0 = - min_case_strong n0 m (fun _ -> x) (fun _ -> x0) - - (** val min_dec : n -> n -> bool **) - - let min_dec = - P.min_dec end (** val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 **) @@ -2006,66 +280,49 @@ let rec nth n0 l default = | O -> (match l with | [] -> default - | x::l' -> x) + | x::_ -> x) | S m -> (match l with | [] -> default - | x::t1 -> nth m t1 default) + | _::t0 -> nth m t0 default) (** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **) let rec map f = function | [] -> [] -| a::t1 -> (f a)::(map f t1) +| a::t0 -> (f a)::(map f t0) (** val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 **) let rec fold_right f a0 = function | [] -> a0 -| b::t1 -> f b (fold_right f a0 t1) - -module Z = - struct - type t = z - - (** val zero : z **) - - let zero = - Z0 - - (** val one : z **) - - let one = - Zpos XH - - (** val two : z **) - - let two = - Zpos (XO XH) - +| b::t0 -> f b (fold_right f a0 t0) + +module Z = + struct (** val double : z -> z **) - + let double = function | Z0 -> Z0 | Zpos p -> Zpos (XO p) | Zneg p -> Zneg (XO p) - + (** val succ_double : z -> z **) - + let succ_double = function | Z0 -> Zpos XH | Zpos p -> Zpos (XI p) | Zneg p -> Zneg (Coq_Pos.pred_double p) - + (** val pred_double : z -> z **) - + let pred_double = function | Z0 -> Zneg XH | Zpos p -> Zpos (Coq_Pos.pred_double p) | Zneg p -> Zneg (XI p) - + (** val pos_sub : positive -> positive -> z **) - + let rec pos_sub x y = match x with | XI p -> @@ -2083,9 +340,9 @@ module Z = | XI q0 -> Zneg (XO q0) | XO q0 -> Zneg (Coq_Pos.pred_double q0) | XH -> Z0) - + (** val add : z -> z -> z **) - + let add x y = match x with | Z0 -> y @@ -2099,31 +356,21 @@ module Z = | Z0 -> x | Zpos y' -> pos_sub y' x' | Zneg y' -> Zneg (Coq_Pos.add x' y')) - + (** val opp : z -> z **) - + let opp = function | Z0 -> Z0 | Zpos x0 -> Zneg x0 | Zneg x0 -> Zpos x0 - - (** val succ : z -> z **) - - let succ x = - add x (Zpos XH) - - (** val pred : z -> z **) - - let pred x = - add x (Zneg XH) - + (** val sub : z -> z -> z **) - + let sub m n0 = add m (opp n0) - + (** val mul : z -> z -> z **) - + let mul x y = match x with | Z0 -> Z0 @@ -2137,28 +384,16 @@ module Z = | Z0 -> Z0 | Zpos y' -> Zneg (Coq_Pos.mul x' y') | Zneg y' -> Zpos (Coq_Pos.mul x' y')) - - (** val pow_pos : z -> positive -> z **) - - let pow_pos z0 n0 = - Coq_Pos.iter n0 (mul z0) (Zpos XH) - - (** val pow : z -> z -> z **) - - let pow x = function - | Z0 -> Zpos XH - | Zpos p -> pow_pos x p - | Zneg p -> Z0 - + (** val compare : z -> z -> comparison **) - + let compare x y = match x with | Z0 -> (match y with | Z0 -> Eq - | Zpos y' -> Lt - | Zneg y' -> Gt) + | Zpos _ -> Lt + | Zneg _ -> Gt) | Zpos x' -> (match y with | Zpos y' -> Coq_Pos.compare x' y' @@ -2167,151 +402,74 @@ module Z = (match y with | Zneg y' -> compOpp (Coq_Pos.compare x' y') | _ -> Lt) - - (** val sgn : z -> z **) - - let sgn = function - | Z0 -> Z0 - | Zpos p -> Zpos XH - | Zneg p -> Zneg XH - + (** val leb : z -> z -> bool **) - + let leb x y = match compare x y with | Gt -> false | _ -> true - - (** val geb : z -> z -> bool **) - - let geb x y = - match compare x y with - | Lt -> false - | _ -> true - + (** val ltb : z -> z -> bool **) - + let ltb x y = match compare x y with | Lt -> true | _ -> false - + (** val gtb : z -> z -> bool **) - + let gtb x y = match compare x y with | Gt -> true | _ -> false - - (** val eqb : z -> z -> bool **) - - let eqb x y = - match x with - | Z0 -> - (match y with - | Z0 -> true - | _ -> false) - | Zpos p -> - (match y with - | Zpos q0 -> Coq_Pos.eqb p q0 - | _ -> false) - | Zneg p -> - (match y with - | Zneg q0 -> Coq_Pos.eqb p q0 - | _ -> false) - + (** val max : z -> z -> z **) - + let max n0 m = match compare n0 m with | Lt -> m | _ -> n0 - - (** val min : z -> z -> z **) - - let min n0 m = - match compare n0 m with - | Gt -> m - | _ -> n0 - + (** val abs : z -> z **) - + let abs = function | Zneg p -> Zpos p | x -> x - - (** val abs_nat : z -> nat **) - - let abs_nat = function - | Z0 -> O - | Zpos p -> Coq_Pos.to_nat p - | Zneg p -> Coq_Pos.to_nat p - - (** val abs_N : z -> n **) - - let abs_N = function - | Z0 -> N0 - | Zpos p -> Npos p - | Zneg p -> Npos p - - (** val to_nat : z -> nat **) - - let to_nat = function - | Zpos p -> Coq_Pos.to_nat p - | _ -> O - + (** val to_N : z -> n **) - + let to_N = function | Zpos p -> Npos p | _ -> N0 - - (** val of_nat : nat -> z **) - - let of_nat = function - | O -> Z0 - | S n1 -> Zpos (Coq_Pos.of_succ_nat n1) - - (** val of_N : n -> z **) - - let of_N = function - | N0 -> Z0 - | Npos p -> Zpos p - - (** val iter : z -> ('a1 -> 'a1) -> 'a1 -> 'a1 **) - - let iter n0 f x = - match n0 with - | Zpos p -> Coq_Pos.iter p f x - | _ -> x - + (** val pos_div_eucl : positive -> z -> z * z **) - + let rec pos_div_eucl a b = match a with | XI a' -> let q0,r = pos_div_eucl a' b in let r' = add (mul (Zpos (XO XH)) r) (Zpos XH) in - if gtb b r' + if ltb r' b then (mul (Zpos (XO XH)) q0),r' else (add (mul (Zpos (XO XH)) q0) (Zpos XH)),(sub r' b) | XO a' -> let q0,r = pos_div_eucl a' b in let r' = mul (Zpos (XO XH)) r in - if gtb b r' + if ltb r' b then (mul (Zpos (XO XH)) q0),r' else (add (mul (Zpos (XO XH)) q0) (Zpos XH)),(sub r' b) - | XH -> if geb b (Zpos (XO XH)) then Z0,(Zpos XH) else (Zpos XH),Z0 - + | XH -> if leb (Zpos (XO XH)) b then Z0,(Zpos XH) else (Zpos XH),Z0 + (** val div_eucl : z -> z -> z * z **) - + let div_eucl a b = match a with | Z0 -> Z0,Z0 | Zpos a' -> (match b with | Z0 -> Z0,Z0 - | Zpos p -> pos_div_eucl a' b + | Zpos _ -> pos_div_eucl a' b | Zneg b' -> let q0,r = pos_div_eucl a' (Zpos b') in (match r with @@ -2320,131 +478,20 @@ module Z = | Zneg a' -> (match b with | Z0 -> Z0,Z0 - | Zpos p -> + | Zpos _ -> let q0,r = pos_div_eucl a' b in (match r with | Z0 -> (opp q0),Z0 | _ -> (opp (add q0 (Zpos XH))),(sub b r)) | Zneg b' -> let q0,r = pos_div_eucl a' (Zpos b') in q0,(opp r)) - + (** val div : z -> z -> z **) - + let div a b = - let q0,x = div_eucl a b in q0 - - (** val modulo : z -> z -> z **) - - let modulo a b = - let x,r = div_eucl a b in r - - (** val quotrem : z -> z -> z * z **) - - let quotrem a b = - match a with - | Z0 -> Z0,Z0 - | Zpos a0 -> - (match b with - | Z0 -> Z0,a - | Zpos b0 -> - let q0,r = N.pos_div_eucl a0 (Npos b0) in (of_N q0),(of_N r) - | Zneg b0 -> - let q0,r = N.pos_div_eucl a0 (Npos b0) in (opp (of_N q0)),(of_N r)) - | Zneg a0 -> - (match b with - | Z0 -> Z0,a - | Zpos b0 -> - let q0,r = N.pos_div_eucl a0 (Npos b0) in - (opp (of_N q0)),(opp (of_N r)) - | Zneg b0 -> - let q0,r = N.pos_div_eucl a0 (Npos b0) in (of_N q0),(opp (of_N r))) - - (** val quot : z -> z -> z **) - - let quot a b = - fst (quotrem a b) - - (** val rem : z -> z -> z **) - - let rem a b = - snd (quotrem a b) - - (** val even : z -> bool **) - - let even = function - | Z0 -> true - | Zpos p -> - (match p with - | XO p2 -> true - | _ -> false) - | Zneg p -> - (match p with - | XO p2 -> true - | _ -> false) - - (** val odd : z -> bool **) - - let odd = function - | Z0 -> false - | Zpos p -> - (match p with - | XO p2 -> false - | _ -> true) - | Zneg p -> - (match p with - | XO p2 -> false - | _ -> true) - - (** val div2 : z -> z **) - - let div2 = function - | Z0 -> Z0 - | Zpos p -> - (match p with - | XH -> Z0 - | _ -> Zpos (Coq_Pos.div2 p)) - | Zneg p -> Zneg (Coq_Pos.div2_up p) - - (** val quot2 : z -> z **) - - let quot2 = function - | Z0 -> Z0 - | Zpos p -> - (match p with - | XH -> Z0 - | _ -> Zpos (Coq_Pos.div2 p)) - | Zneg p -> - (match p with - | XH -> Z0 - | _ -> Zneg (Coq_Pos.div2 p)) - - (** val log2 : z -> z **) - - let log2 = function - | Zpos p2 -> - (match p2 with - | XI p -> Zpos (Coq_Pos.size p) - | XO p -> Zpos (Coq_Pos.size p) - | XH -> Z0) - | _ -> Z0 - - (** val sqrtrem : z -> z * z **) - - let sqrtrem = function - | Zpos p -> - let s,m = Coq_Pos.sqrtrem p in - (match m with - | Coq_Pos.IsPos r -> (Zpos s),(Zpos r) - | _ -> (Zpos s),Z0) - | _ -> Z0,Z0 - - (** val sqrt : z -> z **) - - let sqrt = function - | Zpos p -> Zpos (Coq_Pos.sqrt p) - | _ -> Z0 - + let q0,_ = div_eucl a b in q0 + (** val gcd : z -> z -> z **) - + let gcd a b = match a with | Z0 -> abs b @@ -2458,316 +505,6 @@ module Z = | Z0 -> abs a | Zpos b0 -> Zpos (Coq_Pos.gcd a0 b0) | Zneg b0 -> Zpos (Coq_Pos.gcd a0 b0)) - - (** val ggcd : z -> z -> z * (z * z) **) - - let ggcd a b = - match a with - | Z0 -> (abs b),(Z0,(sgn b)) - | Zpos a0 -> - (match b with - | Z0 -> (abs a),((sgn a),Z0) - | Zpos b0 -> - let g,p = Coq_Pos.ggcd a0 b0 in - let aa,bb = p in (Zpos g),((Zpos aa),(Zpos bb)) - | Zneg b0 -> - let g,p = Coq_Pos.ggcd a0 b0 in - let aa,bb = p in (Zpos g),((Zpos aa),(Zneg bb))) - | Zneg a0 -> - (match b with - | Z0 -> (abs a),((sgn a),Z0) - | Zpos b0 -> - let g,p = Coq_Pos.ggcd a0 b0 in - let aa,bb = p in (Zpos g),((Zneg aa),(Zpos bb)) - | Zneg b0 -> - let g,p = Coq_Pos.ggcd a0 b0 in - let aa,bb = p in (Zpos g),((Zneg aa),(Zneg bb))) - - (** val testbit : z -> z -> bool **) - - let testbit a = function - | Z0 -> odd a - | Zpos p -> - (match a with - | Z0 -> false - | Zpos a0 -> Coq_Pos.testbit a0 (Npos p) - | Zneg a0 -> negb (N.testbit (Coq_Pos.pred_N a0) (Npos p))) - | Zneg p -> false - - (** val shiftl : z -> z -> z **) - - let shiftl a = function - | Z0 -> a - | Zpos p -> Coq_Pos.iter p (mul (Zpos (XO XH))) a - | Zneg p -> Coq_Pos.iter p div2 a - - (** val shiftr : z -> z -> z **) - - let shiftr a n0 = - shiftl a (opp n0) - - (** val coq_lor : z -> z -> z **) - - let coq_lor a b = - match a with - | Z0 -> b - | Zpos a0 -> - (match b with - | Z0 -> a - | Zpos b0 -> Zpos (Coq_Pos.coq_lor a0 b0) - | Zneg b0 -> Zneg (N.succ_pos (N.ldiff (Coq_Pos.pred_N b0) (Npos a0)))) - | Zneg a0 -> - (match b with - | Z0 -> a - | Zpos b0 -> Zneg (N.succ_pos (N.ldiff (Coq_Pos.pred_N a0) (Npos b0))) - | Zneg b0 -> - Zneg - (N.succ_pos (N.coq_land (Coq_Pos.pred_N a0) (Coq_Pos.pred_N b0)))) - - (** val coq_land : z -> z -> z **) - - let coq_land a b = - match a with - | Z0 -> Z0 - | Zpos a0 -> - (match b with - | Z0 -> Z0 - | Zpos b0 -> of_N (Coq_Pos.coq_land a0 b0) - | Zneg b0 -> of_N (N.ldiff (Npos a0) (Coq_Pos.pred_N b0))) - | Zneg a0 -> - (match b with - | Z0 -> Z0 - | Zpos b0 -> of_N (N.ldiff (Npos b0) (Coq_Pos.pred_N a0)) - | Zneg b0 -> - Zneg - (N.succ_pos (N.coq_lor (Coq_Pos.pred_N a0) (Coq_Pos.pred_N b0)))) - - (** val ldiff : z -> z -> z **) - - let ldiff a b = - match a with - | Z0 -> Z0 - | Zpos a0 -> - (match b with - | Z0 -> a - | Zpos b0 -> of_N (Coq_Pos.ldiff a0 b0) - | Zneg b0 -> of_N (N.coq_land (Npos a0) (Coq_Pos.pred_N b0))) - | Zneg a0 -> - (match b with - | Z0 -> a - | Zpos b0 -> - Zneg (N.succ_pos (N.coq_lor (Coq_Pos.pred_N a0) (Npos b0))) - | Zneg b0 -> of_N (N.ldiff (Coq_Pos.pred_N b0) (Coq_Pos.pred_N a0))) - - (** val coq_lxor : z -> z -> z **) - - let coq_lxor a b = - match a with - | Z0 -> b - | Zpos a0 -> - (match b with - | Z0 -> a - | Zpos b0 -> of_N (Coq_Pos.coq_lxor a0 b0) - | Zneg b0 -> - Zneg (N.succ_pos (N.coq_lxor (Npos a0) (Coq_Pos.pred_N b0)))) - | Zneg a0 -> - (match b with - | Z0 -> a - | Zpos b0 -> - Zneg (N.succ_pos (N.coq_lxor (Coq_Pos.pred_N a0) (Npos b0))) - | Zneg b0 -> of_N (N.coq_lxor (Coq_Pos.pred_N a0) (Coq_Pos.pred_N b0))) - - (** val eq_dec : z -> z -> bool **) - - let eq_dec x y = - match x with - | Z0 -> - (match y with - | Z0 -> true - | _ -> false) - | Zpos x0 -> - (match y with - | Zpos p2 -> Coq_Pos.eq_dec x0 p2 - | _ -> false) - | Zneg x0 -> - (match y with - | Zneg p2 -> Coq_Pos.eq_dec x0 p2 - | _ -> false) - - module BootStrap = - struct - - end - - module OrderElts = - struct - type t = z - end - - module OrderTac = MakeOrderTac(OrderElts) - - (** val sqrt_up : z -> z **) - - let sqrt_up a = - match compare Z0 a with - | Lt -> succ (sqrt (pred a)) - | _ -> Z0 - - (** val log2_up : z -> z **) - - let log2_up a = - match compare (Zpos XH) a with - | Lt -> succ (log2 (pred a)) - | _ -> Z0 - - module NZDivP = - struct - - end - - module Quot2Div = - struct - (** val div : z -> z -> z **) - - let div = - quot - - (** val modulo : z -> z -> z **) - - let modulo = - rem - end - - module NZQuot = - struct - - end - - (** val lcm : z -> z -> z **) - - let lcm a b = - abs (mul a (div b (gcd a b))) - - (** val b2z : bool -> z **) - - let b2z = function - | true -> Zpos XH - | false -> Z0 - - (** val setbit : z -> z -> z **) - - let setbit a n0 = - coq_lor a (shiftl (Zpos XH) n0) - - (** val clearbit : z -> z -> z **) - - let clearbit a n0 = - ldiff a (shiftl (Zpos XH) n0) - - (** val lnot : z -> z **) - - let lnot a = - pred (opp a) - - (** val ones : z -> z **) - - let ones n0 = - pred (shiftl (Zpos XH) n0) - - module T = - struct - - end - - module ORev = - struct - type t = z - end - - module MRev = - struct - (** val max : z -> z -> z **) - - let max x y = - min y x - end - - module MPRev = MaxLogicalProperties(ORev)(MRev) - - module P = - struct - (** val max_case_strong : - z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) - -> 'a1 **) - - let max_case_strong n0 m compat hl hr = - let c = compSpec2Type n0 m (compare n0 m) in - (match c with - | CompGtT -> compat n0 (max n0 m) __ (hl __) - | _ -> compat m (max n0 m) __ (hr __)) - - (** val max_case : - z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) - - let max_case n0 m x x0 x1 = - max_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) - - (** val max_dec : z -> z -> bool **) - - let max_dec n0 m = - max_case n0 m (fun x y _ h0 -> h0) true false - - (** val min_case_strong : - z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) - -> 'a1 **) - - let min_case_strong n0 m compat hl hr = - let c = compSpec2Type n0 m (compare n0 m) in - (match c with - | CompGtT -> compat m (min n0 m) __ (hr __) - | _ -> compat n0 (min n0 m) __ (hl __)) - - (** val min_case : - z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) - - let min_case n0 m x x0 x1 = - min_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) - - (** val min_dec : z -> z -> bool **) - - let min_dec n0 m = - min_case n0 m (fun x y _ h0 -> h0) true false - end - - (** val max_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) - - let max_case_strong n0 m x x0 = - P.max_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 - - (** val max_case : z -> z -> 'a1 -> 'a1 -> 'a1 **) - - let max_case n0 m x x0 = - max_case_strong n0 m (fun _ -> x) (fun _ -> x0) - - (** val max_dec : z -> z -> bool **) - - let max_dec = - P.max_dec - - (** val min_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) - - let min_case_strong n0 m x x0 = - P.min_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 - - (** val min_case : z -> z -> 'a1 -> 'a1 -> 'a1 **) - - let min_case n0 m x x0 = - min_case_strong n0 m (fun _ -> x) (fun _ -> x0) - - (** val min_dec : z -> z -> bool **) - - let min_dec = - P.min_dec end (** val zeq_bool : z -> z -> bool **) @@ -2818,9 +555,9 @@ let rec peq ceqb p p' = (** val mkPinj : positive -> 'a1 pol -> 'a1 pol **) let mkPinj j p = match p with -| Pc c -> p +| Pc _ -> p | Pinj (j', q0) -> Pinj ((Coq_Pos.add j j'), q0) -| PX (p2, p3, p4) -> Pinj (j, p) +| PX (_, _, _) -> Pinj (j, p) (** val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol **) @@ -2831,12 +568,13 @@ let mkPinj_pred j p = | XH -> p (** val mkPX : - 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) + 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 + pol **) let mkPX cO ceqb p i q0 = match p with | Pc c -> if ceqb c cO then mkPinj XH q0 else PX (p, i, q0) - | Pinj (p2, p3) -> PX (p, i, q0) + | Pinj (_, _) -> PX (p, i, q0) | PX (p', i', q') -> if peq ceqb q' (p0 cO) then PX (p', (Coq_Pos.add i' i), q0) @@ -2893,8 +631,8 @@ let rec paddI cadd pop q0 j = function | 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 **) + ('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 -> mkPinj j (paddC cadd (popp copp q0) c) @@ -2911,11 +649,11 @@ let rec psubI cadd copp pop q0 j = function | 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 **) + '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) +| Pc _ -> PX (p', i', p) | Pinj (j, q') -> (match j with | XI j0 -> PX (p', i', (Pinj ((XO j0), q'))) @@ -2928,15 +666,16 @@ let rec paddX cO ceqb pop p' i' p = match p with | 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 **) + '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) +| Pc _ -> 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 ((Coq_Pos.pred_double j0), q'))) + | XO j0 -> + PX ((popp copp p'), i', (Pinj ((Coq_Pos.pred_double j0), q'))) | XH -> PX ((popp copp p'), i', q')) | PX (p2, i, q') -> (match Z.pos_sub i i' with @@ -2945,8 +684,8 @@ let rec psubX cO copp ceqb pop p' i' p = match p with | 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 **) + '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' @@ -2964,7 +703,8 @@ let rec padd cO cadd ceqb p = function | PX (p2, i, q0) -> (match Z.pos_sub i i' with | Z0 -> - mkPX cO ceqb (padd cO cadd ceqb p2 p'0) i (padd cO cadd ceqb q0 q') + 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') @@ -2973,8 +713,8 @@ let rec padd cO cadd ceqb p = function (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 **) + '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' @@ -2989,25 +729,27 @@ let rec psub cO cadd csub copp ceqb p = function (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 ((Coq_Pos.pred_double j0), q0)) - q')) - | XH -> PX ((popp copp p'0), i', (psub cO cadd csub copp ceqb q0 q'))) + (psub cO cadd csub copp ceqb (Pinj ((Coq_Pos.pred_double j0), + q0)) q')) + | XH -> + PX ((popp copp p'0), i', (psub cO cadd csub copp ceqb q0 q'))) | PX (p2, i, q0) -> (match Z.pos_sub 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') + 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 (psub cO cadd csub copp ceqb) 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 **) + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 + -> 'a1 pol **) let rec pmulC_aux cO cmul ceqb p c = match p with @@ -3018,8 +760,8 @@ let rec pmulC_aux cO cmul ceqb p c = (pmulC_aux cO cmul ceqb q0 c) (** val pmulC : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> - 'a1 -> 'a1 pol **) + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol + -> 'a1 -> 'a1 pol **) let pmulC cO cI cmul ceqb p c = if ceqb c cO @@ -3027,8 +769,8 @@ let pmulC cO cI cmul ceqb p c = else if ceqb c cI then p else 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 **) + '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 -> mkPinj j (pmulC cO cI cmul ceqb q0 c) @@ -3049,12 +791,13 @@ let rec pmulI cO cI cmul ceqb pmul0 q0 j = function 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 **) + '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 (pmul cO cI cadd cmul ceqb) q' j' p +| Pinj (j', q') -> + pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' j' p | PX (p', i', q') -> (match p with | Pc c -> pmulC cO cI cmul ceqb p'' c @@ -3063,22 +806,24 @@ let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with 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 ((Coq_Pos.pred_double j0), q0)) q' + pmul cO cI cadd cmul ceqb (Pinj ((Coq_Pos.pred_double j0), q0)) + q' | XH -> pmul cO cI cadd cmul ceqb q0 q' in mkPX cO ceqb (pmul cO cI cadd cmul ceqb p p') i' qQ' | PX (p2, i, q0) -> let qQ' = pmul cO cI cadd cmul ceqb q0 q' in - let pQ' = pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' XH p2 in + let pQ' = pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' XH p2 + in let qP' = pmul cO cI cadd cmul ceqb (mkPinj XH q0) p' in let pP' = pmul cO cI cadd cmul ceqb p2 p' in padd cO cadd ceqb - (mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb pP' i (p0 cO)) qP') i' - (p0 cO)) (mkPX cO ceqb pQ' i qQ')) + (mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb pP' i (p0 cO)) qP') + i' (p0 cO)) (mkPX cO ceqb pQ' i qQ')) (** val psquare : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> 'a1 pol -> 'a1 pol **) + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1 -> bool) -> 'a1 pol -> 'a1 pol **) let rec psquare cO cI cadd cmul ceqb = function | Pc c -> Pc (cmul c c) @@ -3107,9 +852,9 @@ 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 **) + '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 -> @@ -3123,16 +868,17 @@ let rec ppow_pos cO cI cadd cmul ceqb subst_l res p = function | 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 **) + '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 **) + '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 @@ -3153,7 +899,8 @@ let rec norm_aux cO cI cadd cmul csub copp ceqb = function 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) + 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) @@ -3185,9 +932,9 @@ let rec map_bformula fct = function | N f0 -> N (map_bformula fct f0) | I (f1, f2) -> I ((map_bformula fct f1), (map_bformula fct f2)) -type 'term' clause = 'term' list +type 'x clause = 'x list -type 'term' cnf = 'term' clause list +type 'x cnf = 'x clause list (** val tt : 'a1 cnf **) @@ -3200,52 +947,52 @@ let ff = []::[] (** val add_term : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1 - clause option **) + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> + 'a1 clause option **) -let rec add_term unsat deduce t1 = function +let rec add_term unsat deduce t0 = function | [] -> - (match deduce t1 t1 with - | Some u -> if unsat u then None else Some (t1::[]) - | None -> Some (t1::[])) + (match deduce t0 t0 with + | Some u -> if unsat u then None else Some (t0::[]) + | None -> Some (t0::[])) | t'::cl0 -> - (match deduce t1 t' with + (match deduce t0 t' with | Some u -> if unsat u then None - else (match add_term unsat deduce t1 cl0 with + else (match add_term unsat deduce t0 cl0 with | Some cl' -> Some (t'::cl') | None -> None) | None -> - (match add_term unsat deduce t1 cl0 with + (match add_term unsat deduce t0 cl0 with | Some cl' -> Some (t'::cl') | None -> None)) (** val or_clause : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause - -> 'a1 clause option **) + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 + clause -> 'a1 clause option **) let rec or_clause unsat deduce cl1 cl2 = match cl1 with | [] -> Some cl2 - | t1::cl -> - (match add_term unsat deduce t1 cl2 with + | t0::cl -> + (match add_term unsat deduce t0 cl2 with | Some cl' -> or_clause unsat deduce cl cl' | None -> None) (** val or_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> - 'a1 cnf **) + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf + -> 'a1 cnf **) -let or_clause_cnf unsat deduce t1 f = +let or_clause_cnf unsat deduce t0 f = fold_right (fun e acc -> - match or_clause unsat deduce t1 e with + match or_clause unsat deduce t0 e with | Some cl -> cl::acc | None -> acc) [] f (** val or_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1 - cnf **) + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> + 'a1 cnf **) let rec or_cnf unsat deduce f f' = match f with @@ -3259,8 +1006,8 @@ let and_cnf f1 f2 = app f1 f2 (** val xcnf : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 - -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **) + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> + ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **) let rec xcnf unsat deduce normalise0 negate0 pol0 = function | TT -> if pol0 then tt else ff @@ -3300,9 +1047,9 @@ let rec cnf_checker checker f l = | c::l0 -> if checker e c then cnf_checker checker f0 l0 else false) (** val tauto_checker : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 - -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list -> - bool **) + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> + ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 + list -> bool **) let tauto_checker unsat deduce normalise0 negate0 checker f w = cnf_checker checker (xcnf unsat deduce normalise0 negate0 true f) w @@ -3335,18 +1082,18 @@ let opMult o o' = | Equal -> Some Equal | NonEqual -> (match o' with - | Strict -> None - | NonStrict -> None - | x -> Some x) + | Equal -> Some Equal + | NonEqual -> Some NonEqual + | _ -> None) | Strict -> (match o' with | NonEqual -> None | _ -> Some o') | NonStrict -> (match o' with + | Equal -> Some Equal | NonEqual -> None - | Strict -> Some NonStrict - | x -> Some x) + | _ -> Some NonStrict) (** val opAdd : op1 -> op1 -> op1 option **) @@ -3394,8 +1141,8 @@ let map_option2 f o o' = | None -> None (** val pexpr_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option **) + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1 -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option **) let pexpr_times_nformula cO cI cplus ctimes ceqb e = function | ef,o -> @@ -3404,8 +1151,8 @@ let pexpr_times_nformula cO cI cplus ctimes ceqb e = function | _ -> None) (** val nformula_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option **) + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option **) let nformula_times_nformula cO cI cplus ctimes ceqb f1 f2 = let e1,o1 = f1 in @@ -3414,8 +1161,8 @@ let nformula_times_nformula cO cI cplus ctimes ceqb f1 f2 = (opMult o1 o2) (** val nformula_plus_nformula : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 - nFormula -> 'a1 nFormula option **) + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> + 'a1 nFormula -> 'a1 nFormula option **) let nformula_plus_nformula cO cplus ceqb f1 f2 = let e1,o1 = f1 in @@ -3423,9 +1170,9 @@ let nformula_plus_nformula cO cplus ceqb f1 f2 = map_option (fun x -> Some ((padd cO cplus ceqb e1 e2),x)) (opAdd o1 o2) (** val eval_Psatz : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 - nFormula option **) + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz + -> 'a1 nFormula option **) let rec eval_Psatz cO cI cplus ctimes ceqb cleb l = function | PsatzIn n0 -> Some (nth n0 l ((Pc cO),Equal)) @@ -3460,9 +1207,9 @@ let check_inconsistent cO ceqb cleb = function | _ -> false) (** val check_normalised_formulas : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> - bool **) + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz + -> bool **) let check_normalised_formulas cO cI cplus ctimes ceqb cleb l cm = match eval_Psatz cO cI cplus ctimes ceqb cleb l cm with @@ -3479,51 +1226,41 @@ type op2 = type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } -(** val flhs : 'a1 formula -> 'a1 pExpr **) - -let flhs x = x.flhs - -(** val fop : 'a1 formula -> op2 **) - -let fop x = x.fop - -(** val frhs : 'a1 formula -> 'a1 pExpr **) - -let frhs x = x.frhs - (** val norm : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **) + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> + 'a1 pol **) let norm cO cI cplus ctimes cminus copp ceqb = norm_aux cO cI cplus ctimes cminus copp ceqb (** val psub0 : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 - -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> + ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) let psub0 cO cplus cminus copp ceqb = psub cO cplus cminus copp ceqb (** val padd0 : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol - -> 'a1 pol **) + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 + pol -> 'a1 pol **) let padd0 cO cplus ceqb = padd cO cplus ceqb (** val xnormalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula list **) + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> + 'a1 nFormula list **) -let xnormalise cO cI cplus ctimes cminus copp ceqb t1 = - let { flhs = lhs; fop = o; frhs = rhs } = t1 in +let xnormalise cO cI cplus ctimes cminus copp ceqb t0 = + let { flhs = lhs; fop = o; frhs = rhs } = t0 in let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in (match o with | OpEq -> - ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO cplus + ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO + cplus cminus copp ceqb rhs0 lhs0),Strict)::[]) @@ -3534,26 +1271,27 @@ let xnormalise cO cI cplus ctimes cminus copp ceqb t1 = | OpGt -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),NonStrict)::[]) (** val cnf_normalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula cnf **) + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> + 'a1 nFormula cnf **) -let cnf_normalise cO cI cplus ctimes cminus copp ceqb t1 = - map (fun x -> x::[]) (xnormalise cO cI cplus ctimes cminus copp ceqb t1) +let cnf_normalise cO cI cplus ctimes cminus copp ceqb t0 = + map (fun x -> x::[]) (xnormalise cO cI cplus ctimes cminus copp ceqb t0) (** val xnegate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula list **) + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> + 'a1 nFormula list **) -let xnegate cO cI cplus ctimes cminus copp ceqb t1 = - let { flhs = lhs; fop = o; frhs = rhs } = t1 in +let xnegate cO cI cplus ctimes cminus copp ceqb t0 = + let { flhs = lhs; fop = o; frhs = rhs } = t0 in let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in (match o with | OpEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Equal)::[] | OpNEq -> - ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO cplus + ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO + cplus cminus copp ceqb rhs0 lhs0),Strict)::[]) @@ -3563,12 +1301,12 @@ let xnegate cO cI cplus ctimes cminus copp ceqb t1 = | OpGt -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::[]) (** val cnf_negate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula cnf **) + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> + 'a1 nFormula cnf **) -let cnf_negate cO cI cplus ctimes cminus copp ceqb t1 = - map (fun x -> x::[]) (xnegate cO cI cplus ctimes cminus copp ceqb t1) +let cnf_negate cO cI cplus ctimes cminus copp ceqb t0 = + map (fun x -> x::[]) (xnegate cO cI cplus ctimes cminus copp ceqb t0) (** val xdenorm : positive -> 'a1 pol -> 'a1 pExpr **) @@ -3602,14 +1340,14 @@ let map_Formula c_of_S f = { flhs = (map_PExpr c_of_S l); fop = o; frhs = (map_PExpr c_of_S r) } (** val simpl_cone : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz -> - 'a1 psatz **) + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz + -> 'a1 psatz **) let simpl_cone cO cI ctimes ceqb e = match e with -| PsatzSquare t1 -> - (match t1 with +| PsatzSquare t0 -> + (match t0 with | Pc c -> if ceqb cO c then PsatzZ else PsatzC (ctimes c c) - | _ -> PsatzSquare t1) + | _ -> PsatzSquare t0) | PsatzMulE (t1, t2) -> (match t1 with | PsatzMulE (x, x0) -> @@ -3641,7 +1379,8 @@ let simpl_cone cO cI ctimes ceqb e = match e with | PsatzC p2 -> PsatzMulE ((PsatzC (ctimes c p2)), x) | _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2))) | PsatzAdd (y, z0) -> - PsatzAdd ((PsatzMulE ((PsatzC c), y)), (PsatzMulE ((PsatzC c), z0))) + PsatzAdd ((PsatzMulE ((PsatzC c), y)), (PsatzMulE ((PsatzC c), + z0))) | PsatzC c0 -> PsatzC (ctimes c c0) | PsatzZ -> PsatzZ | _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2)) @@ -3683,7 +1422,8 @@ let qle_bool x y = (** val qplus : q -> q -> q **) let qplus x y = - { qnum = (Z.add (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden))); + { qnum = + (Z.add (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden))); qden = (Coq_Pos.mul x.qden y.qden) } (** val qmult : q -> q -> q **) @@ -3711,8 +1451,8 @@ let qinv x = (** val qpower_positive : q -> positive -> q **) -let qpower_positive q0 p = - pow_pos qmult q0 p +let qpower_positive = + pow_pos qmult (** val qpower : q -> z -> q **) @@ -3721,12 +1461,12 @@ let qpower q0 = function | Zpos p -> qpower_positive q0 p | Zneg p -> qinv (qpower_positive q0 p) -type 'a t0 = +type 'a t = | Empty | Leaf of 'a -| Node of 'a t0 * 'a * 'a t0 +| Node of 'a t * 'a * 'a t -(** val find : 'a1 -> 'a1 t0 -> positive -> 'a1 **) +(** val find : 'a1 -> 'a1 t -> positive -> 'a1 **) let rec find default vm p = match vm with @@ -3738,6 +1478,29 @@ let rec find default vm p = | XO p2 -> find default l p2 | XH -> e) +(** val singleton : 'a1 -> positive -> 'a1 -> 'a1 t **) + +let rec singleton default x v = + match x with + | XI p -> Node (Empty, default, (singleton default p v)) + | XO p -> Node ((singleton default p v), default, Empty) + | XH -> Leaf v + +(** val vm_add : 'a1 -> positive -> 'a1 -> 'a1 t -> 'a1 t **) + +let rec vm_add default x v = function +| Empty -> singleton default x v +| Leaf vl -> + (match x with + | XI p -> Node (Empty, vl, (singleton default p v)) + | XO p -> Node ((singleton default p v), vl, Empty) + | XH -> Leaf v) +| Node (l, o, r) -> + (match x with + | XI p -> Node (l, o, (vm_add default p v r)) + | XO p -> Node ((vm_add default p v l), o, r) + | XH -> Node (l, v, r)) + type zWitness = z psatz (** val zWeakChecker : z nFormula list -> z psatz -> bool **) @@ -3762,8 +1525,8 @@ let norm0 = (** val xnormalise0 : z formula -> z nFormula list **) -let xnormalise0 t1 = - let { flhs = lhs; fop = o; frhs = rhs } = t1 in +let xnormalise0 t0 = + let { flhs = lhs; fop = o; frhs = rhs } = t0 in let lhs0 = norm0 lhs in let rhs0 = norm0 rhs in (match o with @@ -3780,13 +1543,13 @@ let xnormalise0 t1 = (** val normalise : z formula -> z nFormula cnf **) -let normalise t1 = - map (fun x -> x::[]) (xnormalise0 t1) +let normalise t0 = + map (fun x -> x::[]) (xnormalise0 t0) (** val xnegate0 : z formula -> z nFormula list **) -let xnegate0 t1 = - let { flhs = lhs; fop = o; frhs = rhs } = t1 in +let xnegate0 t0 = + let { flhs = lhs; fop = o; frhs = rhs } = t0 in let lhs0 = norm0 lhs in let rhs0 = norm0 rhs in (match o with @@ -3803,8 +1566,8 @@ let xnegate0 t1 = (** val negate : z formula -> z nFormula cnf **) -let negate t1 = - map (fun x -> x::[]) (xnegate0 t1) +let negate t0 = + map (fun x -> x::[]) (xnegate0 t0) (** val zunsat : z nFormula -> bool **) @@ -3839,8 +1602,8 @@ let zgcdM x y = let rec zgcd_pol = function | Pc c -> Z0,c -| Pinj (p2, p3) -> zgcd_pol p3 -| PX (p2, p3, q0) -> +| Pinj (_, p2) -> zgcd_pol p2 +| PX (p2, _, q0) -> let g1,c1 = zgcd_pol p2 in let g2,c2 = zgcd_pol q0 in (zgcdM (zgcdM g1 c1) g2),c2 @@ -3872,7 +1635,8 @@ let genCuttingPlane = function then None else Some ((makeCuttingPlane e),Equal) | NonEqual -> Some ((e,Z0),op) - | Strict -> Some ((makeCuttingPlane (psubC Z.sub e (Zpos XH))),NonStrict) + | Strict -> + Some ((makeCuttingPlane (psubC Z.sub e (Zpos XH))),NonStrict) | NonStrict -> Some ((makeCuttingPlane e),NonStrict)) (** val nformula_of_cutting_plane : ((z polC * z) * op1) -> z nFormula **) @@ -3966,8 +1730,8 @@ let qnormalise = (** val qnegate : q formula -> q nFormula cnf **) let qnegate = - cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus - qmult qminus qopp qeq_bool + cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } + qplus qmult qminus qopp qeq_bool (** val qunsat : q nFormula -> bool **) @@ -4025,8 +1789,8 @@ let rnormalise = (** val rnegate : q formula -> q nFormula cnf **) let rnegate = - cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus - qmult qminus qopp qeq_bool + cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } + qplus qmult qminus qopp qeq_bool (** val runsat : q nFormula -> bool **) @@ -4043,4 +1807,3 @@ let rdeduce = let rTautoChecker f w = tauto_checker runsat rdeduce rnormalise rnegate rWeakChecker (map_bformula (map_Formula q_of_Rcst) f) w - diff --git a/plugins/micromega/micromega.mli b/plugins/micromega/micromega.mli index bcd61f39..beb042f4 100644 --- a/plugins/micromega/micromega.mli +++ b/plugins/micromega/micromega.mli @@ -1,15 +1,9 @@ -type __ = Obj.t - val negb : bool -> bool type nat = | O | S of nat -val fst : ('a1 * 'a2) -> 'a1 - -val snd : ('a1 * 'a2) -> 'a2 - val app : 'a1 list -> 'a1 list -> 'a1 list type comparison = @@ -19,24 +13,7 @@ type comparison = val compOpp : comparison -> comparison -type compareSpecT = -| CompEqT -| CompLtT -| CompGtT - -val compareSpec2Type : comparison -> compareSpecT - -type 'a compSpecT = compareSpecT - -val compSpec2Type : 'a1 -> 'a1 -> comparison -> 'a1 compSpecT - -type 'a sig0 = - 'a - (* singleton inductive, whose constructor was exist *) - -val plus : nat -> nat -> nat - -val nat_iter : nat -> ('a1 -> 'a1) -> 'a1 -> 'a1 +val add : nat -> nat -> nat type positive = | XI of positive @@ -52,560 +29,59 @@ type z = | Zpos of positive | Zneg of positive -module type TotalOrder' = - sig - type t - end - -module MakeOrderTac : - functor (O:TotalOrder') -> - sig - - end - -module MaxLogicalProperties : - functor (O:TotalOrder') -> - functor (M:sig - val max : O.t -> O.t -> O.t - end) -> - sig - module T : - sig - - end - end - -module Pos : - sig - type t = positive - - val succ : positive -> positive - - val add : positive -> positive -> positive - - val add_carry : positive -> positive -> positive - - val pred_double : positive -> positive - - val pred : positive -> positive - - val pred_N : positive -> n - +module Pos : + sig type mask = | IsNul | IsPos of positive | IsNeg - - val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 - - val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 - - val succ_double_mask : mask -> mask - - val double_mask : mask -> mask - - val double_pred_mask : positive -> mask - - val pred_mask : mask -> mask - - val sub_mask : positive -> positive -> mask - - val sub_mask_carry : positive -> positive -> mask - - val sub : positive -> positive -> positive - - val mul : positive -> positive -> positive - - val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 - - val pow : positive -> positive -> positive - - val div2 : positive -> positive - - val div2_up : positive -> positive - - val size_nat : positive -> nat - - val size : positive -> positive - - val compare_cont : positive -> positive -> comparison -> comparison - - val compare : positive -> positive -> comparison - - val min : positive -> positive -> positive - - val max : positive -> positive -> positive - - val eqb : positive -> positive -> bool - - val leb : positive -> positive -> bool - - val ltb : positive -> positive -> bool - - val sqrtrem_step : - (positive -> positive) -> (positive -> positive) -> (positive * mask) -> - positive * mask - - val sqrtrem : positive -> positive * mask - - val sqrt : positive -> positive - - val gcdn : nat -> positive -> positive -> positive - - val gcd : positive -> positive -> positive - - val ggcdn : nat -> positive -> positive -> positive * (positive * positive) - - val ggcd : positive -> positive -> positive * (positive * positive) - - val coq_Nsucc_double : n -> n - - val coq_Ndouble : n -> n - - val coq_lor : positive -> positive -> positive - - val coq_land : positive -> positive -> n - - val ldiff : positive -> positive -> n - - val coq_lxor : positive -> positive -> n - - val shiftl_nat : positive -> nat -> positive - - val shiftr_nat : positive -> nat -> positive - - val shiftl : positive -> n -> positive - - val shiftr : positive -> n -> positive - - val testbit_nat : positive -> nat -> bool - - val testbit : positive -> n -> bool - - val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 - - val to_nat : positive -> nat - - val of_nat : nat -> positive - - val of_succ_nat : nat -> positive end -module Coq_Pos : - sig - module Coq__1 : sig - type t = positive - end - type t = Coq__1.t - +module Coq_Pos : + sig val succ : positive -> positive - + val add : positive -> positive -> positive - + val add_carry : positive -> positive -> positive - + val pred_double : positive -> positive - - val pred : positive -> positive - - val pred_N : positive -> n - + type mask = Pos.mask = | IsNul | IsPos of positive | IsNeg - - val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 - - val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 - + val succ_double_mask : mask -> mask - + val double_mask : mask -> mask - + val double_pred_mask : positive -> mask - - val pred_mask : mask -> mask - + val sub_mask : positive -> positive -> mask - + val sub_mask_carry : positive -> positive -> mask - + val sub : positive -> positive -> positive - + val mul : positive -> positive -> positive - - val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 - - val pow : positive -> positive -> positive - - val div2 : positive -> positive - - val div2_up : positive -> positive - + val size_nat : positive -> nat - - val size : positive -> positive - - val compare_cont : positive -> positive -> comparison -> comparison - + + val compare_cont : comparison -> positive -> positive -> comparison + val compare : positive -> positive -> comparison - - val min : positive -> positive -> positive - - val max : positive -> positive -> positive - - val eqb : positive -> positive -> bool - - val leb : positive -> positive -> bool - - val ltb : positive -> positive -> bool - - val sqrtrem_step : - (positive -> positive) -> (positive -> positive) -> (positive * mask) -> - positive * mask - - val sqrtrem : positive -> positive * mask - - val sqrt : positive -> positive - + val gcdn : nat -> positive -> positive -> positive - + val gcd : positive -> positive -> positive - - val ggcdn : nat -> positive -> positive -> positive * (positive * positive) - - val ggcd : positive -> positive -> positive * (positive * positive) - - val coq_Nsucc_double : n -> n - - val coq_Ndouble : n -> n - - val coq_lor : positive -> positive -> positive - - val coq_land : positive -> positive -> n - - val ldiff : positive -> positive -> n - - val coq_lxor : positive -> positive -> n - - val shiftl_nat : positive -> nat -> positive - - val shiftr_nat : positive -> nat -> positive - - val shiftl : positive -> n -> positive - - val shiftr : positive -> n -> positive - - val testbit_nat : positive -> nat -> bool - - val testbit : positive -> n -> bool - - val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 - - val to_nat : positive -> nat - - val of_nat : nat -> positive - + val of_succ_nat : nat -> positive - - val eq_dec : positive -> positive -> bool - - val peano_rect : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 - - val peano_rec : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 - - type coq_PeanoView = - | PeanoOne - | PeanoSucc of positive * coq_PeanoView - - val coq_PeanoView_rect : - 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive -> - coq_PeanoView -> 'a1 - - val coq_PeanoView_rec : - 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive -> - coq_PeanoView -> 'a1 - - val peanoView_xO : positive -> coq_PeanoView -> coq_PeanoView - - val peanoView_xI : positive -> coq_PeanoView -> coq_PeanoView - - val peanoView : positive -> coq_PeanoView - - val coq_PeanoView_iter : - 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> coq_PeanoView -> 'a1 - - val switch_Eq : comparison -> comparison -> comparison - - val mask2cmp : mask -> comparison - - module T : - sig - - end - - module ORev : - sig - type t = Coq__1.t - end - - module MRev : - sig - val max : t -> t -> t - end - - module MPRev : - sig - module T : - sig - - end - end - - module P : - sig - val max_case_strong : - t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> - 'a1 - - val max_case : - t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 - - val max_dec : t -> t -> bool - - val min_case_strong : - t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> - 'a1 - - val min_case : - t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 - - val min_dec : t -> t -> bool - end - - val max_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 - - val max_case : t -> t -> 'a1 -> 'a1 -> 'a1 - - val max_dec : t -> t -> bool - - val min_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 - - val min_case : t -> t -> 'a1 -> 'a1 -> 'a1 - - val min_dec : t -> t -> bool end -module N : - sig - type t = n - - val zero : n - - val one : n - - val two : n - - val succ_double : n -> n - - val double : n -> n - - val succ : n -> n - - val pred : n -> n - - val succ_pos : n -> positive - - val add : n -> n -> n - - val sub : n -> n -> n - - val mul : n -> n -> n - - val compare : n -> n -> comparison - - val eqb : n -> n -> bool - - val leb : n -> n -> bool - - val ltb : n -> n -> bool - - val min : n -> n -> n - - val max : n -> n -> n - - val div2 : n -> n - - val even : n -> bool - - val odd : n -> bool - - val pow : n -> n -> n - - val log2 : n -> n - - val size : n -> n - - val size_nat : n -> nat - - val pos_div_eucl : positive -> n -> n * n - - val div_eucl : n -> n -> n * n - - val div : n -> n -> n - - val modulo : n -> n -> n - - val gcd : n -> n -> n - - val ggcd : n -> n -> n * (n * n) - - val sqrtrem : n -> n * n - - val sqrt : n -> n - - val coq_lor : n -> n -> n - - val coq_land : n -> n -> n - - val ldiff : n -> n -> n - - val coq_lxor : n -> n -> n - - val shiftl_nat : n -> nat -> n - - val shiftr_nat : n -> nat -> n - - val shiftl : n -> n -> n - - val shiftr : n -> n -> n - - val testbit_nat : n -> nat -> bool - - val testbit : n -> n -> bool - - val to_nat : n -> nat - +module N : + sig val of_nat : nat -> n - - val iter : n -> ('a1 -> 'a1) -> 'a1 -> 'a1 - - val eq_dec : n -> n -> bool - - val discr : n -> positive option - - val binary_rect : 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 - - val binary_rec : 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 - - val peano_rect : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 - - val peano_rec : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 - - module BootStrap : - sig - - end - - val recursion : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 - - module OrderElts : - sig - type t = n - end - - module OrderTac : - sig - - end - - module NZPowP : - sig - - end - - module NZSqrtP : - sig - - end - - val sqrt_up : n -> n - - val log2_up : n -> n - - module NZDivP : - sig - - end - - val lcm : n -> n -> n - - val b2n : bool -> n - - val setbit : n -> n -> n - - val clearbit : n -> n -> n - - val ones : n -> n - - val lnot : n -> n -> n - - module T : - sig - - end - - module ORev : - sig - type t = n - end - - module MRev : - sig - val max : n -> n -> n - end - - module MPRev : - sig - module T : - sig - - end - end - - module P : - sig - val max_case_strong : - n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> - 'a1 - - val max_case : - n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 - - val max_dec : n -> n -> bool - - val min_case_strong : - n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> - 'a1 - - val min_case : - n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 - - val min_dec : n -> n -> bool - end - - val max_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 - - val max_case : n -> n -> 'a1 -> 'a1 -> 'a1 - - val max_dec : n -> n -> bool - - val min_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 - - val min_case : n -> n -> 'a1 -> 'a1 -> 'a1 - - val min_dec : n -> n -> bool end val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 @@ -616,225 +92,45 @@ val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 -module Z : - sig - type t = z - - val zero : z - - val one : z - - val two : z - +module Z : + sig val double : z -> z - + val succ_double : z -> z - + val pred_double : z -> z - + val pos_sub : positive -> positive -> z - + val add : z -> z -> z - + val opp : z -> z - - val succ : z -> z - - val pred : z -> z - + val sub : z -> z -> z - + val mul : z -> z -> z - - val pow_pos : z -> positive -> z - - val pow : z -> z -> z - + val compare : z -> z -> comparison - - val sgn : z -> z - + val leb : z -> z -> bool - - val geb : z -> z -> bool - + val ltb : z -> z -> bool - + val gtb : z -> z -> bool - - val eqb : z -> z -> bool - + val max : z -> z -> z - - val min : z -> z -> z - + val abs : z -> z - - val abs_nat : z -> nat - - val abs_N : z -> n - - val to_nat : z -> nat - + val to_N : z -> n - - val of_nat : nat -> z - - val of_N : n -> z - - val iter : z -> ('a1 -> 'a1) -> 'a1 -> 'a1 - + val pos_div_eucl : positive -> z -> z * z - + val div_eucl : z -> z -> z * z - + val div : z -> z -> z - - val modulo : z -> z -> z - - val quotrem : z -> z -> z * z - - val quot : z -> z -> z - - val rem : z -> z -> z - - val even : z -> bool - - val odd : z -> bool - - val div2 : z -> z - - val quot2 : z -> z - - val log2 : z -> z - - val sqrtrem : z -> z * z - - val sqrt : z -> z - + val gcd : z -> z -> z - - val ggcd : z -> z -> z * (z * z) - - val testbit : z -> z -> bool - - val shiftl : z -> z -> z - - val shiftr : z -> z -> z - - val coq_lor : z -> z -> z - - val coq_land : z -> z -> z - - val ldiff : z -> z -> z - - val coq_lxor : z -> z -> z - - val eq_dec : z -> z -> bool - - module BootStrap : - sig - - end - - module OrderElts : - sig - type t = z - end - - module OrderTac : - sig - - end - - val sqrt_up : z -> z - - val log2_up : z -> z - - module NZDivP : - sig - - end - - module Quot2Div : - sig - val div : z -> z -> z - - val modulo : z -> z -> z - end - - module NZQuot : - sig - - end - - val lcm : z -> z -> z - - val b2z : bool -> z - - val setbit : z -> z -> z - - val clearbit : z -> z -> z - - val lnot : z -> z - - val ones : z -> z - - module T : - sig - - end - - module ORev : - sig - type t = z - end - - module MRev : - sig - val max : z -> z -> z - end - - module MPRev : - sig - module T : - sig - - end - end - - module P : - sig - val max_case_strong : - z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> - 'a1 - - val max_case : - z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 - - val max_dec : z -> z -> bool - - val min_case_strong : - z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> - 'a1 - - val min_case : - z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 - - val min_dec : z -> z -> bool - end - - val max_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 - - val max_case : z -> z -> 'a1 -> 'a1 -> 'a1 - - val max_dec : z -> z -> bool - - val min_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 - - val min_case : z -> z -> 'a1 -> 'a1 -> 'a1 - - val min_dec : z -> z -> bool end val zeq_bool : z -> z -> bool @@ -872,44 +168,44 @@ val paddI : 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 + ('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 + '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 + '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 + '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 + '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 + '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 + '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 + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol val psquare : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - bool) -> 'a1 pol -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> 'a1 pol -> 'a1 pol type 'c pExpr = | PEc of 'c @@ -923,16 +219,17 @@ type 'c pExpr = 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 + '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 + '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 + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol type 'a bFormula = | TT @@ -946,9 +243,9 @@ type 'a bFormula = val map_bformula : ('a1 -> 'a2) -> 'a1 bFormula -> 'a2 bFormula -type 'term' clause = 'term' list +type 'x clause = 'x list -type 'term' cnf = 'term' clause list +type 'x cnf = 'x clause list val tt : 'a1 cnf @@ -959,12 +256,12 @@ val add_term : clause option val or_clause : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause -> - 'a1 clause option + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause + -> 'a1 clause option val or_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> 'a1 - cnf + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> + 'a1 cnf val or_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1 @@ -973,18 +270,20 @@ val or_cnf : val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf val xcnf : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 -> - 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('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 : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 -> - 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list -> bool + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 + -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list -> + bool val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool -val cltb : ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool +val cltb : + ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool type 'c polC = 'c pol @@ -1015,28 +314,30 @@ val map_option2 : ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option val pexpr_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option val nformula_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option val nformula_plus_nformula : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 - nFormula -> 'a1 nFormula option + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> + 'a1 nFormula -> 'a1 nFormula option val eval_Psatz : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 - nFormula option + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> + 'a1 nFormula option val check_inconsistent : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> + bool val check_normalised_formulas : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> + bool type op2 = | OpEq @@ -1048,43 +349,37 @@ type op2 = type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } -val flhs : 'a1 formula -> 'a1 pExpr - -val fop : 'a1 formula -> op2 - -val frhs : 'a1 formula -> 'a1 pExpr - val norm : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol val psub0 : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 - -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> + ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol val padd0 : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> - 'a1 pol + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol + -> 'a1 pol val xnormalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula - list + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 + nFormula list val cnf_normalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula - cnf + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 + nFormula cnf val xnegate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula - list + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 + nFormula list val cnf_negate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula - cnf + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 + nFormula cnf val xdenorm : positive -> 'a1 pol -> 'a1 pExpr @@ -1095,8 +390,8 @@ val map_PExpr : ('a2 -> 'a1) -> 'a2 pExpr -> 'a1 pExpr val map_Formula : ('a2 -> 'a1) -> 'a2 formula -> 'a1 formula val simpl_cone : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz -> - 'a1 psatz + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz + -> 'a1 psatz type q = { qnum : z; qden : positive } @@ -1122,12 +417,16 @@ val qpower_positive : q -> positive -> q val qpower : q -> z -> q -type 'a t0 = +type 'a t = | Empty | Leaf of 'a -| Node of 'a t0 * 'a * 'a t0 +| Node of 'a t * 'a * 'a t + +val find : 'a1 -> 'a1 t -> positive -> 'a1 -val find : 'a1 -> 'a1 t0 -> positive -> 'a1 +val singleton : 'a1 -> positive -> 'a1 -> 'a1 t + +val vm_add : 'a1 -> positive -> 'a1 -> 'a1 t -> 'a1 t type zWitness = z psatz @@ -1221,4 +520,3 @@ val runsat : q nFormula -> bool val rdeduce : q nFormula -> q nFormula -> q nFormula option val rTautoChecker : rcst formula bFormula -> rWitness list -> bool - diff --git a/plugins/micromega/micromega_plugin.mllib b/plugins/micromega/micromega_plugin.mllib deleted file mode 100644 index f53a9e37..00000000 --- a/plugins/micromega/micromega_plugin.mllib +++ /dev/null @@ -1,10 +0,0 @@ -Sos_types -Mutils -Micromega -Polynomial -Mfourier -Certificate -Persistent_cache -Coq_micromega -G_micromega -Micromega_plugin_mod diff --git a/plugins/micromega/micromega_plugin.mlpack b/plugins/micromega/micromega_plugin.mlpack new file mode 100644 index 00000000..ed253da3 --- /dev/null +++ b/plugins/micromega/micromega_plugin.mlpack @@ -0,0 +1,9 @@ +Sos_types +Mutils +Micromega +Polynomial +Mfourier +Certificate +Persistent_cache +Coq_micromega +G_micromega diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index 2dd443f0..b4c6d032 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -66,6 +66,15 @@ let all_sym_pairs f l = | e::l -> xpairs (pair_with acc e l) l in xpairs [] l +let all_pairs f l = + let pair_with acc e l = List.fold_left (fun acc x -> (f e x) ::acc) acc l in + + let rec xpairs acc l = + match l with + | [] -> acc + | e::lx -> xpairs (pair_with acc e l) lx in + xpairs [] l + let rec map3 f l1 l2 l3 = @@ -285,18 +294,6 @@ struct 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 Int.equal n 1 then [] - else (Int.equal (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 diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index 6a03e2d6..0e6d346a 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -92,7 +92,7 @@ let read_key_elem inch = Some (Marshal.from_channel inch) with | End_of_file -> None - | e when Errors.noncritical e -> raise InvalidTableFormat + | e when CErrors.noncritical e -> raise InvalidTableFormat (** We used to only lock/unlock regions. @@ -212,9 +212,11 @@ let find t k = res let memo cache f = - let tbl = lazy (open_in cache) in - fun x -> - let tbl = Lazy.force tbl in + let tbl = lazy (try Some (open_in cache) with _ -> None) in + fun x -> + match Lazy.force tbl with + | None -> f x + | Some tbl -> try find tbl x with diff --git a/plugins/micromega/vo.itarget b/plugins/micromega/vo.itarget index bf6a1a7d..c9009ea4 100644 --- a/plugins/micromega/vo.itarget +++ b/plugins/micromega/vo.itarget @@ -10,4 +10,6 @@ Tauto.vo VarMap.vo ZCoeff.vo ZMicromega.vo -Lia.vo \ No newline at end of file +Lia.vo +Lqa.vo +Lra.vo -- cgit v1.2.3