diff options
Diffstat (limited to 'plugins')
54 files changed, 3803 insertions, 2225 deletions
diff --git a/plugins/btauto/Reflect.v b/plugins/btauto/Reflect.v index d82e8ae8ad..4cde08872f 100644 --- a/plugins/btauto/Reflect.v +++ b/plugins/btauto/Reflect.v @@ -396,3 +396,16 @@ lazymatch goal with end | _ => fail "Cannot recognize a boolean equality" end. *) + +Register formula_var as plugins.btauto.f_var. +Register formula_btm as plugins.btauto.f_btm. +Register formula_top as plugins.btauto.f_top. +Register formula_cnj as plugins.btauto.f_cnj. +Register formula_dsj as plugins.btauto.f_dsj. +Register formula_neg as plugins.btauto.f_neg. +Register formula_xor as plugins.btauto.f_xor. +Register formula_ifb as plugins.btauto.f_ifb. + +Register formula_eval as plugins.btauto.eval. +Register boolean_witness as plugins.btauto.witness. +Register reduce_poly_of_formula_sound_alt as plugins.btauto.soundness. diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index b0f97c59b8..ac0a875229 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -12,17 +12,7 @@ open Constr let contrib_name = "btauto" -let init_constant dir s = - let find_constant contrib dir s = - UnivGen.constr_of_global (Coqlib.find_reference contrib dir s) - in - find_constant contrib_name dir s - -let get_constant dir s = lazy (UnivGen.constr_of_global @@ Coqlib.coq_reference contrib_name dir s) - -let get_inductive dir s = - let glob_ref () = Coqlib.find_reference contrib_name ("Coq" :: dir) s in - Lazy.from_fun (fun () -> Globnames.destIndRef (glob_ref ())) +let bt_lib_constr n = lazy (UnivGen.constr_of_global @@ Coqlib.lib_ref n) let decomp_term sigma (c : Constr.t) = Constr.kind (EConstr.Unsafe.to_constr (Termops.strip_outer_cast sigma (EConstr.of_constr c))) @@ -31,11 +21,11 @@ let lapp c v = Constr.mkApp (Lazy.force c, v) let (===) = Constr.equal + module CoqList = struct - let path = ["Init"; "Datatypes"] - let typ = get_constant path "list" - let _nil = get_constant path "nil" - let _cons = get_constant path "cons" + let typ = bt_lib_constr "core.list.type" + let _nil = bt_lib_constr "core.list.nil" + let _cons = bt_lib_constr "core.list.cons" let cons ty h t = lapp _cons [|ty; h ; t|] let nil ty = lapp _nil [|ty|] @@ -47,11 +37,10 @@ module CoqList = struct end module CoqPositive = struct - let path = ["Numbers"; "BinNums"] - let typ = get_constant path "positive" - let _xH = get_constant path "xH" - let _xO = get_constant path "xO" - let _xI = get_constant path "xI" + let typ = bt_lib_constr "num.pos.type" + let _xH = bt_lib_constr "num.pos.xH" + let _xO = bt_lib_constr "num.pos.xO" + let _xI = bt_lib_constr "num.pos.xI" (* A coq nat from an int *) let rec of_int n = @@ -91,14 +80,14 @@ end module Bool = struct - let typ = get_constant ["Init"; "Datatypes"] "bool" - let ind = get_inductive ["Init"; "Datatypes"] "bool" - let trueb = get_constant ["Init"; "Datatypes"] "true" - let falseb = get_constant ["Init"; "Datatypes"] "false" - let andb = get_constant ["Init"; "Datatypes"] "andb" - let orb = get_constant ["Init"; "Datatypes"] "orb" - let xorb = get_constant ["Init"; "Datatypes"] "xorb" - let negb = get_constant ["Init"; "Datatypes"] "negb" + let ind = lazy (Globnames.destIndRef (Coqlib.lib_ref "core.bool.type")) + let typ = bt_lib_constr "core.bool.type" + let trueb = bt_lib_constr "core.bool.true" + let falseb = bt_lib_constr "core.bool.false" + let andb = bt_lib_constr "core.bool.andb" + let orb = bt_lib_constr "core.bool.orb" + let xorb = bt_lib_constr "core.bool.xorb" + let negb = bt_lib_constr "core.bool.negb" type t = | Var of int @@ -150,21 +139,20 @@ module Btauto = struct open Pp - let eq = get_constant ["Init"; "Logic"] "eq" - - let f_var = get_constant ["btauto"; "Reflect"] "formula_var" - let f_btm = get_constant ["btauto"; "Reflect"] "formula_btm" - let f_top = get_constant ["btauto"; "Reflect"] "formula_top" - let f_cnj = get_constant ["btauto"; "Reflect"] "formula_cnj" - let f_dsj = get_constant ["btauto"; "Reflect"] "formula_dsj" - let f_neg = get_constant ["btauto"; "Reflect"] "formula_neg" - let f_xor = get_constant ["btauto"; "Reflect"] "formula_xor" - let f_ifb = get_constant ["btauto"; "Reflect"] "formula_ifb" + let eq = bt_lib_constr "core.eq.type" - let eval = get_constant ["btauto"; "Reflect"] "formula_eval" - let witness = get_constant ["btauto"; "Reflect"] "boolean_witness" + let f_var = bt_lib_constr "plugins.btauto.f_var" + let f_btm = bt_lib_constr "plugins.btauto.f_btm" + let f_top = bt_lib_constr "plugins.btauto.f_top" + let f_cnj = bt_lib_constr "plugins.btauto.f_cnj" + let f_dsj = bt_lib_constr "plugins.btauto.f_dsj" + let f_neg = bt_lib_constr "plugins.btauto.f_neg" + let f_xor = bt_lib_constr "plugins.btauto.f_xor" + let f_ifb = bt_lib_constr "plugins.btauto.f_ifb" - let soundness = get_constant ["btauto"; "Reflect"] "reduce_poly_of_formula_sound_alt" + let eval = bt_lib_constr "plugins.btauto.eval" + let witness = bt_lib_constr "plugins.btauto.witness" + let soundness = bt_lib_constr "plugins.btauto.soundness" let rec convert = function | Bool.Var n -> lapp f_var [|CoqPositive.of_int n|] diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 2eaa6146e1..055d36747d 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -28,17 +28,13 @@ open Proofview.Notations module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration -let reference dir s = lazy (Coqlib.coq_reference "CC" dir s) - -let _f_equal = reference ["Init";"Logic"] "f_equal" -let _eq_rect = reference ["Init";"Logic"] "eq_rect" -let _refl_equal = reference ["Init";"Logic"] "eq_refl" -let _sym_eq = reference ["Init";"Logic"] "eq_sym" -let _trans_eq = reference ["Init";"Logic"] "eq_trans" -let _eq = reference ["Init";"Logic"] "eq" -let _False = reference ["Init";"Logic"] "False" -let _True = reference ["Init";"Logic"] "True" -let _I = reference ["Init";"Logic"] "I" +let _f_equal = lazy (Coqlib.lib_ref "core.eq.congr") +let _eq_rect = lazy (Coqlib.lib_ref "core.eq.rect") +let _refl_equal = lazy (Coqlib.lib_ref "core.eq.refl") +let _sym_eq = lazy (Coqlib.lib_ref "core.eq.sym") +let _trans_eq = lazy (Coqlib.lib_ref "core.eq.trans") +let _eq = lazy (Coqlib.lib_ref "core.eq.type") +let _False = lazy (Coqlib.lib_ref "core.False.type") let whd env sigma t = Reductionops.clos_whd_flags CClosure.betaiotazeta env sigma t @@ -423,7 +419,7 @@ let build_term_to_complete uf pac = let cc_tactic depth additionnal_terms = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in - Coqlib.check_required_library Coqlib.logic_module_name; + Coqlib.(check_required_library logic_module_name); let _ = debug (fun () -> Pp.str "Reading subgoal ...") in let state = make_prb gl depth additionnal_terms in let _ = debug (fun () -> Pp.str "Problem built, solving ...") in diff --git a/plugins/derive/g_derive.ml4 b/plugins/derive/g_derive.mlg index a59324149c..18316bf2cd 100644 --- a/plugins/derive/g_derive.ml4 +++ b/plugins/derive/g_derive.mlg @@ -8,13 +8,21 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + open Stdarg +} + DECLARE PLUGIN "derive_plugin" +{ + let classify_derive_command _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]),VtLater) -VERNAC COMMAND EXTEND Derive CLASSIFIED BY classify_derive_command +} + +VERNAC COMMAND EXTEND Derive CLASSIFIED BY { classify_derive_command } | [ "Derive" ident(f) "SuchThat" constr(suchthat) "As" ident(lemma) ] -> - [ Derive.start_deriving f suchthat lemma ] + { Derive.start_deriving f suchthat lemma } END diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index 7e54bc8adb..fdeef5f0ac 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -109,11 +109,11 @@ let gen_ground_tac flag taco ids bases = (* special for compatibility with Intuition -let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str +let constant str = Coqlib.get_constr str let defined_connectives=lazy - [[],EvalConstRef (destConst (constant "not")); - [],EvalConstRef (destConst (constant "iff"))] + [[],EvalConstRef (destConst (constant "core.not.type")); + [],EvalConstRef (destConst (constant "core.iff.type"))] let normalize_evaluables= onAllHypsAndConcl diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index 3ae777cc9a..8fa676de44 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -234,11 +234,11 @@ let ll_forall_tac prod backtrack id continue seq= (* special for compatibility with old Intuition *) let constant str = UnivGen.constr_of_global - @@ Coqlib.coq_reference "User" ["Init";"Logic"] str + @@ Coqlib.lib_ref str -let defined_connectives=lazy - [AllOccurrences,EvalConstRef (fst (Constr.destConst (constant "not"))); - AllOccurrences,EvalConstRef (fst (Constr.destConst (constant "iff")))] +let defined_connectives = lazy + [AllOccurrences, EvalConstRef (fst (Constr.destConst (constant "core.not.type"))); + AllOccurrences, EvalConstRef (fst (Constr.destConst (constant "core.iff.type")))] let normalize_evaluables= Proofview.Goal.enter begin fun gl -> diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 5336948642..b12364d04a 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -414,9 +414,9 @@ let rewrite_until_var arg_num eq_ids : tactic = let rec_pte_id = Id.of_string "Hrec" let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = - let coq_False = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.build_coq_False ()) in - let coq_True = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.build_coq_True ()) in - let coq_I = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.build_coq_I ()) in + let coq_False = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.lib_ref "core.False.type") in + let coq_True = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.lib_ref "core.True.type") in + let coq_I = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.lib_ref "core.True.I") in let rec scan_type context type_of_hyp : tactic = if isLetIn sigma type_of_hyp then let real_type_of_hyp = it_mkProd_or_LetIn type_of_hyp context in @@ -1605,7 +1605,7 @@ let prove_principle_for_gen match !tcc_lemma_ref with | Undefined -> user_err Pp.(str "No tcc proof !!") | Value lemma -> EConstr.of_constr lemma - | Not_needed -> EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.build_coq_I ()) + | Not_needed -> EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.lib_ref "core.True.I") in (* let rec list_diff del_list check_list = *) (* match del_list with *) diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 0c45de4dc4..7c80b776a4 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -259,11 +259,8 @@ let mk_result ctxt value avoid = Some functions to deal with overlapping patterns **************************************************) -let coq_True_ref = - lazy (Coqlib.coq_reference "" ["Init";"Logic"] "True") - -let coq_False_ref = - lazy (Coqlib.coq_reference "" ["Init";"Logic"] "False") +let coq_True_ref = lazy (Coqlib.lib_ref "core.True.type") +let coq_False_ref = lazy (Coqlib.lib_ref "core.False.type") (* [make_discr_match_el \[e1,...en\]] builds match e1,...,en with @@ -957,7 +954,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = assert false end | GApp(eq_as_ref,[ty; id ;rt]) - when is_gvar id && is_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous + when is_gvar id && is_gr eq_as_ref Coqlib.(lib_ref "core.eq.type") && n == Anonymous -> let loc1 = rt.CAst.loc in let loc2 = eq_as_ref.CAst.loc in @@ -1078,7 +1075,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = else new_b, Id.Set.add id id_to_exclude *) | GApp(eq_as_ref,[ty;rt1;rt2]) - when is_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous + when is_gr eq_as_ref Coqlib.(lib_ref "core.eq.type") && n == Anonymous -> begin try @@ -1089,7 +1086,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = List.fold_left (fun acc (lhs,rhs) -> mkGProd(Anonymous, - mkGApp(mkGRef(Lazy.force Coqlib.coq_eq_ref),[mkGHole ();lhs;rhs]),acc) + mkGApp(mkGRef Coqlib.(lib_ref "core.eq.type"),[mkGHole ();lhs;rhs]),acc) ) b l diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index f81de82d5e..5b45a8dbed 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -38,11 +38,11 @@ let glob_decompose_app = (* [glob_make_eq t1 t2] build the glob_constr corresponding to [t2 = t1] *) let glob_make_eq ?(typ= mkGHole ()) t1 t2 = - mkGApp(mkGRef (Lazy.force Coqlib.coq_eq_ref),[typ;t2;t1]) + mkGApp(mkGRef (Coqlib.lib_ref "core.eq.type"),[typ;t2;t1]) (* [glob_make_neq t1 t2] build the glob_constr corresponding to [t1 <> t2] *) let glob_make_neq t1 t2 = - mkGApp(mkGRef (Lazy.force Coqlib.coq_not_ref),[glob_make_eq t1 t2]) + mkGApp(mkGRef (Coqlib.lib_ref "core.not.type"),[glob_make_eq t1 t2]) let remove_name_from_mapping mapping na = match na with diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 6ed382ca1c..03a64988e4 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -114,6 +114,7 @@ let def_of_const t = with Not_found -> assert false) |_ -> assert false +[@@@ocaml.warning "-3"] let coq_constant s = UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules "RecursiveDefinition" @@ -441,7 +442,7 @@ let jmeq () = Coqlib.check_required_library Coqlib.jmeq_module_name; EConstr.of_constr @@ UnivGen.constr_of_global @@ - Coqlib.coq_reference "Function" ["Logic";"JMeq"] "JMeq" + Coqlib.lib_ref "core.JMeq.type" with e when CErrors.noncritical e -> raise (ToShow e) let jmeq_refl () = @@ -449,7 +450,7 @@ let jmeq_refl () = Coqlib.check_required_library Coqlib.jmeq_module_name; EConstr.of_constr @@ UnivGen.constr_of_global @@ - Coqlib.coq_reference "Function" ["Logic";"JMeq"] "JMeq_refl" + Coqlib.lib_ref "core.JMeq.refl" with e when CErrors.noncritical e -> raise (ToShow e) let h_intros l = @@ -461,8 +462,10 @@ let well_founded = function () -> EConstr.of_constr (coq_constant "well_founded" let acc_rel = function () -> EConstr.of_constr (coq_constant "Acc") let acc_inv_id = function () -> EConstr.of_constr (coq_constant "Acc_inv") +[@@@ocaml.warning "-3"] let well_founded_ltof () = EConstr.of_constr @@ UnivGen.constr_of_global @@ - Coqlib.coq_reference "" ["Arith";"Wf_nat"] "well_founded_ltof" + Coqlib.find_reference "IndFun" ["Coq"; "Arith";"Wf_nat"] "well_founded_ltof" +[@@@ocaml.warning "+3"] let ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof") diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 56fe430077..b8973a18dc 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -81,10 +81,9 @@ let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl let make_eq () = try - EConstr.of_constr (UnivGen.constr_of_global (Coqlib.build_coq_eq ())) - with _ -> assert false + EConstr.of_constr (UnivGen.constr_of_global (Coqlib.lib_ref "core.eq.type")) + with _ -> assert false - (* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] (resp. g_to_f = false) where [graph] is the graph of [f] and is the [i]th function in the block. @@ -512,7 +511,7 @@ and intros_with_rewrite_aux : Tacmach.tactic = intros_with_rewrite ] g end - | Ind _ when EConstr.eq_constr sigma t (EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.build_coq_False ())) -> + | Ind _ when EConstr.eq_constr sigma t (EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.lib_ref "core.False.type")) -> Proofview.V82.of_tactic tauto g | Case(_,_,v,_) -> tclTHENLIST[ diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 633d98a585..89dfb58017 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -49,11 +49,12 @@ open Context.Rel.Declaration (* Ugly things which should not be here *) +[@@@ocaml.warning "-3"] let coq_constant m s = EConstr.of_constr @@ UnivGen.constr_of_global @@ - Coqlib.coq_reference "RecursiveDefinition" m s + Coqlib.find_reference "RecursiveDefinition" m s -let arith_Nat = ["Arith";"PeanoNat";"Nat"] -let arith_Lt = ["Arith";"Lt"] +let arith_Nat = ["Coq"; "Arith";"PeanoNat";"Nat"] +let arith_Lt = ["Coq"; "Arith";"Lt"] let pr_leconstr_rd = let sigma, env = Pfedit.get_current_context () in @@ -63,6 +64,7 @@ let coq_init_constant s = EConstr.of_constr ( UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules "RecursiveDefinition" Coqlib.init_modules s) +[@@@ocaml.warning "+3"] let find_reference sl s = let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in @@ -143,6 +145,7 @@ let def_id = Id.of_string "def" let p_id = Id.of_string "p" let rec_res_id = Id.of_string "rec_res";; let lt = function () -> (coq_init_constant "lt") +[@@@ocaml.warning "-3"] let le = function () -> (Coqlib.gen_reference_in_modules "RecursiveDefinition" Coqlib.init_modules "le") let ex = function () -> (coq_init_constant "ex") let nat = function () -> (coq_init_constant "nat") @@ -163,7 +166,6 @@ let coq_S = function () -> (coq_init_constant "S") let lt_n_O = function () -> (coq_constant arith_Nat "nlt_0_r") let max_ref = function () -> (find_reference ["Recdef"] "max") let max_constr = function () -> EConstr.of_constr (constr_of_global (delayed_force max_ref)) -let coq_conj = function () -> find_reference Coqlib.logic_module_name "conj" let f_S t = mkApp(delayed_force coq_S, [|t|]);; @@ -1241,8 +1243,8 @@ let get_current_subgoals_types () = exception EmptySubgoals let build_and_l sigma l = - let and_constr = UnivGen.constr_of_global @@ Coqlib.build_coq_and () in - let conj_constr = coq_conj () in + let and_constr = UnivGen.constr_of_global @@ Coqlib.lib_ref "core.and.type" in + let conj_constr = Coqlib.build_coq_conj () in let mk_and p1 p2 = mkApp(EConstr.of_constr and_constr,[|p1;p2|]) in let rec is_well_founded t = diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index ba3fa6fa0d..e5b032e638 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -693,12 +693,7 @@ let rewrite_except h = end -let refl_equal = - let coq_base_constant s = - Coqlib.gen_reference_in_modules "RecursiveDefinition" - (Coqlib.init_modules @ [["Coq";"Arith";"Le"];["Coq";"Arith";"Lt"]]) s in - function () -> (coq_base_constant "eq_refl") - +let refl_equal () = Coqlib.lib_ref "core.eq.type" (* This is simply an implementation of the case_eq tactic. this code should be replaced by a call to the tactic but I don't know how to diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 5b8bd6d01a..9dd98a4ab7 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -56,12 +56,14 @@ let init_setoid () = if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then () else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"] +let find_reference dir s = + Coqlib.find_reference "generalized rewriting" dir s +[@@warning "-3"] + let lazy_find_reference dir s = - let gr = lazy (Coqlib.coq_reference "generalized rewriting" dir s) in + let gr = lazy (find_reference dir s) in fun () -> Lazy.force gr -let find_reference dir s = Coqlib.coq_reference "generalized rewriting" dir s - type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *) let find_global dir s = @@ -74,13 +76,13 @@ let find_global dir s = (** Global constants. *) -let coq_eq_ref = lazy_find_reference ["Init"; "Logic"] "eq" -let coq_eq = find_global ["Init"; "Logic"] "eq" -let coq_f_equal = find_global ["Init"; "Logic"] "f_equal" -let coq_all = find_global ["Init"; "Logic"] "all" -let impl = find_global ["Program"; "Basics"] "impl" +let coq_eq_ref () = Coqlib.lib_ref "core.eq.type" +let coq_eq = find_global ["Coq"; "Init"; "Logic"] "eq" +let coq_f_equal = find_global ["Coq"; "Init"; "Logic"] "f_equal" +let coq_all = find_global ["Coq"; "Init"; "Logic"] "all" +let impl = find_global ["Coq"; "Program"; "Basics"] "impl" -(** Bookkeeping which evars are constraints so that we can +(** Bookkeeping which evars are constraints so that we can remove them at the end of the tactic. *) let goalevars evars = fst evars @@ -154,7 +156,7 @@ end) = struct let respectful = find_global morphisms "respectful" let respectful_ref = lazy_find_reference morphisms "respectful" - let default_relation = find_global ["Classes"; "SetoidTactics"] "DefaultRelation" + let default_relation = find_global ["Coq"; "Classes"; "SetoidTactics"] "DefaultRelation" let coq_forall = find_global morphisms "forall_def" @@ -374,12 +376,12 @@ let type_app_poly env env evd f args = module PropGlobal = struct module Consts = struct - let relation_classes = ["Classes"; "RelationClasses"] - let morphisms = ["Classes"; "Morphisms"] - let relation = ["Relations";"Relation_Definitions"], "relation" + let relation_classes = ["Coq"; "Classes"; "RelationClasses"] + let morphisms = ["Coq"; "Classes"; "Morphisms"] + let relation = ["Coq"; "Relations";"Relation_Definitions"], "relation" let app_poly = app_poly_nocheck - let arrow = find_global ["Program"; "Basics"] "arrow" - let coq_inverse = find_global ["Program"; "Basics"] "flip" + let arrow = find_global ["Coq"; "Program"; "Basics"] "arrow" + let coq_inverse = find_global ["Coq"; "Program"; "Basics"] "flip" end module G = GlobalBindings(Consts) @@ -395,12 +397,12 @@ end module TypeGlobal = struct module Consts = struct - let relation_classes = ["Classes"; "CRelationClasses"] - let morphisms = ["Classes"; "CMorphisms"] + let relation_classes = ["Coq"; "Classes"; "CRelationClasses"] + let morphisms = ["Coq"; "Classes"; "CMorphisms"] let relation = relation_classes, "crelation" let app_poly = app_poly_check - let arrow = find_global ["Classes"; "CRelationClasses"] "arrow" - let coq_inverse = find_global ["Classes"; "CRelationClasses"] "flip" + let arrow = find_global ["Coq"; "Classes"; "CRelationClasses"] "arrow" + let coq_inverse = find_global ["Coq"; "Classes"; "CRelationClasses"] "flip" end module G = GlobalBindings(Consts) @@ -740,9 +742,9 @@ let new_global (evars, cstrs) gr = (sigma, cstrs), c let make_eq sigma = - new_global sigma (Coqlib.build_coq_eq ()) + new_global sigma Coqlib.(lib_ref "core.eq.type") let make_eq_refl sigma = - new_global sigma (Coqlib.build_coq_eq_refl ()) + new_global sigma Coqlib.(lib_ref "core.eq.refl") let get_rew_prf evars r = match r.rew_prf with | RewPrf (rel, prf) -> evars, (rel, prf) diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 636cb8ebf8..a77a9c2f45 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -187,7 +187,7 @@ let add_tactic_entry (kn, ml, tg) state = | TacTerm s -> GramTerminal s | TacNonTerm (loc, (s, ido)) -> let EntryName (typ, e) = prod_item_of_symbol tg.tacgram_level s in - GramNonTerminal (Loc.tag ?loc @@ (Option.map (fun _ -> typ) ido, e)) + GramNonTerminal (Loc.tag ?loc @@ (typ, e)) in let prods = List.map map tg.tacgram_prods in let rules = make_rule mkact prods in @@ -556,18 +556,14 @@ let () = ] in register_grammars_by_name "tactic" entries -let get_identifier id = +let get_identifier i = (** Workaround for badly-designed generic arguments lacking a closure *) - Names.Id.of_string_soft ("$" ^ id) - + Names.Id.of_string_soft (Printf.sprintf "$%i" i) type _ ty_sig = | TyNil : (Geninterp.interp_sign -> unit Proofview.tactic) ty_sig | TyIdent : string * 'r ty_sig -> 'r ty_sig -| TyArg : - ('a, 'b, 'c) Extend.ty_user_symbol * string * 'r ty_sig -> ('c -> 'r) ty_sig -| TyAnonArg : - ('a, 'b, 'c) Extend.ty_user_symbol * 'r ty_sig -> 'r ty_sig +| TyArg : ('a, 'b, 'c) Extend.ty_user_symbol * 'r ty_sig -> ('c -> 'r) ty_sig type ty_ml = TyML : 'r ty_sig * 'r -> ty_ml @@ -581,18 +577,16 @@ let rec untype_user_symbol : type a b c. (a,b,c) ty_user_symbol -> Genarg.ArgT.a | TUentry a -> Uentry (Genarg.ArgT.Any a) | TUentryl (a,i) -> Uentryl (Genarg.ArgT.Any a,i) -let rec clause_of_sign : type a. a ty_sig -> Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list = - fun sign -> match sign with +let rec clause_of_sign : type a. int -> a ty_sig -> Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list = + fun i sign -> match sign with | TyNil -> [] - | TyIdent (s, sig') -> TacTerm s :: clause_of_sign sig' - | TyArg (a, id, sig') -> - let id = get_identifier id in - TacNonTerm (None,(untype_user_symbol a,Some id)) :: clause_of_sign sig' - | TyAnonArg (a, sig') -> - TacNonTerm (None,(untype_user_symbol a,None)) :: clause_of_sign sig' + | TyIdent (s, sig') -> TacTerm s :: clause_of_sign i sig' + | TyArg (a, sig') -> + let id = Some (get_identifier i) in + TacNonTerm (None, (untype_user_symbol a, id)) :: clause_of_sign (i + 1) sig' let clause_of_ty_ml = function - | TyML (t,_) -> clause_of_sign t + | TyML (t,_) -> clause_of_sign 1 t let rec eval_sign : type a. a ty_sig -> a -> Geninterp.Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic = fun sign tac -> @@ -603,7 +597,7 @@ let rec eval_sign : type a. a ty_sig -> a -> Geninterp.Val.t list -> Geninterp.i | _ :: _ -> assert false end | TyIdent (s, sig') -> eval_sign sig' tac - | TyArg (a, _, sig') -> + | TyArg (a, sig') -> let f = eval_sign sig' in begin fun tac vals ist -> match vals with | [] -> assert false @@ -611,7 +605,6 @@ let rec eval_sign : type a. a ty_sig -> a -> Geninterp.Val.t list -> Geninterp.i let v' = Taccoerce.Value.cast (topwit (Egramml.proj_symbol a)) v in f (tac v') vals ist end tac - | TyAnonArg (a, sig') -> eval_sign sig' tac let eval : ty_ml -> Geninterp.Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic = function | TyML (t,tac) -> eval_sign t tac @@ -623,14 +616,12 @@ let is_constr_entry = function let rec only_constr : type a. a ty_sig -> bool = function | TyNil -> true | TyIdent(_,_) -> false -| TyArg (u, _, s) -> if is_constr_entry u then only_constr s else false -| TyAnonArg (u, s) -> if is_constr_entry u then only_constr s else false +| TyArg (u, s) -> if is_constr_entry u then only_constr s else false -let rec mk_sign_vars : type a. a ty_sig -> Name.t list = function +let rec mk_sign_vars : type a. int -> a ty_sig -> Name.t list = fun i tu -> match tu with | TyNil -> [] -| TyIdent (_,s) -> mk_sign_vars s -| TyArg (_, name, s) -> Name (get_identifier name) :: mk_sign_vars s -| TyAnonArg (_, s) -> Anonymous :: mk_sign_vars s +| TyIdent (_,s) -> mk_sign_vars i s +| TyArg (_, s) -> Name (get_identifier i) :: mk_sign_vars (i + 1) s let dummy_id = Id.of_string "_" @@ -661,12 +652,7 @@ let tactic_extend plugin_name tacname ~level ?deprecation sign = | [TyML (TyIdent (name, s),tac) as ml_tac] when only_constr s -> (** The extension is only made of a name followed by constr entries: we do not add any grammar nor printing rule and add it as a true Ltac definition. *) - (* - let patt = make_patt rem in - let vars = List.map make_var rem in - let vars = mlexpr_of_list (mlexpr_of_name mlexpr_of_ident) vars in - *) - let vars = mk_sign_vars s in + let vars = mk_sign_vars 1 s in let ml = { Tacexpr.mltac_name = ml_tactic_name; Tacexpr.mltac_index = 0 } in let tac = match s with | TyNil -> eval ml_tac diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli index 138a584e01..0b2b426018 100644 --- a/plugins/ltac/tacentries.mli +++ b/plugins/ltac/tacentries.mli @@ -73,10 +73,7 @@ val print_located_tactic : Libnames.qualid -> unit type _ ty_sig = | TyNil : (Geninterp.interp_sign -> unit Proofview.tactic) ty_sig | TyIdent : string * 'r ty_sig -> 'r ty_sig -| TyArg : - ('a, 'b, 'c) Extend.ty_user_symbol * string * 'r ty_sig -> ('c -> 'r) ty_sig -| TyAnonArg : - ('a, 'b, 'c) Extend.ty_user_symbol * 'r ty_sig -> 'r ty_sig +| TyArg : ('a, 'b, 'c) Extend.ty_user_symbol * 'r ty_sig -> ('c -> 'r) ty_sig type ty_ml = TyML : 'r ty_sig * 'r -> ty_ml diff --git a/plugins/micromega/Lia.v b/plugins/micromega/Lia.v index ae05cf5459..dd6319d5c4 100644 --- a/plugins/micromega/Lia.v +++ b/plugins/micromega/Lia.v @@ -32,7 +32,7 @@ Ltac zchange := Ltac zchecker_no_abstract := zchange ; vm_compute ; reflexivity. -Ltac zchecker_abstract := zchange ; vm_cast_no_check (eq_refl true). +Ltac zchecker_abstract := abstract (zchange ; vm_cast_no_check (eq_refl true)). Ltac zchecker := zchecker_no_abstract. diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v index 158ddb589b..5f01f981ef 100644 --- a/plugins/micromega/MExtraction.v +++ b/plugins/micromega/MExtraction.v @@ -53,12 +53,11 @@ Extract Constant Rinv => "fun x -> 1 / x". (** In order to avoid annoying build dependencies the actual extraction is only performed as a test in the test suite. *) -(* Extraction "plugins/micromega/micromega.ml" *) -(* Recursive Extraction *) -(* List.map simpl_cone (*map_cone indexes*) *) -(* denorm Qpower vm_add *) -(* n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. *) - +(*Extraction "micromega.ml" +(*Recursive Extraction*) List.map simpl_cone (*map_cone indexes*) + denorm Qpower vm_add + normZ normQ normQ n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. +*) (* Local Variables: *) (* coding: utf-8 *) (* End: *) diff --git a/plugins/micromega/QMicromega.v b/plugins/micromega/QMicromega.v index ddf4064a03..2880a05d8d 100644 --- a/plugins/micromega/QMicromega.v +++ b/plugins/micromega/QMicromega.v @@ -179,6 +179,8 @@ Definition qunsat := check_inconsistent 0 Qeq_bool Qle_bool. Definition qdeduce := nformula_plus_nformula 0 Qplus Qeq_bool. +Definition normQ := norm 0 1 Qplus Qmult Qminus Qopp Qeq_bool. +Declare Equivalent Keys normQ RingMicromega.norm. Definition QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness) : bool := diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v index 892858e63f..f341a04e03 100644 --- a/plugins/micromega/ZMicromega.v +++ b/plugins/micromega/ZMicromega.v @@ -162,8 +162,8 @@ Declare Equivalent Keys psub RingMicromega.psub. Definition padd := padd Z0 Z.add Zeq_bool. Declare Equivalent Keys padd RingMicromega.padd. -Definition norm := norm 0 1 Z.add Z.mul Z.sub Z.opp Zeq_bool. -Declare Equivalent Keys norm RingMicromega.norm. +Definition normZ := norm 0 1 Z.add Z.mul Z.sub Z.opp Zeq_bool. +Declare Equivalent Keys normZ RingMicromega.norm. Definition eval_pol := eval_pol Z.add Z.mul (fun x => x). Declare Equivalent Keys eval_pol RingMicromega.eval_pol. @@ -180,7 +180,7 @@ Proof. apply (eval_pol_add Zsor ZSORaddon). Qed. -Lemma eval_pol_norm : forall env e, eval_expr env e = eval_pol env (norm e) . +Lemma eval_pol_norm : forall env e, eval_expr env e = eval_pol env (normZ e) . Proof. intros. apply (eval_pol_norm Zsor ZSORaddon). @@ -188,8 +188,8 @@ Qed. Definition xnormalise (t:Formula Z) : list (NFormula Z) := let (lhs,o,rhs) := t in - let lhs := norm lhs in - let rhs := norm rhs in + let lhs := normZ lhs in + let rhs := normZ rhs in match o with | OpEq => ((psub lhs (padd rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil @@ -225,8 +225,8 @@ Qed. Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z) := let (lhs,o,rhs) := t in - let lhs := norm lhs in - let rhs := norm rhs in + let lhs := normZ lhs in + let rhs := normZ rhs in match o with | OpEq => (psub lhs rhs,Equal) :: nil | OpNEq => ((psub lhs (padd rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 3a9709b6ce..e6edd50878 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -28,109 +28,80 @@ module Mc = Micromega module Ml2C = Mutils.CamlToCoq module C2Ml = Mutils.CoqToCaml +let use_simplex = ref true + open Mutils type 'a number_spec = { - bigint_to_number : big_int -> 'a; - number_to_num : 'a -> num; - zero : 'a; - unit : 'a; - mult : 'a -> 'a -> 'a; - eqb : 'a -> 'a -> bool -} + bigint_to_number : big_int -> 'a; + number_to_num : 'a -> num; + zero : 'a; + unit : 'a; + mult : 'a -> 'a -> 'a; + eqb : 'a -> 'a -> bool + } let z_spec = { - bigint_to_number = Ml2C.bigint ; - number_to_num = (fun x -> Big_int (C2Ml.z_big_int x)); - zero = Mc.Z0; - unit = Mc.Zpos Mc.XH; - mult = Mc.Z.mul; - eqb = Mc.zeq_bool -} - + bigint_to_number = Ml2C.bigint ; + number_to_num = (fun x -> Big_int (C2Ml.z_big_int x)); + zero = Mc.Z0; + unit = Mc.Zpos Mc.XH; + mult = Mc.Z.mul; + eqb = Mc.zeq_bool + } + let q_spec = { - bigint_to_number = (fun x -> {Mc.qnum = Ml2C.bigint x; Mc.qden = Mc.XH}); - number_to_num = C2Ml.q_to_num; - zero = {Mc.qnum = Mc.Z0;Mc.qden = Mc.XH}; - unit = {Mc.qnum = (Mc.Zpos Mc.XH) ; Mc.qden = Mc.XH}; - mult = Mc.qmult; - eqb = Mc.qeq_bool -} + bigint_to_number = (fun x -> {Mc.qnum = Ml2C.bigint x; Mc.qden = Mc.XH}); + number_to_num = C2Ml.q_to_num; + zero = {Mc.qnum = Mc.Z0;Mc.qden = Mc.XH}; + unit = {Mc.qnum = (Mc.Zpos Mc.XH) ; Mc.qden = Mc.XH}; + mult = Mc.qmult; + eqb = Mc.qeq_bool + } let 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 + 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 let rec fixpoint f x = - let y' = f x in - if Pervasives.(=) y' x then y' - else fixpoint f y' + let y' = f x in + 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 + 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 let simplify_cone n_spec c = fixpoint (rec_simpl_cone n_spec) c -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 - - 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 - - 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 - - (rebuild_cone (List.sort Pervasives.compare (cone_list c [])) None) - (* The binding with Fourier might be a bit obsolete @@ -147,956 +118,921 @@ let factorise_linear_cone c = This is a linear problem: each monomial is considered as a variable. Hence, we can use fourier. - The variable c is at index 0 -*) - -open Mfourier + The variable c is at index 1 + *) (* fold_left followed by a rev ! *) -let constrain_monomial mn l = - let coeffs = List.fold_left (fun acc p -> (Poly.get mn p)::acc) [] l in - if Pervasives.(=) mn Monomial.const - then - { coeffs = Vect.from_list ((Big_int unit_big_int):: (List.rev coeffs)) ; +let constrain_variable v l = + let coeffs = List.fold_left (fun acc p -> (Vect.get v p.coeffs)::acc) [] l in + { coeffs = Vect.from_list ((Big_int zero_big_int):: (Big_int zero_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)) ; + + + +let constrain_constant l = + let coeffs = List.fold_left (fun acc p -> minus_num p.cst ::acc) [] l in + { coeffs = Vect.from_list ((Big_int zero_big_int):: (Big_int unit_big_int):: (List.rev coeffs)) ; op = Eq ; cst = Big_int zero_big_int } - let positivity l = - let rec xpositivity i l = - match l with - | [] -> [] - | (_,Mc.Equal)::l -> xpositivity (i+1) l - | (_,_)::l -> - {coeffs = Vect.update (i+1) (fun _ -> Int 1) Vect.null ; - op = Ge ; - cst = Int 0 } :: (xpositivity (i+1) l) - in - xpositivity 0 l + let rec xpositivity i l = + match l with + | [] -> [] + | c::l -> match c.op with + | Eq -> xpositivity (i+1) l + | _ -> + {coeffs = Vect.update (i+1) (fun _ -> Int 1) Vect.null ; + op = Ge ; + cst = Int 0 } :: (xpositivity (i+1) l) + in + xpositivity 1 l + + +let cstr_of_poly (p,o) = + let (c,l) = Vect.decomp_cst p in + {coeffs = l; op = o ; cst = minus_num c} + + + +let variables_of_cstr c = Vect.variables c.coeffs -module MonSet = Set.Make(Monomial) (* If the certificate includes at least one strict inequality, the obtained polynomial can also be 0 *) -let build_linear_system l = - - (* Gather the monomials: HINT add up of the polynomials ==> This does not work anymore *) - let l' = List.map fst l in - - let monomials = - List.fold_left (fun acc p -> - 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 *) - let strict = { - coeffs = Vect.from_list ((Big_int unit_big_int):: - (List.map (fun (x,y) -> - match y with Mc.Strict -> - Big_int unit_big_int - | _ -> Big_int zero_big_int) l)); - op = Ge ; cst = Big_int unit_big_int } in + +let build_dual_linear_system l = + + let variables = + List.fold_left (fun acc p -> ISet.union acc (variables_of_cstr p)) ISet.empty l in + (* For each monomial, compute a constraint *) + let s0 = + ISet.fold (fun mn res -> (constrain_variable mn l)::res) variables [] in + let c = constrain_constant l in + + (* I need at least something strictly positive *) + let strict = { + coeffs = Vect.from_list ((Big_int zero_big_int) :: (Big_int unit_big_int):: + (List.map (fun c -> if is_strict c then Big_int unit_big_int else 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) - -(* For Q, this is a pity that the certificate has been scaled - -- at a lower layer, certificates are using nums... *) -let make_certificate n_spec (cert,li) = - let bint_to_cst = n_spec.bigint_to_number in - match cert with - | [] -> 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 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 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 - - (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 ; *) - - 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 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)) + {coeffs = Vect.from_list ([Big_int zero_big_int ;Big_int unit_big_int]) ; + op = Ge ; + cst = Big_int zero_big_int}::(strict::(positivity l)@c::s0) + + +(** [direct_linear_prover l] does not handle strict inegalities *) +let fourier_linear_prover l = + match Mfourier.Fourier.find_point l with + | Inr prf -> + if debug then Printf.printf "AProof : %a\n" Mfourier.pp_proof prf ; + let cert = (*List.map (fun (x,n) -> x+1,n)*) (fst (List.hd (Mfourier.Proof.mk_proof l prf))) in + if debug then Printf.printf "CProof : %a" Vect.pp cert ; + (*Some (rats_to_ints (Vect.to_list cert))*) + Some (Vect.normalise cert) | Inl _ -> None - with Strict -> + + +let direct_linear_prover l = + if !use_simplex + then Simplex.find_unsat_certificate l + else fourier_linear_prover l + +let find_point l = + if !use_simplex + then Simplex.find_point l + else match Mfourier.Fourier.find_point l with + | Inr _ -> None + | Inl cert -> Some cert + +let optimise v l = + if !use_simplex + then Simplex.optimise v l + else Mfourier.Fourier.optimise v l + + + +let dual_raw_certificate l = + if debug + then begin + Printf.printf "dual_raw_certificate\n"; + List.iter (fun c -> Printf.fprintf stdout "%a\n" output_cstr c) l + end; + + let sys = build_dual_linear_system l in + + if debug then begin + Printf.printf "dual_system\n"; + List.iter (fun c -> Printf.fprintf stdout "%a\n" output_cstr c) sys + end; + + try + match find_point sys with + | None -> None + | Some cert -> + match Vect.choose cert with + | None -> failwith "dual_raw_certificate: empty_certificate" + | Some _ -> + (*Some (rats_to_ints (Vect.to_list (Vect.decr_var 2 (Vect.set 1 (Int 0) cert))))*) + Some (Vect.normalise (Vect.decr_var 2 (Vect.set 1 (Int 0) cert))) + (* should not use rats_to_ints *) + with x when CErrors.noncritical x -> + if debug + then (Printf.printf "dual raw certificate %s" (Printexc.to_string x); + flush stdout) ; + None + + + +let simple_linear_prover l = + try + direct_linear_prover l + with Strict -> (* Fourier elimination should handle > *) - dual_raw_certificate l + dual_raw_certificate l +open ProofFormat + + +let env_of_list l = + snd (List.fold_left (fun (i,m) p -> (i+1,IMap.add i p m)) (0,IMap.empty) 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) - +let linear_prover_cstr sys = + let (sysi,prfi) = List.split sys in -let linear_prover n_spec l = - let build_system n_spec l = - let li = List.combine l (CList.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' + + match simple_linear_prover sysi with + | None -> None + | Some cert -> Some (proof_of_farkas (env_of_list prfi) cert) + +let linear_prover_cstr = + if debug + then + fun sys -> + Printf.printf "<linear_prover"; flush stdout ; + let res = linear_prover_cstr sys in + Printf.printf ">"; flush stdout ; + res + else linear_prover_cstr -let linear_prover n_spec l = - try linear_prover n_spec l - 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 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 = List.mapi (fun i c -> (c,Mc.PsatzIn (Ml2C.nat i))) sys in +let develop_constraint z_spec (e,k) = + (dev_form z_spec e, + match k with + | Mc.NonStrict -> Ge + | Mc.Equal -> Eq + | Mc.Strict -> Gt + | _ -> assert false + ) + +(** A single constraint can be unsat for the following reasons: + - 0 >= c for c a negative constant + - 0 = c for c a non-zero constant + - e = c when the coeffs of e are all integers and c is rational + *) +open ProofFormat +type checksat = + | Tauto (* Tautology *) + | Unsat of prf_rule (* Unsatisfiable *) + | Cut of cstr * prf_rule (* Cutting plane *) + | Normalise of cstr * prf_rule (* Coefficients may be normalised i.e relatively prime *) - (* 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 +exception FoundProof of prf_rule + + +(** [check_sat] + - detects constraints that are not satisfiable; + - normalises constraints and generate cuts. + *) + +let check_int_sat (cstr,prf) = + let {coeffs=coeffs ; op=op ; cst=cst} = cstr in + match Vect.choose coeffs with + | None -> + if eval_op op (Int 0) cst then Tauto else Unsat prf + | _ -> + let gcdi = Vect.gcd 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 = Vect.div 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 = Vect.div gcd coeffs; + op = op ; cst = ceiling_num (cst // gcd) + } in Cut(cstr,CutPrf prf) + | Gt -> failwith "check_sat : Unexpected operator" + + +let apply_and_normalise check f psys = + List.fold_left (fun acc pc' -> + match f pc' with + | None -> pc'::acc + | Some pc' -> + match check pc' with + | Tauto -> acc + | Unsat prf -> raise (FoundProof prf) + | Cut(c,p) -> (c,p)::acc + | Normalise (c,p) -> (c,p)::acc + ) [] psys + + +let simplify f sys = + let (sys',b) = + List.fold_left (fun (sys',b) c -> + match f c with + | None -> (c::sys',b) + | Some c' -> + (c'::sys',true) + ) ([],false) sys in + if b then Some sys' else None + +let saturate f sys = + List.fold_left (fun sys' c -> match f c with + | None -> sys' + | Some c' -> c'::sys' + ) [] sys + +let is_substitution strict ((p,o),prf) = + let pred v = if strict then v =/ Int 1 || v =/ Int (-1) else true 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 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 + | Eq -> LinPoly.search_linear pred p + | _ -> None + + +let is_linear_for v pc = + LinPoly.is_linear (fst (fst pc)) || LinPoly.is_linear_for v (fst (fst pc)) + + + + +let non_linear_pivot sys pc v pc' = + if LinPoly.is_linear (fst (fst pc')) + then None (* There are other ways to deal with those *) + else WithProof.linear_pivot sys pc v pc' + + +let is_linear_substitution sys ((p,o),prf) = + let pred v = v =/ Int 1 || v =/ Int (-1) in + match o with + | Eq -> begin + match + List.filter (fun v -> List.for_all (is_linear_for v) sys) (LinPoly.search_all_linear pred p) + with + | [] -> None + | v::_ -> Some v (* make a choice *) + end + | _ -> None + + +let elim_simple_linear_equality sys0 = + + let elim sys = + let (oeq,sys') = extract (is_linear_substitution sys) sys in + match oeq with + | None -> None + | Some(v,pc) -> simplify (WithProof.linear_pivot sys0 pc v) sys' in + + iterate_until_stable elim sys0 + + +let saturate_linear_equality_non_linear sys0 = + let (l,_) = extract_all (is_substitution false) sys0 in + let rec elim l acc = + match l with + | [] -> acc + | (v,pc)::l' -> + let nc = saturate (non_linear_pivot sys0 pc v) (sys0@acc) in + elim l' (nc@acc) in + elim l [] + + + +let develop_constraints prfdepth n_spec sys = + LinPoly.MonT.clear (); + max_nb_cstr := compute_max_nb_cstr sys prfdepth ; + let sys = List.map (develop_constraint n_spec) sys in + List.mapi (fun i (p,o) -> ((LinPoly.linpol_of_pol p,o),Hyp i)) sys + +let square_of_var i = + let x = LinPoly.var i in + ((LinPoly.product x x,Ge),(Square x)) + +(** [nlinear_preprocess sys] augments the system [sys] by performing some limited non-linear reasoning. + For instance, it asserts that the x² ≥0 but also that if c₁ ≥ 0 ∈ sys and c₂ ≥ 0 ∈ sys then c₁ × c₂ ≥ 0. + The resulting system is linearised. + *) + +let nlinear_preprocess (sys:WithProof.t list) = + + let is_linear = List.for_all (fun ((p,_),_) -> LinPoly.is_linear p) sys in + + if is_linear then sys + else + let collect_square = + List.fold_left (fun acc ((p,_),_) -> MonMap.union (fun k e1 e2 -> Some e1) acc (LinPoly.collect_square p)) MonMap.empty sys in + let sys = MonMap.fold (fun s m acc -> + let s = LinPoly.of_monomial s in + let m = LinPoly.of_monomial m in + ((m, Ge), (Square s))::acc) collect_square sys in + + let collect_vars = List.fold_left (fun acc p -> ISet.union acc (LinPoly.variables (fst (fst p)))) ISet.empty sys in + + let sys = ISet.fold (fun i acc -> square_of_var i :: acc) collect_vars sys in + + let sys = sys @ (all_pairs WithProof.product sys) in - MonMap.fold (fun s m acc -> ((pol_of_mon m , Mc.NonStrict), Mc.PsatzSquare(norm0 (pol_of_mon s)))::acc) square [] in + if debug then begin + Printf.fprintf stdout "Preprocessed\n"; + List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys; + end ; + + List.map (WithProof.annot "P") sys + - let sys = sys @ square in +let nlinear_prover prfdepth sys = + let sys = develop_constraints prfdepth q_spec sys in + let sys1 = elim_simple_linear_equality sys in + let sys2 = saturate_linear_equality_non_linear sys1 in + let sys = nlinear_preprocess sys1@sys2 in + let sys = List.map (fun ((p,o),prf) -> (cstr_of_poly (p,o), prf)) sys in + let id = (List.fold_left + (fun acc (_,r) -> max acc (ProofFormat.pr_rule_max_id r)) 0 sys) in + let env = CList.interval 0 id in + match linear_prover_cstr sys with + | None -> None + | Some cert -> + Some (cmpl_prf_rule Mc.normQ CamlToCoq.q env cert) - (* 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 linear_prover_with_cert prfdepth sys = + let sys = develop_constraints prfdepth q_spec sys in + (* let sys = nlinear_preprocess sys in *) + let sys = List.map (fun (c,p) -> cstr_of_poly c,p) sys in + + match linear_prover_cstr sys with + | None -> None + | Some cert -> + Some (cmpl_prf_rule Mc.normQ CamlToCoq.q (List.mapi (fun i e -> i) sys) cert) (* The prover is (probably) incomplete -- 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 - 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), + 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" + | Sub _ -> failwith "scale term: not implemented" + | Mul(y,z) -> let s1,y1 = scale_term y and s2,y2 = scale_term z in + mult_big_int s1 s2 , Mul (y1, y2) + | Pow(t,n) -> let s,t = scale_term t in + power_big_int_positive_int s n , Pow(t,n) + | _ -> failwith "scale_term : not implemented" let scale_term t = - let (s,t') = scale_term t in - s,t' + let (s,t') = scale_term t in + s,t' let rec scale_certificate pos = match pos with - | Axiom_eq i -> unit_big_int , Axiom_eq i - | Axiom_le i -> unit_big_int , Axiom_le i - | Axiom_lt i -> unit_big_int , Axiom_lt i - | Monoid l -> unit_big_int , Monoid l - | Rational_eq n -> (denominator n) , Rational_eq (Big_int (numerator n)) - | Rational_le n -> (denominator n) , Rational_le (Big_int (numerator n)) - | Rational_lt n -> (denominator n) , Rational_lt (Big_int (numerator n)) - | Square t -> let s,t' = scale_term t in - mult_big_int s s , Square t' - | Eqmul (t, y) -> let s1,y1 = scale_term t and s2,y2 = scale_certificate y in - mult_big_int s1 s2 , Eqmul (y1,y2) - | Sum (y, z) -> let s1,y1 = scale_certificate y - and s2,y2 = scale_certificate z in - let g = gcd_big_int s1 s2 in - let s1' = div_big_int s1 g in - let s2' = div_big_int s2 g in - mult_big_int g (mult_big_int s1' s2'), - Sum (Product(Rational_le (Big_int s2'), y1), - Product (Rational_le (Big_int s1'), y2)) - | Product (y, z) -> - let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in - mult_big_int s1 s2 , Product (y1,y2) + | Axiom_eq i -> unit_big_int , Axiom_eq i + | Axiom_le i -> unit_big_int , Axiom_le i + | Axiom_lt i -> unit_big_int , Axiom_lt i + | Monoid l -> unit_big_int , Monoid l + | Rational_eq n -> (denominator n) , Rational_eq (Big_int (numerator n)) + | Rational_le n -> (denominator n) , Rational_le (Big_int (numerator n)) + | Rational_lt n -> (denominator n) , Rational_lt (Big_int (numerator n)) + | Square t -> let s,t' = scale_term t in + mult_big_int s s , Square t' + | Eqmul (t, y) -> let s1,y1 = scale_term t and s2,y2 = scale_certificate y in + mult_big_int s1 s2 , Eqmul (y1,y2) + | Sum (y, z) -> let s1,y1 = scale_certificate y + and s2,y2 = scale_certificate z in + let g = gcd_big_int s1 s2 in + let s1' = div_big_int s1 g in + let s2' = div_big_int s2 g in + mult_big_int g (mult_big_int s1' s2'), + Sum (Product(Rational_le (Big_int s2'), y1), + Product (Rational_le (Big_int s1'), y2)) + | Product (y, z) -> + let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in + mult_big_int s1 s2 , Product (y1,y2) open Micromega let rec term_to_q_expr = function - | Const n -> PEc (Ml2C.q n) - | Zero -> PEc ( Ml2C.q (Int 0)) - | Var s -> PEX (Ml2C.index - (int_of_string (String.sub s 1 (String.length s - 1)))) - | Mul(p1,p2) -> PEmul(term_to_q_expr p1, term_to_q_expr p2) - | Add(p1,p2) -> PEadd(term_to_q_expr p1, term_to_q_expr p2) - | Opp p -> PEopp (term_to_q_expr p) - | Pow(t,n) -> PEpow (term_to_q_expr t,Ml2C.n n) - | Sub(t1,t2) -> PEsub (term_to_q_expr t1, term_to_q_expr t2) - | _ -> failwith "term_to_q_expr: not implemented" + | 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) + 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_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) - | 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) + let rec _cert_of_pos = function + 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) + | 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) 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" + | 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 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_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)) - | 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) - | 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) + let s,pos = (scale_certificate pos) in + let rec _cert_of_pos = function + 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)) + | 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) + | 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) (** All constraints (initial or derived) have an index and have a justification i.e., proof. Given a constraint, all the coefficients are always integers. -*) + *) open Mutils -open Mfourier open Num open Big_int open Polynomial -module Env = -struct - - 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 +type prf_sys = (cstr * prf_rule) list -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 - - 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" - - -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) - - -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 - -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 - - -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 "==> %a" output_prf_rule 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 linear_prover = - if debug - then - fun sys -> - Printf.printf "<linear_prover"; flush stdout ; - let res = linear_prover sys in - Printf.printf ">"; flush stdout ; - res - else linear_prover - - - - -(** A single constraint can be unsat for the following reasons: - - 0 >= c for c a negative constant - - 0 = c for c a non-zero constant - - e = c when the coeffs of e are all integers and c is rational -*) - -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 *) - - -(** [check_sat] - - detects constraints that are not satisfiable; - - normalises constraints and generate cuts. -*) - -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) (** 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 }, - - 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 *) - -exception FoundProof of prf_rule + let xpivot cv1 cv2 = + ( + {coeffs = Vect.add (Vect.mul cv1 v1) (Vect.mul cv2 v2) ; + op = opAdd op1 op2 ; + cst = n1 */ cv1 +/ n2 */ cv2 }, + + AddPrf(mul_cst_proof cv1 p1,mul_cst_proof cv2 p2)) in + + match Vect.get v v1 , Vect.get v v2 with + | Int 0 , _ | _ , Int 0 -> None + | a , 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 *) + 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_int_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. [ext_gcd a b = (x,y,g)] iff [ax+by=g] 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 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 + if c1.op == Eq && c2.op == Eq + then Vect.exists2 (fun n1 n2 -> + Int.equal (compare_big_int (gcd_big_int (numerator n1) (numerator n2)) unit_big_int) 0) + 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 +let extract_coprime_equation 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 -let pivot_sys v pc psys = apply_and_normalise (pivot v pc) psys +let pivot_sys v pc psys = apply_and_normalise check_int_sat (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_cst_proof l1' p1) (mul_cst_proof 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 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 + Vect.find (fun v n -> if n =/ (Int 1) || n=/ (Int (-1)) then Some v else None) cstr.coeffs + 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_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 get v vect = - match Vect.get v vect with - | None -> Int 0 - | Some n -> n 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 - - Some (apply_and_normalise pivot_eq 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 rec rel_prime vect = + match Vect.choose vect with + | None -> None + | Some(x,v,vect) -> + let v = numerator v in + match Vect.find (fun x' v' -> + let v' = numerator v' in + if eq_big_int (gcd_big_int v v') unit_big_int + then Some(x',v') else None) vect with + | Some(x',v') -> Some ((x,v),(x', v')) + | None -> 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 pivot_eq (c',p') = + let {coeffs = coeffs ; op = op ; cst = cst} = c' in + let vx = Vect.get x coeffs in + let vx' = Vect.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((LinPoly.constant m),p),p')) in + + Some (apply_and_normalise check_int_sat pivot_eq sys) + let reduction_equations psys = - iterate_until_stable (app_funs - [reduce_unary ; reduce_coprime ; - reduce_var_change (*; reduce_pivot*)]) 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 *) +(** [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 - - (* 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 - (* x <= ub -> x > ub *) - 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 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 optimise vect sys with + | None -> acc + | Some i -> + if debug then Printf.printf "Found a new bound %a in %a" Vect.pp vect Itv.pp i; + 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 *) + direct_linear_prover ({coeffs = Vect.mul (Big_int ubd) e ; op = Ge ; cst = Big_int ubn} :: sys), + (* lb <= x -> lb > x *) + direct_linear_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 (Vect.to_list clb),(lb,e,ub), List.tl (Vect.to_list 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 + List.for_all (fun (c,p) -> Vect.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 -> if can_enum then enum_proof id sys else None - with FoundProof prf -> + let rec enum_proof (id:int) (sys:prf_sys) : ProofFormat.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 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 (env_of_list prf) (Vect.from_list prf1),e, + proof_of_farkas (env_of_list prf) (Vect.from_list 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) : ProofFormat.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_cstr 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 -> - (*Printf.printf "direct proof %a\n" output_proof prf ; *) - let env = List.mapi (fun i _ -> i) sys in - let prf = compile_proof env prf in - (*try + let id = 1 + (List.fold_left + (fun acc (_,r) -> max acc (ProofFormat.pr_rule_max_id r)) 0 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 env = CList.interval 0 (id - 1) in + if debug then begin + Printf.fprintf stdout "direct proof %a\n" output_proof prf; + flush stdout; + end; + 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 } - + *) Some prf + +let xlia_simplex env sys = + match Simplex.integer_solver sys with + | None -> None + | Some prf -> + (*let _ = ProofFormat.eval_proof (env_of_list env) prf in *) + + let id = 1 + (List.fold_left + (fun acc (_,r) -> max acc (ProofFormat.pr_rule_max_id r)) 0 sys) in + let env = CList.interval 0 (id - 1) in + Some (compile_proof env prf) + +let xlia env0 en red sys = + if !use_simplex then xlia_simplex env0 sys + else xlia en red sys + + +let dump_file = ref None + +let gen_bench (tac, prover) can_enum prfdepth sys = + let res = prover can_enum prfdepth sys in + (match !dump_file with + | None -> () + | Some file -> + begin + let o = open_out (Filename.temp_file ~temp_dir:(Sys.getcwd ()) file ".v") in + let sys = develop_constraints prfdepth z_spec sys in + Printf.fprintf o "Require Import ZArith Lia. Open Scope Z_scope.\n"; + Printf.fprintf o "Goal %a.\n" (LinPoly.pp_goal "Z") (List.map fst sys) ; + begin + match res with + | None -> + Printf.fprintf o "Proof.\n intros. Fail %s.\nAbort.\n" tac + | Some res -> + Printf.fprintf o "Proof.\n intros. %s.\nQed.\n" tac + end + ; + flush o ; + close_out o ; + end); + res 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 = List.mapi (fun i c -> (c,Hyp i)) sys in - xlia can_enum reduction_equations sys + let sys = develop_constraints prfdepth z_spec sys in + if debug then begin + Printf.fprintf stdout "Input problem\n"; + List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys; + end; + + let sys' = List.map (fun ((p,o),prf) -> (cstr_of_poly (p,o), prf)) sys in + xlia (List.map fst sys) can_enum reduction_equations sys' +let make_cstr_system sys = + List.map (fun ((p,o),prf) -> (cstr_of_poly (p,o), prf)) 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 = List.mapi (fun i c -> (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 = develop_constraints prfdepth z_spec sys in + let is_linear = List.for_all (fun ((p,_),_) -> LinPoly.is_linear p) sys in + + if debug then begin + Printf.fprintf stdout "Input problem\n"; + List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys; + end; + + if is_linear + then xlia (List.map fst sys) enum reduction_equations (make_cstr_system sys) + else + (* + let sys1 = elim_every_substitution sys in + No: if a wrong equation is chosen, the proof may fail. + It would only be safe if the variable is linear... + *) + let sys1 = elim_simple_linear_equality sys in + let sys2 = saturate_linear_equality_non_linear sys1 in + let sys3 = nlinear_preprocess (sys1@sys2) in + + let sys4 = make_cstr_system ((*sys2@*)sys3) in + (* [reduction_equations] is too brutal - there should be some non-linear reasoning *) + xlia (List.map fst sys) enum reduction_equations sys4 + +(* For regression testing, if bench = true generate a Coq goal *) + +let lia can_enum prfdepth sys = + gen_bench ("lia",lia) can_enum prfdepth sys + +let nlia enum prfdepth sys = + gen_bench ("nia",nlia) enum prfdepth sys + - 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/certificate.mli b/plugins/micromega/certificate.mli index 13d50d1eee..e925f1bc5e 100644 --- a/plugins/micromega/certificate.mli +++ b/plugins/micromega/certificate.mli @@ -10,13 +10,33 @@ module Mc = Micromega -type 'a number_spec +(** [use_simplex] is bound to the Coq option Simplex. + If set, use the Simplex method, otherwise use Fourier *) +val use_simplex : bool ref + +(** [dump_file] is bound to the Coq option Dump Arith. + If set to some [file], arithmetic goals are dumped in filexxx.v *) +val dump_file : string option ref + +(** [q_cert_of_pos prf] converts a Sos proof into a rational Coq proof *) val q_cert_of_pos : Sos_types.positivstellensatz -> Mc.q Mc.psatz + +(** [z_cert_of_pos prf] converts a Sos proof into an integer Coq proof *) val z_cert_of_pos : Sos_types.positivstellensatz -> Mc.z Mc.psatz + +(** [lia enum depth sys] generates an unsat proof for the linear constraints in [sys]. + If the Simplex option is set, any failure to find a proof should be considered as a bug. *) val lia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> Mc.zArithProof option + +(** [nlia enum depth sys] generates an unsat proof for the non-linear constraints in [sys]. + The solver is incomplete -- the problem is undecidable *) val nlia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> Mc.zArithProof option + +(** [linear_prover_with_cert depth sys] generates an unsat proof for the linear constraints in [sys]. + Over the rationals, the solver is complete. *) +val linear_prover_with_cert : int -> (Mc.q Mc.pExpr * Mc.op1) list -> Mc.q Micromega.psatz option + +(** [nlinear depth sys] generates an unsat proof for the non-linear constraints in [sys]. + The solver is incompete -- the problem is decidable. *) val nlinear_prover : int -> (Mc.q Mc.pExpr * Mc.op1) list -> Mc.q Mc.psatz option -val linear_prover_with_cert : int -> 'a number_spec -> - ('a Mc.pExpr * Mc.op1) list -> 'a Mc.psatz option -val q_spec : Mc.q number_spec diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index e0a369ca5f..402e8b91e6 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -12,7 +12,7 @@ (* *) (* ** Toplevel definition of tactics ** *) (* *) -(* - Modules ISet, M, Mc, Env, Cache, CacheZ *) +(* - Modules M, Mc, Env, Cache, CacheZ *) (* *) (* Frédéric Besson (Irisa/Inria) 2006-20011 *) (* *) @@ -44,7 +44,7 @@ let lia_enum = ref true let lia_proof_depth = ref max_depth let get_lia_option () = - (!lia_enum,!lia_proof_depth) + (!Certificate.use_simplex,!lia_enum,!lia_proof_depth) let get_lra_option () = !lra_proof_depth @@ -70,10 +70,32 @@ let _ = optread = (fun () -> !lia_enum); optwrite = (fun x -> lia_enum := x) } in + + let solver_opt = + { + optdepr = false; + optname = "Use the Simplex instead of Fourier elimination"; + optkey = ["Simplex"]; + optread = (fun () -> !Certificate.use_simplex); + optwrite = (fun x -> Certificate.use_simplex := x) + } in + + let dump_file_opt = + { + optdepr = false; + optname = "Generate Coq goals in file from calls to 'lia' 'nia'"; + optkey = ["Dump"; "Arith"]; + optread = (fun () -> !Certificate.dump_file); + optwrite = (fun x -> Certificate.dump_file := x) + } in + + let _ = declare_bool_option solver_opt in + let _ = declare_stringopt_option dump_file_opt 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). @@ -288,11 +310,6 @@ let rec add_term t0 = function xcnf true f -(** - * MODULE: Ordered set of integers. - *) - -module ISet = Set.Make(Int) (** * Given a set of integers s=\{i0,...,iN\} and a list m, return the list of @@ -340,6 +357,8 @@ struct ["Coq";"Reals" ; "Rpow_def"]; ["LRing_normalise"]] +[@@@ocaml.warning "-3"] + let coq_modules = Coqlib.(init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules @ mic_modules) @@ -362,6 +381,8 @@ struct let gen_constant_in_modules s m n = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules s m n) let init_constant = gen_constant_in_modules "ZMicromega" Coqlib.init_modules + [@@@ocaml.warning "+3"] + let constant = gen_constant_in_modules "ZMicromega" coq_modules let bin_constant = gen_constant_in_modules "ZMicromega" bin_module let r_constant = gen_constant_in_modules "ZMicromega" r_modules @@ -1937,7 +1958,9 @@ let really_call_csdpcert : provername -> micromega_polys -> Sos_types.positivste ["plugins"; "micromega"; "csdpcert" ^ Coq_config.exec_extension] in match ((command cmdname [|cmdname|] (provername,poly)) : csdp_certificate) with - | F str -> failwith str + | F str -> + if debug then Printf.fprintf stdout "really_call_csdpcert : %s\n" str; + raise (failwith str) | S res -> res (** @@ -2047,7 +2070,7 @@ let compact_pt pt f = let lift_pexpr_prover p l = p (List.map (fun (e,o) -> Mc.denorm e , o) l) module CacheZ = PHashtable(struct - type prover_option = bool * int + type prover_option = bool * bool* int type t = prover_option * ((Mc.z Mc.pol * Mc.op1) list) let equal = (=) @@ -2060,8 +2083,8 @@ module CacheQ = PHashtable(struct 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_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) @@ -2069,7 +2092,7 @@ let memo_nra = CacheQ.memo ".nra.cache" (fun (o,s) -> lift_pexpr_prover (Certifi let linear_prover_Q = { 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) ; + prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o ) l) ; hyps = hyps_of_cone ; compact = compact_cone ; pp_prf = pp_psatz pp_q ; @@ -2080,7 +2103,7 @@ let linear_prover_Q = { let linear_prover_R = { 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) ; + prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o ) l) ; hyps = hyps_of_cone ; compact = compact_cone ; pp_prf = pp_psatz pp_q ; diff --git a/plugins/micromega/itv.ml b/plugins/micromega/itv.ml new file mode 100644 index 0000000000..dc1df7ec9f --- /dev/null +++ b/plugins/micromega/itv.ml @@ -0,0 +1,80 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Intervals (extracted from mfourier.ml) *) + +open Num + (** The type of intervals is *) + type interval = num option * num option + (** None models the absence of bound i.e. infinity *) + (** As a result, + - None , None -> \]-oo,+oo\[ + - None , Some v -> \]-oo,v\] + - Some v, None -> \[v,+oo\[ + - Some v, Some v' -> \[v,v'\] + Intervals needs to be explicitly normalised. + *) + + let pp o (n1,n2) = + (match n1 with + | None -> output_string o "]-oo" + | Some n -> Printf.fprintf o "[%s" (string_of_num n) + ); + output_string o ","; + (match n2 with + | None -> output_string o "+oo[" + | Some n -> Printf.fprintf o "%s]" (string_of_num n) + ) + + + + (** if then interval [itv] is empty, [norm_itv itv] returns [None] + otherwise, it returns [Some itv] *) + + let norm_itv itv = + match itv with + | Some a , Some b -> if a <=/ b then Some itv else None + | _ -> Some itv + +(** [inter i1 i2 = None] if the intersection of intervals is empty + [inter i1 i2 = Some i] if [i] is the intersection of the intervals [i1] and [i2] *) + let inter i1 i2 = + let (l1,r1) = i1 + and (l2,r2) = i2 in + + let inter f o1 o2 = + match o1 , o2 with + | None , None -> None + | Some _ , None -> o1 + | None , Some _ -> o2 + | Some n1 , Some n2 -> Some (f n1 n2) in + + norm_itv (inter max_num l1 l2 , inter min_num r1 r2) + + let range = function + | None,_ | _,None -> None + | Some i,Some j -> Some (floor_num j -/ceiling_num i +/ (Int 1)) + + + let smaller_itv i1 i2 = + match range i1 , range i2 with + | None , _ -> false + | _ , None -> true + | Some i , Some j -> i <=/ j + + +(** [in_bound bnd v] checks whether [v] is within the bounds [bnd] *) +let in_bound bnd v = + let (l,r) = bnd in + match l , r with + | None , None -> true + | None , Some a -> v <=/ a + | Some a , None -> a <=/ v + | Some a , Some b -> a <=/ v && v <=/ b diff --git a/plugins/micromega/itv.mli b/plugins/micromega/itv.mli new file mode 100644 index 0000000000..31f6a89fe2 --- /dev/null +++ b/plugins/micromega/itv.mli @@ -0,0 +1,18 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +open Num + +type interval = num option * num option +val pp : out_channel -> interval -> unit +val inter : interval -> interval -> interval option +val range : interval -> num option +val smaller_itv : interval -> interval -> bool +val in_bound : interval -> num -> bool +val norm_itv : interval -> interval option diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml index 3328abdab7..baf8c82355 100644 --- a/plugins/micromega/mfourier.ml +++ b/plugins/micromega/mfourier.ml @@ -1,3 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + open Util open Num open Polynomial @@ -8,66 +18,6 @@ let debug = false let compare_float (p : float) q = Pervasives.compare p q (** Implementation of intervals *) -module Itv = -struct - - (** The type of intervals is *) - type interval = num option * num option - (** None models the absence of bound i.e. infinity *) - (** As a result, - - None , None -> \]-oo,+oo\[ - - None , Some v -> \]-oo,v\] - - Some v, None -> \[v,+oo\[ - - Some v, Some v' -> \[v,v'\] - Intervals needs to be explicitly normalised. - *) - - (** if then interval [itv] is empty, [norm_itv itv] returns [None] - otherwise, it returns [Some itv] *) - - let norm_itv itv = - match itv with - | Some a , Some b -> if a <=/ b then Some itv else None - | _ -> Some itv - -(** [inter i1 i2 = None] if the intersection of intervals is empty - [inter i1 i2 = Some i] if [i] is the intersection of the intervals [i1] and [i2] *) - let inter i1 i2 = - let (l1,r1) = i1 - and (l2,r2) = i2 in - - let inter f o1 o2 = - match o1 , o2 with - | None , None -> None - | Some _ , None -> o1 - | None , Some _ -> o2 - | Some n1 , Some n2 -> Some (f n1 n2) in - - norm_itv (inter max_num l1 l2 , inter min_num r1 r2) - - let range = function - | None,_ | _,None -> None - | Some i,Some j -> Some (floor_num j -/ceiling_num i +/ (Int 1)) - - - let smaller_itv i1 i2 = - match range i1 , range i2 with - | None , _ -> false - | _ , None -> true - | Some i , Some j -> i <=/ j - - -(** [in_bound bnd v] checks whether [v] is within the bounds [bnd] *) -let in_bound bnd v = - let (l,r) = bnd in - match l , r with - | None , None -> true - | None , Some a -> v <=/ a - | Some a , None -> a <=/ v - | Some a , Some b -> a <=/ v && v <=/ b - - -end open Itv type vector = Vect.t @@ -84,8 +34,6 @@ type proof = | Elim of var * proof * proof | And of proof * proof -let max_nb_cstr = ref max_int - type system = { sys : cstr_info ref System.t ; vars : ISet.t @@ -126,7 +74,7 @@ let pp_cstr o (vect,bnd) = | None -> () | Some n -> Printf.fprintf o "%s <= " (string_of_num n)) ; - pp_vect o vect ; + Vect.pp o vect ; (match r with | None -> output_string o"\n" | Some n -> Printf.fprintf o "<=%s\n" (string_of_num n)) @@ -185,30 +133,23 @@ let normalise_cstr vect cinfo = match norm_itv cinfo.bound with | None -> Contradiction | Some (l,r) -> - match vect with - | [] -> if Itv.in_bound (l,r) (Int 0) then Redundant else Contradiction - | (_,n)::_ -> Cstr( - (if n <>/ Int 1 then List.map (fun (x,nx) -> (x,nx // n)) vect else vect), + match Vect.choose vect with + | None -> if Itv.in_bound (l,r) (Int 0) then Redundant else Contradiction + | Some (_,n,_) -> Cstr(Vect.div n vect, let divn x = x // n in if Int.equal (sign_num n) 1 then{cinfo with bound = (Option.map divn l , Option.map divn r) } else {cinfo with pos = cinfo.neg ; neg = cinfo.pos ; bound = (Option.map divn r , Option.map divn l)}) -(** For compatibility, there is an external representation of constraints *) +(** For compatibility, there is an external representation of constraints *) -let eval_op = function - | Eq -> (=/) - | Ge -> (>=/) let count v = - let rec count n p v = - match v with - | [] -> (n,p) - | (_,vl)::v -> let sg = sign_num vl in - assert (sg <> 0) ; - if Int.equal sg 1 then count n (p+1) v else count (n+1) p v in - count 0 0 v + Vect.fold (fun (n,p) _ vl -> + let sg = sign_num vl in + assert (sg <> 0) ; + if Int.equal sg 1 then (n,p+1)else (n+1, p)) (0,0) v let norm_cstr {coeffs = v ; op = o ; cst = c} idx = @@ -217,7 +158,9 @@ let norm_cstr {coeffs = v ; op = o ; cst = c} idx = normalise_cstr v {pos = p ; neg = n ; bound = (match o with | Eq -> Some c , Some c - | Ge -> Some c , None) ; + | Ge -> Some c , None + | Gt -> raise Polynomial.Strict + ) ; prf = Assum idx } @@ -237,7 +180,7 @@ let load_system l = | Redundant -> vrs | Cstr(vect,info) -> xadd_cstr vect info sys ; - List.fold_left (fun s (v,_) -> ISet.add v s) vrs cstr.coeffs) ISet.empty li in + Vect.fold (fun s v _ -> ISet.add v s) vrs cstr.coeffs) ISet.empty li in {sys = sys ;vars = vars} @@ -255,27 +198,7 @@ let system_list sys = let add (v1,c1) (v2,c2) = assert (c1 <>/ Int 0 && c2 <>/ Int 0) ; - - let rec xadd v1 v2 = - match v1 , v2 with - | (x1,n1)::v1' , (x2,n2)::v2' -> - if Int.equal x1 x2 - then - let n' = (n1 // c1) +/ (n2 // c2) in - if n' =/ Int 0 then xadd v1' v2' - else - let res = xadd v1' v2' in - (x1,n') ::res - else if x1 < x2 - then let res = xadd v1' v2 in - (x1, n1 // c1)::res - else let res = xadd v1 v2' in - (x2, n2 // c2)::res - | [] , [] -> [] - | [] , _ -> List.map (fun (x,vl) -> (x,vl // c2)) v2 - | _ , [] -> List.map (fun (x,vl) -> (x,vl // c1)) v1 in - - let res = xadd v1 v2 in + let res = mul_add (Int 1 // c1) v1 (Int 1 // c2) v2 in (res, count res) let add (v1,c1) (v2,c2) = @@ -294,9 +217,9 @@ let add (v1,c1) (v2,c2) = let split x (vect: vector) info (l,m,r) = match get x vect with - | None -> (* The constraint does not mention [x], store it in m *) + | Int 0 -> (* The constraint does not mention [x], store it in m *) (l,(vect,info)::m,r) - | Some vl -> (* otherwise *) + | vl -> (* otherwise *) let cons_bound lst bd = match bd with @@ -352,7 +275,8 @@ let project vr sys = let project_using_eq vr c vect bound prf (vect',info') = match get vr vect' with - | Some c2 -> + | Int 0 -> (vect',info') + | c2 -> let c1 = if c2 >=/ Int 0 then minus_num c else c in let c2 = abs_num c2 in @@ -367,10 +291,10 @@ let project_using_eq vr c vect bound prf (vect',info') = (Option.map f l , Option.map f r) in (vres,{neg = n ; pos = p ; bound = bndres ; prf = Elim(vr,prf,info'.prf)}) - | None -> (vect',info') + let elim_var_using_eq vr vect cst prf sys = - let c = Option.get (get vr vect) in + let c = get vr vect in let elim_var = project_using_eq vr c vect cst prf in @@ -397,16 +321,13 @@ module IMap = CMap.Make(Int) The function returns as second argument, a sub-vector consisting in the variables that are not in [map]. *) let eval_vect map vect = - let rec xeval_vect vect sum rst = - match vect with - | [] -> (sum,rst) - | (v,vl)::vect -> - try - let val_v = IMap.find v map in - xeval_vect vect (sum +/ (val_v */ vl)) rst - with - Not_found -> xeval_vect vect sum ((v,vl)::rst) in - xeval_vect vect (Int 0) [] + Vect.fold (fun (sum,rst) v vl -> + try + let val_v = IMap.find v map in + (sum +/ (val_v */ vl), rst) + with + Not_found -> (sum, Vect.set v vl rst)) (Int 0,Vect.null) vect + (** [restrict_bound n sum itv] returns the interval of [x] @@ -427,11 +348,13 @@ let restrict_bound n sum (itv:interval) = let bound_of_variable map v sys = System.fold (fun vect iref bnd -> let sum,rst = eval_vect map vect in - let vl = match get v rst with - | None -> Int 0 - | Some v -> v in + let vl = Vect.get v rst in match inter bnd (restrict_bound vl sum (!iref).bound) with - | None -> failwith "bound_of_variable: impossible" + | None -> + Printf.fprintf stdout "bound_of_variable: eval_vecr %a = %s,%a\n" + Vect.pp vect (Num.string_of_num sum) Vect.pp rst ; + Printf.fprintf stdout "current interval: %a\n" Itv.pp (!iref).bound; + failwith "bound_of_variable: impossible" | Some itv -> itv) sys (None,None) @@ -458,12 +381,13 @@ let solve_sys black_v choose_eq choose_variable sys sys_l = let rec solve_sys sys sys_l = if debug then Printf.printf "S #%i size %i\n" (System.length sys.sys) (size sys.sys); + if debug then Printf.printf "solve_sys :\n %a" pp_system sys.sys ; let eqs = choose_eq sys in try let (v,vect,cst,ln) = fst (List.find (fun ((v,_,_,_),_) -> v <> black_v) eqs) in if debug then - (Printf.printf "\nE %a = %s variable %i\n" pp_vect vect (string_of_num cst) v ; + (Printf.printf "\nE %a = %s variable %i\n" Vect.pp vect (string_of_num cst) v ; flush stdout); let sys' = elim_var_using_eq v vect cst ln sys in solve_sys sys' ((v,sys)::sys_l) @@ -503,9 +427,9 @@ struct match l with | [] -> (ltl, n,z,p) | (l1,info) ::rl -> - match l1 with - | [] -> xpart rl (([],info)::ltl) n (info.neg+info.pos+z) p - | (vr,vl)::rl1 -> + match Vect.choose l1 with + | None -> xpart rl ((Vect.null,info)::ltl) n (info.neg+info.pos+z) p + | Some(vr, vl, rl1) -> if Int.equal v vr then let cons_bound lst bd = @@ -557,24 +481,26 @@ struct | _ -> false let rec unroll_until v l = - match l with - | [] -> (false,[]) - | (i,_)::rl -> if Int.equal i v + match Vect.choose l with + | None -> (false,Vect.null) + | Some(i,_,rl) -> if Int.equal i v then (true,rl) else if i < v then unroll_until v rl else (false,l) + let rec choose_simple_equation eqs = match eqs with | [] -> None | (vect,a,prf,ln)::eqs -> - match vect with - | [i,_] -> Some (i,vect,a,prf,ln) - | _ -> choose_simple_equation eqs + match Vect.choose vect with + | Some(i,v,rst) -> if Vect.is_null rst + then Some (i,vect,a,prf,ln) + else choose_simple_equation eqs + | _ -> choose_simple_equation eqs - - let choose_primal_equation eqs sys_l = + let choose_primal_equation eqs (sys_l: (Vect.t *cstr_info) list) = (* Counts the number of equations referring to variable [v] -- It looks like nb_cst is dead... @@ -586,9 +512,9 @@ struct else nb_eq) 0 sys_l in let rec find_var vect = - match vect with - | [] -> None - | (i,_)::vect -> + match Vect.choose vect with + | None -> None + | Some(i,_,vect) -> let nb_eq = is_primal_equation_var i in if Int.equal nb_eq 2 then Some i else find_var vect in @@ -638,9 +564,9 @@ struct let cost_eq eq const prf ln acc_costs = let rec cost_eq eqr sysl costs = - match eqr with - | [] -> costs - | (v,_) ::eqr -> let (cst,tlsys) = estimate_cost v (ln-1) sysl 0 [] in + match Vect.choose eqr with + | None -> costs + | Some(v,_,eqr) -> let (cst,tlsys) = estimate_cost v (ln-1) sysl 0 [] in cost_eq eqr tlsys (((v,eq,const,prf),cst)::costs) in cost_eq eq sys_l acc_costs in @@ -692,10 +618,10 @@ struct in let map = rebuild_solution l IMap.empty in - let vect = List.rev (IMap.fold (fun v i vect -> (v,i)::vect) map []) in -(* Printf.printf "SOLUTION %a" pp_vect vect ; *) - let res = Inl vect in - res + let vect = IMap.fold (fun v i vect -> Vect.set v i vect) map Vect.null in + if debug then Printf.printf "SOLUTION %a" Vect.pp vect ; + let res = Inl vect in + res end @@ -735,8 +661,8 @@ struct and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in match Vect.get v v1 , Vect.get v v2 with - | None , _ | _ , None -> None - | Some a , Some b -> + | Int 0 , _ | _ , Int 0 -> None + | a , b -> if Int.equal ((sign_num a) * (sign_num b)) (-1) then Some (add (p1,abs_num a) (p2,abs_num b) , @@ -768,7 +694,7 @@ struct | Cstr(v,info) -> Inl ((prf,cstr,v,info)::acc)) (Inl []) l - type oproof = (vector * cstr_compat * num) option + type oproof = (vector * cstr * num) option let merge_proof (oleft:oproof) (prf,cstr,v,info) (oright:oproof) = let (l,r) = info.bound in @@ -789,9 +715,9 @@ struct if l <=/ r then Inl (oleft,oright) else (* There is a contradiction - it should show up by scaling up the vectors - any pivot should do*) - match cstrr.coeffs with - | [] -> Inr (add (prfl,Int 1) (prfr,Int 1), cstrr) (* this is wrong *) - | (v,_)::_ -> + match Vect.choose cstrr.coeffs with + | None -> Inr (add (prfl,Int 1) (prfr,Int 1), cstrr) (* this is wrong *) + | Some(v,_,_) -> match pivot v (prfl,cstrl) (prfr,cstrr) with | None -> failwith "merge_proof : pivot is not possible" | Some x -> Inr x @@ -804,7 +730,7 @@ let mk_proof hyps prf = let rec mk_proof prf = match prf with - | Assum i -> [ ([i, Int 1] , List.nth hyps i) ] + | Assum i -> [ (Vect.set i (Int 1) Vect.null , List.nth hyps i) ] | Elim(v,prf1,prf2) -> let prfsl = mk_proof prf1 diff --git a/plugins/micromega/mfourier.mli b/plugins/micromega/mfourier.mli index f1d8edeab6..45a81cc118 100644 --- a/plugins/micromega/mfourier.mli +++ b/plugins/micromega/mfourier.mli @@ -8,25 +8,18 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -module Itv : sig - - type interval = Num.num option * Num.num option - val range : interval -> Num.num option - val smaller_itv : interval -> interval -> bool - -end - module IMap : CSig.MapS with type key = int type proof module Fourier : sig - val find_point : Polynomial.cstr_compat list -> - ((IMap.key * Num.num) list, proof) Util.union - val optimise : Polynomial.Vect.t -> - Polynomial.cstr_compat list -> + val find_point : Polynomial.cstr list -> + (Vect.t, proof) Util.union + + val optimise : Vect.t -> + Polynomial.cstr list -> Itv.interval option end @@ -35,15 +28,11 @@ val pp_proof : out_channel -> proof -> unit module Proof : sig - val mk_proof : Polynomial.cstr_compat list -> - proof -> (Polynomial.Vect.t * Polynomial.cstr_compat) list + val mk_proof : Polynomial.cstr list -> + proof -> (Vect.t * Polynomial.cstr) list val add_op : Polynomial.op -> Polynomial.op -> Polynomial.op end -val max_nb_cstr : int ref - -val eval_op : Polynomial.op -> Num.num -> Num.num -> bool - exception TimeOut diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml index 52c6ef983d..f67f1da146 100644 --- a/plugins/micromega/micromega.ml +++ b/plugins/micromega/micromega.ml @@ -1484,17 +1484,17 @@ let psub1 = let padd1 = padd0 Z0 Z.add zeq_bool -(** val norm0 : z pExpr -> z pol **) +(** val normZ : z pExpr -> z pol **) -let norm0 = +let normZ = norm Z0 (Zpos XH) Z.add Z.mul Z.sub Z.opp zeq_bool (** val xnormalise0 : z formula -> z nFormula list **) let xnormalise0 t0 = let { flhs = lhs; fop = o; frhs = rhs } = t0 in - let lhs0 = norm0 lhs in - let rhs0 = norm0 rhs in + let lhs0 = normZ lhs in + let rhs0 = normZ rhs in (match o with | OpEq -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::(((psub1 rhs0 @@ -1516,8 +1516,8 @@ let normalise t0 = let xnegate0 t0 = let { flhs = lhs; fop = o; frhs = rhs } = t0 in - let lhs0 = norm0 lhs in - let rhs0 = norm0 rhs in + let lhs0 = normZ lhs in + let rhs0 = normZ rhs in (match o with | OpEq -> ((psub1 lhs0 rhs0),Equal)::[] | OpNEq -> @@ -1707,6 +1707,12 @@ let qunsat = let qdeduce = nformula_plus_nformula { qnum = Z0; qden = XH } qplus qeq_bool +(** val normQ : q pExpr -> q pol **) + +let normQ = + norm { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult + qminus qopp qeq_bool + (** val qTautoChecker : q formula bFormula -> qWitness list -> bool **) let qTautoChecker f w = diff --git a/plugins/micromega/micromega.mli b/plugins/micromega/micromega.mli index 9619781786..72c2bf7da3 100644 --- a/plugins/micromega/micromega.mli +++ b/plugins/micromega/micromega.mli @@ -151,8 +151,7 @@ val mkPinj : positive -> 'a1 pol -> 'a1 pol val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol -val mkPX : - 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol +val mkPX : 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol @@ -164,49 +163,27 @@ val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol -val paddI : - ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> - positive -> 'a1 pol -> 'a1 pol +val paddI : ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol -val psubI : - ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> - 'a1 pol -> positive -> 'a1 pol -> 'a1 pol +val psubI : ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol -val paddX : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol - -> positive -> 'a1 pol -> 'a1 pol +val paddX : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol -val psubX : - 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 - pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol +val psubX : 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol -val padd : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> - 'a1 pol +val padd : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol -val psub : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 - -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol +val psub : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol -val pmulC_aux : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 - pol +val pmulC_aux : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol -val pmulC : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 - -> 'a1 pol +val pmulC : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol -val pmulI : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> - 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol +val 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 +val pmul : '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 +val psquare : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol type 'c pExpr = | PEc of 'c @@ -220,16 +197,12 @@ 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 +val ppow_N : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol val norm_aux : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol type 'a bFormula = | TT @@ -251,32 +224,22 @@ val tt : 'a1 cnf val ff : 'a1 cnf -val add_term : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1 - clause option +val add_term : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1 clause option -val or_clause : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause -> - 'a1 clause option +val or_clause : ('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 +val or_clause_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 cnf +val or_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1 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 +val xcnf : ('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 @@ -307,32 +270,24 @@ type 'c psatz = val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option -val map_option2 : - ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option +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 +val nformula_plus_nformula : '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 + '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 +val check_inconsistent : '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 @@ -345,36 +300,27 @@ type op2 = type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't 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 +val psub0 : '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 +val padd0 : '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 @@ -384,9 +330,7 @@ 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 +val simpl_cone : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz -> 'a1 psatz type q = { qnum : z; qden : positive } @@ -431,7 +375,7 @@ val psub1 : z pol -> z pol -> z pol val padd1 : z pol -> z pol -> z pol -val norm0 : z pExpr -> z pol +val normZ : z pExpr -> z pol val xnormalise0 : z formula -> z nFormula list @@ -487,6 +431,8 @@ val qunsat : q nFormula -> bool val qdeduce : q nFormula -> q nFormula -> q nFormula option +val normQ : q pExpr -> q pol + val qTautoChecker : q formula bFormula -> qWitness list -> bool type rcst = diff --git a/plugins/micromega/micromega_plugin.mlpack b/plugins/micromega/micromega_plugin.mlpack index ed253da3fd..2baf6608a4 100644 --- a/plugins/micromega/micromega_plugin.mlpack +++ b/plugins/micromega/micromega_plugin.mlpack @@ -1,8 +1,11 @@ -Sos_types Mutils +Itv +Vect +Sos_types Micromega Polynomial Mfourier +Simplex Certificate Persistent_cache Coq_micromega diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index 9d03560b71..40aeef3959 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -19,11 +19,31 @@ (* *) (************************************************************************) -let rec pp_list f o l = + +module ISet = Set.Make(Int) + +module IMap = + struct + include Map.Make(Int) + + let from k m = + let (_,_,r) = split (k-1) m in + r + end + +(*let output_int o i = output_string o (string_of_int i)*) + +let iset_pp o s = + Printf.fprintf o "{ %a }" + (fun o s -> ISet.iter (fun i -> Printf.fprintf o "%i " i) s) s + +let rec pp_list s f o l = match l with | [] -> () - | e::l -> f o e ; output_string o ";" ; pp_list f o l + | [e] -> f o e + | e::l -> f o e ; output_string o s ; pp_list s f o l +let output_bigint o bi = output_string o (Big_int.string_of_big_int bi) let finally f rst = try @@ -79,6 +99,12 @@ let extract pred l = | _ -> (fd, e::sys) ) (None,[]) l +let extract_all pred l = + List.fold_left (fun (s1,s2) e -> + match pred e with + | None -> s1,e::s2 + | Some v -> (v,e)::s1 , s2) ([],[]) l + open Num open Big_int @@ -117,7 +143,22 @@ let rats_to_ints l = List.map (fun x -> (div_big_int (mult_big_int (numerator x) c) (denominator x))) l -(* assoc_pos j [a0...an] = [j,a0....an,j+n],j+n+1 *) +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' + + (** * MODULE: Coq to Caml data-structure mappings *) diff --git a/plugins/micromega/mutils.mli b/plugins/micromega/mutils.mli index 094429ea18..35ca1e5516 100644 --- a/plugins/micromega/mutils.mli +++ b/plugins/micromega/mutils.mli @@ -8,6 +8,22 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) + +module ISet : Set.S with type elt = int + +module IMap : +sig + include Map.S with type key = int + + (** [from k m] returns the submap of [m] with keys greater or equal k *) + val from : key -> 'elt t -> 'elt t + +end + +val iset_pp : out_channel -> ISet.t -> unit + +val output_bigint : out_channel -> Big_int.big_int -> unit + val numerator : Num.num -> Big_int.big_int val denominator : Num.num -> Big_int.big_int @@ -30,7 +46,7 @@ end module TagSet : CSig.SetS with type elt = Tag.t -val pp_list : (out_channel -> 'a -> unit) -> out_channel -> 'a list -> unit +val pp_list : string -> (out_channel -> 'a -> unit) -> out_channel -> 'a list -> unit module CamlToCoq : sig @@ -56,6 +72,7 @@ module CoqToCaml : sig end +val ppcm : Big_int.big_int -> Big_int.big_int -> Big_int.big_int val rats_to_ints : Num.num list -> Big_int.big_int list val all_pairs : ('a -> 'a -> 'b) -> 'a list -> 'b list @@ -67,4 +84,10 @@ val gcd_list : Num.num list -> Big_int.big_int val extract : ('a -> 'b option) -> 'a list -> ('b * 'a) option * 'a list +val extract_all : ('a -> 'b option) -> 'a list -> ('b * 'a) list * 'a list + +val iterate_until_stable : ('a -> 'a option) -> 'a -> 'a + +val app_funs : ('a -> 'b option) list -> 'a -> 'b option + val command : string -> string array -> 'a -> 'b diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml index 1d18a26f33..5f31b6f145 100644 --- a/plugins/micromega/polynomial.ml +++ b/plugins/micromega/polynomial.ml @@ -10,7 +10,7 @@ (* *) (* Micromega: A reflexive tactic using the Positivstellensatz *) (* *) -(* Frédéric Besson (Irisa/Inria) 2006-20011 *) +(* Frédéric Besson (Irisa/Inria) 2006-20018 *) (* *) (************************************************************************) @@ -18,6 +18,10 @@ open Num module Utils = Mutils open Utils +module Mc = Micromega + +let max_nb_cstr = ref max_int + type var = int let debug = false @@ -25,652 +29,882 @@ let debug = false let (<+>) = add_num let (<*>) = mult_num - module Monomial : sig - type t - val const : t - val is_const : t -> bool - val var : var -> t - val is_var : t -> bool - val prod : t -> t -> t - val exp : t -> int -> t - val div : t -> t -> t * int - val compare : t -> t -> int - val pp : out_channel -> t -> unit - val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a - val sqrt : t -> t option + type t + val const : t + val is_const : t -> bool + val var : var -> t + val is_var : t -> bool + val get_var : t -> var option + val prod : t -> t -> t + val exp : t -> int -> t + val div : t -> t -> t * int + val compare : t -> t -> int + val pp : out_channel -> t -> unit + val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a + val sqrt : t -> t option + val variables : t -> ISet.t end - = -struct - (* A monomial is represented by a multiset of variables *) - module Map = Map.Make(Int) - open Map - - type t = int Map.t - - let pp o m = Map.iter - (fun k v -> - if v = 1 then Printf.fprintf o "x%i." k - else Printf.fprintf o "x%i^%i." k v) m - - - (* The monomial that corresponds to a constant *) - let const = Map.empty - - let sum_degree m = Map.fold (fun _ n s -> s + n) m 0 - - (* Total ordering of monomials *) - let compare: t -> t -> int = - fun m1 m2 -> - let s1 = sum_degree m1 - and s2 = sum_degree m2 in - if Int.equal s1 s2 then Map.compare Int.compare m1 m2 - else Int.compare s1 s2 - - let is_const m = (m = Map.empty) - - (* The monomial 'x' *) - let var x = Map.add x 1 Map.empty - - let is_var m = - try - not (Map.fold (fun _ i fk -> - if fk = true (* first key *) - then - if i = 1 then false - else raise Not_found - else raise Not_found) m true) - with Not_found -> false - - let sqrt m = - if is_const m then None - else - try - Some (Map.fold (fun v i acc -> - let i' = i / 2 in - if i mod 2 = 0 - then add v i' m - else raise Not_found) m const) - with Not_found -> None - - (* Get the degre of a variable in a monomial *) - let find x m = try find x m with Not_found -> 0 - - (* Product of monomials *) - let prod m1 m2 = Map.fold (fun k d m -> add k ((find k m) + d) m) m1 m2 - - - let exp m n = - let rec exp acc n = - if n = 0 then acc - else exp (prod acc m) (n - 1) in - - exp const n - - - (* [div m1 m2 = mr,n] such that mr * (m2)^n = m1 *) - let div m1 m2 = - let n = fold (fun x i n -> let i' = find x m1 in - let nx = i' / i in - min n nx) m2 max_int in - - let mr = fold (fun x i' m -> - let i = find x m2 in - let ir = i' - i * n in - if ir = 0 then m - else add x ir m) m1 empty in - (mr,n) - - - let fold = fold + = struct + (* A monomial is represented by a multiset of variables *) + module Map = Map.Make(Int) + open Map + + type t = int Map.t + + let is_singleton m = + try + let (k,v) = choose m in + let (l,e,r) = split k m in + if is_empty l && is_empty r + then Some(k,v) else None + with Not_found -> None + + let pp o m = + let pp_elt o (k,v)= + if v = 1 then Printf.fprintf o "x%i" k + else Printf.fprintf o "x%i^%i" k v in + + let rec pp_list o l = + match l with + [] -> () + | [e] -> pp_elt o e + | e::l -> Printf.fprintf o "%a*%a" pp_elt e pp_list l in + + pp_list o (Map.bindings m) + + + + (* The monomial that corresponds to a constant *) + let const = Map.empty + + let sum_degree m = Map.fold (fun _ n s -> s + n) m 0 + + (* Total ordering of monomials *) + let compare: t -> t -> int = + fun m1 m2 -> + let s1 = sum_degree m1 + and s2 = sum_degree m2 in + if Int.equal s1 s2 then Map.compare Int.compare m1 m2 + else Int.compare s1 s2 + + let is_const m = (m = Map.empty) + + (* The monomial 'x' *) + let var x = Map.add x 1 Map.empty + + let is_var m = + match is_singleton m with + | None -> false + | Some (_,i) -> i = 1 + + let get_var m = + match is_singleton m with + | None -> None + | Some (k,i) -> if i = 1 then Some k else None + + + let sqrt m = + if is_const m then None + else + try + Some (Map.fold (fun v i acc -> + let i' = i / 2 in + if i mod 2 = 0 + then add v i' acc + else raise Not_found) m const) + with Not_found -> None + + + (* Get the degre of a variable in a monomial *) + let find x m = try find x m with Not_found -> 0 + + (* Product of monomials *) + let prod m1 m2 = Map.fold (fun k d m -> add k ((find k m) + d) m) m1 m2 + + let exp m n = + let rec exp acc n = + if n = 0 then acc + else exp (prod acc m) (n - 1) in + + exp const n + + (* [div m1 m2 = mr,n] such that mr * (m2)^n = m1 *) + let div m1 m2 = + let n = fold (fun x i n -> let i' = find x m1 in + let nx = i' / i in + min n nx) m2 max_int in + + let mr = fold (fun x i' m -> + let i = find x m2 in + let ir = i' - i * n in + if ir = 0 then m + else add x ir m) m1 empty in + (mr,n) + + + let variables m = fold (fun v i acc -> ISet.add v acc) m ISet.empty + + let fold = fold end +module MonMap = + struct + include Map.Make(Monomial) + + let union f = merge + (fun x v1 v2 -> + match v1 , v2 with + | None , None -> None + | Some v , None | None , Some v -> Some v + | Some v1 , Some v2 -> f x v1 v2) + end + +let pp_mon o (m, i) = + if Monomial.is_const m + then if eq_num (Int 0) i then () + else Printf.fprintf o "%s" (string_of_num i) + else + match i with + | Int 1 -> Monomial.pp o m + | Int -1 -> Printf.fprintf o "-%a" Monomial.pp m + | Int 0 -> () + | _ -> Printf.fprintf o "%s*%a" (string_of_num i) Monomial.pp m + + + module Poly : - (* A polynomial is a map of monomials *) - (* - This is probably a naive implementation +(* A polynomial is a map of monomials *) +(* + This is probably a naive implementation (expected to be fast enough - Coq is probably the bottleneck) *The new ring contribution is using a sparse Horner representation. - *) + *) sig - type t - val get : Monomial.t -> t -> num - val variable : var -> t - val add : Monomial.t -> num -> t -> t - val constant : num -> t - val product : t -> t -> t - val addition : t -> t -> t - val uminus : t -> t - val fold : (Monomial.t -> num -> 'a -> 'a) -> t -> 'a -> 'a - val is_linear : t -> bool -end = -struct - (*normalisation bug : 0*x ... *) - module P = Map.Make(Monomial) - open P - - type t = num P.t - - (* Get the coefficient of monomial mn *) - let get : Monomial.t -> t -> num = - fun mn p -> try find mn p with Not_found -> (Int 0) - - - (* The polynomial 1.x *) - let variable : var -> t = - fun x -> add (Monomial.var x) (Int 1) empty - - (*The constant polynomial *) - let constant : num -> t = - fun c -> add (Monomial.const) c empty - - (* The addition of a monomial *) - - let add : Monomial.t -> num -> t -> t = - fun mn v p -> + type t + val pp : out_channel -> t -> unit + val get : Monomial.t -> t -> num + val variable : var -> t + val add : Monomial.t -> num -> t -> t + val constant : num -> t + val product : t -> t -> t + val addition : t -> t -> t + val uminus : t -> t + val fold : (Monomial.t -> num -> 'a -> 'a) -> t -> 'a -> 'a + val is_linear : t -> bool + val variables : t -> ISet.t + val factorise : var -> t -> t * t +end = struct + (*normalisation bug : 0*x ... *) + module P = Map.Make(Monomial) + open P + + type t = num P.t + + + let pp o p = P.iter (fun mn i -> Printf.fprintf o "%a + " pp_mon (mn, i)) p + + + (* Get the coefficient of monomial mn *) + let get : Monomial.t -> t -> num = + fun mn p -> try find mn p with Not_found -> (Int 0) + + + (* The polynomial 1.x *) + let variable : var -> t = + fun x -> add (Monomial.var x) (Int 1) empty + + (*The constant polynomial *) + let constant : num -> t = + fun c -> add (Monomial.const) c empty + + (* The addition of a monomial *) + + let add : Monomial.t -> num -> t -> t = + fun mn v p -> if sign_num v = 0 then p else let vl = (get mn p) <+> v in - if sign_num vl = 0 then - remove mn p - else add mn vl p + if sign_num vl = 0 then + remove mn p + else add mn vl p - (** Design choice: empty is not a polynomial - I do not remember why .... - **) + (** Design choice: empty is not a polynomial + I do not remember why .... + **) - (* The product by a monomial *) - let mult : Monomial.t -> num -> t -> t = - fun mn v p -> - if sign_num v = 0 + (* The product by a monomial *) + let mult : Monomial.t -> num -> t -> t = + fun mn v p -> + if sign_num v = 0 then constant (Int 0) else fold (fun mn' v' res -> P.add (Monomial.prod mn mn') (v<*>v') res) p empty - let addition : t -> t -> t = - fun p1 p2 -> fold (fun mn v p -> add mn v p) p1 p2 - + let addition : t -> t -> t = + fun p1 p2 -> fold (fun mn v p -> add mn v p) p1 p2 - let product : t -> t -> t = - fun p1 p2 -> - fold (fun mn v res -> addition (mult mn v p2) res ) p1 empty + let product : t -> t -> t = + fun p1 p2 -> + fold (fun mn v res -> addition (mult mn v p2) res ) p1 empty - let uminus : t -> t = - fun p -> map (fun v -> minus_num v) p - let fold = P.fold + let uminus : t -> t = + fun p -> map (fun v -> minus_num v) p - let is_linear p = P.fold (fun m _ acc -> acc && (Monomial.is_const m || Monomial.is_var m)) p true + let fold = P.fold -(* let is_linear p = - let res = is_linear p in - Printf.printf "is_linear %a = %b\n" pp p res ; res -*) -end + let is_linear p = P.fold (fun m _ acc -> acc && (Monomial.is_const m || Monomial.is_var m)) p true + let variables p = P.fold (fun m _ acc -> ISet.union (Monomial.variables m) acc) p ISet.empty + + let factorise x p = + let x = Monomial.var x in + P.fold (fun m v (px,cx) -> + let (m1,i) = Monomial.div m x in + if i = 0 + then (px, add m v cx) + else + let mx = Monomial.prod m1 (Monomial.exp x (i-1)) in + (add mx v px,cx) ) p (constant (Int 0) , constant (Int 0)) + +end -module Vect = - struct - (** [t] is the type of vectors. - A vector [(x1,v1) ; ... ; (xn,vn)] is such that: - - variables indexes are ordered (x1 <c ... < xn - - values are all non-zero - *) - type var = int - type t = (var * num) list - -(** [equal v1 v2 = true] if the vectors are syntactically equal. *) - - let rec equal v1 v2 = - match v1 , v2 with - | [] , [] -> true - | [] , _ -> false - | _::_ , [] -> false - | (i1,n1)::v1 , (i2,n2)::v2 -> - (Int.equal i1 i2) && n1 =/ n2 && equal v1 v2 - - let hash v = - let rec hash i = function - | [] -> i - | (vr,vl)::l -> hash (i + (Hashtbl.hash (vr, float_of_num vl))) l in - Hashtbl.hash (hash 0 v ) - - - let null = [] - - let pp_vect o vect = - List.iter (fun (v,n) -> Printf.printf "%sx%i + " (string_of_num n) v) vect - - let from_list (l: num list) = - let rec xfrom_list i l = - match l with - | [] -> [] - | e::l -> - if e <>/ Int 0 - then (i,e)::(xfrom_list (i+1) l) - else xfrom_list (i+1) l in - - xfrom_list 0 l - - let zero_num = Int 0 - - - let to_list m = - let rec xto_list i l = - match l with - | [] -> [] - | (x,v)::l' -> - if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in - xto_list 0 m - - - let cons i v rst = if v =/ Int 0 then rst else (i,v)::rst - - let rec update i f t = - match t with - | [] -> cons i (f zero_num) [] - | (k,v)::l -> - match Int.compare i k with - | 0 -> cons k (f v) l - | -1 -> cons i (f zero_num) t - | 1 -> (k,v) ::(update i f l) - | _ -> failwith "compare_num" - - let rec set i n t = - match t with - | [] -> cons i n [] - | (k,v)::l -> - match Int.compare i k with - | 0 -> cons k n l - | -1 -> cons i n t - | 1 -> (k,v) :: (set i n l) - | _ -> failwith "compare_num" - - let mul z t = - match z with - | Int 0 -> [] - | Int 1 -> t - | _ -> List.map (fun (i,n) -> (i, mult_num z n)) t - - - let rec add v1 v2 = - match v1 , v2 with - | (x1,n1)::v1' , (x2,n2)::v2' -> - if x1 = x2 - then - let n' = n1 +/ n2 in - if n' =/ Int 0 then add v1' v2' - else - let res = add v1' v2' in - (x1,n') ::res - else if x1 < x2 - then let res = add v1' v2 in - (x1, n1)::res - else let res = add v1 v2' in - (x2, n2)::res - | [] , [] -> [] - | [] , _ -> v2 - | _ , [] -> v1 - - - - - let compare : t -> t -> int = Mutils.Cmp.compare_list (fun x y -> Mutils.Cmp.compare_lexical - [ - (fun () -> Int.compare (fst x) (fst y)); - (fun () -> compare_num (snd x) (snd y))]) - - (** [tail v vect] returns - - [None] if [v] is not a variable of the vector [vect] - - [Some(vl,rst)] where [vl] is the value of [v] in vector [vect] - and [rst] is the remaining of the vector - We exploit that vectors are ordered lists - *) - let rec tail (v:var) (vect:t) = - match vect with - | [] -> None - | (v',vl)::vect' -> - match Int.compare v' v with - | 0 -> Some (vl,vect) (* Ok, found *) - | -1 -> tail v vect' (* Might be in the tail *) - | _ -> None (* Hopeless *) - - let get v vect = - match tail v vect with - | None -> None - | Some(vl,_) -> Some vl - - - let rec fresh v = - match v with - | [] -> 1 - | [v,_] -> v + 1 - | _::v -> fresh v - end type vector = Vect.t -type cstr_compat = {coeffs : vector ; op : op ; cst : num} -and op = |Eq | Ge +type cstr = {coeffs : vector ; op : op ; cst : num} +and op = |Eq | Ge | Gt -let string_of_op = function Eq -> "=" | Ge -> ">=" +exception Strict -let output_cstr o {coeffs = coeffs ; op = op ; cst = cst} = - Printf.fprintf o "%a %s %s" Vect.pp_vect coeffs (string_of_op op) (string_of_num cst) +let is_strict c = Pervasives.(=) c.op Gt -let opMult o1 o2 = - match o1, o2 with - | Eq , Eq -> Eq - | Eq , Ge | Ge , Eq -> Ge - | Ge , Ge -> Ge - -open Big_int - -type prf_rule = - | Hyp of int - | Def of int - | Cst of big_int - | Zero - | Square of (Vect.t * num) - | MulC of (Vect.t * num) * prf_rule - | Gcd of big_int * prf_rule - | MulPrf of prf_rule * prf_rule - | AddPrf of prf_rule * prf_rule - | CutPrf of prf_rule - -type proof = - | Done - | Step of int * prf_rule * proof - | Enum of int * prf_rule * Vect.t * prf_rule * proof list - - -let rec output_prf_rule o = function - | Hyp i -> Printf.fprintf o "Hyp %i" i - | Def i -> Printf.fprintf o "Def %i" i - | Cst c -> Printf.fprintf o "Cst %s" (string_of_big_int c) - | Zero -> Printf.fprintf o "Zero" - | Square _ -> Printf.fprintf o "( )^2" - | MulC(p,pr) -> Printf.fprintf o "P * %a" output_prf_rule pr - | MulPrf(p1,p2) -> Printf.fprintf o "%a * %a" output_prf_rule p1 output_prf_rule p2 - | AddPrf(p1,p2) -> Printf.fprintf o "%a + %a" output_prf_rule p1 output_prf_rule p2 - | CutPrf(p) -> Printf.fprintf o "[%a]" output_prf_rule p - | Gcd(c,p) -> Printf.fprintf o "(%a)/%s" output_prf_rule p (string_of_big_int c) - -let rec output_proof o = function - | Done -> Printf.fprintf o "." - | Step(i,p,pf) -> Printf.fprintf o "%i:= %a ; %a" i output_prf_rule p output_proof pf - | Enum(i,p1,v,p2,pl) -> Printf.fprintf o "%i{%a<=%a<=%a}%a" i - output_prf_rule p1 Vect.pp_vect v output_prf_rule p2 - (pp_list output_proof) pl - -let rec pr_rule_max_id = function - | Hyp i | Def i -> i - | Cst _ | Zero | Square _ -> -1 - | MulC(_,p) | CutPrf p | Gcd(_,p) -> pr_rule_max_id p - | MulPrf(p1,p2)| AddPrf(p1,p2) -> max (pr_rule_max_id p1) (pr_rule_max_id p2) - -let rec proof_max_id = function - | Done -> -1 - | Step(i,pr,prf) -> max i (max (pr_rule_max_id pr) (proof_max_id prf)) - | Enum(i,p1,_,p2,l) -> - let m = max (pr_rule_max_id p1) (pr_rule_max_id p2) in - List.fold_left (fun i prf -> max i (proof_max_id prf)) (max i m) l - -let rec pr_rule_def_cut id = function - | MulC(p,prf) -> - let (bds,id',prf') = pr_rule_def_cut id prf in - (bds, id', MulC(p,prf')) - | MulPrf(p1,p2) -> - let (bds1,id,p1) = pr_rule_def_cut id p1 in - let (bds2,id,p2) = pr_rule_def_cut id p2 in - (bds2@bds1,id,MulPrf(p1,p2)) - | AddPrf(p1,p2) -> - let (bds1,id,p1) = pr_rule_def_cut id p1 in - let (bds2,id,p2) = pr_rule_def_cut id p2 in - (bds2@bds1,id,AddPrf(p1,p2)) - | CutPrf p -> - let (bds,id,p) = pr_rule_def_cut id p in - ((id,p)::bds,id+1,Def id) - | Gcd(c,p) -> - let (bds,id,p) = pr_rule_def_cut id p in - ((id,p)::bds,id+1,Def id) - | Square _|Cst _|Def _|Hyp _|Zero as x -> ([],id,x) - - -(* Do not define top-level cuts *) -let pr_rule_def_cut id = function - | CutPrf p -> - let (bds,ids,p') = pr_rule_def_cut id p in - bds,ids, CutPrf p' - | p -> pr_rule_def_cut id p - - -let rec implicit_cut p = - match p with - | CutPrf p -> implicit_cut p - | _ -> p - - -let rec normalise_proof id prf = - match prf with - | Done -> (id,Done) - | Step(i,Gcd(c,p),Done) -> normalise_proof id (Step(i,p,Done)) - | Step(i,p,prf) -> - let bds,id,p' = pr_rule_def_cut id p in - let (id,prf) = normalise_proof id prf in - let prf = List.fold_left (fun acc (i,p) -> Step(i, CutPrf p,acc)) - (Step(i,p',prf)) bds in - - (id,prf) - | Enum(i,p1,v,p2,pl) -> - (* Why do I have top-level cuts ? *) -(* let p1 = implicit_cut p1 in - let p2 = implicit_cut p2 in - let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in - (List.fold_left max 0 ids , - Enum(i,p1,v,p2,prfs)) -*) +let eval_op = function + | Eq -> (=/) + | Ge -> (>=/) + | Gt -> (>/) - let bds1,id,p1' = pr_rule_def_cut id (implicit_cut p1) in - let bds2,id,p2' = pr_rule_def_cut id (implicit_cut p2) in - let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in - (List.fold_left max 0 ids , - List.fold_left (fun acc (i,p) -> Step(i, CutPrf p,acc)) - (Enum(i,p1',v,p2',prfs)) (bds2@bds1)) +let string_of_op = function Eq -> "=" | Ge -> ">=" | Gt -> ">" -let normalise_proof id prf = - let res = normalise_proof id prf in - if debug then Printf.printf "normalise_proof %a -> %a" output_proof prf output_proof (snd res) ; - res +let output_cstr o {coeffs = coeffs ; op = op ; cst = cst} = + Printf.fprintf o "%a %s %s" Vect.pp coeffs (string_of_op op) (string_of_num cst) +let opMult o1 o2 = + match o1, o2 with + | Eq , _ | _ , Eq -> Eq + | Ge , _ | _ , Ge -> Ge + | Gt , Gt -> Gt -let add_proof x y = - match x, y with - | Zero , p | p , Zero -> p - | _ -> AddPrf(x,y) +let opAdd o1 o2 = + match o1, o2 with + | Eq , x | x , Eq -> x + | Gt , x | x , Gt -> Gt + | Ge , Ge -> Ge -let mul_proof c p = - match sign_big_int c with - | 0 -> Zero (* This is likely to be a bug *) - | -1 -> MulC(([],Big_int c),p) (* [p] should represent an equality *) - | 1 -> - if eq_big_int c unit_big_int - then p - else MulPrf(Cst c,p) - | _ -> assert false -let mul_proof_ext (p,c) prf = - match p with - | [] -> mul_proof (numerator c) prf - | _ -> MulC((p,c),prf) - +module LinPoly = struct + (** A linear polynomial a0 + a1.x1 + ... + an.xn + By convention, the constant a0 is the coefficient of the variable 0. + *) -module LinPoly = -struct - type t = Vect.t * num + type t = Vect.t - module MonT = - struct + module MonT = struct module MonoMap = Map.Make(Monomial) module IntMap = Map.Make(Int) - + (** A hash table might be preferable but requires a hash function. *) let (index_of_monomial : int MonoMap.t ref) = ref (MonoMap.empty) let (monomial_of_index : Monomial.t IntMap.t ref) = ref (IntMap.empty) let fresh = ref 0 - let clear () = + let clear () = index_of_monomial := MonoMap.empty; - monomial_of_index := IntMap.empty ; + monomial_of_index := IntMap.empty ; fresh := 0 - let register m = + let register m = try - MonoMap.find m !index_of_monomial - with Not_found -> - begin - let res = !fresh in - index_of_monomial := MonoMap.add m res !index_of_monomial ; - monomial_of_index := IntMap.add res m !monomial_of_index ; - incr fresh ; res - end + MonoMap.find m !index_of_monomial + with Not_found -> + begin + let res = !fresh in + index_of_monomial := MonoMap.add m res !index_of_monomial ; + monomial_of_index := IntMap.add res m !monomial_of_index ; + incr fresh ; res + end let retrieve i = IntMap.find i !monomial_of_index + let _ = register Monomial.const - end + end - let normalise (v,c) = - (List.sort (fun x y -> Int.compare (fst x) (fst y)) v , c) + let var v = Vect.set (MonT.register (Monomial.var v)) (Int 1) Vect.null + let of_monomial m = + let v = MonT.register m in + Vect.set v (Int 1) Vect.null - let output_mon o (x,v) = - Printf.fprintf o "%s.%a +" (string_of_num v) Monomial.pp (MonT.retrieve x) + let linpol_of_pol p = + Poly.fold + (fun mon num vct -> + let vr = MonT.register mon in + Vect.set vr num vct) p Vect.null + let pol_of_linpol v = + Vect.fold (fun p vr n -> Poly.add (MonT.retrieve vr) n p) (Poly.constant (Int 0)) v + let coq_poly_of_linpol cst p = - let output_cstr o {coeffs = coeffs ; op = op ; cst = cst} = - Printf.fprintf o "%a %s %s" (pp_list output_mon) coeffs (string_of_op op) (string_of_num cst) + let pol_of_mon m = + Monomial.fold (fun x v p -> Mc.PEmul(Mc.PEpow(Mc.PEX(CamlToCoq.positive x),CamlToCoq.n v),p)) m (Mc.PEc (cst (Int 1))) in + Vect.fold (fun acc x v -> + let mn = MonT.retrieve x in + Mc.PEadd(Mc.PEmul(Mc.PEc (cst v), pol_of_mon mn),acc)) (Mc.PEc (cst (Int 0))) p + let pp_var o vr = + try + Monomial.pp o (MonT.retrieve vr) (* this is a non-linear variable *) + with Not_found -> Printf.fprintf o "v%i" vr + + + let pp o p = Vect.pp_gen pp_var o p + + let constant c = + if sign_num c = 0 + then Vect.null + else Vect.set 0 c Vect.null + + + let is_linear p = + Vect.for_all (fun v _ -> + let mn = (MonT.retrieve v) in + Monomial.is_var mn || Monomial.is_const mn) p + + + let factorise x p = + let (px,cx) = Poly.factorise x (pol_of_linpol p) in + (linpol_of_pol px, linpol_of_pol cx) + + + let is_linear_for x p = + let (a,b) = factorise x p in + Vect.is_constant a + + let search_linear p l = + + Vect.find (fun x v -> + if p v + then + let x' = MonT.retrieve x in + match Monomial.get_var x' with + | None -> None + | Some x -> if is_linear_for x l + then Some x + else None + else None) l + + + let search_all_linear p l = + Vect.fold (fun acc x v -> + if p v + then + let x' = MonT.retrieve x in + match Monomial.get_var x' with + | None -> acc + | Some x -> + if is_linear_for x l + then x::acc + else acc + else acc) [] l + + + let product p1 p2 = + linpol_of_pol (Poly.product (pol_of_linpol p1) (pol_of_linpol p2)) + + let addition p1 p2 = Vect.add p1 p2 + + let variables p = Vect.fold + (fun acc v _ -> + ISet.union (Monomial.variables (MonT.retrieve v)) acc) ISet.empty p + + + let pp_goal typ o l = + let vars = List.fold_left (fun acc p -> ISet.union acc (variables (fst p))) ISet.empty l in + let pp_vars o i = ISet.iter (fun v -> Printf.fprintf o "(x%i : %s) " v typ) vars in + + Printf.fprintf o "forall %a\n" pp_vars vars ; + List.iteri (fun i (p,op) -> Printf.fprintf o "(H%i : %a %s 0)\n" i pp p (string_of_op op)) l; + Printf.fprintf o ", False\n" - let linpol_of_pol p = - let (v,c) = - Poly.fold - (fun mon num (vct,cst) -> - if Monomial.is_const mon then (vct,num) - else - let vr = MonT.register mon in - ((vr,num)::vct,cst)) p ([], Int 0) in - normalise (v,c) - let mult v m (vect,c) = - if Monomial.is_const m - then - (Vect.mul v vect, v <*> c) - else - if sign_num v <> 0 - then - let hd = - if sign_num c <> 0 - then [MonT.register m,v <*> c] - else [] in - - let vect = hd @ (List.map (fun (x,n) -> - let x = MonT.retrieve x in - let x_m = MonT.register (Monomial.prod m x) in - (x_m, v <*> n)) vect ) in - normalise (vect , Int 0) - else ([],Int 0) - let mult v m (vect,c) = - let (vect',c') = mult v m (vect,c) in - if debug then - Printf.printf "mult %s %a (%a,%s) -> (%a,%s)\n" (string_of_num v) Monomial.pp m - (pp_list output_mon) vect (string_of_num c) - (pp_list output_mon) vect' (string_of_num c') ; - (vect',c') + let collect_square p = + Vect.fold (fun acc v _ -> + let m = (MonT.retrieve v) in + match Monomial.sqrt m with + | None -> acc + | Some s -> MonMap.add s m acc + ) MonMap.empty p - let make_lin_pol v mon = - if Monomial.is_const mon - then [] , v - else [MonT.register mon, v],Int 0 - +end + +let output_nlin_cstr o {coeffs = coeffs ; op = op ; cst = cst} = + let p = LinPoly.pol_of_linpol coeffs in + + Printf.fprintf o "%a %s %s" Poly.pp p (string_of_op op) (string_of_num cst) + + +module ProofFormat = struct + open Big_int + + type prf_rule = + | Annot of string * prf_rule + | Hyp of int + | Def of int + | Cst of Num.num + | Zero + | Square of Vect.t + | MulC of Vect.t * prf_rule + | Gcd of Big_int.big_int * prf_rule + | MulPrf of prf_rule * prf_rule + | AddPrf of prf_rule * prf_rule + | CutPrf of prf_rule + + type proof = + | Done + | Step of int * prf_rule * proof + | Enum of int * prf_rule * Vect.t * prf_rule * proof list + + + let rec output_prf_rule o = function + | Annot(s,p) -> Printf.fprintf o "(%a)@%s" output_prf_rule p s + | Hyp i -> Printf.fprintf o "Hyp %i" i + | Def i -> Printf.fprintf o "Def %i" i + | Cst c -> Printf.fprintf o "Cst %s" (string_of_num c) + | Zero -> Printf.fprintf o "Zero" + | Square s -> Printf.fprintf o "(%a)^2" Poly.pp (LinPoly.pol_of_linpol s) + | MulC(p,pr) -> Printf.fprintf o "(%a) * %a" Poly.pp (LinPoly.pol_of_linpol p) output_prf_rule pr + | MulPrf(p1,p2) -> Printf.fprintf o "%a * %a" output_prf_rule p1 output_prf_rule p2 + | AddPrf(p1,p2) -> Printf.fprintf o "%a + %a" output_prf_rule p1 output_prf_rule p2 + | CutPrf(p) -> Printf.fprintf o "[%a]" output_prf_rule p + | Gcd(c,p) -> Printf.fprintf o "(%a)/%s" output_prf_rule p (string_of_big_int c) + + let rec output_proof o = function + | Done -> Printf.fprintf o "." + | Step(i,p,pf) -> Printf.fprintf o "%i:= %a ; %a" i output_prf_rule p output_proof pf + | Enum(i,p1,v,p2,pl) -> Printf.fprintf o "%i{%a<=%a<=%a}%a" i + output_prf_rule p1 Vect.pp v output_prf_rule p2 + (pp_list ";" output_proof) pl + + let rec pr_rule_max_id = function + | Annot(_,p) -> pr_rule_max_id p + | Hyp i | Def i -> i + | Cst _ | Zero | Square _ -> -1 + | MulC(_,p) | CutPrf p | Gcd(_,p) -> pr_rule_max_id p + | MulPrf(p1,p2)| AddPrf(p1,p2) -> max (pr_rule_max_id p1) (pr_rule_max_id p2) + + let rec proof_max_id = function + | Done -> -1 + | Step(i,pr,prf) -> max i (max (pr_rule_max_id pr) (proof_max_id prf)) + | Enum(i,p1,_,p2,l) -> + let m = max (pr_rule_max_id p1) (pr_rule_max_id p2) in + List.fold_left (fun i prf -> max i (proof_max_id prf)) (max i m) l + + + let rec pr_rule_def_cut id = function + | Annot(_,p) -> pr_rule_def_cut id p + | MulC(p,prf) -> + let (bds,id',prf') = pr_rule_def_cut id prf in + (bds, id', MulC(p,prf')) + | MulPrf(p1,p2) -> + let (bds1,id,p1) = pr_rule_def_cut id p1 in + let (bds2,id,p2) = pr_rule_def_cut id p2 in + (bds2@bds1,id,MulPrf(p1,p2)) + | AddPrf(p1,p2) -> + let (bds1,id,p1) = pr_rule_def_cut id p1 in + let (bds2,id,p2) = pr_rule_def_cut id p2 in + (bds2@bds1,id,AddPrf(p1,p2)) + | CutPrf p -> + let (bds,id,p) = pr_rule_def_cut id p in + ((id,p)::bds,id+1,Def id) + | Gcd(c,p) -> + let (bds,id,p) = pr_rule_def_cut id p in + ((id,p)::bds,id+1,Def id) + | Square _|Cst _|Def _|Hyp _|Zero as x -> ([],id,x) + + + (* Do not define top-level cuts *) + let pr_rule_def_cut id = function + | CutPrf p -> + let (bds,ids,p') = pr_rule_def_cut id p in + bds,ids, CutPrf p' + | p -> pr_rule_def_cut id p + + + let rec implicit_cut p = + match p with + | CutPrf p -> implicit_cut p + | _ -> p + + + let rec pr_rule_collect_hyps pr = + match pr with + | Annot(_,pr) -> pr_rule_collect_hyps pr + | Hyp i | Def i -> ISet.add i ISet.empty + | Cst _ | Zero | Square _ -> ISet.empty + | MulC(_,pr) | Gcd(_,pr)| CutPrf pr -> pr_rule_collect_hyps pr + | MulPrf(p1,p2) | AddPrf(p1,p2) -> ISet.union (pr_rule_collect_hyps p1) (pr_rule_collect_hyps p2) + + let simplify_proof p = + let rec simplify_proof p = + match p with + | Done -> (Done, ISet.empty) + | Step(i,pr,Done) -> (p, ISet.add i (pr_rule_collect_hyps pr)) + | Step(i,pr,prf) -> + let (prf',hyps) = simplify_proof prf in + if not (ISet.mem i hyps) + then (prf',hyps) + else + (Step(i,pr,prf'), ISet.add i (ISet.union (pr_rule_collect_hyps pr) hyps)) + | Enum(i,p1,v,p2,pl) -> + let (pl,hl) = List.split (List.map simplify_proof pl) in + let hyps = List.fold_left ISet.union ISet.empty hl in + (Enum(i,p1,v,p2,pl),ISet.add i (ISet.union (ISet.union (pr_rule_collect_hyps p1) (pr_rule_collect_hyps p2)) hyps)) in + fst (simplify_proof p) + + + let rec normalise_proof id prf = + match prf with + | Done -> (id,Done) + | Step(i,Gcd(c,p),Done) -> normalise_proof id (Step(i,p,Done)) + | Step(i,p,prf) -> + let bds,id,p' = pr_rule_def_cut id p in + let (id,prf) = normalise_proof id prf in + let prf = List.fold_left (fun acc (i,p) -> Step(i, CutPrf p,acc)) + (Step(i,p',prf)) bds in + + (id,prf) + | Enum(i,p1,v,p2,pl) -> + (* Why do I have top-level cuts ? *) + (* let p1 = implicit_cut p1 in + let p2 = implicit_cut p2 in + let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in + (List.fold_left max 0 ids , + Enum(i,p1,v,p2,prfs)) + *) + + let bds1,id,p1' = pr_rule_def_cut id (implicit_cut p1) in + let bds2,id,p2' = pr_rule_def_cut id (implicit_cut p2) in + let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in + (List.fold_left max 0 ids , + List.fold_left (fun acc (i,p) -> Step(i, CutPrf p,acc)) + (Enum(i,p1',v,p2',prfs)) (bds2@bds1)) + + + let normalise_proof id prf = + let prf = simplify_proof prf in + let res = normalise_proof id prf in + if debug then Printf.printf "normalise_proof %a -> %a" output_proof prf output_proof (snd res) ; + res + + + + let add_proof x y = + match x, y with + | Zero , p | p , Zero -> p + | _ -> AddPrf(x,y) + + + let mul_cst_proof c p = + match sign_num c with + | 0 -> Zero (* This is likely to be a bug *) + | -1 -> MulC(LinPoly.constant c,p) (* [p] should represent an equality *) + | 1 -> + if eq_num (Int 1) c + then p + else MulPrf(Cst c,p) + | _ -> assert false + let mul_proof p1 p2 = + match p1 , p2 with + | Zero , _ | _ , Zero -> Zero + | Cst (Int 1) , p | p , Cst (Int 1) -> p + | _ , _ -> MulPrf(p1,p2) - let xpivot_eq (c,prf) x v (c',prf') = - if debug then Printf.printf "xpivot_eq {%a} %a %s {%a}\n" - output_cstr c - Monomial.pp (MonT.retrieve x) - (string_of_num v) output_cstr c' ; + let proof_of_farkas env vect = + Vect.fold (fun prf x n -> + add_proof (mul_cst_proof n (IMap.find x env)) prf) Zero vect - let {coeffs = coeffs ; op = op ; cst = cst} = c' in - let m = MonT.retrieve x in - let apply_pivot (vqn,q,n) (c',prf') = - (* Morally, we have (Vect.get (q*x^n) c'.coeffs) = vmn with n >=0 *) + module Env = struct - let cc' = abs_num v in - let cc_num = Int (- (sign_num v)) <*> vqn in - let cc_mon = Monomial.prod q (Monomial.exp m (n-1)) in + let rec string_of_int_list l = + match l with + | [] -> "" + | i::l -> Printf.sprintf "%i,%s" i (string_of_int_list l) - let (c_coeff,c_cst) = mult cc_num cc_mon (c.coeffs, minus_num c.cst) in - - let c' = {coeffs = Vect.add (Vect.mul cc' c'.coeffs) c_coeff ; op = op ; cst = (minus_num c_cst) <+> (cc' <*> c'.cst)} in - let prf' = add_proof - (mul_proof_ext (make_lin_pol cc_num cc_mon) prf) - (mul_proof (numerator cc') prf') in - if debug then Printf.printf "apply_pivot -> {%a}\n" output_cstr c' ; - (c',prf') in + let id_of_hyp hyp l = + let rec xid_of_hyp i l' = + match l' with + | [] -> failwith (Printf.sprintf "id_of_hyp %i %s" hyp (string_of_int_list l)) + | hyp'::l' -> if Pervasives.(=) hyp hyp' then i else xid_of_hyp (i+1) l' in + xid_of_hyp 0 l + end + + let cmpl_prf_rule norm (cst:num-> 'a) env prf = + let rec cmpl = + function + | Annot(s,p) -> cmpl p + | Hyp i | Def i -> Mc.PsatzIn (CamlToCoq.nat (Env.id_of_hyp i env)) + | Cst i -> Mc.PsatzC (cst i) + | Zero -> Mc.PsatzZ + | MulPrf(p1,p2) -> Mc.PsatzMulE(cmpl p1, cmpl p2) + | AddPrf(p1,p2) -> Mc.PsatzAdd(cmpl p1 , cmpl p2) + | MulC(lp,p) -> let lp = norm (LinPoly.coq_poly_of_linpol cst lp) in + Mc.PsatzMulC(lp,cmpl p) + | Square lp -> Mc.PsatzSquare (norm (LinPoly.coq_poly_of_linpol cst lp)) + | _ -> failwith "Cuts should already be compiled" in + cmpl prf + + + + + let cmpl_prf_rule_z env r = cmpl_prf_rule Mc.normZ (fun x -> CamlToCoq.bigint (numerator x)) env r + + let rec cmpl_proof env = function + | Done -> Mc.DoneProof + | Step(i,p,prf) -> + begin + match p with + | CutPrf p' -> + Mc.CutProof(cmpl_prf_rule_z env p', cmpl_proof (i::env) prf) + | _ -> Mc.RatProof(cmpl_prf_rule_z env p,cmpl_proof (i::env) prf) + end + | Enum(i,p1,_,p2,l) -> + Mc.EnumProof(cmpl_prf_rule_z env p1,cmpl_prf_rule_z 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 + cmpl_proof env prf + + let rec eval_prf_rule env = function + | Annot(s,p) -> eval_prf_rule env p + | Hyp i | Def i -> env i + | Cst n -> (Vect.set 0 n Vect.null, + match Num.compare_num n (Int 0) with + | 0 -> Ge + | 1 -> Gt + | _ -> failwith "eval_prf_rule : negative constant" + ) + | Zero -> (Vect.null, Ge) + | Square v -> (LinPoly.product v v,Ge) + | MulC(v, p) -> + let (p1,o) = eval_prf_rule env p in + begin match o with + | Eq -> (LinPoly.product v p1,Eq) + | _ -> + Printf.fprintf stdout "MulC(%a,%a) invalid 2d arg %a %s" Vect.pp v output_prf_rule p Vect.pp p1 (string_of_op o); + failwith "eval_prf_rule : not an equality" + end + | Gcd(g,p) -> let (v,op) = eval_prf_rule env p in + (Vect.div (Big_int g) v, op) + | MulPrf(p1,p2) -> + let (v1,o1) = eval_prf_rule env p1 in + let (v2,o2) = eval_prf_rule env p2 in + (LinPoly.product v1 v2, opMult o1 o2) + | AddPrf(p1,p2) -> + let (v1,o1) = eval_prf_rule env p1 in + let (v2,o2) = eval_prf_rule env p2 in + (LinPoly.addition v1 v2, opAdd o1 o2) + | CutPrf p -> eval_prf_rule env p + + + let is_unsat (p,o) = + let (c,r) = Vect.decomp_cst p in + if Vect.is_null r + then not (eval_op o c (Int 0)) + else false + + let rec eval_proof env p = + match p with + | Done -> failwith "Proof is not finished" + | Step(i, prf, rst) -> + let (p,o) = eval_prf_rule (fun i -> IMap.find i env) prf in + if is_unsat (p,o) then true + else + if Pervasives.(=) rst Done + then + begin + Printf.fprintf stdout "Last inference %a %s\n" LinPoly.pp p (string_of_op o); + false + end + else eval_proof (IMap.add i (p,o) env) rst + | Enum(i,r1,v,r2,l) -> let _ = eval_prf_rule (fun i -> IMap.find i env) r1 in + let _ = eval_prf_rule (fun i -> IMap.find i env) r2 in + (* Should check bounds *) + failwith "Not implemented" + +end + +module WithProof = struct + + type t = ((LinPoly.t * op) * ProofFormat.prf_rule) + + let annot s (p,prf) = (p, ProofFormat.Annot(s,prf)) + + let output o ((lp,op),prf) = + Printf.fprintf o "%a %s 0 by %a\n" LinPoly.pp lp (string_of_op op) ProofFormat.output_prf_rule prf - let cmp (q,n) (q',n') = - if n < n' then -1 - else if n = n' then Monomial.compare q q' - else 1 in + exception InvalidProof - - let find_pivot (c',prf') = - let (v,q,n) = List.fold_left - (fun (v,q,n) (x,v') -> - let x = MonT.retrieve x in - let (q',n') = Monomial.div x m in - if cmp (q,n) (q',n') = -1 then (v',q',n') else (v,q,n)) (Int 0, Monomial.const,0) c'.coeffs in - if n > 0 then Some (v,q,n) else None in + let zero = ((Vect.null,Eq), ProofFormat.Zero) - let rec pivot (q,n) (c',prf') = - match find_pivot (c',prf') with - | None -> (c',prf') - | Some(v,q',n') -> - if cmp (q',n') (q,n) = -1 - then pivot (q',n') (apply_pivot (v,q',n') (c',prf')) - else (c',prf') in - pivot (Monomial.const,max_int) (c',prf') + let of_cstr (c,prf) = + (Vect.set 0 (Num.minus_num (c.cst)) c.coeffs,c.op), prf + let product : t -> t -> t = fun ((p1,o1),prf1) ((p2,o2),prf2) -> + ((LinPoly.product p1 p2 , opMult o1 o2), ProofFormat.mul_proof prf1 prf2) - let pivot_eq x (c,prf) = - match Vect.get x c.coeffs with - | None -> (fun x -> None) - | Some v -> fun cp' -> Some (xpivot_eq (c,prf) x v cp') + let addition : t -> t -> t = fun ((p1,o1),prf1) ((p2,o2),prf2) -> + ((Vect.add p1 p2, opAdd o1 o2), ProofFormat.add_proof prf1 prf2) + let mult p ((p1,o1),prf1) = + match o1 with + | Eq -> ((LinPoly.product p p1,o1), ProofFormat.MulC(p, prf1)) + | Gt| Ge -> let (n,r) = Vect.decomp_cst p in + if Vect.is_null r && n >/ Int 0 + then ((LinPoly.product p p1, o1), ProofFormat.mul_cst_proof n prf1) + else raise InvalidProof + + + let cutting_plane ((p,o),prf) = + let (c,p') = Vect.decomp_cst p in + let g = (Vect.gcd p') in + if (Big_int.eq_big_int Big_int.unit_big_int g) || c =/ Int 0 || + not (Big_int.eq_big_int (denominator c) Big_int.unit_big_int) + then None (* Nothing to do *) + else + let c1 = c // (Big_int g) in + let c1' = Num.floor_num c1 in + if c1 =/ c1' + then None + else + match o with + | Eq -> Some ((Vect.set 0 (Int (-1)) Vect.null,Eq), ProofFormat.Gcd(g,prf)) + | Gt -> failwith "cutting_plane ignore strict constraints" + | Ge -> + (* This is a non-trivial common divisor *) + Some ((Vect.set 0 c1' (Vect.div (Big_int g) p),o),ProofFormat.Gcd(g, prf)) + + + let construct_sign p = + let (c,p') = Vect.decomp_cst p in + if Vect.is_null p' + then + Some (begin match sign_num c with + | 0 -> (true, Eq, ProofFormat.Zero) + | 1 -> (true,Gt, ProofFormat.Cst c) + | _ (*-1*) -> (false,Gt, ProofFormat.Cst (minus_num c)) + end) + else None + + + let get_sign l p = + match construct_sign p with + | None -> begin + try + let ((p',o),prf) = + List.find (fun ((p',o),prf) -> Vect.equal p p') l in + Some (true,o,prf) + with Not_found -> + let p = Vect.uminus p in + try + let ((p',o),prf) = List.find (fun ((p',o),prf) -> Vect.equal p p') l in + Some (false,o,prf) + with Not_found -> None + end + | Some s -> Some s + + + let mult_sign : bool -> t -> t = fun b ((p,o),prf) -> + if b then ((p,o),prf) + else ((Vect.uminus p,o),prf) + + + let rec linear_pivot sys ((lp1,op1), prf1) x ((lp2,op2), prf2) = + + (* lp1 = a1.x + b1 *) + let (a1,b1) = LinPoly.factorise x lp1 in + + (* lp2 = a2.x + b2 *) + let (a2,b2) = LinPoly.factorise x lp2 in + + if Vect.is_null a2 + then (* We are done *) + Some ((lp2,op2),prf2) + else + match op1,op2 with + | Eq , (Ge|Gt) -> begin + match get_sign sys a1 with + | None -> None (* Impossible to pivot without sign information *) + | Some(b,o,prf) -> + let sa1 = mult_sign b ((a1,o),prf) in + let sa2 = if b then (Vect.uminus a2) else a2 in + + let ((lp2,op2),prf2) = + addition (product sa1 ((lp2,op2),prf2)) + (mult sa2 ((lp1,op1),prf1)) in + linear_pivot sys ((lp1,op1),prf1) x ((lp2,op2),prf2) + + end + | Eq , Eq -> + let ((lp2,op2),prf2) = addition (mult a1 ((lp2,op2),prf2)) + (mult (Vect.uminus a2) ((lp1,op1),prf1)) in + linear_pivot sys ((lp1,op1),prf1) x ((lp2,op2),prf2) + + | (Ge | Gt) , (Ge| Gt) -> begin + match get_sign sys a1 , get_sign sys a2 with + | Some(b1,o1,p1) , Some(b2,o2,p2) -> + if b1 <> b2 + then + let ((lp2,op2),prf2) = + addition (product (mult_sign b1 ((a1,o1), p1)) ((lp2,op2),prf2)) + (product (mult_sign b2 ((a2,o2), p2)) ((lp1,op1),prf1)) in + linear_pivot sys ((lp1,op1),prf1) x ((lp2,op2),prf2) + else None + | _ -> None + end + | (Ge|Gt) , Eq -> failwith "pivot: equality as second argument" end + + +(* Local Variables: *) +(* coding: utf-8 *) +(* End: *) diff --git a/plugins/micromega/polynomial.mli b/plugins/micromega/polynomial.mli index 4c095202ab..6f26f7a959 100644 --- a/plugins/micromega/polynomial.mli +++ b/plugins/micromega/polynomial.mli @@ -8,111 +8,329 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Mutils + +module Mc = Micromega + +val max_nb_cstr : int ref + type var = int module Monomial : sig - + (** A monomial is represented by a multiset of variables *) type t + + (** [fold f m acc] + folds over the variables with multiplicities *) val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a + + (** [const] + @return the empty monomial i.e. without any variable *) val const : t + + (** [var x] + @return the monomial x^1 *) + val var : var -> t + + (** [sqrt m] + @return [Some r] iff r^2 = m *) val sqrt : t -> t option + + (** [is_var m] + @return [true] iff m = x^1 for some variable x *) val is_var : t -> bool + + (** [div m1 m2] + @return a pair [mr,n] such that mr * (m2)^n = m1 where n is maximum *) val div : t -> t -> t * int + (** [compare m1 m2] provides a total order over monomials*) val compare : t -> t -> int + (** [variables m] + @return the set of variables with (strictly) positive multiplicities *) + val variables : t -> ISet.t +end + +module MonMap : sig + include Map.S with type key = Monomial.t + + val union : (Monomial.t -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t end module Poly : sig + (** Representation of polonomial with rational coefficient. + a1.m1 + ... + c where + - ai are rational constants (num type) + - mi are monomials + - c is a rational constant + + *) type t + (** [constant c] + @return the constant polynomial c *) val constant : Num.num -> t + + (** [variable x] + @return the polynomial 1.x^1 *) val variable : var -> t + + (** [addition p1 p2] + @return the polynomial p1+p2 *) val addition : t -> t -> t + + (** [product p1 p2] + @return the polynomial p1*p2 *) val product : t -> t -> t + + (** [uminus p] + @return the polynomial -p i.e product by -1 *) val uminus : t -> t + + (** [get mi p] + @return the coefficient ai of the monomial mi. *) val get : Monomial.t -> t -> Num.num + + + (** [fold f p a] folds f over the monomials of p with non-zero coefficient *) val fold : (Monomial.t -> Num.num -> 'a -> 'a) -> t -> 'a -> 'a + (** [is_linear p] + @return true if the polynomial is of the form a1.x1 +...+ an.xn + c + i.e every monomial is made of at most a variable *) val is_linear : t -> bool + + (** [add m n p] + @return the polynomial n*m + p *) val add : Monomial.t -> Num.num -> t -> t + (** [variables p] + @return the set of variables of the polynomial p *) + val variables : t -> ISet.t + end -module Vect : sig +type cstr = {coeffs : Vect.t ; op : op ; cst : Num.num} (** Representation of linear constraints *) +and op = Eq | Ge | Gt - type var = int - type t = (var * Num.num) list - val hash : t -> int - val equal : t -> t -> bool - val compare : t -> t -> int - val pp_vect : 'a -> t -> unit +val eval_op : op -> Num.num -> Num.num -> bool + +(*val opMult : op -> op -> op*) + +val opAdd : op -> op -> op + +(** [is_strict c] + @return whether the constraint is strict i.e. c.op = Gt *) +val is_strict : cstr -> bool + +exception Strict + +module LinPoly : sig + (** Linear(ised) polynomials represented as a [Vect.t] + i.e a sorted association list. + The constant is the coefficient of the variable 0 + + Each linear polynomial can be interpreted as a multi-variate polynomial. + There is a bijection mapping between a linear variable and a monomial + (see module [MonT]) + *) + + type t = Vect.t + + (** Each variable of a linear polynomial is mapped to a monomial. + This is done using the monomial tables of the module MonT. *) + + module MonT : sig + (** [clear ()] clears the mapping. *) + val clear : unit -> unit + + (** [retrieve x] + @return the monomial corresponding to the variable [x] *) + val retrieve : int -> Monomial.t + + end + + (** [linpol_of_pol p] linearise the polynomial p *) + val linpol_of_pol : Poly.t -> t + + (** [var x] + @return 1.y where y is the variable index of the monomial x^1. + *) + val var : var -> t - val get : var -> t -> Num.num option - val set : var -> Num.num -> t -> t - val fresh : (int * 'a) list -> int - val update : Int.t -> (Num.num -> Num.num) -> - (Int.t * Num.num) list -> (Int.t * Num.num) list - val null : t + (** [coq_poly_of_linpol c p] + @param p is a multi-variate polynomial. + @param c maps a rational to a Coq polynomial coefficient. + @return the coq expression corresponding to polynomial [p].*) + val coq_poly_of_linpol : (Num.num -> 'a) -> t -> 'a Mc.pExpr - val from_list : Num.num list -> t - val to_list : t -> Num.num list + (** [of_monomial m] + @returns 1.x where x is the variable (index) for monomial m *) + val of_monomial : Monomial.t -> t - val add : t -> t -> t - val mul : Num.num -> t -> t + (** [variables p] + @return the set of variables of the polynomial p + interpreted as a multi-variate polynomial *) + val variables : t -> ISet.t + + (** [is_linear p] + @return whether the multi-variate polynomial is linear. *) + val is_linear : t -> bool + + (** [is_linear_for x p] + @return true if the polynomial is linear in x + i.e can be written c*x+r where c is a constant and r is independent from x *) + val is_linear_for : var -> t -> bool + + (** [constant c] + @return the constant polynomial c + *) + val constant : Num.num -> t + + (** [search_linear pred p] + @return a variable x such p = a.x + b such that + p is linear in x i.e x does not occur in b and + a is a constant such that [pred a] *) + + val search_linear : (Num.num -> bool) -> t -> var option + + (** [search_all_linear pred p] + @return all the variables x such p = a.x + b such that + p is linear in x i.e x does not occur in b and + a is a constant such that [pred a] *) + val search_all_linear : (Num.num -> bool) -> t -> var list + + (** [product p q] + @return the product of the polynomial [p*q] *) + val product : t -> t -> t + + (** [factorise x p] + @return [a,b] such that [p = a.x + b] + and [x] does not occur in [b] *) + val factorise : var -> t -> t * t + + (** [collect_square p] + @return a mapping m such that m[s] = s^2 + for every s^2 that is a monomial of [p] *) + val collect_square : t -> Monomial.t MonMap.t + + + (** [pp_var o v] pretty-prints a monomial indexed by v. *) + val pp_var : out_channel -> var -> unit + + (** [pp o p] pretty-prints a polynomial. *) + val pp : out_channel -> t -> unit + + (** [pp_goal typ o l] pretty-prints the list of constraints as a Coq goal. *) + val pp_goal : string -> out_channel -> (t * op) list -> unit end -type cstr_compat = {coeffs : Vect.t ; op : op ; cst : Num.num} -and op = Eq | Ge +module ProofFormat : sig + (** Proof format used by the proof-generating procedures. + It is fairly close to Coq format but a bit more liberal. -type prf_rule = - | Hyp of int - | Def of int - | Cst of Big_int.big_int - | Zero - | Square of (Vect.t * Num.num) - | MulC of (Vect.t * Num.num) * prf_rule - | Gcd of Big_int.big_int * prf_rule - | MulPrf of prf_rule * prf_rule - | AddPrf of prf_rule * prf_rule - | CutPrf of prf_rule + It is used for proofs over Z, Q, R. + However, certain constructions e.g. [CutPrf] are only relevant for Z. + *) -type proof = - | Done - | Step of int * prf_rule * proof - | Enum of int * prf_rule * Vect.t * prf_rule * proof list + type prf_rule = + | Annot of string * prf_rule + | Hyp of int + | Def of int + | Cst of Num.num + | Zero + | Square of Vect.t + | MulC of Vect.t * prf_rule + | Gcd of Big_int.big_int * prf_rule + | MulPrf of prf_rule * prf_rule + | AddPrf of prf_rule * prf_rule + | CutPrf of prf_rule -val proof_max_id : proof -> int + type proof = + | Done + | Step of int * prf_rule * proof + | Enum of int * prf_rule * Vect.t * prf_rule * proof list -val normalise_proof : int -> proof -> int * proof + val pr_rule_max_id : prf_rule -> int -val output_proof : out_channel -> proof -> unit + val proof_max_id : proof -> int -val add_proof : prf_rule -> prf_rule -> prf_rule -val mul_proof : Big_int.big_int -> prf_rule -> prf_rule + val normalise_proof : int -> proof -> int * proof -module LinPoly : sig + val output_prf_rule : out_channel -> prf_rule -> unit - type t = Vect.t * Num.num + val output_proof : out_channel -> proof -> unit - module MonT : sig + val add_proof : prf_rule -> prf_rule -> prf_rule - val clear : unit -> unit - val retrieve : int -> Monomial.t + val mul_cst_proof : Num.num -> prf_rule -> prf_rule - end + val mul_proof : prf_rule -> prf_rule -> prf_rule - val pivot_eq : Vect.var -> - cstr_compat * prf_rule -> - cstr_compat * prf_rule -> (cstr_compat * prf_rule) option + val compile_proof : int list -> proof -> Micromega.zArithProof - val linpol_of_pol : Poly.t -> t + val cmpl_prf_rule : ('a Micromega.pExpr -> 'a Micromega.pol) -> + (Num.num -> 'a) -> (int list) -> prf_rule -> 'a Micromega.psatz + + val proof_of_farkas : prf_rule IMap.t -> Vect.t -> prf_rule + + val eval_prf_rule : (int -> LinPoly.t * op) -> prf_rule -> LinPoly.t * op + + val eval_proof : (LinPoly.t * op) IMap.t -> proof -> bool end -val output_cstr : out_channel -> cstr_compat -> unit +val output_cstr : out_channel -> cstr -> unit + +val output_nlin_cstr : out_channel -> cstr -> unit val opMult : op -> op -> op + +(** [module WithProof] constructs polynomials packed with the proof that their sign is correct. *) +module WithProof : +sig + + type t = (LinPoly.t * op) * ProofFormat.prf_rule + + (** [InvalidProof] is raised if the operation is invalid. *) + exception InvalidProof + + val annot : string -> t -> t + + val of_cstr : cstr * ProofFormat.prf_rule -> t + + (** [out_channel chan c] pretty-prints the constraint [c] over the channel [chan] *) + val output : out_channel -> t -> unit + + (** [zero] represents the tautology (0=0) *) + val zero : t + + (** [product p q] + @return the polynomial p*q with its sign and proof *) + val product : t -> t -> t + + (** [addition p q] + @return the polynomial p+q with its sign and proof *) + val addition : t -> t -> t + + (** [mult p q] + @return the polynomial p*q with its sign and proof. + @raise InvalidProof if p is not a constant and p is not an equality *) + val mult : LinPoly.t -> t -> t + + (** [cutting_plane p] does integer reasoning and adjust the constant to be integral *) + val cutting_plane : t -> t option + + (** [linear_pivot sys p x q] + @return the polynomial [q] where [x] is eliminated using the polynomial [p] + The pivoting operation is only defined if + - p is linear in x i.e p = a.x+b and x neither occurs in a and b + - The pivoting also requires some sign conditions for [a] + *) + val linear_pivot : t list -> t -> Vect.var -> t -> t option + +end diff --git a/plugins/micromega/simplex.ml b/plugins/micromega/simplex.ml new file mode 100644 index 0000000000..8d8c6ea90b --- /dev/null +++ b/plugins/micromega/simplex.ml @@ -0,0 +1,621 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** A naive simplex *) +open Polynomial +open Num +open Util +open Mutils + +let debug = false + +type iset = unit IMap.t + +type tableau = Vect.t IMap.t (** Mapping basic variables to their equation. + All variables >= than a threshold rst are restricted.*) +module Restricted = + struct + type t = + { + base : int; (** All variables above [base] are restricted *) + exc : int option (** Except [exc] which is currently optimised *) + } + + let pp o {base;exc} = + Printf.fprintf o ">= %a " LinPoly.pp_var base; + match exc with + | None ->Printf.fprintf o "-" + | Some x ->Printf.fprintf o "-%a" LinPoly.pp_var base + + let is_exception (x:var) (r:t) = + match r.exc with + | None -> false + | Some x' -> x = x' + + let restrict x rst = + if is_exception x rst + then + {base = rst.base;exc= None} + else failwith (Printf.sprintf "Cannot restrict %i" x) + + + let is_restricted x r0 = + x >= r0.base && not (is_exception x r0) + + let make x = {base = x ; exc = None} + + let set_exc x rst = {base = rst.base ; exc = Some x} + + let fold rst f m acc = + IMap.fold (fun k v acc -> + if is_exception k rst then acc + else f k v acc) (IMap.from rst.base m) acc + + end + + + +let pp_row o v = LinPoly.pp o v + +let output_tableau o t = + IMap.iter (fun k v -> + Printf.fprintf o "%a = %a\n" LinPoly.pp_var k pp_row v) t + +let output_vars o m = + IMap.iter (fun k _ -> Printf.fprintf o "%a " LinPoly.pp_var k) m + + +(** A tableau is feasible iff for every basic restricted variable xi, + we have ci>=0. + + When all the non-basic variables are set to 0, the value of a basic + variable xi is necessarily ci. If xi is restricted, it is feasible + if ci>=0. + *) + + +let unfeasible (rst:Restricted.t) tbl = + Restricted.fold rst (fun k v m -> + if Vect.get_cst v >=/ Int 0 then m + else IMap.add k () m) tbl IMap.empty + + +let is_feasible rst tb = IMap.is_empty (unfeasible rst tb) + +(** Let a1.x1+...+an.xn be a vector of non-basic variables. + It is maximised if all the xi are restricted + and the ai are negative. + + If xi>= 0 (restricted) and ai is negative, + the maximum for ai.xi is obtained for xi = 0 + + Otherwise, it is possible to make ai.xi arbitrarily big: + - if xi is not restricted, take +/- oo depending on the sign of ai + - if ai is positive, take +oo + *) + +let is_maximised_vect rst v = + Vect.for_all (fun xi ai -> + if ai >/ Int 0 + then false + else Restricted.is_restricted xi rst) v + + +(** [is_maximised rst v] + @return None if the variable is not maximised + @return Some v where v is the maximal value + *) +let is_maximised rst v = + try + let (vl,v) = Vect.decomp_cst v in + if is_maximised_vect rst v + then Some vl + else None + with Not_found -> None + +(** A variable xi is unbounded if for every + equation xj= ...ai.xi ... + if ai < 0 then xj is not restricted. + As a result, even if we + increase the value of xi, it is always + possible to adjust the value of xj without + violating a restriction. + *) + +(* let is_unbounded rst tbl vr = + IMap.for_all (fun x v -> if Vect.get vr v </ Int 0 + then not (IMap.mem vr rst) + else true + ) tbl + *) + +type result = + | Max of num (** Maximum is reached *) + | Ubnd of var (** Problem is unbounded *) + | Feas (** Problem is feasible *) + +type pivot = + | Done of result + | Pivot of int * int * num + + + + +type simplex = + | Opt of tableau * result + +(** For a row, x = ao.xo+...+ai.xi + a valid pivot variable is such that it can improve the value of xi. + it is the case, if xi is unrestricted (increase if ai> 0, decrease if ai < 0) + xi is restricted but ai > 0 + +This is the entering variable. + *) + +let rec find_pivot_column (rst:Restricted.t) (r:Vect.t) = + match Vect.choose r with + | None -> failwith "find_pivot_column" + | Some(xi,ai,r') -> if ai </ Int 0 + then if Restricted.is_restricted xi rst + then find_pivot_column rst r' (* ai.xi cannot be improved *) + else (xi, -1) (* r is not restricted, sign of ai does not matter *) + else (* ai is positive, xi can be increased *) + (xi,1) + +(** Finding the variable leaving the basis is more subtle because we need to: + - increase the objective function + - make sure that the entering variable has a feasible value + - but also that after pivoting all the other basic variables are still feasible. + This explains why we choose the pivot with the smallest score + *) + +let min_score s (i1,sc1) = + match s with + | None -> Some (i1,sc1) + | Some(i0,sc0) -> + if sc0 </ sc1 then s + else if sc1 </ sc0 then Some (i1,sc1) + else if i0 < i1 then s else Some(i1,sc1) + +let find_pivot_row rst tbl j sgn = + Restricted.fold rst + (fun i' v res -> + let aij = Vect.get j v in + if (Int sgn) */ aij </ Int 0 + then (* This would improve *) + let score' = Num.abs_num ((Vect.get_cst v) // aij) in + min_score res (i',score') + else res) tbl None + +let safe_find err x t = + try + IMap.find x t + with Not_found -> + if debug + then Printf.fprintf stdout "safe_find %s x%i %a\n" err x output_tableau t; + failwith err + + +(** [find_pivot vr t] aims at improving the objective function of the basic variable vr *) +let find_pivot vr (rst:Restricted.t) tbl = + (* Get the objective of the basic variable vr *) + let v = safe_find "find_pivot" vr tbl in + match is_maximised rst v with + | Some mx -> Done (Max mx) (* Maximum is reached; we are done *) + | None -> + (* Extract the vector *) + let (_,v) = Vect.decomp_cst v in + let (j',sgn) = find_pivot_column rst v in + match find_pivot_row rst (IMap.remove vr tbl) j' sgn with + | None -> Done (Ubnd j') + | Some (i',sc) -> Pivot(i', j', sc) + +(** [solve_column c r e] + @param c is a non-basic variable + @param r is a basic variable + @param e is a vector such that r = e + and e is of the form ai.c+e' + @return the vector (-r + e').-1/ai i.e + c = (r - e')/ai + *) + +let solve_column (c : var) (r : var) (e : Vect.t) : Vect.t = + let a = Vect.get c e in + if a =/ Int 0 + then failwith "Cannot solve column" + else + let a' = (Int (-1) // a) in + Vect.mul a' (Vect.set r (Int (-1)) (Vect.set c (Int 0) e)) + +(** [pivot_row r c e] + @param c is such that c = e + @param r is a vector r = g.c + r' + @return g.e+r' *) + +let pivot_row (row: Vect.t) (c : var) (e : Vect.t) : Vect.t = + let g = Vect.get c row in + if g =/ Int 0 + then row + else Vect.mul_add g e (Int 1) (Vect.set c (Int 0) row) + +let pivot_with (m : tableau) (v: var) (p : Vect.t) = + IMap.map (fun (r:Vect.t) -> pivot_row r v p) m + +let pivot (m : tableau) (r : var) (c : var) = + let row = safe_find "pivot" r m in + let piv = solve_column c r row in + IMap.add c piv (pivot_with (IMap.remove r m) c piv) + + +let adapt_unbounded vr x rst tbl = + if Vect.get_cst (IMap.find vr tbl) >=/ Int 0 + then tbl + else pivot tbl vr x + +module BaseSet = Set.Make(struct type t = iset let compare = IMap.compare (fun x y -> 0) end) + +let get_base tbl = IMap.mapi (fun k _ -> ()) tbl + +let simplex opt vr rst tbl = + let b = ref BaseSet.empty in + +let rec simplex opt vr rst tbl = + + if debug then begin + let base = get_base tbl in + if BaseSet.mem base !b + then Printf.fprintf stdout "Cycling detected\n" + else b := BaseSet.add base !b + end; + + if debug && not (is_feasible rst tbl) + then + begin + let m = unfeasible rst tbl in + Printf.fprintf stdout "Simplex error\n"; + Printf.fprintf stdout "The current tableau is not feasible\n"; + Printf.fprintf stdout "Restricted >= %a\n" Restricted.pp rst ; + output_tableau stdout tbl; + Printf.fprintf stdout "Error for variables %a\n" output_vars m + end; + + if not opt && (Vect.get_cst (IMap.find vr tbl) >=/ Int 0) + then Opt(tbl,Feas) + else + match find_pivot vr rst tbl with + | Done r -> + begin match r with + | Max _ -> Opt(tbl, r) + | Ubnd x -> + let t' = adapt_unbounded vr x rst tbl in + Opt(t',r) + | Feas -> raise (Invalid_argument "find_pivot") + end + | Pivot(i,j,s) -> + if debug then begin + Printf.fprintf stdout "Find pivot for x%i(%s)\n" vr (string_of_num s); + Printf.fprintf stdout "Leaving variable x%i\n" i; + Printf.fprintf stdout "Entering variable x%i\n" j; + end; + let m' = pivot tbl i j in + simplex opt vr rst m' in + +simplex opt vr rst tbl + + + +type certificate = + | Unsat of Vect.t + | Sat of tableau * var option + +(** [normalise_row t v] + @return a row obtained by pivoting the basic variables of the vector v + *) + +let normalise_row (t : tableau) (v: Vect.t) = + Vect.fold (fun acc vr ai -> try + let e = IMap.find vr t in + Vect.add (Vect.mul ai e) acc + with Not_found -> Vect.add (Vect.set vr ai Vect.null) acc) + Vect.null v + +let normalise_row (t : tableau) (v: Vect.t) = + let v' = normalise_row t v in + if debug then Printf.fprintf stdout "Normalised Optimising %a\n" LinPoly.pp v'; + v' + +let add_row (nw :var) (t : tableau) (v : Vect.t) : tableau = + IMap.add nw (normalise_row t v) t + +(** [push_real] performs reasoning over the rationals *) +let push_real (opt : bool) (nw : var) (v : Vect.t) (rst: Restricted.t) (t : tableau) : certificate = + if debug + then begin Printf.fprintf stdout "Current Tableau\n%a\n" output_tableau t; + Printf.fprintf stdout "Optimising %a=%a\n" LinPoly.pp_var nw LinPoly.pp v + end; + match simplex opt nw rst (add_row nw t v) with + | Opt(t',r) -> (* Look at the optimal *) + match r with + | Ubnd x-> + if debug then Printf.printf "The objective is unbounded (variable %a)\n" LinPoly.pp_var x; + Sat (t',Some x) (* This is sat and we can extract a value *) + | Feas -> Sat (t',None) + | Max n -> + if debug then begin + Printf.printf "The objective is maximised %s\n" (string_of_num n); + Printf.printf "%a = %a\n" LinPoly.pp_var nw pp_row (IMap.find nw t') + end; + + if n >=/ Int 0 + then Sat (t',None) + else + let v' = safe_find "push_real" nw t' in + Unsat (Vect.set nw (Int 1) (Vect.set 0 (Int 0) (Vect.mul (Int (-1)) v'))) + + +(** One complication is that equalities needs some pre-processing.contents + *) +open Mutils +open Polynomial + +let fresh_var l = + 1 + + try + (ISet.max_elt (List.fold_left (fun acc c -> ISet.union acc (Vect.variables c.coeffs)) ISet.empty l)) + with Not_found -> 0 + + +(*type varmap = (int * bool) IMap.t*) + + +let make_certificate vm l = + Vect.normalise (Vect.fold (fun acc x n -> + let (x',b) = IMap.find x vm in + Vect.set x' (if b then n else Num.minus_num n) acc) Vect.null l) + + + + + +let eliminate_equalities (vr0:var) (l:Polynomial.cstr list) = + let rec elim idx vr vm l acc = + match l with + | [] -> (vr,vm,acc) + | c::l -> match c.op with + | Ge -> let v = Vect.set 0 (minus_num c.cst) c.coeffs in + elim (idx+1) (vr+1) (IMap.add vr (idx,true) vm) l ((vr,v)::acc) + | Eq -> let v1 = Vect.set 0 (minus_num c.cst) c.coeffs in + let v2 = Vect.mul (Int (-1)) v1 in + let vm = IMap.add vr (idx,true) (IMap.add (vr+1) (idx,false) vm) in + elim (idx+1) (vr+2) vm l ((vr,v1)::(vr+1,v2)::acc) + | Gt -> raise Strict in + elim 0 vr0 IMap.empty l [] + +let find_solution rst tbl = + IMap.fold (fun vr v res -> if Restricted.is_restricted vr rst + then res + else Vect.set vr (Vect.get_cst v) res) tbl Vect.null + +let choose_conflict (sol:Vect.t) (l: (var * Vect.t) list) = + let esol = Vect.set 0 (Int 1) sol in + let is_conflict (x,v) = + if Vect.dotproduct esol v >=/ Int 0 + then None else Some(x,v) in + let (c,r) = extract is_conflict l in + match c with + | Some (c,_) -> Some (c,r) + | None -> match l with + | [] -> None + | e::l -> Some(e,l) + +(*let remove_redundant rst t = + IMap.fold (fun k v m -> if Restricted.is_restricted k rst && Vect.for_all (fun x _ -> x == 0 || Restricted.is_restricted x rst) v + then begin + if debug then + Printf.printf "%a is redundant\n" LinPoly.pp_var k; + IMap.remove k m + end + else m) t t + *) + + +let rec solve opt l (rst:Restricted.t) (t:tableau) = + let sol = find_solution rst t in + match choose_conflict sol l with + | None -> Inl (rst,t,None) + | Some((vr,v),l) -> + match push_real opt vr v (Restricted.set_exc vr rst) t with + | Sat (t',x) -> + (* let t' = remove_redundant rst t' in*) + begin + match l with + | [] -> Inl(rst,t', x) + | _ -> solve opt l rst t' + end + | Unsat c -> Inr c + +let find_unsat_certificate (l : Polynomial.cstr list ) = + let vr = fresh_var l in + let (_,vm,l') = eliminate_equalities vr l in + + match solve false l' (Restricted.make vr) IMap.empty with + | Inr c -> Some (make_certificate vm c) + | Inl _ -> None + + + +let find_point (l : Polynomial.cstr list) = + let vr = fresh_var l in + let (_,vm,l') = eliminate_equalities vr l in + + match solve false l' (Restricted.make vr) IMap.empty with + | Inl (rst,t,_) -> Some (find_solution rst t) + | _ -> None + + + +let optimise obj l = + let vr0 = fresh_var l in + let (_,vm,l') = eliminate_equalities (vr0+1) l in + + let bound pos res = + match res with + | Opt(_,Max n) -> Some (if pos then n else minus_num n) + | Opt(_,Ubnd _) -> None + | Opt(_,Feas) -> None + in + + match solve false l' (Restricted.make vr0) IMap.empty with + | Inl (rst,t,_) -> + Some (bound false + (simplex true vr0 rst (add_row vr0 t (Vect.uminus obj))), + bound true + (simplex true vr0 rst (add_row vr0 t obj))) + | _ -> None + + + +open Polynomial + +let env_of_list l = + List.fold_left (fun (i,m) l -> (i+1, IMap.add i l m)) (0,IMap.empty) l + + +open ProofFormat + +let make_farkas_certificate (env: WithProof.t IMap.t) vm v = + Vect.fold (fun acc x n -> + add_proof acc + begin + try + let (x',b) = IMap.find x vm in + (mul_cst_proof + (if b then n else (Num.minus_num n)) + (snd (IMap.find x' env))) + with Not_found -> (* This is an introduced hypothesis *) + (mul_cst_proof n (snd (IMap.find x env))) + end) Zero v + +let make_farkas_proof (env: WithProof.t IMap.t) vm v = + Vect.fold (fun wp x n -> + WithProof.addition wp begin + try + let (x', b) = IMap.find x vm in + let n = if b then n else Num.minus_num n in + WithProof.mult (Vect.cst n) (IMap.find x' env) + with Not_found -> + WithProof.mult (Vect.cst n) (IMap.find x env) + end) WithProof.zero v + +(* +let incr_cut rmin x = + match rmin with + | None -> true + | Some r -> Int.compare x r = 1 + *) + +let cut env rmin sol vm (rst:Restricted.t) (x,v) = +(* if not (incr_cut rmin x) + then None + else *) + let (n,r) = Vect.decomp_cst v in + + let nf = Num.floor_num n in + if nf =/ n + then None (* The solution is integral *) + else + (* This is potentially a cut *) + let cut = Vect.normalise + (Vect.fold (fun acc x n -> + if Restricted.is_restricted x rst then + Vect.set x (n -/ (Num.floor_num n)) acc + else acc + ) Vect.null r) in + if debug then Printf.fprintf stdout "Cut vector for %a : %a\n" LinPoly.pp_var x LinPoly.pp cut ; + let cut = make_farkas_proof env vm cut in + + match WithProof.cutting_plane cut with + | None -> None + | Some (v,prf) -> + if debug then begin + Printf.printf "This is a cutting plane:\n" ; + Printf.printf "%a -> %a\n" WithProof.output cut WithProof.output (v,prf); + end; + if Pervasives.(=) (snd v) Eq + then (* Unsat *) Some (x,(v,prf)) + else if eval_op Ge (Vect.dotproduct (fst v) (Vect.set 0 (Int 1) sol)) (Int 0) + then begin + (* Can this happen? *) + if debug then Printf.printf "The cut is feasible - drop it\n"; + None + end + else Some(x,(v,prf)) + +let find_cut env u sol vm rst tbl = + (* find first *) + IMap.fold (fun x v acc -> + match acc with + | None -> cut env u sol vm rst (x,v) + | Some c -> acc) tbl None + +(* +let find_cut env u sol vm rst tbl = + IMap.fold (fun x v acc -> + match acc with + | Some c -> Some c + | None -> cut env u sol vm rst (x,v) + ) tbl None + *) + +let integer_solver lp = + let (l,_) = List.split lp in + let vr0 = fresh_var l in + let (vr,vm,l') = eliminate_equalities vr0 l in + + let _,env = env_of_list (List.map WithProof.of_cstr lp) in + + let insert_row vr v rst tbl = + match push_real true vr v rst tbl with + | Sat (t',x) -> Inl (Restricted.restrict vr rst,t',x) + | Unsat c -> Inr c in + + let rec isolve env cr vr res = + match res with + | Inr c -> Some (Step (vr, make_farkas_certificate env vm (Vect.normalise c),Done)) + | Inl (rst,tbl,x) -> + if debug then begin + Printf.fprintf stdout "Looking for a cut\n"; + Printf.fprintf stdout "Restricted %a ...\n" Restricted.pp rst; + Printf.fprintf stdout "Current Tableau\n%a\n" output_tableau tbl; + end; + let sol = find_solution rst tbl in + + match find_cut env cr (*x*) sol vm rst tbl with + | None -> None + | Some(cr,((v,op),cut)) -> + if Pervasives.(=) op Eq + then (* This is a contradiction *) + Some(Step(vr,CutPrf cut, Done)) + else + let res = insert_row vr v (Restricted.set_exc vr rst) tbl in + let prf = isolve (IMap.add vr ((v,op),Def vr) env) (Some cr) (vr+1) res in + match prf with + | None -> None + | Some p -> Some (Step(vr,CutPrf cut,p)) in + + let res = solve true l' (Restricted.make vr0) IMap.empty in + isolve env None vr res + +let integer_solver lp = + match integer_solver lp with + | None -> None + | Some prf -> if debug + then Printf.fprintf stdout "Proof %a\n" ProofFormat.output_proof prf ; + Some prf diff --git a/plugins/micromega/simplex.mli b/plugins/micromega/simplex.mli new file mode 100644 index 0000000000..9f87e745eb --- /dev/null +++ b/plugins/micromega/simplex.mli @@ -0,0 +1,18 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +open Polynomial + +val optimise : Vect.t -> cstr list -> (Num.num option * Num.num option) option + +val find_point : cstr list -> Vect.t option + +val find_unsat_certificate : cstr list -> Vect.t option + +val integer_solver : (cstr * ProofFormat.prf_rule) list -> ProofFormat.proof option diff --git a/plugins/micromega/vect.ml b/plugins/micromega/vect.ml new file mode 100644 index 0000000000..b188ab4278 --- /dev/null +++ b/plugins/micromega/vect.ml @@ -0,0 +1,295 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Num +open Mutils + +(** [t] is the type of vectors. + A vector [(x1,v1) ; ... ; (xn,vn)] is such that: + - variables indexes are ordered (x1 < ... < xn + - values are all non-zero + *) +type var = int +type t = (var * num) list + +(** [equal v1 v2 = true] if the vectors are syntactically equal. *) + +let rec equal v1 v2 = + match v1 , v2 with + | [] , [] -> true + | [] , _ -> false + | _::_ , [] -> false + | (i1,n1)::v1 , (i2,n2)::v2 -> + (Int.equal i1 i2) && n1 =/ n2 && equal v1 v2 + +let hash v = + let rec hash i = function + | [] -> i + | (vr,vl)::l -> hash (i + (Hashtbl.hash (vr, float_of_num vl))) l in + Hashtbl.hash (hash 0 v ) + + +let null = [] + +let is_null v = + match v with + | [] | [0,Int 0] -> true + | _ -> false + +let pp_var_num pp_var o (v,n) = + if Int.equal v 0 + then if eq_num (Int 0) n then () + else Printf.fprintf o "%s" (string_of_num n) + else + match n with + | Int 1 -> pp_var o v + | Int -1 -> Printf.fprintf o "-%a" pp_var v + | Int 0 -> () + | _ -> Printf.fprintf o "%s*%a" (string_of_num n) pp_var v + + +let rec pp_gen pp_var o v = + match v with + | [] -> output_string o "0" + | [e] -> pp_var_num pp_var o e + | e::l -> Printf.fprintf o "%a + %a" (pp_var_num pp_var) e (pp_gen pp_var) l + + +let pp_var o v = Printf.fprintf o "x%i" v + +let pp o v = pp_gen pp_var o v + + +let from_list (l: num list) = + let rec xfrom_list i l = + match l with + | [] -> [] + | e::l -> + if e <>/ Int 0 + then (i,e)::(xfrom_list (i+1) l) + else xfrom_list (i+1) l in + + xfrom_list 0 l + +let zero_num = Int 0 + + +let to_list m = + let rec xto_list i l = + match l with + | [] -> [] + | (x,v)::l' -> + if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in + xto_list 0 m + + +let cons i v rst = if v =/ Int 0 then rst else (i,v)::rst + +let rec update i f t = + match t with + | [] -> cons i (f zero_num) [] + | (k,v)::l -> + match Int.compare i k with + | 0 -> cons k (f v) l + | -1 -> cons i (f zero_num) t + | 1 -> (k,v) ::(update i f l) + | _ -> failwith "compare_num" + +let rec set i n t = + match t with + | [] -> cons i n [] + | (k,v)::l -> + match Int.compare i k with + | 0 -> cons k n l + | -1 -> cons i n t + | 1 -> (k,v) :: (set i n l) + | _ -> failwith "compare_num" + +let cst n = if n =/ Int 0 then [] else [0,n] + + +let mul z t = + match z with + | Int 0 -> [] + | Int 1 -> t + | _ -> List.map (fun (i,n) -> (i, mult_num z n)) t + +let div z t = + if z <>/ Int 1 + then List.map (fun (x,nx) -> (x,nx // z)) t + else t + + +let uminus t = List.map (fun (i,n) -> i, minus_num n) t + + +let rec add (ve1:t) (ve2:t) = + match ve1 , ve2 with + | [] , v | v , [] -> v + | (v1,c1)::l1 , (v2,c2)::l2 -> + let cmp = Pervasives.compare v1 v2 in + if cmp == 0 then + let s = add_num c1 c2 in + if eq_num (Int 0) s + then add l1 l2 + else (v1,s)::(add l1 l2) + else if cmp < 0 then (v1,c1) :: (add l1 ve2) + else (v2,c2) :: (add l2 ve1) + + +let rec xmul_add (n1:num) (ve1:t) (n2:num) (ve2:t) = + match ve1 , ve2 with + | [] , _ -> mul n2 ve2 + | _ , [] -> mul n1 ve1 + | (v1,c1)::l1 , (v2,c2)::l2 -> + let cmp = Pervasives.compare v1 v2 in + if cmp == 0 then + let s = ( n1 */ c1) +/ (n2 */ c2) in + if eq_num (Int 0) s + then xmul_add n1 l1 n2 l2 + else (v1,s)::(xmul_add n1 l1 n2 l2) + else if cmp < 0 then (v1,n1 */ c1) :: (xmul_add n1 l1 n2 ve2) + else (v2,n2 */c2) :: (xmul_add n1 ve1 n2 l2) + +let mul_add n1 ve1 n2 ve2 = + if n1 =/ Int 1 && n2 =/ Int 1 + then add ve1 ve2 + else xmul_add n1 ve1 n2 ve2 + + +let compare : t -> t -> int = Mutils.Cmp.compare_list (fun x y -> Mutils.Cmp.compare_lexical + [ + (fun () -> Int.compare (fst x) (fst y)); + (fun () -> compare_num (snd x) (snd y))]) + +(** [tail v vect] returns + - [None] if [v] is not a variable of the vector [vect] + - [Some(vl,rst)] where [vl] is the value of [v] in vector [vect] + and [rst] is the remaining of the vector + We exploit that vectors are ordered lists + *) +let rec tail (v:var) (vect:t) = + match vect with + | [] -> None + | (v',vl)::vect' -> + match Int.compare v' v with + | 0 -> Some (vl,vect) (* Ok, found *) + | -1 -> tail v vect' (* Might be in the tail *) + | _ -> None (* Hopeless *) + +let get v vect = + match tail v vect with + | None -> Int 0 + | Some(vl,_) -> vl + +let is_constant v = + match v with + | [] | [0,_] -> true + | _ -> false + + + +let get_cst vect = + match vect with + | (0,v)::_ -> v + | _ -> Int 0 + +let choose v = + match v with + | [] -> None + | (vr,vl)::rst -> Some (vr,vl,rst) + + +let rec fresh v = + match v with + | [] -> 1 + | [v,_] -> v + 1 + | _::v -> fresh v + + +let variables v = + List.fold_left (fun acc (x,_) -> ISet.add x acc) ISet.empty v + +let decomp_cst v = + match v with + | (0,vl)::v -> vl,v + | _ -> Int 0,v + +let fold f acc v = + List.fold_left (fun acc (v,i) -> f acc v i) acc v + +let fold_error f acc v = + let rec fold acc v = + match v with + | [] -> Some acc + | (x,i)::v' -> match f acc x i with + | None -> None + | Some acc' -> fold acc' v' in + fold acc v + + + +let rec find p v = + match v with + | [] -> None + | (v,n)::v' -> match p v n with + | None -> find p v' + | Some r -> Some r + + +let for_all p l = + List.for_all (fun (v,n) -> p v n) l + + +let decr_var i v = List.map (fun (v,n) -> (v-i,n)) v +let incr_var i v = List.map (fun (v,n) -> (v+i,n)) v + +open Big_int + +let gcd v = + let res = fold (fun c _ n -> + assert (Int.equal (compare_big_int (denominator n) unit_big_int) 0); + gcd_big_int c (numerator n)) zero_big_int v in + if Int.equal (compare_big_int res zero_big_int) 0 + then unit_big_int else res + +let normalise v = + let ppcm = fold (fun c _ n -> ppcm c (denominator n)) unit_big_int v in + let gcd = + let gcd = fold (fun c _ n -> gcd_big_int c (numerator n)) zero_big_int v in + if Int.equal (compare_big_int gcd zero_big_int) 0 then unit_big_int else gcd in + List.map (fun (x,v) -> (x, v */ (Big_int ppcm) // (Big_int gcd))) v + +let rec exists2 p vect1 vect2 = + match vect1 , vect2 with + | _ , [] | [], _ -> None + | (v1,n1)::vect1' , (v2, n2) :: vect2' -> + if Int.equal v1 v2 + then + if p n1 n2 + then Some (v1,n1,n2) + else + exists2 p vect1' vect2' + else + if v1 < v2 + then exists2 p vect1' vect2 + else exists2 p vect1 vect2' + +let dotproduct v1 v2 = + let rec dot acc v1 v2 = + match v1, v2 with + | [] , _ | _ , [] -> acc + | (x1,n1)::v1', (x2,n2)::v2' -> + if x1 == x2 + then dot (acc +/ n1 */ n2) v1' v2' + else if x1 < x2 + then dot acc v1' v2 + else dot acc v1 v2' in + dot (Int 0) v1 v2 diff --git a/plugins/micromega/vect.mli b/plugins/micromega/vect.mli new file mode 100644 index 0000000000..da6b1e8e9b --- /dev/null +++ b/plugins/micromega/vect.mli @@ -0,0 +1,156 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Num +open Mutils + +type var = int (** Variables are simply (positive) integers. *) + +type t (** The type of vectors or equivalently linear expressions. + The current implementation is using association lists. + A list [(0,c),(x1,ai),...,(xn,an)] represents the linear expression + c + a1.xn + ... an.xn where ai are rational constants and xi are variables. + + Note that the variable 0 has a special meaning and represent a constant. + Moreover, the representation is spare and variables with a zero coefficient + are not represented. + *) + +(** {1 Generic functions} *) + +(** [hash] [equal] and [compare] so that Vect.t can be used as + keys for Set Map and Hashtbl *) + +val hash : t -> int +val equal : t -> t -> bool +val compare : t -> t -> int + +(** {1 Basic accessors and utility functions} *) + +(** [pp_gen pp_var o v] prints the representation of the vector [v] over the channel [o] *) +val pp_gen : (out_channel -> var -> unit) -> out_channel -> t -> unit + +(** [pp o v] prints the representation of the vector [v] over the channel [o] *) +val pp : out_channel -> t -> unit + +(** [variables v] returns the set of variables with non-zero coefficients *) +val variables : t -> ISet.t + +(** [get_cst v] returns c i.e. the coefficient of the variable zero *) +val get_cst : t -> num + +(** [decomp_cst v] returns the pair (c,a1.x1+...+an.xn) *) +val decomp_cst : t -> num * t + +(** [cst c] returns the vector v=c+0.x1+...+0.xn *) +val cst : num -> t + +(** [is_constant v] holds if [v] is a constant vector i.e. v=c+0.x1+...+0.xn + *) +val is_constant : t -> bool + +(** [null] is the empty vector i.e. 0+0.x1+...+0.xn *) +val null : t + +(** [is_null v] returns whether [v] is the [null] vector i.e [equal v null] *) +val is_null : t -> bool + +(** [get xi v] returns the coefficient ai of the variable [xi]. + [get] is also defined for the variable 0 *) +val get : var -> t -> num + +(** [set xi ai' v] returns the vector c+a1.x1+...ai'.xi+...+an.xn + i.e. the coefficient of the variable xi is set to ai' *) +val set : var -> num -> t -> t + +(** [update xi f v] returns c+a1.x1+...+f(ai).xi+...+an.xn *) +val update : var -> (num -> num) -> t -> t + +(** [fresh v] return the fresh variable with inded 1+ max (variables v) *) +val fresh : t -> int + +(** [choose v] decomposes a vector [v] depending on whether it is [null] or not. + @return None if v is [null] + @return Some(x,n,r) where v = r + n.x x is the smallest variable with non-zero coefficient n <> 0. + *) +val choose : t -> (var * num * t) option + +(** [from_list l] returns the vector c+a1.x1...an.xn from the list of coefficient [l=c;a1;...;an] *) +val from_list : num list -> t + +(** [to_list v] returns the list of all coefficient of the vector v i.e. [c;a1;...;an] + The list representation is (obviously) not sparsed + and therefore certain ai may be 0 *) +val to_list : t -> num list + +(** [decr_var i v] decrements the variables of the vector [v] by the amount [i]. + Beware, it is only defined if all the variables of v are greater than i + *) +val decr_var : int -> t -> t + +(** [incr_var i v] increments the variables of the vector [v] by the amount [i]. + *) +val incr_var : int -> t -> t + +(** [gcd v] returns gcd(num(c),num(a1),...,num(an)) where num extracts + the numerator of a rational value. *) +val gcd : t -> Big_int.big_int + +(** [normalise v] returns a vector with only integer coefficients *) +val normalise : t -> t + + +(** {1 Linear arithmetics} *) + +(** [add v1 v2] is vector addition. + @param v1 is of the form c +a1.x1 +...+an.xn + @param v2 is of the form c'+a1'.x1 +...+an'.xn + @return c1+c1'+ (a1+a1').x1 + ... + (an+an').xn + *) +val add : t -> t -> t + +(** [mul a v] is vector multiplication of vector [v] by a scalar [a]. + @return a.v = a.c+a.a1.x1+...+a.an.xn *) +val mul : num -> t -> t + +(** [mul_add c1 v1 c2 v2] returns the linear combination c1.v1+c2.v2 *) +val mul_add : num -> t -> num -> t -> t + +(** [div c1 v1] returns the mutiplication by the inverse of c1 i.e (1/c1).v1 *) +val div : num -> t -> t + +(** [uminus v] @return -v the opposite vector of v i.e. (-1).v *) +val uminus : t -> t + +(** {1 Iterators} *) + +(** [fold f acc v] returns f (f (f acc 0 c ) x1 a1 ) ... xn an *) +val fold : ('acc -> var -> num -> 'acc) -> 'acc -> t -> 'acc + +(** [fold_error f acc v] is the same as + [fold (fun acc x i -> match acc with None -> None | Some acc' -> f acc' x i) (Some acc) v] + but with early exit... + *) +val fold_error : ('acc -> var -> num -> 'acc option) -> 'acc -> t -> 'acc option + +(** [find f v] returns the first [f xi ai] such that [f xi ai <> None]. + If no such xi ai exists, it returns None *) +val find : (var -> num -> 'c option) -> t -> 'c option + +(** [for_all p v] returns /\_{i>=0} (f xi ai) *) +val for_all : (var -> num -> bool) -> t -> bool + +(** [exists2 p v v'] returns Some(xi,ai,ai') + if p(xi,ai,ai') holds and ai,ai' <> 0. + It returns None if no such pair of coefficient exists. *) +val exists2 : (num -> num -> bool) -> t -> t -> (var * num * num) option + +(** [dotproduct v1 v2] is the dot product of v1 and v2. *) +val dotproduct : t -> t -> num diff --git a/plugins/nsatz/nsatz.ml b/plugins/nsatz/nsatz.ml index d2d4639d2b..11d0a4a44d 100644 --- a/plugins/nsatz/nsatz.ml +++ b/plugins/nsatz/nsatz.ml @@ -12,7 +12,6 @@ open CErrors open Util open Constr open Tactics -open Coqlib open Num open Utile @@ -136,36 +135,32 @@ let mul = function | (Const n,q) when eq_num n num_1 -> q | (p,q) -> Mul(p,q) -let gen_constant msg path s = UnivGen.constr_of_global @@ - coq_reference msg path s +let gen_constant n = lazy (UnivGen.constr_of_global (Coqlib.lib_ref n)) -let tpexpr = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PExpr") -let ttconst = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEc") -let ttvar = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEX") -let ttadd = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEadd") -let ttsub = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEsub") -let ttmul = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEmul") -let ttopp = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEopp") -let ttpow = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEpow") +let tpexpr = gen_constant "plugins.setoid_ring.pexpr" +let ttconst = gen_constant "plugins.setoid_ring.const" +let ttvar = gen_constant "plugins.setoid_ring.var" +let ttadd = gen_constant "plugins.setoid_ring.add" +let ttsub = gen_constant "plugins.setoid_ring.sub" +let ttmul = gen_constant "plugins.setoid_ring.mul" +let ttopp = gen_constant "plugins.setoid_ring.opp" +let ttpow = gen_constant "plugins.setoid_ring.pow" -let datatypes = ["Init";"Datatypes"] -let binnums = ["Numbers";"BinNums"] +let tlist = gen_constant "core.list.type" +let lnil = gen_constant "core.list.nil" +let lcons = gen_constant "core.list.cons" -let tlist = lazy (gen_constant "CC" datatypes "list") -let lnil = lazy (gen_constant "CC" datatypes "nil") -let lcons = lazy (gen_constant "CC" datatypes "cons") +let tz = gen_constant "num.Z.type" +let z0 = gen_constant "num.Z.Z0" +let zpos = gen_constant "num.Z.Zpos" +let zneg = gen_constant "num.Z.Zneg" -let tz = lazy (gen_constant "CC" binnums "Z") -let z0 = lazy (gen_constant "CC" binnums "Z0") -let zpos = lazy (gen_constant "CC" binnums "Zpos") -let zneg = lazy(gen_constant "CC" binnums "Zneg") +let pxI = gen_constant "num.pos.xI" +let pxO = gen_constant "num.pos.xO" +let pxH = gen_constant "num.pos.xH" -let pxI = lazy(gen_constant "CC" binnums "xI") -let pxO = lazy(gen_constant "CC" binnums "xO") -let pxH = lazy(gen_constant "CC" binnums "xH") - -let nN0 = lazy (gen_constant "CC" binnums "N0") -let nNpos = lazy(gen_constant "CC" binnums "Npos") +let nN0 = gen_constant "num.N.N0" +let nNpos = gen_constant "num.N.Npos" let mkt_app name l = mkApp (Lazy.force name, Array.of_list l) @@ -545,7 +540,7 @@ let nsatz lpol = let return_term t = let a = - mkApp(gen_constant "CC" ["Init";"Logic"] "eq_refl",[|tllp ();t|]) in + mkApp (UnivGen.constr_of_global @@ Coqlib.lib_ref "core.eq.refl",[|tllp ();t|]) in let a = EConstr.of_constr a in generalize [a] diff --git a/plugins/omega/OmegaLemmas.v b/plugins/omega/OmegaLemmas.v index dc86a98998..9593e1225c 100644 --- a/plugins/omega/OmegaLemmas.v +++ b/plugins/omega/OmegaLemmas.v @@ -267,3 +267,49 @@ Proof. intros n; exists (Z.of_nat n); split; trivial. rewrite Z.mul_1_r, Z.add_0_r. apply Nat2Z.is_nonneg. Qed. + +Register fast_Zplus_assoc_reverse as plugins.omega.fast_Zplus_assoc_reverse. +Register fast_Zplus_assoc as plugins.omega.fast_Zplus_assoc. +Register fast_Zmult_assoc_reverse as plugins.omega.fast_Zmult_assoc_reverse. +Register fast_Zplus_permute as plugins.omega.fast_Zplus_permute. +Register fast_Zplus_comm as plugins.omega.fast_Zplus_comm. +Register fast_Zmult_comm as plugins.omega.fast_Zmult_comm. + +Register OMEGA1 as plugins.omega.OMEGA1. +Register OMEGA2 as plugins.omega.OMEGA2. +Register OMEGA3 as plugins.omega.OMEGA3. +Register OMEGA4 as plugins.omega.OMEGA4. +Register OMEGA5 as plugins.omega.OMEGA5. +Register OMEGA6 as plugins.omega.OMEGA6. +Register OMEGA7 as plugins.omega.OMEGA7. +Register OMEGA8 as plugins.omega.OMEGA8. +Register OMEGA9 as plugins.omega.OMEGA9. +Register fast_OMEGA10 as plugins.omega.fast_OMEGA10. +Register fast_OMEGA11 as plugins.omega.fast_OMEGA11. +Register fast_OMEGA12 as plugins.omega.fast_OMEGA12. +Register fast_OMEGA13 as plugins.omega.fast_OMEGA13. +Register fast_OMEGA14 as plugins.omega.fast_OMEGA14. +Register fast_OMEGA15 as plugins.omega.fast_OMEGA15. +Register fast_OMEGA16 as plugins.omega.fast_OMEGA16. +Register OMEGA17 as plugins.omega.OMEGA17. +Register OMEGA18 as plugins.omega.OMEGA18. +Register OMEGA19 as plugins.omega.OMEGA19. +Register OMEGA20 as plugins.omega.OMEGA20. + +Register fast_Zred_factor0 as plugins.omega.fast_Zred_factor0. +Register fast_Zred_factor1 as plugins.omega.fast_Zred_factor1. +Register fast_Zred_factor2 as plugins.omega.fast_Zred_factor2. +Register fast_Zred_factor3 as plugins.omega.fast_Zred_factor3. +Register fast_Zred_factor4 as plugins.omega.fast_Zred_factor4. +Register fast_Zred_factor5 as plugins.omega.fast_Zred_factor5. +Register fast_Zred_factor6 as plugins.omega.fast_Zred_factor6. + +Register fast_Zmult_plus_distr_l as plugins.omega.fast_Zmult_plus_distr_l. +Register fast_Zmult_opp_comm as plugins.omega.fast_Zmult_opp_comm. +Register fast_Zopp_plus_distr as plugins.omega.fast_Zopp_plus_distr. +Register fast_Zopp_mult_distr_r as plugins.omega.fast_Zopp_mult_distr_r. +Register fast_Zopp_eq_mult_neg_1 as plugins.omega.fast_Zopp_eq_mult_neg_1. +Register fast_Zopp_involutive as plugins.omega.fast_Zopp_involutive. + +Register new_var as plugins.omega.new_var. +Register intro_Z as plugins.omega.intro_Z. diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index abae6940fa..f55458de8d 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -193,172 +193,159 @@ let reset_all () = To use the constant Zplus, one must type "Lazy.force coq_Zplus" This is the right way to access to Coq constants in tactics ML code *) -open Coqlib - -let logic_dir = ["Coq";"Logic";"Decidable"] -let coq_modules = - init_modules @arith_modules @ [logic_dir] @ zarith_base_modules - @ [["Coq"; "omega"; "OmegaLemmas"]] - -let gen_constant_in_modules n m s = EConstr.of_constr (UnivGen.constr_of_global @@ gen_reference_in_modules n m s) -let init_constant = gen_constant_in_modules "Omega" init_modules -let constant = gen_constant_in_modules "Omega" coq_modules - -let z_constant = gen_constant_in_modules "Omega" [["Coq";"ZArith"]] -let zbase_constant = - gen_constant_in_modules "Omega" [["Coq";"ZArith";"BinInt"]] +let gen_constant k = lazy (k |> Coqlib.lib_ref |> UnivGen.constr_of_global |> EConstr.of_constr) (* Zarith *) -let coq_xH = lazy (constant "xH") -let coq_xO = lazy (constant "xO") -let coq_xI = lazy (constant "xI") -let coq_Z0 = lazy (constant "Z0") -let coq_Zpos = lazy (constant "Zpos") -let coq_Zneg = lazy (constant "Zneg") -let coq_Z = lazy (constant "Z") -let coq_comparison = lazy (constant "comparison") -let coq_Gt = lazy (constant "Gt") -let coq_Zplus = lazy (zbase_constant "Z.add") -let coq_Zmult = lazy (zbase_constant "Z.mul") -let coq_Zopp = lazy (zbase_constant "Z.opp") -let coq_Zminus = lazy (zbase_constant "Z.sub") -let coq_Zsucc = lazy (zbase_constant "Z.succ") -let coq_Zpred = lazy (zbase_constant "Z.pred") -let coq_Z_of_nat = lazy (zbase_constant "Z.of_nat") -let coq_inj_plus = lazy (z_constant "Nat2Z.inj_add") -let coq_inj_mult = lazy (z_constant "Nat2Z.inj_mul") -let coq_inj_minus1 = lazy (z_constant "Nat2Z.inj_sub") -let coq_inj_minus2 = lazy (constant "inj_minus2") -let coq_inj_S = lazy (z_constant "Nat2Z.inj_succ") -let coq_inj_le = lazy (z_constant "Znat.inj_le") -let coq_inj_lt = lazy (z_constant "Znat.inj_lt") -let coq_inj_ge = lazy (z_constant "Znat.inj_ge") -let coq_inj_gt = lazy (z_constant "Znat.inj_gt") -let coq_inj_neq = lazy (z_constant "inj_neq") -let coq_inj_eq = lazy (z_constant "inj_eq") -let coq_fast_Zplus_assoc_reverse = lazy (constant "fast_Zplus_assoc_reverse") -let coq_fast_Zplus_assoc = lazy (constant "fast_Zplus_assoc") -let coq_fast_Zmult_assoc_reverse = lazy (constant "fast_Zmult_assoc_reverse") -let coq_fast_Zplus_permute = lazy (constant "fast_Zplus_permute") -let coq_fast_Zplus_comm = lazy (constant "fast_Zplus_comm") -let coq_fast_Zmult_comm = lazy (constant "fast_Zmult_comm") -let coq_Zmult_le_approx = lazy (constant "Zmult_le_approx") -let coq_OMEGA1 = lazy (constant "OMEGA1") -let coq_OMEGA2 = lazy (constant "OMEGA2") -let coq_OMEGA3 = lazy (constant "OMEGA3") -let coq_OMEGA4 = lazy (constant "OMEGA4") -let coq_OMEGA5 = lazy (constant "OMEGA5") -let coq_OMEGA6 = lazy (constant "OMEGA6") -let coq_OMEGA7 = lazy (constant "OMEGA7") -let coq_OMEGA8 = lazy (constant "OMEGA8") -let coq_OMEGA9 = lazy (constant "OMEGA9") -let coq_fast_OMEGA10 = lazy (constant "fast_OMEGA10") -let coq_fast_OMEGA11 = lazy (constant "fast_OMEGA11") -let coq_fast_OMEGA12 = lazy (constant "fast_OMEGA12") -let coq_fast_OMEGA13 = lazy (constant "fast_OMEGA13") -let coq_fast_OMEGA14 = lazy (constant "fast_OMEGA14") -let coq_fast_OMEGA15 = lazy (constant "fast_OMEGA15") -let coq_fast_OMEGA16 = lazy (constant "fast_OMEGA16") -let coq_OMEGA17 = lazy (constant "OMEGA17") -let coq_OMEGA18 = lazy (constant "OMEGA18") -let coq_OMEGA19 = lazy (constant "OMEGA19") -let coq_OMEGA20 = lazy (constant "OMEGA20") -let coq_fast_Zred_factor0 = lazy (constant "fast_Zred_factor0") -let coq_fast_Zred_factor1 = lazy (constant "fast_Zred_factor1") -let coq_fast_Zred_factor2 = lazy (constant "fast_Zred_factor2") -let coq_fast_Zred_factor3 = lazy (constant "fast_Zred_factor3") -let coq_fast_Zred_factor4 = lazy (constant "fast_Zred_factor4") -let coq_fast_Zred_factor5 = lazy (constant "fast_Zred_factor5") -let coq_fast_Zred_factor6 = lazy (constant "fast_Zred_factor6") -let coq_fast_Zmult_plus_distr_l = lazy (constant "fast_Zmult_plus_distr_l") -let coq_fast_Zmult_opp_comm = lazy (constant "fast_Zmult_opp_comm") -let coq_fast_Zopp_plus_distr = lazy (constant "fast_Zopp_plus_distr") -let coq_fast_Zopp_mult_distr_r = lazy (constant "fast_Zopp_mult_distr_r") -let coq_fast_Zopp_eq_mult_neg_1 = lazy (constant "fast_Zopp_eq_mult_neg_1") -let coq_fast_Zopp_involutive = lazy (constant "fast_Zopp_involutive") -let coq_Zegal_left = lazy (constant "Zegal_left") -let coq_Zne_left = lazy (constant "Zne_left") -let coq_Zlt_left = lazy (constant "Zlt_left") -let coq_Zge_left = lazy (constant "Zge_left") -let coq_Zgt_left = lazy (constant "Zgt_left") -let coq_Zle_left = lazy (constant "Zle_left") -let coq_new_var = lazy (constant "new_var") -let coq_intro_Z = lazy (constant "intro_Z") - -let coq_dec_eq = lazy (zbase_constant "Z.eq_decidable") -let coq_dec_Zne = lazy (constant "dec_Zne") -let coq_dec_Zle = lazy (zbase_constant "Z.le_decidable") -let coq_dec_Zlt = lazy (zbase_constant "Z.lt_decidable") -let coq_dec_Zgt = lazy (constant "dec_Zgt") -let coq_dec_Zge = lazy (constant "dec_Zge") - -let coq_not_Zeq = lazy (constant "not_Zeq") -let coq_not_Zne = lazy (constant "not_Zne") -let coq_Znot_le_gt = lazy (constant "Znot_le_gt") -let coq_Znot_lt_ge = lazy (constant "Znot_lt_ge") -let coq_Znot_ge_lt = lazy (constant "Znot_ge_lt") -let coq_Znot_gt_le = lazy (constant "Znot_gt_le") -let coq_neq = lazy (constant "neq") -let coq_Zne = lazy (constant "Zne") -let coq_Zle = lazy (zbase_constant "Z.le") -let coq_Zgt = lazy (zbase_constant "Z.gt") -let coq_Zge = lazy (zbase_constant "Z.ge") -let coq_Zlt = lazy (zbase_constant "Z.lt") +let coq_xH = gen_constant "num.pos.xH" +let coq_xO = gen_constant "num.pos.xO" +let coq_xI = gen_constant "num.pos.xI" +let coq_Z0 = gen_constant "num.Z.Z0" +let coq_Zpos = gen_constant "num.Z.Zpos" +let coq_Zneg = gen_constant "num.Z.Zneg" +let coq_Z = gen_constant "num.Z.type" +let coq_comparison = gen_constant "core.comparison.type" +let coq_Gt = gen_constant "core.comparison.Gt" +let coq_Zplus = gen_constant "num.Z.add" +let coq_Zmult = gen_constant "num.Z.mul" +let coq_Zopp = gen_constant "num.Z.opp" +let coq_Zminus = gen_constant "num.Z.sub" +let coq_Zsucc = gen_constant "num.Z.succ" +let coq_Zpred = gen_constant "num.Z.pred" +let coq_Z_of_nat = gen_constant "num.Z.of_nat" +let coq_inj_plus = gen_constant "num.Nat2Z.inj_add" +let coq_inj_mult = gen_constant "num.Nat2Z.inj_mul" +let coq_inj_minus1 = gen_constant "num.Nat2Z.inj_sub" +let coq_inj_minus2 = gen_constant "plugins.omega.inj_minus2" +let coq_inj_S = gen_constant "num.Nat2Z.inj_succ" +let coq_inj_eq = gen_constant "plugins.omega.inj_eq" +let coq_inj_neq = gen_constant "plugins.omega.inj_neq" +let coq_inj_le = gen_constant "plugins.omega.inj_le" +let coq_inj_lt = gen_constant "plugins.omega.inj_lt" +let coq_inj_ge = gen_constant "plugins.omega.inj_ge" +let coq_inj_gt = gen_constant "plugins.omega.inj_gt" +let coq_fast_Zplus_assoc_reverse = gen_constant "plugins.omega.fast_Zplus_assoc_reverse" +let coq_fast_Zplus_assoc = gen_constant "plugins.omega.fast_Zplus_assoc" +let coq_fast_Zmult_assoc_reverse = gen_constant "plugins.omega.fast_Zmult_assoc_reverse" +let coq_fast_Zplus_permute = gen_constant "plugins.omega.fast_Zplus_permute" +let coq_fast_Zplus_comm = gen_constant "plugins.omega.fast_Zplus_comm" +let coq_fast_Zmult_comm = gen_constant "plugins.omega.fast_Zmult_comm" +let coq_Zmult_le_approx = gen_constant "plugins.omega.Zmult_le_approx" +let coq_OMEGA1 = gen_constant "plugins.omega.OMEGA1" +let coq_OMEGA2 = gen_constant "plugins.omega.OMEGA2" +let coq_OMEGA3 = gen_constant "plugins.omega.OMEGA3" +let coq_OMEGA4 = gen_constant "plugins.omega.OMEGA4" +let coq_OMEGA5 = gen_constant "plugins.omega.OMEGA5" +let coq_OMEGA6 = gen_constant "plugins.omega.OMEGA6" +let coq_OMEGA7 = gen_constant "plugins.omega.OMEGA7" +let coq_OMEGA8 = gen_constant "plugins.omega.OMEGA8" +let coq_OMEGA9 = gen_constant "plugins.omega.OMEGA9" +let coq_fast_OMEGA10 = gen_constant "plugins.omega.fast_OMEGA10" +let coq_fast_OMEGA11 = gen_constant "plugins.omega.fast_OMEGA11" +let coq_fast_OMEGA12 = gen_constant "plugins.omega.fast_OMEGA12" +let coq_fast_OMEGA13 = gen_constant "plugins.omega.fast_OMEGA13" +let coq_fast_OMEGA14 = gen_constant "plugins.omega.fast_OMEGA14" +let coq_fast_OMEGA15 = gen_constant "plugins.omega.fast_OMEGA15" +let coq_fast_OMEGA16 = gen_constant "plugins.omega.fast_OMEGA16" +let coq_OMEGA17 = gen_constant "plugins.omega.OMEGA17" +let coq_OMEGA18 = gen_constant "plugins.omega.OMEGA18" +let coq_OMEGA19 = gen_constant "plugins.omega.OMEGA19" +let coq_OMEGA20 = gen_constant "plugins.omega.OMEGA20" +let coq_fast_Zred_factor0 = gen_constant "plugins.omega.fast_Zred_factor0" +let coq_fast_Zred_factor1 = gen_constant "plugins.omega.fast_Zred_factor1" +let coq_fast_Zred_factor2 = gen_constant "plugins.omega.fast_Zred_factor2" +let coq_fast_Zred_factor3 = gen_constant "plugins.omega.fast_Zred_factor3" +let coq_fast_Zred_factor4 = gen_constant "plugins.omega.fast_Zred_factor4" +let coq_fast_Zred_factor5 = gen_constant "plugins.omega.fast_Zred_factor5" +let coq_fast_Zred_factor6 = gen_constant "plugins.omega.fast_Zred_factor6" +let coq_fast_Zmult_plus_distr_l = gen_constant "plugins.omega.fast_Zmult_plus_distr_l" +let coq_fast_Zmult_opp_comm = gen_constant "plugins.omega.fast_Zmult_opp_comm" +let coq_fast_Zopp_plus_distr = gen_constant "plugins.omega.fast_Zopp_plus_distr" +let coq_fast_Zopp_mult_distr_r = gen_constant "plugins.omega.fast_Zopp_mult_distr_r" +let coq_fast_Zopp_eq_mult_neg_1 = gen_constant "plugins.omega.fast_Zopp_eq_mult_neg_1" +let coq_fast_Zopp_involutive = gen_constant "plugins.omega.fast_Zopp_involutive" +let coq_Zegal_left = gen_constant "plugins.omega.Zegal_left" +let coq_Zne_left = gen_constant "plugins.omega.Zne_left" +let coq_Zlt_left = gen_constant "plugins.omega.Zlt_left" +let coq_Zge_left = gen_constant "plugins.omega.Zge_left" +let coq_Zgt_left = gen_constant "plugins.omega.Zgt_left" +let coq_Zle_left = gen_constant "plugins.omega.Zle_left" +let coq_new_var = gen_constant "plugins.omega.new_var" +let coq_intro_Z = gen_constant "plugins.omega.intro_Z" + +let coq_dec_eq = gen_constant "num.Z.eq_decidable" +let coq_dec_Zne = gen_constant "plugins.omega.dec_Zne" +let coq_dec_Zle = gen_constant "num.Z.le_decidable" +let coq_dec_Zlt = gen_constant "num.Z.lt_decidable" +let coq_dec_Zgt = gen_constant "plugins.omega.dec_Zgt" +let coq_dec_Zge = gen_constant "plugins.omega.dec_Zge" + +let coq_not_Zeq = gen_constant "plugins.omega.not_Zeq" +let coq_not_Zne = gen_constant "plugins.omega.not_Zne" +let coq_Znot_le_gt = gen_constant "plugins.omega.Znot_le_gt" +let coq_Znot_lt_ge = gen_constant "plugins.omega.Znot_lt_ge" +let coq_Znot_ge_lt = gen_constant "plugins.omega.Znot_ge_lt" +let coq_Znot_gt_le = gen_constant "plugins.omega.Znot_gt_le" +let coq_neq = gen_constant "plugins.omega.neq" +let coq_Zne = gen_constant "plugins.omega.Zne" +let coq_Zle = gen_constant "num.Z.le" +let coq_Zlt = gen_constant "num.Z.lt" +let coq_Zge = gen_constant "num.Z.ge" +let coq_Zgt = gen_constant "num.Z.gt" (* Peano/Datatypes *) -let coq_le = lazy (init_constant "le") -let coq_lt = lazy (init_constant "lt") -let coq_ge = lazy (init_constant "ge") -let coq_gt = lazy (init_constant "gt") -let coq_minus = lazy (init_constant "Nat.sub") -let coq_plus = lazy (init_constant "Nat.add") -let coq_mult = lazy (init_constant "Nat.mul") -let coq_pred = lazy (init_constant "Nat.pred") -let coq_nat = lazy (init_constant "nat") -let coq_S = lazy (init_constant "S") -let coq_O = lazy (init_constant "O") +let coq_nat = gen_constant "num.nat.type" +let coq_O = gen_constant "num.nat.O" +let coq_S = gen_constant "num.nat.S" +let coq_le = gen_constant "num.nat.le" +let coq_lt = gen_constant "num.nat.lt" +let coq_ge = gen_constant "num.nat.ge" +let coq_gt = gen_constant "num.nat.gt" +let coq_plus = gen_constant "num.nat.add" +let coq_minus = gen_constant "num.nat.sub" +let coq_mult = gen_constant "num.nat.mul" +let coq_pred = gen_constant "num.nat.pred" (* Compare_dec/Peano_dec/Minus *) -let coq_pred_of_minus = lazy (constant "pred_of_minus") -let coq_le_gt_dec = lazy (constant "le_gt_dec") -let coq_dec_eq_nat = lazy (constant "dec_eq_nat") -let coq_dec_le = lazy (constant "dec_le") -let coq_dec_lt = lazy (constant "dec_lt") -let coq_dec_ge = lazy (constant "dec_ge") -let coq_dec_gt = lazy (constant "dec_gt") -let coq_not_eq = lazy (constant "not_eq") -let coq_not_le = lazy (constant "not_le") -let coq_not_lt = lazy (constant "not_lt") -let coq_not_ge = lazy (constant "not_ge") -let coq_not_gt = lazy (constant "not_gt") +let coq_pred_of_minus = gen_constant "num.nat.pred_of_minus" +let coq_le_gt_dec = gen_constant "num.nat.le_gt_dec" +let coq_dec_eq_nat = gen_constant "num.nat.eq_dec" +let coq_dec_le = gen_constant "num.nat.dec_le" +let coq_dec_lt = gen_constant "num.nat.dec_lt" +let coq_dec_ge = gen_constant "num.nat.dec_ge" +let coq_dec_gt = gen_constant "num.nat.dec_gt" +let coq_not_eq = gen_constant "num.nat.not_eq" +let coq_not_le = gen_constant "num.nat.not_le" +let coq_not_lt = gen_constant "num.nat.not_lt" +let coq_not_ge = gen_constant "num.nat.not_ge" +let coq_not_gt = gen_constant "num.nat.not_gt" (* Logic/Decidable *) -let coq_eq_ind_r = lazy (constant "eq_ind_r") - -let coq_dec_or = lazy (constant "dec_or") -let coq_dec_and = lazy (constant "dec_and") -let coq_dec_imp = lazy (constant "dec_imp") -let coq_dec_iff = lazy (constant "dec_iff") -let coq_dec_not = lazy (constant "dec_not") -let coq_dec_False = lazy (constant "dec_False") -let coq_dec_not_not = lazy (constant "dec_not_not") -let coq_dec_True = lazy (constant "dec_True") - -let coq_not_or = lazy (constant "not_or") -let coq_not_and = lazy (constant "not_and") -let coq_not_imp = lazy (constant "not_imp") -let coq_not_iff = lazy (constant "not_iff") -let coq_not_not = lazy (constant "not_not") -let coq_imp_simp = lazy (constant "imp_simp") -let coq_iff = lazy (constant "iff") -let coq_not = lazy (init_constant "not") -let coq_and = lazy (init_constant "and") -let coq_or = lazy (init_constant "or") -let coq_eq = lazy (init_constant "eq") -let coq_ex = lazy (init_constant "ex") -let coq_False = lazy (init_constant "False") -let coq_True = lazy (init_constant "True") +let coq_eq_ind_r = gen_constant "core.eq.ind_r" + +let coq_dec_or = gen_constant "core.dec.or" +let coq_dec_and = gen_constant "core.dec.and" +let coq_dec_imp = gen_constant "core.dec.imp" +let coq_dec_iff = gen_constant "core.dec.iff" +let coq_dec_not = gen_constant "core.dec.not" +let coq_dec_False = gen_constant "core.dec.False" +let coq_dec_not_not = gen_constant "core.dec.not_not" +let coq_dec_True = gen_constant "core.dec.True" + +let coq_not_or = gen_constant "core.dec.not_or" +let coq_not_and = gen_constant "core.dec.not_and" +let coq_not_imp = gen_constant "core.dec.not_imp" +let coq_not_iff = gen_constant "core.dec.not_iff" +let coq_not_not = gen_constant "core.dec.dec_not_not" +let coq_imp_simp = gen_constant "core.dec.imp_simp" +let coq_iff = gen_constant "core.iff.type" +let coq_not = gen_constant "core.not.type" +let coq_and = gen_constant "core.and.type" +let coq_or = gen_constant "core.or.type" +let coq_eq = gen_constant "core.eq.type" +let coq_ex = gen_constant "core.ex.type" +let coq_False = gen_constant "core.False.type" +let coq_True = gen_constant "core.True.type" (* uses build_coq_and, build_coq_not, build_coq_or, build_coq_ex *) diff --git a/plugins/quote/plugin_base.dune b/plugins/quote/plugin_base.dune deleted file mode 100644 index 323906acb2..0000000000 --- a/plugins/quote/plugin_base.dune +++ /dev/null @@ -1,5 +0,0 @@ -(library - (name quote_plugin) - (public_name coq.plugins.quote) - (synopsis "Coq's quote plugin") - (libraries coq.plugins.ltac)) diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v index 600e8993b4..99c02995fb 100644 --- a/plugins/rtauto/Bintree.v +++ b/plugins/rtauto/Bintree.v @@ -319,6 +319,9 @@ Arguments F_empty [A]. Arguments F_push [A] a S _. Arguments In [A] x S F. +Register empty as plugins.rtauto.empty. +Register push as plugins.rtauto.push. + Section Map. Variables A B:Set. diff --git a/plugins/rtauto/Rtauto.v b/plugins/rtauto/Rtauto.v index 06cdf76b4e..f027a4a46e 100644 --- a/plugins/rtauto/Rtauto.v +++ b/plugins/rtauto/Rtauto.v @@ -387,3 +387,24 @@ exact (Reflect (empty \ A \ B \ C) Qed. Print toto. *) + +Register Reflect as plugins.rtauto.Reflect. + +Register Atom as plugins.rtauto.Atom. +Register Arrow as plugins.rtauto.Arrow. +Register Bot as plugins.rtauto.Bot. +Register Conjunct as plugins.rtauto.Conjunct. +Register Disjunct as plugins.rtauto.Disjunct. + +Register Ax as plugins.rtauto.Ax. +Register I_Arrow as plugins.rtauto.I_Arrow. +Register E_Arrow as plugins.rtauto.E_Arrow. +Register D_Arrow as plugins.rtauto.D_Arrow. +Register E_False as plugins.rtauto.E_False. +Register I_And as plugins.rtauto.I_And. +Register E_And as plugins.rtauto.E_And. +Register D_And as plugins.rtauto.D_And. +Register I_Or_l as plugins.rtauto.I_Or_l. +Register I_Or_r as plugins.rtauto.I_Or_r. +Register E_Or as plugins.rtauto.E_Or. +Register D_Or as plugins.rtauto.D_Or. diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 8a0f48dc4d..79418da27c 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -26,49 +26,39 @@ let step_count = ref 0 let node_count = ref 0 -let logic_constant s = UnivGen.constr_of_global @@ - Coqlib.coq_reference "refl_tauto" ["Init";"Logic"] s - -let li_False = lazy (destInd (logic_constant "False")) -let li_and = lazy (destInd (logic_constant "and")) -let li_or = lazy (destInd (logic_constant "or")) - -let pos_constant s = UnivGen.constr_of_global @@ - Coqlib.coq_reference "refl_tauto" ["Numbers";"BinNums"] s - -let l_xI = lazy (pos_constant "xI") -let l_xO = lazy (pos_constant "xO") -let l_xH = lazy (pos_constant "xH") - -let store_constant s = UnivGen.constr_of_global @@ - Coqlib.coq_reference "refl_tauto" ["rtauto";"Bintree"] s - -let l_empty = lazy (store_constant "empty") -let l_push = lazy (store_constant "push") - -let constant s = UnivGen.constr_of_global @@ - Coqlib.coq_reference "refl_tauto" ["rtauto";"Rtauto"] s - -let l_Reflect = lazy (constant "Reflect") - -let l_Atom = lazy (constant "Atom") -let l_Arrow = lazy (constant "Arrow") -let l_Bot = lazy (constant "Bot") -let l_Conjunct = lazy (constant "Conjunct") -let l_Disjunct = lazy (constant "Disjunct") - -let l_Ax = lazy (constant "Ax") -let l_I_Arrow = lazy (constant "I_Arrow") -let l_E_Arrow = lazy (constant "E_Arrow") -let l_D_Arrow = lazy (constant "D_Arrow") -let l_E_False = lazy (constant "E_False") -let l_I_And = lazy (constant "I_And") -let l_E_And = lazy (constant "E_And") -let l_D_And = lazy (constant "D_And") -let l_I_Or_l = lazy (constant "I_Or_l") -let l_I_Or_r = lazy (constant "I_Or_r") -let l_E_Or = lazy (constant "E_Or") -let l_D_Or = lazy (constant "D_Or") +let li_False = lazy (destInd (UnivGen.constr_of_global @@ Coqlib.lib_ref "core.False.type")) +let li_and = lazy (destInd (UnivGen.constr_of_global @@ Coqlib.lib_ref "core.and.type")) +let li_or = lazy (destInd (UnivGen.constr_of_global @@ Coqlib.lib_ref "core.or.type")) + +let gen_constant n = lazy (UnivGen.constr_of_global (Coqlib.lib_ref n)) + +let l_xI = gen_constant "num.pos.xI" +let l_xO = gen_constant "num.pos.xO" +let l_xH = gen_constant "num.pos.xH" + +let l_empty = gen_constant "plugins.rtauto.empty" +let l_push = gen_constant "plugins.rtauto.push" + +let l_Reflect = gen_constant "plugins.rtauto.Reflect" + +let l_Atom = gen_constant "plugins.rtauto.Atom" +let l_Arrow = gen_constant "plugins.rtauto.Arrow" +let l_Bot = gen_constant "plugins.rtauto.Bot" +let l_Conjunct = gen_constant "plugins.rtauto.Conjunct" +let l_Disjunct = gen_constant "plugins.rtauto.Disjunct" + +let l_Ax = gen_constant "plugins.rtauto.Ax" +let l_I_Arrow = gen_constant "plugins.rtauto.I_Arrow" +let l_E_Arrow = gen_constant "plugins.rtauto.E_Arrow" +let l_D_Arrow = gen_constant "plugins.rtauto.D_Arrow" +let l_E_False = gen_constant "plugins.rtauto.E_False" +let l_I_And = gen_constant "plugins.rtauto.I_And" +let l_E_And = gen_constant "plugins.rtauto.E_And" +let l_D_And = gen_constant "plugins.rtauto.D_And" +let l_I_Or_l = gen_constant "plugins.rtauto.I_Or_l" +let l_I_Or_r = gen_constant "plugins.rtauto.I_Or_r" +let l_E_Or = gen_constant "plugins.rtauto.E_Or" +let l_D_Or = gen_constant "plugins.rtauto.D_Or" let special_whd gl c = diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v index 33df36d847..ccd82eabcd 100644 --- a/plugins/setoid_ring/Ring_polynom.v +++ b/plugins/setoid_ring/Ring_polynom.v @@ -919,6 +919,14 @@ Section MakeRingPol. | PEopp : PExpr -> PExpr | PEpow : PExpr -> N -> PExpr. + Register PExpr as plugins.setoid_ring.pexpr. + Register PEc as plugins.setoid_ring.const. + Register PEX as plugins.setoid_ring.var. + Register PEadd as plugins.setoid_ring.add. + Register PEsub as plugins.setoid_ring.sub. + Register PEmul as plugins.setoid_ring.mul. + Register PEopp as plugins.setoid_ring.opp. + Register PEpow as plugins.setoid_ring.pow. (** evaluation of polynomial expressions towards R *) Definition mk_X j := mkPinj_pred j mkX. diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 0734654abf..85e759d152 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -205,25 +205,16 @@ let exec_tactic env evd n f args = let nf c = constr_of evd c in Array.map nf !tactic_res, Evd.universe_context_set evd -let stdlib_modules = - [["Coq";"Setoids";"Setoid"]; - ["Coq";"Lists";"List"]; - ["Coq";"Init";"Datatypes"]; - ["Coq";"Init";"Logic"]; - ] - -let coq_constant c = - lazy (EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules "Ring" stdlib_modules c)) -let coq_reference c = - lazy (Coqlib.gen_reference_in_modules "Ring" stdlib_modules c) - -let coq_mk_Setoid = coq_constant "Build_Setoid_Theory" -let coq_None = coq_reference "None" -let coq_Some = coq_reference "Some" -let coq_eq = coq_constant "eq" - -let coq_cons = coq_reference "cons" -let coq_nil = coq_reference "nil" +let gen_constant n = lazy (EConstr.of_constr (UnivGen.constr_of_global (Coqlib.lib_ref n))) +let gen_reference n = lazy (Coqlib.lib_ref n) + +let coq_mk_Setoid = gen_constant "plugins.setoid_ring.Build_Setoid_Theory" +let coq_None = gen_reference "core.option.None" +let coq_Some = gen_reference "core.option.Some" +let coq_eq = gen_constant "core.eq.type" + +let coq_cons = gen_reference "core.list.cons" +let coq_nil = gen_reference "core.list.nil" let lapp f args = mkApp(Lazy.force f,args) @@ -260,16 +251,18 @@ let plugin_modules = let my_constant c = lazy (EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules "Ring" plugin_modules c)) + [@@ocaml.warning "-3"] let my_reference c = lazy (Coqlib.gen_reference_in_modules "Ring" plugin_modules c) + [@@ocaml.warning "-3"] let znew_ring_path = DirPath.make (List.map Id.of_string ["InitialRing";plugin_dir;"Coq"]) let zltac s = lazy(KerName.make (ModPath.MPfile znew_ring_path) (Label.make s)) -let mk_cst l s = lazy (Coqlib.coq_reference "newring" l s);; -let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s ;; +let mk_cst l s = lazy (Coqlib.coq_reference "newring" l s) [@@ocaml.warning "-3"] +let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s (* Ring theory *) @@ -907,7 +900,7 @@ let ftheory_to_obj : field_info -> obj = let field_equality evd r inv req = match EConstr.kind !evd req with | App (f, [| _ |]) when eq_constr_nounivs !evd f (Lazy.force coq_eq) -> - let c = UnivGen.constr_of_global (Coqlib.build_coq_eq_data()).congr in + let c = UnivGen.constr_of_global Coqlib.(lib_ref "core.eq.congr") in let c = EConstr.of_constr c in mkApp(c,[|r;r;inv|]) | _ -> diff --git a/plugins/setoid_ring/plugin_base.dune b/plugins/setoid_ring/plugin_base.dune index 101246e28f..d83857edad 100644 --- a/plugins/setoid_ring/plugin_base.dune +++ b/plugins/setoid_ring/plugin_base.dune @@ -2,4 +2,4 @@ (name newring_plugin) (public_name coq.plugins.setoid_ring) (synopsis "Coq's setoid ring plugin") - (libraries coq.plugins.quote)) + (libraries coq.plugins.ltac)) diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index f2f236f448..1492cfb4e4 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -201,8 +201,8 @@ let mkRInd mind = DAst.make @@ GRef (IndRef mind,None) let mkRLambda n s t = DAst.make @@ GLambda (n, Explicit, s, t) let rec mkRnat n = - if n <= 0 then DAst.make @@ GRef (Coqlib.glob_O, None) else - mkRApp (DAst.make @@ GRef (Coqlib.glob_S, None)) [mkRnat (n - 1)] + if n <= 0 then DAst.make @@ GRef (Coqlib.lib_ref "num.nat.O", None) else + mkRApp (DAst.make @@ GRef (Coqlib.lib_ref "num.nat.S", None)) [mkRnat (n - 1)] let glob_constr ist genv = function | _, Some ce -> @@ -763,7 +763,7 @@ let mkEtaApp c n imin = let mkRefl t c gl = let sigma = project gl in - let (sigma, refl) = EConstr.fresh_global (pf_env gl) sigma Coqlib.((build_coq_eq_data()).refl) in + let (sigma, refl) = EConstr.fresh_global (pf_env gl) sigma Coqlib.(lib_ref "core.eq.refl") in EConstr.mkApp (refl, [|t; c|]), { gl with sigma } let discharge_hyp (id', (id, mode)) gl = @@ -1220,7 +1220,7 @@ let genclrtac cl cs clr = (fun type_err gl -> tclTHEN (tclTHEN (Proofview.V82.of_tactic (Tactics.elim_type (EConstr.of_constr - (UnivGen.constr_of_global @@ Coqlib.build_coq_False ())))) (old_cleartac clr)) + (UnivGen.constr_of_global @@ Coqlib.(lib_ref "core.False.type"))))) (old_cleartac clr)) (fun gl -> raise type_err) gl)) (old_cleartac clr) @@ -1504,7 +1504,7 @@ let tclOPTION o d = let tacIS_INJECTION_CASE ?ty t = begin tclOPTION ty (tacTYPEOF t) >>= fun ty -> tacREDUCE_TO_QUANTIFIED_IND ty >>= fun ((mind,_),_) -> - tclUNIT (GlobRef.equal (GlobRef.IndRef mind) (Coqlib.build_coq_eq ())) + tclUNIT (Coqlib.check_ind_ref "core.eq.type" mind) end let tclWITHTOP tac = Goal.enter begin fun gl -> diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 602fcfcab5..7f9a9e125e 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -115,7 +115,7 @@ let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac let orig_gl, concl, env = gl, pf_concl gl, pf_env gl in ppdebug(lazy(Pp.str(if is_case then "==CASE==" else "==ELIM=="))); let fire_subst gl t = Reductionops.nf_evar (project gl) t in - let eq, gl = pf_fresh_global (Coqlib.build_coq_eq ()) gl in + let eq, gl = pf_fresh_global Coqlib.(lib_ref "core.eq.type") gl in let eq = EConstr.of_constr eq in let is_undef_pat = function | sigma, T t -> EConstr.isEvar sigma (EConstr.of_constr t) @@ -421,7 +421,7 @@ let injectl2rtac sigma c = match EConstr.kind sigma c with let is_injection_case c gl = let gl, cty = pfe_type_of gl c in let (mind,_), _ = pf_reduce_to_quantified_ind gl cty in - GlobRef.equal (IndRef mind) (Coqlib.build_coq_eq ()) + GlobRef.equal (IndRef mind) Coqlib.(lib_ref "core.eq.type") let perform_injection c gl = let gl, cty = pfe_type_of gl c in diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 2af917b939..c04ced4ab4 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -130,7 +130,7 @@ let newssrcongrtac arg ist gl = let ssr_congr lr = EConstr.mkApp (arr, lr) in (* here thw two cases: simple equality or arrow *) let equality, _, eq_args, gl' = - let eq, gl = pf_fresh_global (Coqlib.build_coq_eq ()) gl in + let eq, gl = pf_fresh_global Coqlib.(lib_ref "core.eq.type") gl in pf_saturate gl (EConstr.of_constr eq) 3 in tclMATCH_GOAL (equality, gl') (fun gl' -> fs gl' (List.assoc 0 eq_args)) (fun ty -> congrtac (arg, Detyping.detype Detyping.Now false Id.Set.empty (pf_env gl) (project gl) ty) ist) @@ -386,7 +386,7 @@ let rwcltac cl rdx dir sr gl = ppdebug(lazy Pp.(str"r@rwcltac=" ++ pr_econstr_env (pf_env gl) (project gl) (snd sr))); let cvtac, rwtac, gl = if EConstr.Vars.closed0 (project gl) r' then - let env, sigma, c, c_eq = pf_env gl, fst sr, snd sr, Coqlib.build_coq_eq () in + let env, sigma, c, c_eq = pf_env gl, fst sr, snd sr, Coqlib.(lib_ref "core.eq.type") in let sigma, c_ty = Typing.type_of env sigma c in ppdebug(lazy Pp.(str"c_ty@rwcltac=" ++ pr_econstr_env env sigma c_ty)); match EConstr.kind_of_type sigma (Reductionops.whd_all env sigma c_ty) with @@ -427,6 +427,7 @@ let rwcltac cl rdx dir sr gl = ;; +[@@@ocaml.warning "-3"] let lz_coq_prod = let prod = lazy (Coqlib.build_prod ()) in fun () -> Lazy.force prod @@ -438,7 +439,7 @@ let lz_setoid_relation = | _ -> let srel = try Some (UnivGen.constr_of_global @@ - Coqlib.coq_reference "Class_setoid" sdir "RewriteRelation") + Coqlib.find_reference "Class_setoid" ("Coq"::sdir) "RewriteRelation" [@ocaml.warning "-3"]) with _ -> None in last_srel := (env, srel); srel @@ -484,7 +485,7 @@ let rwprocess_rule dir rule gl = | _ -> let sigma, pi2 = Evd.fresh_global env sigma coq_prod.Coqlib.proj2 in EConstr.mkApp (pi2, ra), sigma in - if EConstr.eq_constr sigma a.(0) (EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.build_coq_True ())) then + if EConstr.eq_constr sigma a.(0) (EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.(lib_ref "core.True.type"))) then let s, sigma = sr sigma 2 in loop (converse_dir d) sigma s a.(1) rs 0 else diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index 1dbacf0ff7..ce439d0497 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -149,6 +149,7 @@ let tac_case t = end (** [=> [: id]] ************************************************************) +[@@@ocaml.warning "-3"] let mk_abstract_id = let open Coqlib in let ssr_abstract_id = Summary.ref ~name:"SSR:abstractid" 0 in @@ -375,7 +376,7 @@ let elim_intro_tac ipats ?ist what eqid ssrelim is_rec clr = let rec gen_eq_tac () = Goal.enter begin fun g -> let sigma, env, concl = Goal.(sigma g, env g, concl g) in let sigma, eq = - EConstr.fresh_global env sigma (Coqlib.build_coq_eq ()) in + EConstr.fresh_global env sigma (Coqlib.lib_ref "core.eq.type") in let ctx, last = EConstr.decompose_prod_assum sigma concl in let args = match EConstr.kind_of_type sigma last with | Term.AtomicType (hd, args) -> diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index 8ee6fbf036..94255bab6c 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -40,8 +40,7 @@ let ascii_kn = MutInd.make2 ascii_modpath ascii_label let path_of_Ascii = ((ascii_kn,0),1) let static_glob_Ascii = ConstructRef path_of_Ascii -let make_reference id = find_reference "Ascii interpretation" ascii_module id -let glob_Ascii = lazy (make_reference "Ascii") +let glob_Ascii = lazy (lib_ref "plugins.syntax.Ascii") open Lazy @@ -49,7 +48,7 @@ let interp_ascii ?loc p = let rec aux n p = if Int.equal n 0 then [] else let mp = p mod 2 in - (DAst.make ?loc @@ GRef ((if Int.equal mp 0 then glob_false else glob_true),None)) + (DAst.make ?loc @@ GRef (lib_ref (if Int.equal mp 0 then "core.bool.false" else "core.bool.true"),None)) :: (aux (n-1) (p/2)) in DAst.make ?loc @@ GApp (DAst.make ?loc @@ GRef(force glob_Ascii,None), aux 8 p) @@ -67,8 +66,8 @@ let interp_ascii_string ?loc s = let uninterp_ascii r = let rec uninterp_bool_list n = function | [] when Int.equal n 0 -> 0 - | r::l when is_gr r glob_true -> 1+2*(uninterp_bool_list (n-1) l) - | r::l when is_gr r glob_false -> 2*(uninterp_bool_list (n-1) l) + | r::l when is_gr r (lib_ref "core.bool.true") -> 1+2*(uninterp_bool_list (n-1) l) + | r::l when is_gr r (lib_ref "core.bool.false") -> 2*(uninterp_bool_list (n-1) l) | _ -> raise Non_closed_ascii in try let aux c = match DAst.get c with diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml index 703b40dd3e..59e65a0672 100644 --- a/plugins/syntax/string_syntax.ml +++ b/plugins/syntax/string_syntax.ml @@ -31,9 +31,8 @@ let string_kn = MutInd.make2 string_modpath @@ Label.make "string" let static_glob_EmptyString = ConstructRef ((string_kn,0),1) let static_glob_String = ConstructRef ((string_kn,0),2) -let make_reference id = find_reference "String interpretation" string_module id -let glob_String = lazy (make_reference "String") -let glob_EmptyString = lazy (make_reference "EmptyString") +let glob_String = lazy (lib_ref "plugins.syntax.String") +let glob_EmptyString = lazy (lib_ref "plugins.syntax.EmptyString") let is_gr c gr = match DAst.get c with | GRef (r, _) -> GlobRef.equal r gr |